Composing two DSLs using FreeT.

ConsoleT.hs

{-# LANGUAGE DeriveFunctor #-}

module ConsoleT where

import Control.Monad.Trans.Free
import Control.Monad.IO.Class
import Control.Monad.Identity
import Control.Monad.Trans.Class

import Control.Applicative.Free

-- At the end of Data Types a la Carte [1], a Teletype
-- DSL is created by composing two other DSLs together,
-- one that can interact with the console and another
-- that can interact with the filesystem. The combined
-- Teletype DSL has the power to do both.
-- [1] http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.101.4131

-- An alternative is FreeT, the free monad transformer.
-- Below is a demonstration of this, creating a DSL that can
-- read and write to the console from two sublanguages:
-- one that an read from the console (ReadT) and one that can
-- write to the console (WriteT). This solution avoids the
-- complicated type class machinery in Data Types a la Carte,
-- and strikes me as simpler.

-- I start with the DSL for writing to the console.

-- The Free DSL is written in the usual way, starting
-- with an alegbra of actions for writing to the
-- console.
data WriteAction a = WriteLn String a -- There is one action,
                   deriving (Functor) -- the one that writes to the console.

-- WriteT is a monad transformer of WriteActions.
type WriteT m a = FreeT WriteAction m a

-- This creates an action in WriteT by lifting
-- the respective action from WriteAction.
writeConsole :: (Monad m) => String -> WriteT m ()
writeConsole msg = liftF $ WriteLn msg ()

-- WriteT is interpreted by translating the actions
-- into IO effects in the standard library.
runWriteT :: MonadIO m => WriteT m a -> m a
runWriteT = iterT interp
  where interp (WriteLn msg next) = (liftIO (putStrLn msg)) >> next

-- Below is the DSL for reading from the console.

-- The DSL is written in the same way as WriteT above.
data ReadAction a = ReadLn (String -> a) 
                  deriving (Functor)

type ReadT m a = FreeT ReadAction m a

readConsole :: Monad m => ReadT m String
readConsole = liftF $ ReadLn id

runReadT :: MonadIO m => ReadT m a -> m a
runReadT = iterT interp
  where interp (ReadLn next) = (liftIO (getLine)) >>= next

-- Now WriteT and ReadT can be composed into a language
-- that allows for both reading from and writing to the
-- console.

-- The combined effect is made by stacking the two
-- individual effects.
type ConsoleT m a = ReadT (FreeT WriteAction m) a

-- The interpreter for the combined language is
-- the composition of the interpreters for the
-- sublanguages: runWriteT and runReadT.
runConsoleT :: MonadIO m => ConsoleT m a -> m a
runConsoleT = runWriteT . runReadT

-- Below is an example of using the combined effect to 
-- echo a line from stdin. Just as with the Teletype DSL,
-- IO need not be involved in describing this process.
readAndWriteExample :: Monad m => ConsoleT m ()
readAndWriteExample = do
  ln <- readConsole
  lift $ writeConsole ln

-- One drawback is the need for transformer-style `lift`s,
-- but creating mtl-style classes and instances is one 
-- solution to this (along with the usual caveats of having to
-- write many instances.)