Coproduct to combine algebras for a free monad interpreter.

AlaCarte.hs

module AlaCarte where

-- Control.Monad.Free

data Free f a = Free (f (Free f a)) | Pure a

instance Functor f => Monad (Free f) where
    Pure a >>= f = f a
    Free r >>= f = Free (fmap (>>= f) r)
    return = Pure

liftF :: Functor f => f a -> Free f a
liftF = Free . fmap return

-- Data.Functor.Coproduct

data Coproduct f g a = Coproduct (Either (f a) (g a))

instance (Functor f, Functor g) => Functor (Coproduct f g) where
    fmap f = Coproduct . coproduct (Left . fmap f) (Right . fmap f)

left :: f a -> Coproduct f g a
left = Coproduct . Left

right :: g a -> Coproduct f g a
right = Coproduct . Right

coproduct :: (f a -> b) -> (g a -> b) -> Coproduct f g a -> b
coproduct f g (Coproduct e) = either f g e

-- Actions

data FPrint a = FPrint String a

instance Functor FPrint where
    fmap f (FPrint s a) = FPrint s $ f a

data FRead a = FRead (String -> a)

instance Functor FRead where
    fmap f (FRead g) = FRead $ f . g

fprint :: String -> FPrint ()
fprint s = FPrint s ()

fread :: FRead String
fread = FRead id

-- Example program

readPrint :: Free (Coproduct FPrint FRead) ()
readPrint = do
  liftF . left $ fprint "Hello, name?"
  name <- liftF $ right fread
  liftF . left . fprint $ "Hi " ++ name ++ "!"

-- Interpreter

runIO :: Free (Coproduct FPrint FRead) a -> IO a
runIO (Free c) = coproduct (\(FPrint s a) -> putStrLn s >> runIO a) (\(FRead f) -> getLine >>= runIO . f) c
runIO (Pure a) = return a

main :: IO ()
main = runIO readPrint