Interpreting without continuation monad

InterpreterWithout.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module Main where

import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Data.Semigroup

-- A monad that can interpret a command of type @x@
class Monad m => MonadEffect x m where
    doEffect :: x (m a) -> m a

-- Data structure describing the different types of effects
-- I don't need to derive Functor, but I do it to show
-- that the data type has the same shape as for Free Monads.
data IOEffect next
    -- PutStrLn is effect with an () return value.
    = PutStrLn String (() -> next)
    -- GetLine is an effect with a String return value.
    -- Requires continuation that does something with the return.
    | GetLine (String -> next)
    deriving Functor

-- Another DSL for other effects
data HelloWorldEffect next
    = HelloWorld (() -> next)
    | ByeWorld (() -> next)
    deriving Functor

-- IO version
newtype IOAppEffect a = IOAppEffect
    { runIOAppEffect :: IO a
    } deriving ( Functor
               , Applicative
               , Monad
               , MonadIO
               )

-- runs the AppEffect
instance MonadEffect IOEffect IOAppEffect where
    doEffect (PutStrLn s f) = liftIO $ putStrLn s >>= (runIOAppEffect . f)
    doEffect (GetLine f) = liftIO $ getLine >>= (runIOAppEffect . f)

instance MonadEffect HelloWorldEffect IOAppEffect where
    doEffect (HelloWorld f) = liftIO $ putStrLn "Hello, world!" >>= (runIOAppEffect . f)
    doEffect (ByeWorld f) = liftIO $ putStrLn "Bye, world!" >>= (runIOAppEffect . f)

-- Test version that uses preconfigured inputs and stores details commands executed.
-- in a state (GetString input, description of commands executed (in reverse order))
newtype TestAppEffect m a = TestAppEffect
    { runTestAppEffect :: StateT ([String], [String]) m a
    } deriving ( Functor
               , Applicative
               , Monad
               , MonadIO
               , MonadState ([String], [String])
               )

instance Monad m => MonadEffect IOEffect (TestAppEffect m) where
    doEffect (PutStrLn s f) = do
        (is, os) <- get
        put (is, ("PutStrLn " <> show s) : os)
        f ()
    doEffect (GetLine f) = do
        (is, os) <- get
        let (i', is') = case is of
                        (h : t) -> (h, t)
                        _ -> ("Unexpected GetLine!", [])
        put (is', (show i' <> " <- GetLine") : os)
        f i'

instance Monad m => MonadEffect HelloWorldEffect (TestAppEffect m) where
    doEffect (HelloWorld f) = do
        (is, os) <- get
        put (is, "HelloWorld" : os)
        f ()
    doEffect (ByeWorld f) = do
        (is, os) <- get
        put (is, "HelloWorld" : os)
        f ()

program' :: (MonadEffect IOEffect m) => m ()
program' = do
    doEffect $ PutStrLn "Write something" pure
    -- Use the continuation monad to compose the continuation to pass into GetLine
    a <- doEffect $ GetLine pure
    -- Do something monadic/different based on the return value.
    case a of
        "secret" -> doEffect $ PutStrLn "Easter egg!" pure
        _ -> do
            doEffect $ PutStrLn "Write something else" pure
            -- more GetLine input
            b <- doEffect $ GetLine pure
            doEffect $ PutStrLn ("You wrote: " <> a <> " then " <> b) pure

-- | Program using both effects
program :: (MonadEffect HelloWorldEffect m, MonadEffect IOEffect m) => m ()
program = do
    doEffect $ HelloWorld pure
    program'
    doEffect $ ByeWorld pure

main :: IO ()
main = do
    -- run the program interactively
    runIOAppEffect program
    -- run the program with preconfigured inputs
    (is, os) <- (`execStateT` (["secret", "y", "z"], [])) $ runTestAppEffect program
    putStrLn $ "Unconsumed input: " <> show is
    putStrLn $ "Effects executed: " <> show (reverse os)