Terminal.hs

{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types                 #-}

module Terminal where


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

instance Functor f => Functor (Free f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (Free x) = Free (fmap f <$> x)

instance Functor f => Applicative (Free f) where
  pure = Pure
  Pure f <*> Pure a = Pure (f a)
  Pure f <*> Free x = Free (fmap f <$> x)
  Free x <*> my     = Free ((<*> my) <$> x)

instance Functor f => Monad (Free f) where
  return = pure
  Pure a >>= f = f a
  Free x >>= f = Free ((>>= f) <$> x)

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

data Terminal a
  = GetLine (String -> a)
  | PrintLine String a
  deriving Functor

data Log a
  = Log String a
  deriving Functor

class (Functor f, Functor g) => Inject f g where
  inject  :: f a -> g a
  project :: g a -> Maybe (f a)

class Monad m => MonadTerm m where
  getLine   :: m String
  printLine :: String -> m ()

class Monad m => MonadLog m where
  log :: String -> m ()

newtype LogTerm f a = LogTerm { runLogTerm :: Free f a }
 deriving (Functor, Applicative, Monad)

instance Inject Terminal f => MonadTerm (LogTerm f) where
  getLine = LogTerm (Free $ inject (GetLine return))
  printLine str = LogTerm (liftF $ inject (PrintLine str ()))

instance Inject Log f => MonadLog (LogTerm f) where
  log str = LogTerm (liftF $ inject (Log str ()))

liberate :: (Inject Terminal f, Inject Log f)
         => (forall m. (MonadTerm m, MonadLog m) => m ())
         -> Free f ()
liberate p = runLogTerm p