Terminal I/O with Free

Terminal.hs

{-# LANGUAGE RankNTypes #-}

data Free f a =
  Done a
  | More (f (Free f a))

instance Functor f => Functor (Free f) where
  fmap f (Done a) =
    Done (f a)
  fmap f (More k) =
    More ((fmap.fmap) f k)

instance Functor f => Monad (Free f) where
  return = 
    Done
  Done a >>= f =
    f a
  More k >>= f =
    More (fmap (>>= f) k)

data TerminalOp a =
  ReadLine (String -> a)
  | PutCharacter Char a
  | PutLine String a

instance Functor TerminalOp where
  fmap f (ReadLine k) =
    ReadLine (f . k)
  fmap f (PutCharacter c a) =
    PutCharacter c (f a)
  fmap f (PutLine s a) =
    PutLine s (f a)

newtype Terminal a =
  Terminal {
    runTerminal ::
      Free TerminalOp a
  }

instance Functor Terminal where
  fmap f (Terminal t) =
    Terminal (fmap f t)

instance Monad Terminal where
  return =
    Terminal . return
  Terminal t >>= f =
    Terminal (t >>= runTerminal . f)

readLine ::
  Terminal String
readLine =
  Terminal (More (fmap Done (ReadLine id)))

putCharacter ::
  Char
  -> Terminal ()
putCharacter c =
  Terminal (More (fmap Done (PutCharacter c ())))

putLine ::
  String
  -> Terminal ()
putLine s =
  Terminal (More (fmap Done (PutLine s ())))

example ::
  Terminal ()
example =
  do s <- readLine
     putLine s
     t <- readLine
     case t of
       [] -> putLine "<empty>"
       (h:_) -> putCharacter h
     u <- readLine
     putLine (reverse u)

---------------------------------------------------------
-- The following code is only necessary because: Haskell.
-- It is otherwise completely unnecessary.
-- We have a program without it.
---------------------------------------------------------

data Hom f g =
  Hom {
    runHom ::
      forall a. f a -> g a
  }

type Interpreter =
  Hom Terminal IO

interpret ::
  Interpreter
interpret =
  Hom (let run (More (ReadLine k)) =
             readLn >>= run . k
           run (More (PutCharacter c a)) =
             putChar c >> run a
           run (More (PutLine s a)) =
             putStrLn s >> run a
           run (Done a) =
             return a
       in run . runTerminal)