Concurrently interpret polymorphic variant of commands

ConcurrentVariantInterpreter.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# 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.Concurrent
import Control.Concurrent.STM
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe
import Data.Diverse.Lens
import qualified Data.DList as DL
import Data.Foldable
import Data.Semigroup
import Data.Tagged
import qualified UnliftIO.Concurrent as U

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

instance Show (IOEffect c) where
    showsPrec d (PutStrLn s) = showParen (d >= 11) $ showString "PutStrLn " . shows s
    showsPrec _ (GetLine _) = showString "GetLine"

-- | Another DSL for other effects
data HelloWorldEffect
    = HelloWorld
    | ByeWorld

instance Show HelloWorldEffect where
    showsPrec _ HelloWorld = showString "HelloWorld"
    showsPrec _ ByeWorld = showString "ByeWorld"

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

-- | 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 'command'' for commands that require a continuation ("returns" a value).
command :: (AsFacet c cmd) => c -> cmd
command = review facet

-- | A variation of 'command' 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.
command' :: (AsFacet (c cmd) cmd) => c cmd -> cmd
command' = 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)

-- | @'postcmd' = 'post' . 'command'@
postcmd :: (MonadState (DL.DList cmd) m, AsFacet c cmd) => c -> m ()
postcmd = post . command

-- | @'postcmd'' = 'post' . 'command''@
postcmd' :: (MonadState (DL.DList cmd) m, AsFacet (c cmd) cmd) => c cmd -> m ()
postcmd' = post . command'

-- | Converts a State list of commands to a single command
codify :: AsFacet [cmd] cmd => State (DL.DList cmd) () -> cmd
codify = command' @[] . DL.toList . (`execState` mempty)

-- | This converts a command that requires a handler into a ContT monad so that the do notation
-- can be used to compose the handler for that command.
-- 'conclude' is used inside an 'inquire' block.
conclude :: (AsFacet (c cmd) cmd, AsFacet [cmd] cmd) => ((a -> cmd) -> c cmd) -> ContT () (State (DL.DList cmd)) a
conclude m = ContT $ \k -> postcmd' $ m (codify . k)

-- | Adds the ContT monad's commands into the 'MonadState' of commands.
-- 'inquire' is used to start usages of 'conclude'.
inquire :: MonadState (DL.DList cmd) m => ContT () (State (DL.DList cmd)) () -> m ()
inquire = (\s -> id %= (<> execState s mempty)) . evalContT

----------------------------------------------
-- 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_ ::
    ( AsFacet [cmd] cmd
    , AsFacet (IOEffect cmd) cmd
    , AsFacet HelloWorldEffect cmd
    , AsConcur cmd
    , Show cmd
    , MonadUnliftIO m
    )
    => (cmd -> m ()) -> cmd -> MaybeT m ()
execEffects_ exec c =
    maybeExec (traverse_ @[] exec) c
    <|> maybeExec (execConcurCmd exec) c
    <|> maybeExec (execIOEffect exec) c
    <|> maybeExec execHelloWorldEffect c

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

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

data Output
data Input

-- Some interpreters need to be an instance of MonadUniftIO,
-- which limits the transformer stack to ReaderT.
testIOEffect ::
    ( MonadReader r m
    , Has (Tagged Output (TVar [String])) r
    , Has (Tagged Input (TVar [String])) r
    , MonadIO m
    )
    => (cmd -> m ()) -> IOEffect cmd -> m ()
