{-# language GeneralizedNewtypeDeriving #-}
{-# language DeriveFunctor #-}
{-# language FlexibleInstances #-}
{-# language FlexibleContexts #-}
{-# language MultiParamTypeClasses #-}
{-# language RankNTypes #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# language ScopedTypeVariables #-}
module Eve.Internal.Actions
( AppF(..)
, ActionT(..)
, AppT
, runEve
, evalEve
, execEve
, runApp
, runAction
, runActionOver
) where
import Eve.Internal.States
import Control.Monad.State
import Control.Monad.Trans.Free
import Control.Lens
import Data.Typeable
import Data.Default
import Data.Semigroup
type AppT s m a = ActionT s s m a
newtype AppF base m next =
RunApp (StateT base m next)
deriving (Functor, Applicative)
newtype ActionT base zoomed m a = ActionT
{ getAction :: FreeT (AppF base m) (StateT zoomed m) a
} deriving (Functor, Applicative, Monad, MonadIO, MonadState zoomed)
instance (Semigroup a,Monad m) => Semigroup (ActionT base zoomed m a) where
a <> b = do
a' <- a
b' <- b
return $ a' <> b'
instance (Monoid a, Monad m) => Monoid (ActionT base zoomed m a) where
mempty = return mempty
mappend = (<>)
instance Monad n => MonadFree (AppF base n) (ActionT base zoomed n) where
wrap (RunApp act) = join . ActionT . liftF . RunApp $ act
instance MonadTrans (ActionT base zoomed) where
lift = ActionT . lift . lift
unLift :: Monad m => FreeT (AppF base m) (StateT base m) a -> StateT base m a
unLift m = do
step <- runFreeT m
case step of
Pure a -> return a
Free (RunApp next) -> next >>= unLift
type instance Zoomed (ActionT base zoomed m) = Zoomed (FreeT (AppF base m) (StateT zoomed m))
instance Monad m => Zoom (ActionT base s m) (ActionT base t m) s t where
zoom l (ActionT action) = ActionT $ zoom l action
runAction :: (HasStates t, Functor (Zoomed m c), Default s, Typeable s, Zoom m n s t) => m c -> n c
runAction = zoom stateLens
runActionOver :: Zoom m n s t => LensLike' (Zoomed m c) t s -> m c -> n c
runActionOver = zoom
runApp :: Monad m => AppT base m a -> ActionT base zoomed m a
runApp = liftF . RunApp . unLift . getAction
runEve :: Monad m => base -> AppT base m a -> m (a, base)
runEve baseState = flip runStateT baseState . unLift . getAction
evalEve :: Monad m => base -> AppT base m a -> m a
evalEve baseState = fmap fst . runEve baseState
execEve :: Monad m => base -> AppT base m a -> m base
execEve baseState = fmap snd . runEve baseState