module Control.Monad.Trans.Crtn.Driver where
import Control.Monad.Reader
import Control.Monad.Trans.Either
import Data.Foldable
import Control.Monad.Trans.Crtn
import Control.Monad.Trans.Crtn.Event
import Control.Monad.Trans.Crtn.Logger
import Control.Monad.Trans.Crtn.Object
import Control.Monad.Trans.Crtn.World
data DrvOp e i o where
Dispatch :: DrvOp e e (Maybe (ActionOrder e))
type Driver e m = SObjT (DrvOp e) m
type DrvClient e m r = CObjT (DrvOp e) m r
dispatch :: (Monad m) => e -> DrvClient e m (Maybe (ActionOrder e))
dispatch ev = do Res Dispatch r <- request (Arg Dispatch ev)
return r
driver :: forall m e. (Monad m, MonadLog m, MonadIO m) =>
LogServer (SObjBT (DrvOp e) m) ()
-> SObjT (WorldOp e (SObjBT (DrvOp e) m)) (SObjBT (DrvOp e) m) ()
-> Driver e m ()
driver logger world =
ReaderT (driverW logger world)
where
driverW :: LogServer (SObjBT (DrvOp e) m) ()
-> SObjT (WorldOp e (SObjBT (DrvOp e) m)) (SObjBT (DrvOp e) m) ()
-> Arg (DrvOp e)
-> SObjBT (DrvOp e) m ()
driverW logobj worldobj (Arg Dispatch ev) = do
(logobj',worldobj') <- multiDispatchTillEnd (logobj,worldobj) [Right ev]
req <- request (Res Dispatch Nothing)
driverW logobj' worldobj' req
singleDispatch :: (Monad m) =>
Either (ActionOrder e) e
-> ( LogServer (SObjBT (DrvOp e) m) ()
, World e (SObjBT (DrvOp e) m) ()
, [EvOrAct e])
-> SObjBT (DrvOp e) m
( LogServer (SObjBT (DrvOp e) m) ()
, World e (SObjBT (DrvOp e) m) ()
, [EvOrAct e])
singleDispatch (Right ev) (logobj,worldobj,evacc) = do
r <-
runEitherT $ do (worldobj1,_) <- EitherT (worldobj <==| giveEvent ev)
(worldobj2,logobj1) <- EitherT (worldobj1 <==| flushLog logobj)
(worldobj3,events) <- EitherT (worldobj2 <==| flushQueue)
return (logobj1,worldobj3,events)
case r of
Left _ ->
return (logobj,worldobj,evacc)
Right (logobj',worldobj',events) -> return (logobj',worldobj',evacc++events)
singleDispatch (Left act) (logobj,worldobj,evacc) = do
Arg Dispatch ev <- request (Res Dispatch (Just act))
return (logobj,worldobj,evacc++[Right ev])
multiDispatch :: (Monad m) =>
( LogServer (SObjBT (DrvOp e) m) ()
, World e (SObjBT (DrvOp e) m) ())
-> [EvOrAct e]
-> SObjBT (DrvOp e) m
( LogServer (SObjBT (DrvOp e) m) ()
, World e (SObjBT (DrvOp e) m) ()
, [EvOrAct e] )
multiDispatch (logobj,worldobj) events = do
foldrM singleDispatch (logobj,worldobj,[]) events
multiDispatchTillEnd :: (Monad m) =>
( LogServer (SObjBT (DrvOp e) m) ()
, World e (SObjBT (DrvOp e) m) ())
-> [EvOrAct e]
-> SObjBT (DrvOp e) m
(LogServer (SObjBT (DrvOp e) m) ()
, World e (SObjBT (DrvOp e) m) ())
multiDispatchTillEnd (logobj,worldobj) events =
go (logobj,worldobj,events)
where go (l,w,evs) = do
(l',w',evs') <- multiDispatch (l,w) evs
if (not.null) evs'
then go (l',w',evs')
else return (l',w')
fire :: (Monad m, MonadLog m) => e -> EStT (Driver e m ()) m
(Maybe (ActionOrder e))
fire = query . dispatch