module Rasa.Internal.Action
( Action(..)
, runAction
, evalAction
, execAction
, ActionState
, mkActionState
, Listener(..)
, ListenerId(..)
, Listeners
, listeners
, nextListenerId
, actionQueue
) where
import Rasa.Internal.Editor
import Rasa.Internal.Extensions
import Control.Lens
import Control.Monad.Free
import Control.Monad.State
import Data.Default
import Data.Map
import Data.Typeable
import Pipes.Concurrent hiding (Buffer)
data Listener = forall a. Listener ListenerId (a -> Action ())
data ListenerId =
ListenerId Int TypeRep
instance Eq ListenerId where
ListenerId a _ == ListenerId b _ = a == b
type Listeners = Map TypeRep [Listener]
data ActionF state next =
LiftState (state -> (next, state))
| LiftIO (IO next)
deriving (Functor)
newtype Action a = Action
{ getAction :: Free (ActionF ActionState) a
} deriving (Functor, Applicative, Monad)
data ActionState = ActionState
{ _ed :: Editor
, _listeners :: Listeners
, _nextListenerId :: Int
, _actionQueue :: Output (Action ())
}
makeLenses ''ActionState
instance Show ActionState where
show as = show (_ed as)
mkActionState :: Output (Action ()) -> ActionState
mkActionState out = ActionState
{ _ed=def
, _listeners=def
, _nextListenerId=0
, _actionQueue=out
}
instance HasEditor ActionState where
editor = ed
instance HasExts ActionState where
exts = ed.exts
liftActionF :: ActionF ActionState a -> Action a
liftActionF = Action . liftF
liftState :: (ActionState -> (a, ActionState)) -> Action a
liftState = liftActionF . LiftState
liftFIO :: IO r -> Action r
liftFIO = liftActionF . LiftIO
instance (MonadState ActionState) Action where
state = liftState
instance MonadIO Action where
liftIO = liftFIO
runAction :: ActionState -> Action a -> IO (a, ActionState)
runAction actionState (Action actionF) = actionInterpreter actionState actionF
evalAction :: ActionState -> Action a -> IO a
evalAction actionState action = fst <$> runAction actionState action
execAction :: ActionState -> Action a -> IO ActionState
execAction actionState action = snd <$> runAction actionState action
actionInterpreter :: ActionState -> Free (ActionF ActionState) r -> IO (r, ActionState)
actionInterpreter actionState (Free actionF) =
case actionF of
(LiftState stateFunc) ->
let (next, newState) = stateFunc actionState
in actionInterpreter newState next
(LiftIO ioNext) ->
ioNext >>= actionInterpreter actionState
actionInterpreter actionState (Pure res) = return (res, actionState)