module Eve.Internal.Actions
( Action(..)
, ActionF(..)
, App
, execApp
, AppState(..)
, asyncQueue
, liftAction
, runAction
, exit
, isExiting
, Exiting(..)
) where
import Eve.Internal.Extensions
import Data.Default
import Control.Monad.State
import Control.Monad.Trans.Free
import Control.Lens
import Pipes.Concurrent
type App a = Action AppState a
data AppState = AppState
{ _baseExts :: Exts
, _asyncQueue :: Output (App ())
}
newtype ActionF next =
LiftAction (StateT AppState IO next)
deriving (Functor, Applicative)
newtype Action zoomed a = Action
{ getAction :: FreeT ActionF (StateT zoomed IO) a
} deriving (Functor, Applicative, Monad, MonadIO, MonadState zoomed, MonadFree ActionF)
makeLenses ''AppState
instance HasExts AppState where
exts = baseExts
instance HasEvents AppState where
unLift :: FreeT ActionF (StateT AppState IO) a -> StateT AppState IO a
unLift m = do
step <- runFreeT m
case step of
Pure a -> return a
Free (LiftAction next) -> next >>= unLift
liftAction :: Action AppState a -> Action zoomed a
liftAction = liftF . LiftAction . unLift . getAction
execApp :: AppState -> Action AppState a -> IO a
execApp appState = flip evalStateT appState . unLift . getAction
type instance Zoomed (Action s) = Zoomed (FreeT ActionF (StateT s IO))
instance Zoom (Action s) (Action t) s t where
zoom l (Action action) = Action $ zoom l action
runAction :: Zoom m n s t => LensLike' (Zoomed m c) t s -> m c -> n c
runAction = zoom
newtype Exiting =
Exiting Bool
deriving (Show, Eq)
instance Default Exiting where
def = Exiting False
exit :: App ()
exit = ext .= Exiting True
isExiting :: App Bool
isExiting = do
Exiting b <- use ext
return b