{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Glazier.Command
( MonadCodify(..)
, codifies'
, codify
, codify'
, MonadCommand
, command
, command'
, command_
, commands
, instruct
, instructs
, exec
, exec'
, exec_
, eval
, eval'
, sequentially
, dispatch
, dispatch_
, concurringly
, concurringly_
, AsConcur
, Concur(..)
, NewEmptyMVar
, unNewEmptyMVar
) where
import Control.Applicative
import Control.Concurrent
import Control.Lens
import Control.Monad.Cont
import Control.Monad.Delegate
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Except
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Data.Diverse.Lens
import qualified Data.DList as DL
import GHC.Generics
#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0)
import Data.Semigroup
#endif
class Monad m => MonadCodify cmd m | m -> cmd where
codifies :: (a -> m ()) -> m (a -> [cmd])
codifies' :: (MonadCodify cmd m) => m () -> m [cmd]
codifies' m = do
f <- codifies (const m)
pure (f ())
codify :: (AsFacet [cmd] cmd, MonadCodify cmd m) => (a -> m ()) -> m (a -> cmd)
codify f = (commands .) <$> codifies f
codify' :: (AsFacet [cmd] cmd, MonadCodify cmd m) => m () -> m cmd
codify' m = do
f <- codify (const m)
pure (f ())
instance MonadCodify cmd (Strict.State (DL.DList cmd)) where
codifies f = pure $ \a -> DL.toList . (`Strict.execState` mempty) $ f a
instance MonadCodify cmd (Lazy.State (DL.DList cmd)) where
codifies f = pure $ \a -> DL.toList . (`Lazy.execState` mempty) $ f a
instance MonadCodify cmd m => MonadCodify cmd (IdentityT m) where
codifies f = lift . codifies $ runIdentityT . f
instance MonadCodify cmd m => MonadCodify cmd (ContT () m) where
codifies f = lift . codifies $ evalContT . f
instance MonadCodify cmd m => MonadCodify cmd (ReaderT r m) where
codifies f = do
r <- ask
lift . codifies $ (`runReaderT` r) . f
instance MonadCodify cmd m => MonadCodify cmd (MaybeT m) where
codifies f = lift . codifies $ void . runMaybeT . f
instance (MonadDelegate () m, MonadCodify cmd m) => MonadCodify cmd (ExceptT e m) where
codifies f = ExceptT $ delegate $ \kec -> do
let g a = do
e <- runExceptT $ f a
case e of
Left e' -> kec (Left e')
Right _ -> pure ()
g' <- codifies g
kec (Right g')
type MonadCommand cmd m =
( MonadState (DL.DList cmd) m
, MonadDelegate () m
, MonadCodify cmd m
, AsFacet [cmd] cmd
)
command :: (AsFacet c cmd) => c -> cmd
command = review facet
command' :: (AsFacet (c cmd) cmd) => c cmd -> cmd
command' = review facet
command_ :: (AsFacet [cmd] cmd) => () -> cmd
command_ = command' . const []
commands :: (AsFacet [cmd] cmd) => [cmd] -> cmd
commands [x] = x
commands xs = command' xs
instruct :: (MonadState (DL.DList cmd) m) => cmd -> m ()
instruct c = id %= (`DL.snoc` c)
instructs :: (MonadState (DL.DList cmd) m) => [cmd] -> m ()
instructs cs = id %= (<> DL.fromList cs)
exec :: (MonadState (DL.DList cmd) m, AsFacet c cmd) => c -> m ()
exec = instruct . command
exec' :: (MonadState (DL.DList cmd) m, AsFacet (c cmd) cmd) => c cmd -> m ()
exec' = instruct . command'
exec_ :: (Functor c, MonadState (DL.DList cmd) m, AsFacet [cmd] cmd, AsFacet (c cmd) cmd)
=> c () -> m ()
exec_ = instruct . command' . fmap command_
eval_ ::
( MonadDelegate () m
, MonadCodify cmd m
, AsFacet [cmd] cmd
)
=> ((a -> cmd) -> m ()) -> m a
eval_ m = delegate $ \k -> do
f <- codify k
m f
eval' ::
( MonadCommand cmd m
, AsFacet [cmd] cmd
, AsFacet (c cmd) cmd
)
=> ((a -> cmd) -> c cmd) -> m a
eval' k = eval_ $ exec' . k
eval ::
( MonadCommand cmd m
, AsFacet [cmd] cmd
, AsFacet c cmd
)
=> ((a -> cmd) -> c) -> m a
eval k = eval_ $ exec . k
sequentially :: MonadCont m => m a -> m a
sequentially = id
dispatch ::
( AsFacet (c cmd) cmd
, MonadCommand cmd m
, Functor c
) => c a -> m a
dispatch c = delegate $ \fire -> do
fire' <- codify fire
exec' $ fire' <$> c
dispatch_ ::
( AsFacet (c cmd) cmd
, AsFacet [cmd] cmd
, MonadState (DL.DList cmd) m
, Functor c
) => c () -> m ()
dispatch_ = exec' . fmap command_
type AsConcur cmd = (AsFacet [cmd] cmd, AsFacet (Concur cmd cmd) cmd)
newtype Concur cmd a = Concur
{ runConcur :: Strict.StateT (DL.DList cmd) NewEmptyMVar (Either (IO a) a)
} deriving (Generic)
instance Show (Concur cmd a) where
showsPrec _ _ = showString "Concur"
newtype NewEmptyMVar a = NewEmptyMVar (IO a)
deriving (Functor, Applicative, Monad)
unNewEmptyMVar :: NewEmptyMVar a -> IO a
unNewEmptyMVar (NewEmptyMVar m) = m
concurringly ::
( MonadCommand cmd m
, AsConcur cmd
) => Concur cmd a -> m a
concurringly = dispatch
concurringly_ :: (MonadState (DL.DList cmd) m, AsConcur cmd) => Concur cmd () -> m ()
concurringly_ = dispatch_
instance (AsConcur cmd) => MonadState (DL.DList cmd) (Concur cmd) where
state m = Concur $ Right <$> Strict.state m
instance Functor (Concur cmd) where
fmap f (Concur m) = Concur $ (either (Left . fmap f) (Right . f)) <$> m
instance Applicative (Concur cmd) where
pure = Concur . pure . pure
(Concur f) <*> (Concur a) = Concur $ liftA2 go f a
where
go :: Either (IO (a -> b)) (a -> b)
-> Either (IO a) a
-> Either (IO b) b
go g b = case (g, b) of
(Left g', Left b') -> Left (g' <*> b')
(Left g', Right b') -> Left (($b') <$> g')
(Right g', Left b') -> Left (g' <$> b')
(Right g', Right b') -> Right (g' b')
instance (AsConcur cmd) => Monad (Concur cmd) where
(Concur m) >>= k = Concur $ do
m' <- m
case m' of
Right a -> runConcur $ k a
Left ma -> do
v <- lift $ NewEmptyMVar newEmptyMVar
exec' $ flip fmap (Concur @cmd $ pure (Left ma))
(\a -> command' $ flip fmap (k a)
(\b -> command' $ command_ <$> (Concur @cmd $ pure $ Left $ putMVar v b)))
pure $ Left $ takeMVar v
instance AsConcur cmd => MonadCodify cmd (Concur cmd) where
codifies f = pure $ pure . command' . fmap command_ . f
instance AsConcur cmd => MonadDelegate () (Concur cmd) where
delegate f = Concur $ do
v <- lift $ NewEmptyMVar newEmptyMVar
b <- runConcur $ f (\a -> Concur $ lift $ pure $ Left $ putMVar v a)
pure $ Left (either id pure b *> takeMVar v)