# LANGUAGE FlexibleInstances #
{-# LANGUAGE GADTs #-}
# LANGUAGE ScopedTypeVariables #

module Control.Monad.Trans.Crtn.Driver where

import Control.Monad.Reader (ReaderT (..))
import Control.Monad.Trans (MonadIO)
import Control.Monad.Trans.Crtn
  ( request,
    (<==|),
  )
import Control.Monad.Trans.Crtn.Event
  ( ActionOrder,
    EvOrAct,
  )
import Control.Monad.Trans.Crtn.Logger
  ( LogServer,
    MonadLog,
  )
import Control.Monad.Trans.Crtn.Object
  ( Arg (..),
    CObjT,
    EStT,
    Res (..),
    SObjBT,
    SObjT,
    query,
  )
import Control.Monad.Trans.Crtn.World
  ( World,
    WorldOp,
    flushLog,
    flushQueue,
    giveEvent,
  )
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Data.Foldable (foldrM)

  | signature of IO event driver
data DrvOp e i o where
  Dispatch :: DrvOp e e (Maybe (ActionOrder e))

-- | driver
type Driver e m = SObjT (DrvOp e) m

-- | driver client
type DrvClient e m r = CObjT (DrvOp e) m r

-- |
dispatch :: (Monad m) => e -> DrvClient e m (Maybe (ActionOrder e))
dispatch ev = do
  res <- request (Arg Dispatch ev)
  case res of
    Res Dispatch r -> return r
    Ign -> error "dispatch: Ignore happened"

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

-- | single event dispatch
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
  -- Right (logobj',worldobj',events) <-
  r <-
    runExceptT $ do
      (worldobj1, _) <- ExceptT (worldobj <==| giveEvent ev)
      (worldobj2, logobj1) <- ExceptT (worldobj1 <==| flushLog logobj)
      (worldobj3, events) <- ExceptT (worldobj2 <==| flushQueue)
      return (logobj1, worldobj3, events)
  case r of
    Left _ ->
      -- resuming original (this must be refined. resume point must be defined )
      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])

-- | a single feedback step of multiple event dispatch
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

-- | full multiple event dispatch with feedback
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')

-- | convenience routine for driver
fire ::
  (Monad m, MonadLog m) =>
  e ->
  EStT
    (Driver e m ())
    m
    (Maybe (ActionOrder e))
fire = query . dispatch

# LANGUAGE GADTs #
 | driver
 | driver client
 |
 | basic driver
 | single event dispatch
 Right (logobj',worldobj',events) <-
 resuming original (this must be refined. resume point must be defined )
 | a single feedback step of multiple event dispatch
 | full multiple event dispatch with feedback
 | convenience routine for driver
# LANGUAGE FlexibleInstances #
# LANGUAGE ScopedTypeVariables #

module Control.Monad.Trans.Crtn.Driver where

import Control.Monad.Reader (ReaderT (..))
import Control.Monad.Trans (MonadIO)
import Control.Monad.Trans.Crtn
  ( request,
    (<==|),
  )
import Control.Monad.Trans.Crtn.Event
  ( ActionOrder,
    EvOrAct,
  )
import Control.Monad.Trans.Crtn.Logger
  ( LogServer,
    MonadLog,
  )
import Control.Monad.Trans.Crtn.Object
  ( Arg (..),
    CObjT,
    EStT,
    Res (..),
    SObjBT,
    SObjT,
    query,
  )
import Control.Monad.Trans.Crtn.World
  ( World,
    WorldOp,
    flushLog,
    flushQueue,
    giveEvent,
  )
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Data.Foldable (foldrM)

  | signature of IO event driver
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 <- request (Arg Dispatch ev)
  case res of
    Res Dispatch r -> return r
    Ign -> error "dispatch: Ignore happened"

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 <-
    runExceptT $ do
      (worldobj1, _) <- ExceptT (worldobj <==| giveEvent ev)
      (worldobj2, logobj1) <- ExceptT (worldobj1 <==| flushLog logobj)
      (worldobj3, events) <- ExceptT (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