testIOEffect _ (PutStrLn str) = do
    xs <- view (itemTag' @Output)
    liftIO $ atomically $ modifyTVar' xs (\xs' -> ("PutStrLn " <> show str) : xs')

testIOEffect exec (GetLine k) = do
    xs <- view (itemTag' @Output)
    ys <- view (itemTag' @Input)
    y <- liftIO $ atomically $ do
        ys' <- readTVar ys
        let (y, ys'') = case ys' of
                        (h : t) -> (h, t)
                        _ -> ("Unexpected GetLine!", [])
        writeTVar ys ys''
        modifyTVar' xs (\xs' -> show y <> " <- GetLine" : xs')
        pure y
    exec $ k y

testHelloWorldEffect ::
    ( MonadReader r m
    , Has (Tagged Output (TVar [String])) r
    , MonadIO m
    )
    => HelloWorldEffect -> m ()
testHelloWorldEffect HelloWorld = do
    xs <- view (itemTag' @Output)
    liftIO $ atomically $ modifyTVar' xs (\xs' -> "Hello World" : xs')
testHelloWorldEffect ByeWorld = do
    xs <- view (itemTag' @Output)
    liftIO $ atomically $ modifyTVar' xs (\xs' -> "Bye, World" : xs')

-- | Combine test interpreters
testEffects_ ::
    ( MonadReader r m
    , Has (Tagged Output (TVar [String])) r
    , Has (Tagged Input (TVar [String])) r
    , MonadUnliftIO m
    , AsFacet [cmd] cmd
    , AsFacet (IOEffect cmd) cmd
    , AsFacet HelloWorldEffect cmd
    , AsConcur cmd
    , Show cmd
    )
    => (cmd -> m ()) -> cmd -> MaybeT m ()
testEffects_ exec c =
    maybeExec (traverse_ @[] exec) c
    <|> maybeExec (execConcurCmd exec) c
    <|> maybeExec (testIOEffect exec) c
    <|> maybeExec testHelloWorldEffect c

-- | Tie testEffects_ with itself to get the final interpreter
testEffects ::
    ( MonadReader r m
    , Has (Tagged Output (TVar [String])) r
    , Has (Tagged Input (TVar [String])) r
    , MonadUnliftIO m
    , AsFacet [cmd] cmd
    , AsFacet (IOEffect cmd) cmd
    , AsFacet HelloWorldEffect cmd
    , AsConcur cmd
    , Show 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
    postcmd' $ PutStrLn "Write two things"
    inquire $ do
        -- Use the continuation monad to compose the function to pass into GetLine
        a1 <- conclude GetLine
        a2 <- conclude GetLine
        -- Do something monadic/different based on the return value.
        case a1 of
            "secret" -> postcmd' $ PutStrLn "Easter egg!"
            _ -> do
                postcmd' $ PutStrLn "Write something else"
                -- more GetLine input
                b <- conclude GetLine
                postcmd' $ PutStrLn $ "You wrote: (" <> a1 <> ", " <> a2 <> ") then " <> b

-- | using only concur
ioProgramWithOnlyConcur ::
    ( AsFacet (IOEffect cmd) cmd
    , AsConcur cmd
    , MonadState (DL.DList cmd) m) => m ()
ioProgramWithOnlyConcur = do
    postcmd' $ PutStrLn "Write two things"
    postcmd' $ concurringly_ $ do
        -- Use the Concur monad to batch two GetLines concurrently
        a1 <- concur GetLine
        a2 <- concur GetLine
        -- Do something monadic/different based on the return value.
        case a1 of
            "secret" -> postcmd' $ PutStrLn "Easter egg!"
            _ -> do
                postcmd' $ PutStrLn "Write something else"
                -- more GetLine input
                b <- concur GetLine
                postcmd' $ PutStrLn $ "You wrote: (" <> a1 <> ", " <> a2 <> ") then " <> b

-- | using concur & cont together
ioProgramWithConcur ::
    ( AsFacet (IOEffect cmd) cmd
    , AsConcur cmd
    , AsFacet [cmd] cmd
    , MonadState (DL.DList cmd) m) => m ()
ioProgramWithConcur = do
    postcmd' $ PutStrLn "Write two things"
    inquire $ do
        (a1, a2) <- conclude . concurringly $ do
                -- Use the Concur monad to batch two GetLines concurrently
                a1 <- concur GetLine
                a2 <- concur GetLine
                pure (a1, a2)
        -- Do something monadic/different based on the return value.
        case a1 of
            "secret" -> postcmd' $ PutStrLn "Easter egg!"
            _ -> do
                postcmd' $ PutStrLn "Write something else"
                -- more GetLine input
                b <- conclude GetLine
                postcmd' $ PutStrLn $ "You wrote: (" <> a1 <> ", " <> a2 <> ") 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
    postcmd HelloWorld
    ioProgram
    postcmd ByeWorld

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

    -- interpret the program commands with preconfigured inputs
    is <- newTVarIO ["secret", "y", "z"]
    os <- newTVarIO ([] :: [String])
    (`runReaderT` (Tagged @Input is, Tagged @Output os)) $ testEffects $ command' @[] cs
    is' <- readTVarIO is
    os' <- readTVarIO os
    putStrLn $ "Unconsumed input: " <> show is'
    putStrLn $ "Effects executed: " <> show (reverse os')

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

----------------------------------------------
-- Batch independant commands
----------------------------------------------

-- | Adds a handler to polymorphic commands that produce a value
data Cmd f cmd where
    Cmd :: Show (f a) => f a -> (a -> cmd) -> Cmd f cmd
    Cmd_ :: Show (f ()) => f () -> Cmd f cmd

instance Show (Cmd f cmd) where
    showsPrec p (Cmd f _) = showParen (p >= 11) $
        showString "Cmd " . shows f
    showsPrec p (Cmd_ f) = showParen (p >= 11) $
        showString "Cmd_ " . shows f

type AsConcur cmd = (AsFacet (ConcurCmd cmd) cmd)
type ConcurCmd cmd = Cmd (Concur cmd) cmd

-- | This monad is intended to be used with @ApplicativeDo@ to allow do notation
-- for composing commands that can be run concurrently.
-- The 'Applicative' instance can merge multiple commands into the internal state of @DList c@.
-- The 'Monad' instance creates a 'ConcurCmd' command before continuing the bind.
newtype Concur c a = Concur
    -- The base IO doesn't block (only does newEmptyMVar), but the returns an IO that blocks.
    { runConcur :: StateT (DL.DList c) MkMVar (IO a)
    }

instance Show (Concur c a) where
    showsPrec _ _ = showString "Concur"

-- | NB. Don't export MkMVar constructor to guarantee
-- that that it only contains non-blocking 'newEmptyMVar' IO.
newtype MkMVar a = MkMVar (IO a)
    deriving (Functor, Applicative, Monad)

mkNewEmptyMVar :: MkMVar (MVar a)
mkNewEmptyMVar = MkMVar newEmptyMVar

unMkMVar :: MkMVar a -> IO a
unMkMVar (MkMVar m) = m

-- | Allows usages  of 'concur' inside a 'concurringly' block.
-- This resuls in a command that requires a handler, which may be used by 'conclude'
concurringly :: Concur cmd a -> (a -> cmd) -> ConcurCmd cmd
concurringly = Cmd

-- | Allows usages  of 'concur' inside a 'concurring' block.
-- This results in a command that doesn't require a handler and may be 'postcmd''ed.
concurringly_ :: Concur cmd () -> ConcurCmd cmd
concurringly_ = Cmd_

instance (AsConcur cmd) => MonadState (DL.DList cmd) (Concur cmd) where
    state m = Concur $ pure <$> state m

instance Functor (Concur cmd) where
    fmap f (Concur m) = Concur $ fmap f <$> m

-- | Applicative instand allows building up list of commands without blocking
instance Applicative (Concur cmd) where
    pure = Concur . pure . pure
    (Concur f) <*> (Concur a) = Concur $ liftA2 (<*>) f a

-- Monad instance can't build commands without blocking.
instance (AsConcur cmd) => Monad (Concur cmd) where
    (Concur m) >>= k = Concur $ do
        m' <- m -- get the blocking io action while updating the state
        v <- lift mkNewEmptyMVar
        postcmd' $ concurringly (Concur $ pure m')
            (\a -> command' $ concurringly (k a)
                (\b -> command' $ concurringly_ (Concur $ pure $ putMVar v b)))
        pure $ takeMVar v

-- | Concurrent version of 'conclude'. Converts a command that requires a handler to a Concur monad
-- so that the do notation can be used to compose the handler for that command.
-- The Concur monad allows schedule the command in concurrently with other 'concur'red commands.
-- 'concur' is used inside an 'concurringly' or 'concurringly_' block.
concur :: (AsConcur cmd, AsFacet (c cmd) cmd) => ((a -> cmd) -> c cmd) -> Concur cmd a
concur k = Concur $ do
    v <- lift mkNewEmptyMVar
    postcmd' $ k (\a -> command' $ concurringly_ (Concur $ pure $ putMVar v a))
    pure $ takeMVar v

execCommandsConcurrently ::
    (MonadUnliftIO m, Show cmd)
    => (cmd -> m ())
    -> [cmd]
    -> m ()
execCommandsConcurrently exec cs = do
    if length cs /= 0
        then liftIO $ putStrLn $ "Concurrently executing: " <> show cs
        else pure ()
    traverse_ (void . U.forkIO . exec) cs

-- | The @toIO@ arg is analogous to @Control.Monad.IO.Unlift.unliftIO@
-- which essentially limits the @m@ monad to ReaderT and IdentityT transformers on top of IO.
execConcurCmd ::
    (MonadUnliftIO m, Show cmd)
    => (cmd -> m ())
    -> ConcurCmd cmd
    -> m ()
execConcurCmd exec cmd = do
    case cmd of
        (Cmd (Concur m) k) -> do
            ma <- execConcurCmd_ exec m
            -- Now run the blocking io, which produces the final command
            a <- liftIO ma
            exec (k a)
        (Cmd_ (Concur m)) -> do
            ma <- execConcurCmd_ exec m
            -- Now run the blocking io, which produces the final command
            liftIO ma
  where
    execConcurCmd_ exec' m = do
        -- get the list of commands to run
        (ma, cs) <- liftIO $ unMkMVar $ runStateT m mempty
        -- run the batched commands in separate threads
        execCommandsConcurrently exec' (DL.toList cs)
        pure ma

https://www.reddit.com/r/haskell/comments/8f2ama/haxllike_concurrent_interpreter_of_commands/

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