module Hoodle.Type.Coroutine where
import Control.Applicative
import Control.Concurrent
import Control.Lens ((^.),(.~),(%~),view,set)
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Either
import Data.Time.Clock
import Data.Time.LocalTime
import Control.Monad.Trans.Crtn
import Control.Monad.Trans.Crtn.Object
import qualified Control.Monad.Trans.Crtn.Driver as D
import Control.Monad.Trans.Crtn.Logger
import Control.Monad.Trans.Crtn.Queue
import Control.Monad.Trans.Crtn.World
import Hoodle.Type.Canvas
import Hoodle.Type.Event
import Hoodle.Type.HoodleState
import Hoodle.Type.Widget
import Hoodle.Util
data MainOp i o where
DoEvent :: MainOp AllEvent ()
doEvent :: (Monad m) => AllEvent -> CObjT MainOp m ()
doEvent ev = request (Arg DoEvent ev) >> return ()
type MainCoroutine = MainObjB
type MainObjB = SObjBT MainOp (EStT HoodleState WorldObjB)
type MainObj = SObjT MainOp (EStT HoodleState WorldObjB)
nextevent :: MainCoroutine UserEvent
nextevent = do Arg DoEvent ev <- request (Res DoEvent ())
case ev of
SysEv sev -> sysevent sev >> nextevent
UsrEv uev -> return uev
sysevent :: SystemEvent -> MainCoroutine ()
sysevent ClockUpdateEvent = do
utctime <- liftIO $ getCurrentTime
zone <- liftIO $ getCurrentTimeZone
let ltime = utcToLocalTime zone utctime
ltimeofday = localTimeOfDay ltime
(h,m,s) :: (Int,Int,Int) =
(,,) <$> (\x->todHour x `mod` 12) <*> todMin <*> (floor . todSec)
$ ltimeofday
xst <- get
let cinfo = view currentCanvasInfo xst
cwgts = view (unboxLens canvasWidgets) cinfo
nwgts = set (clockWidgetConfig.clockWidgetTime) (h,m,s) cwgts
ncinfo = set (unboxLens canvasWidgets) nwgts cinfo
put . set currentCanvasInfo ncinfo $ xst
when (view (widgetConfig.doesUseClockWidget) cwgts) $ do
let cid = getCurrentCanvasId xst
modify (tempQueue %~ enqueue (Right (UsrEv (UpdateCanvasEfficient cid))))
sysevent ev = liftIO $ print ev
type WorldObj = SObjT (WorldOp AllEvent DriverB) DriverB
type WorldObjB = SObjBT (WorldOp AllEvent DriverB) DriverB
world :: HoodleState -> MainObj () -> WorldObj ()
world xstate initmc = ReaderT staction
where
staction req = runStateT erract xstate >> return ()
where erract = do r <- runEitherT (go initmc req)
case r of
Left e -> liftIO (errorlog (show e))
Right _r' -> return ()
go :: MainObj()
-> Arg (WorldOp AllEvent DriverB)
-> EStT HoodleState WorldObjB ()
go mcobj (Arg GiveEvent ev) = do
Right mcobj' <- liftM (fmap fst) (mcobj <==| doEvent ev)
req <- lift . lift $ request (Res GiveEvent ())
go mcobj' req
go mcobj (Arg FlushLog logobj) = do
logf <- (^. tempLog) <$> get
let msg = logf ""
if ((not.null) msg)
then do
Right logobj' <- lift . lift . lift $ liftM (fmap fst) (logobj <==| writeLog msg)
modify (tempLog .~ id)
req <- lift . lift $ request (Res FlushLog logobj')
go mcobj req
else do
req <- lift . lift $ request Ign
go mcobj req
go mcobj (Arg FlushQueue ()) = do
q <- (^. tempQueue) <$> get
let lst = fqueue q ++ reverse (bqueue q)
modify (tempQueue .~ emptyQueue)
req <- lift . lift $ request (Res FlushQueue lst)
go mcobj req
type Driver a = D.Driver AllEvent IO a
type DriverB = SObjBT (D.DrvOp AllEvent) IO
type EventVar = MVar (Maybe (Driver ()))
maybeError :: String -> Maybe a -> MainCoroutine a
maybeError str = maybe (lift . hoistEither . Left . Other $ str) return
doIOaction :: ((AllEvent -> IO ()) -> IO AllEvent) -> MainCoroutine ()
doIOaction action = modify (tempQueue %~ enqueue (mkIOaction action))