Continuation monad interpreter

ContMonadInterpreter.hs

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

-- Example of interpreting using continuation monad instead of the free monad.
module Main where

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

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

-- 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
    -- 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
    | ByeWorld
    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) = liftIO $ putStrLn s
    doEffect (GetLine f) = liftIO $ getLine >>= (runIOAppEffect . f)

instance MonadEffect HelloWorldEffect IOAppEffect where
    doEffect HelloWorld = liftIO $ putStrLn "Hello, world!"
    doEffect ByeWorld = liftIO $ putStrLn "Bye, world!"

-- 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) = do
        (is, os) <- get
        put (is, ("PutStrLn " <> show s) : os)
    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 = do
        (is, os) <- get
        put (is, "HelloWorld" : os)
    doEffect ByeWorld = do
        (is, os) <- get
        put (is, "HelloWorld" : os)


-- The contination monad is used to make it easy to compose the continuation
-- to pass into GetLine.
-- The final monad must be a "ContT () m ()" so that it can be trivially run
-- with 'pure'
program' :: (MonadEffect IOEffect m) => m ()
program' = (`runContT` pure) $ do
    lift . doEffect $ PutStrLn "Write something"
    -- Use the continuation monad to compose the continuation to pass into GetLine
    a <- ContT $ doEffect . GetLine
    -- Do something monadic/different based on the return value.
    case a of
        "secret" -> lift . doEffect $ PutStrLn "Easter egg!"
        _ -> do
            lift . doEffect $ PutStrLn "Write something else"
            -- more GetLine input
            b <- ContT $ doEffect . GetLine
            lift . doEffect . PutStrLn $ "You wrote: " <> a <> " then " <> b

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

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)

https://www.reddit.com/r/haskell/comments/7yll62/interpreting_using_continuation_monad_instead_of/