86 lines
1.8 KiB
Haskell
86 lines
1.8 KiB
Haskell
{-# LANGUAGE DeriveFunctor, FlexibleContexts, GADTs #-}
|
|
|
|
-- based on 'why free monads matter'
|
|
|
|
--import Data.Functor.Foldable
|
|
--import Control.Monad.Free
|
|
--import qualified Control.Monad.Trans.Free as CMTF
|
|
import Control.Monad
|
|
|
|
|
|
data Toy a next =
|
|
Output a next
|
|
| Bell next
|
|
| Done
|
|
deriving Functor
|
|
|
|
-- absolutely unmanageable
|
|
toy1 :: Toy Char (Toy a (Toy Char (Toy a next)))
|
|
toy1 = Output 'A' (Bell (Output 'B' Done))
|
|
|
|
newtype Fix f = Fix { unfix :: f (Fix f) }
|
|
|
|
toy2 :: Fix (Toy Char)
|
|
toy2 = Fix (Output 'A' (Fix (Bell (Fix (Output 'B' (Fix Done))))))
|
|
|
|
-- What about subroutines?
|
|
data Free f r = Free (f (Free f r)) | Pure r
|
|
deriving Functor
|
|
|
|
instance Functor f => Applicative (Free f) where
|
|
pure = Pure
|
|
(<*>) = ap
|
|
|
|
instance Functor f => Monad (Free f) where
|
|
return = Pure
|
|
(Pure r) >>= f = f r
|
|
(Free x) >>= f = Free (fmap (>>= f) x)
|
|
|
|
liftF cmd = Free (fmap Pure cmd)
|
|
|
|
output x = liftF (Output x ())
|
|
bell = liftF (Bell ())
|
|
done = liftF Done
|
|
|
|
toy3 :: Free (Toy Char) r
|
|
toy3 = do
|
|
output 'A'
|
|
bell
|
|
output 'B'
|
|
done
|
|
|
|
subroutine :: Free (Toy Char) ()
|
|
subroutine = output 'A' >> bell
|
|
|
|
program :: Free (Toy Char) r
|
|
program = do
|
|
subroutine
|
|
output 'B'
|
|
bell
|
|
done
|
|
|
|
-- what can we do with our "quoted" DSL?
|
|
data FreeF f a b = PureF a | FreeF (f b)
|
|
deriving Functor
|
|
|
|
project (Pure r) = PureF r
|
|
project (Free f) = FreeF f
|
|
|
|
cata :: (FreeF (Toy a) r b -> b) -> Free (Toy a) r -> b
|
|
cata f = h where h = f . fmap h . project
|
|
|
|
countBells :: FreeF (Toy a) r Int -> Int
|
|
countBells (PureF x) = 0
|
|
countBells (FreeF r) = case r of
|
|
Done -> 0
|
|
Bell r -> 1 + r
|
|
Output _ r -> r
|
|
|
|
eval :: Show a => FreeF (Toy a) r (IO ()) -> IO ()
|
|
eval (PureF x) = pure () --error "improper termination"
|
|
eval (FreeF r) = case r of
|
|
Done -> pure ()
|
|
Bell r -> putChar '\7' >> r
|
|
Output x r -> print x >> r
|
|
|