Interpreting using typeclasses

TypeclassInterpreter.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

-- 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.
class Monad m => IOEffect m where
    -- PutStrLn is effect with an () return value.
    doPutStrLn :: String -> m ()
    -- GetLine is an effect with a String return value.
    -- Requires continuation that does something with the return.
    doGetLine :: m String

-- Another DSL for other effects
class Monad m => HelloWorldEffect m where
    doHelloWorld :: m ()
    doByeWorld :: m ()

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

-- runs the AppEffect
instance IOEffect IOAppEffect where
    doPutStrLn s = liftIO $ putStrLn s
    doGetLine = liftIO $ getLine

instance HelloWorldEffect IOAppEffect where
    doHelloWorld = liftIO $ putStrLn "Hello, world!"
    doByeWorld = 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 => IOEffect (TestAppEffect m) where
    doPutStrLn s = do
        (is, os) <- get
        put (is, ("PutStrLn " <> show s) : os)
    doGetLine = do
        (is, os) <- get
        let (i', is') = case is of
                        (h : t) -> (h, t)
                        _ -> ("Unexpected GetLine!", [])
        put (is', (show i' <> " <- GetLine") : os)
        pure i'

instance Monad m => HelloWorldEffect (TestAppEffect m) where
    doHelloWorld = do
        (is, os) <- get
        put (is, "HelloWorld" : os)
    doByeWorld = do
        (is, os) <- get
        put (is, "HelloWorld" : os)

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

-- | Program using both effects
program :: (HelloWorldEffect m, IOEffect m) => m ()
program = do
    doHelloWorld
    program'
    doByeWorld

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)