module Dingo.Internal.CallbackTypes
( CallbackState
, CallbackM
, CallbackT(..)
, WrapCallback(..)
, addCommand
, augmentState
, getCommands
, mkSession
, runCallbackT
) where
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.State (StateT, runStateT)
import qualified Control.Monad.Trans.State as MTS
import qualified Data.Label as L
import Data.Label.PureM (modify)
import Data.Monoid (Monoid(..))
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as S
import Dingo.Internal.Base (Command(..))
import Dingo.Internal.SessionTypes
import Dingo.ResourceBundle (ResourceBundle)
data WrapCallback = WrapCallback { unWrapCallback :: CallbackM () }
data CallbackState =
CallbackState { _csCommands :: Seq Command
}
instance Monoid CallbackState where
mempty = CallbackState S.empty
mappend (CallbackState s1) (CallbackState s2) = CallbackState $ s1 `mappend` s2
newtype CallbackT m a = CallbackT { unCallback :: StateT CallbackState m a }
deriving (Functor, Monad)
instance MonadTrans CallbackT where
lift m = CallbackT $ lift m
instance (MonadIO m) => MonadIO (CallbackT m) where
liftIO = lift . liftIO
type CallbackM = CallbackT (SessionT WrapCallback IO)
$(L.mkLabels [''CallbackState])
mkSession :: CallbackM () -> [ResourceBundle] -> SessionState WrapCallback
mkSession main = mkSessionState (WrapCallback main)
getCommands :: CallbackState -> Seq Command
getCommands = L.get csCommands
runCallbackT :: Monad m => CallbackT m a -> m (a, CallbackState)
runCallbackT (CallbackT callback) = runStateT callback mempty
addCommand :: Monad m => Command -> CallbackT m ()
addCommand command = CallbackT $ modify csCommands (|> command)
augmentState :: Monad m => CallbackState -> CallbackT m ()
augmentState st = CallbackT $ MTS.modify $ \s -> s `mappend` st