Toying with free monads

IOAction.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}

-- This script is based on Chris Taylor's gist: https://gist.github.com/chris-taylor/4745921
--
-- The main differences are:
-- 1. An interpretation in a different monad, the RWS monad. This idea was also was taken from somewhere else:
--    http://www.cs.uu.nl/docs/vakken/afp/assignment3.html
-- 2. An implementation based on free monads, see the `IOActionFreeMonad.hs` file.

import Control.Monad.Trans.RWS.Lazy hiding (get, put)

data IOAction a = Return a
                | Put String (IOAction a)
                | Get (String -> IOAction a)
    deriving Functor

instance Applicative IOAction where
    pure = Return
    (<*>) = undefined  -- TODO

instance Monad IOAction where
    (>>=) :: IOAction a -> (a -> IOAction b) -> IOAction b
    (Return a) >>= f = f a
    (Put s io) >>= f = Put s $ io >>= f
    (Get g)    >>= f = Get (\s -> g s >>= f)

instance Show a => Show (IOAction a) where
  show = go 0 0
    where
      go m n (Return a) = ind m "Return " ++ show a
      go m n (Put s io) = ind m "Put " ++ show s ++ " (\n" ++ go (m+2) n io ++ "\n" ++ ind m ")"
      go m n (Get g)    = let i = "$" ++ show n
                          in ind m "Get (" ++ i ++ " -> \n" ++ go (m+2) (n+1) (g i) ++ "\n" ++ ind m ")"

      ind m s = replicate m ' ' ++ s

-- Utilities
get :: IOAction String
get = Get Return

put :: String -> IOAction ()
put s = Put s (Return ())

-- Sample programs
echo :: IOAction ()
echo = get >>= put

echo' :: IOAction ()
echo' =
    do word <- get
       if word == "\04"  -- Ctrl-D
       then return ()
       else put word >> echo'

hello :: IOAction ()
hello = put "What is your name?"      >>= \_    ->
        get                           >>= \name ->
        put "What is your age?"       >>= \_    ->
        get                           >>= \age  ->
        put ("Hello " ++ name ++ "!") >>= \_    -> 
        put ("You are " ++ age ++ " years old")

hello2 :: IOAction ()
hello2 =
    do put "What is your name?"
       name <- get
       put "What is your age?"
       age <- get
       put ("Hello, " ++ name ++ "!")
       put ("You are " ++ age ++ " years old!")

-- Interpreters: IO and RWS
interpIO :: IOAction a -> IO a
interpIO = \case
    Return a -> return a
    Put s io -> putStrLn s >> interpIO io
    Get f    -> getLine >>= interpIO . f

-- > type RWS r w s
-- A monad containing:
-- * an environment of type r
-- * output of type w
-- * an updatable state of type s.
type IOActionRWS = RWS [String] () [String]

-- TODO Discuss with Ionuț
interpRWS :: IOAction a -> IOActionRWS a
interpRWS = \case
    Return a -> return a
    Put s io -> modify (\t -> t ++ [s]) >> interpRWS io
    Get f    -> reader head >>= local tail . interpRWS . f

mockConsole :: IOAction a -> [String] -> (a, [String])
mockConsole p inp = (a, s)
    where
        (a, s, _) = runRWS (interpRWS p) inp []

-- Examples:
-- > inerpIO hello
-- > mockConsole hello ["john", "18"]

IOActionFreeMonad.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}

import Control.Monad.Free
import Control.Monad.RWS.Lazy hiding (get, put)

-- Data type
data IOActionF a = Put String a
                 | Get (String -> a)
    deriving Functor

type IOAction = Free IOActionF

-- Utilities
get :: IOAction String
get = liftF $ Get id

put :: String -> IOAction ()
put s = liftF $ Put s ()

-- Sample programs
echo :: IOAction ()
echo = get >>= put

echo' :: IOAction ()
echo' =
    do word <- get
       if word == "\04"  -- Ctrl-D
       then return ()
       else put word >> echo'

hello :: IOAction ()
hello = put "What is your name?"      >>= \_    ->
        get                           >>= \name ->
        put "What is your age?"       >>= \_    ->
        get                           >>= \age  ->
        put ("Hello " ++ name ++ "!") >>= \_    -> 
        put ("You are " ++ age ++ " years old")

-- Interpreters: IO and RWS
interpIO :: IOAction a -> IO a
interpIO = foldFree i
    where
        i = \case
            Put s a -> putStrLn s >> return a
            Get f   -> getLine >>= return . f

type IOActionRWS = RWS [String] () [String]

-- See this answer on why we need `iterM` instead of `foldFree`:
-- https://stackoverflow.com/a/52883770/474311
interpRWS :: IOAction a -> IOActionRWS a
interpRWS = iterM i
    where 
        i = \case
            Put s a -> modify (\t -> t ++ [s]) >> a
            Get f   -> reader head >>= local tail . f

mockConsole :: IOAction a -> [String] -> (a, [String])
mockConsole p inp = (a, s)
    where
        (a, s, _) = runRWS (interpRWS p) inp []

-- Examples:
-- > inerpIO hello
-- > mockConsole hello ["john", "18"]