Interpret polymorphic variant of commands using ContT and State

VariantInterpreter.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

-- Example of interpreting using polymorphic variant
-- with the help of ContT and State
module Main where

import Control.Applicative
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Data.Diverse
import Data.Diverse.Lens (AsFacet(..))
import qualified Data.DList as DL
import Data.Foldable
import Data.Semigroup

-- | NB. Data.Diverse imports @Which (xs :: [Type])@
-- which is a polymorphic variant

-- | NB. Data.Diverse.Lens imports the following
--
-- @
-- class AsFacet a s where
--     facet :: Prism' s a
-- @
--
-- The polymorphic variant 'Which' has
-- AsFacet instances for all the types in the variant typelist.

----------------------------------------------
-- Commands
----------------------------------------------

-- | Define data type to encapsulate the parameters required for effects.
-- If an an effect "returns" a value (eg GetLine),
-- then the last arg is a continuation that returns the next command "command".
-- Eg (String -> cmd)
-- 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
    = HelloWorld
    | ByeWorld


-- | Define the sum of all variants
type AppCmd' cmd = Which '[[cmd], IOEffect cmd, HelloWorldEffect]
-- | Add a newtype wrapper to allow recursive definition
newtype AppCmd = AppCmd { unAppCmd :: AppCmd' AppCmd}

-- | Define AsFacet instances for all types in the variant
-- UndecidableInstances!
instance (AsFacet a (AppCmd' AppCmd)) => AsFacet a AppCmd where
    facet = iso unAppCmd AppCmd . facet

----------------------------------------------
-- Command utilties
----------------------------------------------

-- | convert a request type to a command type.
-- This is used for commands that doesn't have a continuation.
-- Ie. commands that doesn't "returns" a value from running an effect.
-- Use 'cmd'' for commands that require a continuation ("returns" a value).
cmd :: (AsFacet c cmd) => c -> cmd
cmd = review facet

-- | A variation of 'cmd' for commands with a type variable @cmd@,
-- which is usually commands that are containers of command,
-- or commands that require a continuation
-- Eg. commands that "returns" a value from running an effect.
-- 'cmd'' is usually used with 'retrieve' (ContT State) monad to help
-- create the continuation.
--
-- @
-- postState . evalContT $ do
--     a <- retrieve $ cmd' . GetLine
--     pure . cmd $ DoSomething (f a)
-- @
cmd' :: (AsFacet (c cmd) cmd) => c cmd -> cmd
cmd' = review facet

-- | Add a command to the list of commands for this state tick.
-- I basically want a Writer monad, but I'm using a State monad
-- because but I also want to use it inside a ContT which only has an instance of MonadState.
post :: (MonadState (DL.DList cmd) m) => cmd -> m ()
post c = id %= (`DL.snoc` c)

-- | Add the commands from input State monad
postState :: (MonadState (DL.DList cmd) m) => State (DL.DList cmd) () ->  m ()
postState s = id %= (<> execState s mempty)

-- | This allows using the do notation to compose the continuation required by commands that "returns" a value.
retrieve :: AsFacet [cmd] cmd => ((a -> cmd) -> cmd) -> ContT () (State (DL.DList cmd)) a
retrieve m = ContT $ \k -> post $ m (cmd' @[] . DL.toList . (`execState` mempty) . k)

----------------------------------------------
-- Interpreter utilties
----------------------------------------------

maybeExec :: (Applicative m, AsFacet a c) => (a -> m b) -> c -> MaybeT m b
maybeExec k y = MaybeT . sequenceA $ k <$> preview facet y

----------------------------------------------
-- IO interpreter
----------------------------------------------

execIOEffect :: MonadIO m => (cmd -> m ()) -> IOEffect cmd -> m ()
execIOEffect _ (PutStrLn str) = liftIO $ putStrLn str
execIOEffect exec (GetLine k) = liftIO getLine >>= exec . k

execHelloWorldEffect :: MonadIO m => HelloWorldEffect -> m ()
execHelloWorldEffect HelloWorld = liftIO $ putStrLn "Hello, world!"
execHelloWorldEffect ByeWorld = liftIO $ putStrLn "Bye, world!"

-- | Combine interpreters
execEffects_ ::
    ( MonadIO m
    , AsFacet [cmd] cmd
    , AsFacet (IOEffect cmd) cmd
    , AsFacet HelloWorldEffect cmd
    )
    => (cmd -> m ()) -> cmd -> MaybeT m ()
execEffects_ exec c =
    maybeExec (traverse_ @[] exec) c
    <|> maybeExec (execIOEffect exec) c
    <|> maybeExec execHelloWorldEffect c

-- | Tie execEffects_ with itself to get the final interpreter
execEffects ::
    ( MonadIO m
    , AsFacet [cmd] cmd
    , AsFacet (IOEffect cmd) cmd
    , AsFacet HelloWorldEffect cmd
    )
    => cmd -> m ()
execEffects = void . runMaybeT . execEffects_ execEffects

----------------------------------------------
-- Test interpreter
----------------------------------------------

testIOEffect :: MonadState ([String], [String]) m => (cmd -> m ()) -> IOEffect cmd -> m ()
testIOEffect _ (PutStrLn str) = do
    (is, os) <- get
    put (is, ("PutStrLn " <> show str) : os)
testIOEffect exec (GetLine k) = do
    (is, os) <- get
    let (i', is') = case is of
                    (h : t) -> (h, t)
                    _ -> ("Unexpected GetLine!", [])
    put (is', (show i' <> " <- GetLine") : os)
    exec $ k i'

testHelloWorldEffect :: MonadState ([String], [String]) m => HelloWorldEffect -> m ()
testHelloWorldEffect HelloWorld = do
    (is, os) <- get
    put (is, "HelloWorld" : os)
testHelloWorldEffect ByeWorld = do
    (is, os) <- get
    put (is, "HelloWorld" : os)

-- | Combine test interpreters
testEffects_ ::
    ( MonadState ([String], [String]) m
    , AsFacet [cmd] cmd
    , AsFacet (IOEffect cmd) cmd
    , AsFacet HelloWorldEffect cmd
    )
    => (cmd -> m ()) -> cmd -> MaybeT m ()
testEffects_ exec c =
    maybeExec (traverse_ @[] exec) c
    <|> maybeExec (testIOEffect exec) c
    <|> maybeExec testHelloWorldEffect c

-- | Tie testEffects_ with itself to get the final interpreter
testEffects ::
    ( MonadState ([String], [String]) m
    , AsFacet [cmd] cmd
    , AsFacet (IOEffect cmd) cmd
    , AsFacet HelloWorldEffect cmd
    )
    => cmd -> m ()
testEffects = void . runMaybeT . testEffects_ testEffects

----------------------------------------------
-- programs
----------------------------------------------

ioProgram :: (AsFacet (IOEffect cmd) cmd, AsFacet [cmd] cmd, MonadState (DL.DList cmd) m) => m ()
ioProgram = do
    post . cmd' $ PutStrLn "Write something"
    postState . evalContT $ do
        -- Use the continuation monad to compose the function to pass into GetLine
        a <- retrieve $ cmd' . GetLine
        -- Do something monadic/different based on the return value.
        case a of
            "secret" -> post . cmd' $ PutStrLn "Easter egg!"
            _ -> do
                post . cmd' $ PutStrLn "Write something else"
                -- more GetLine input
                b <- retrieve $ cmd' . GetLine
                post . cmd' $ PutStrLn $ "You wrote: " <> a <> " then " <> b

-- | Program using both effects
program ::
    ( AsFacet HelloWorldEffect cmd
    , AsFacet (IOEffect cmd) cmd
    , AsFacet [cmd] cmd
    , MonadState (DL.DList cmd) m
    ) => m ()
program = do
    post . cmd $ HelloWorld
    ioProgram
    post . cmd $ ByeWorld

main :: IO ()
main = do
    -- reduce the program to the list of commands
    let cs :: [AppCmd]
        cs =  DL.toList $ (`execState` mempty) program

    -- interpret the program commands interactively
    execEffects $ cmd' @[] cs

    -- interpret the program commands with preconfigured inputs
    (is, os) <- (`execStateT` (["secret", "y", "z"], [])) $ testEffects $ cmd' @[] cs
    putStrLn $ "Unconsumed input: " <> show is
    putStrLn $ "Effects executed: " <> show (reverse os)

https://www.reddit.com/r/haskell/comments/8ejkku/interpreter_with_polymorphic_variants_and_state/

See https://gist.github.com/louispan/85bd50c73b3349917ef4ba02e1829cd5 for an updated & renamed version which interleaves concurrent and sequential requests.

https://github.com/louispan/glazier/blob/master/test/Spec.hs