module Control.Monad.State.LGBT( LGBT
, LGLT
, LGCT
, MonadLGBT (..)
, runLGBT
, runLGLT
, runLGCT
, withGlobal, withLocal
, getsLocal, getsGlobal
) where
import Control.Applicative
import Control.Monad.Cont
import Control.Monad.Logic
import Control.Monad.State.Strict
import Control.Monad.Backtrack
newtype LGBT localState globalState m a = LGBT { _unLGBT :: forall result.
StateT localState
(BacktrackT (Either String (result, localState))
(StateT globalState m)) a }
instance Functor (LGBT localState globalState m) where
fmap f (LGBT act) = LGBT $ fmap f act
instance Applicative (LGBT localState globalState m) where
LGBT f <*> LGBT a = LGBT $ f <*> a
pure v = LGBT $ pure v
instance Applicative m
=> Alternative (LGBT localState globalState m) where
empty = LGBT empty
LGBT a <|> LGBT b = LGBT $ a <|> b
some (LGBT act) = LGBT $ some act
many (LGBT act) = LGBT $ many act
instance Monad m
=> Monad (LGBT localState globalState m) where
return v = LGBT $ return v
LGBT a >>= b = LGBT $ a >>= (_unLGBT . b)
fail s = LGBT $ fail s
instance MonadPlus m
=> MonadPlus (LGBT localState globalState m) where
mzero = LGBT mzero
LGBT a `mplus` LGBT b = LGBT $ a `mplus` b
instance MonadIO m
=> MonadIO (LGBT localState globalState m) where
liftIO act = LGBT $ liftIO act
newtype LGLT localState globalState m a =
LGLT { _unLGLT ::
StateT localState (LogicT (StateT globalState m)) a }
deriving (Functor, Applicative, Alternative,
Monad, MonadPlus, MonadIO, MonadLogic)
newtype LGCT localState globalState result m a = LGCT { _unLGCT ::
StateT localState (ContT (result, localState) (StateT globalState m)) a }
deriving (Functor, Applicative, Monad, MonadIO, MonadCont)
instance MonadTrans (LGBT localState globalState) where
lift act = LGBT $ lift $ lift $ lift act
instance MonadTrans (LGLT localState globalState) where
lift = LGLT . lift . lift . lift
instance MonadTrans (LGCT localState globalState result) where
lift = LGCT . lift . lift . lift
class Monad m
=> MonadLGBT m localState globalState
| m -> localState,
m -> globalState where
getLocal :: m localState
getGlobal :: m globalState
putLocal :: localState -> m ()
putGlobal :: globalState -> m ()
modifyLocal :: (localState -> localState ) -> m ()
modifyLocal m = putLocal . m =<< getLocal
modifyGlobal :: (globalState -> globalState) -> m ()
modifyGlobal m = putGlobal . m =<< getGlobal
getsLocal :: forall m localState globalState a.
MonadLGBT m localState globalState
=> (localState -> a) -> m a
getsLocal f = f <$> getLocal
getsGlobal :: forall m localState globalState a.
MonadLGBT m localState globalState
=> (globalState -> a) -> m a
getsGlobal f = f <$> getGlobal
instance Monad m
=> MonadLGBT (LGBT localState globalState m)
localState globalState where
getLocal = LGBT get
getGlobal = LGBT $ lift $ lift get
putLocal l = LGBT $ put l
putGlobal g = LGBT $ lift . lift $ put g
modifyLocal m = LGBT $ modify m
modifyGlobal m = LGBT $ lift . lift $ modify m
instance Monad m
=> MonadLGBT (LGLT localState globalState m)
localState globalState where
getLocal = LGLT get
getGlobal = LGLT $ lift $ lift get
putLocal = LGLT . put
putGlobal = LGLT . lift . lift . put
modifyLocal = LGLT . modify
modifyGlobal = LGLT . lift . lift . modify
withLocal :: forall (t :: (* -> *) -> * -> *)
(m :: * -> *)
localState
globalState.
(Monad m,
MonadTrans t ,
MonadLGBT (t m) localState globalState)
=> (localState -> m localState )
-> t m ()
withLocal f = getLocal >>= (lift . f) >>= putLocal
withGlobal :: forall (t :: (* -> *) -> * -> *)
(m :: * -> * )
localState
globalState.
(Monad m,
MonadTrans t ,
MonadLGBT (t m) localState globalState)
=> (globalState -> m globalState)
-> t m ()
withGlobal f = getGlobal >>= (lift . f) >>= putGlobal
runLGBT :: forall m localState globalState result.
Monad m
=> LGBT localState globalState m result
-> localState
-> globalState
-> m (Either String (result, localState), globalState)
runLGBT (LGBT act) localState globalState =
runStateT (runBacktrackT (runStateT act localState) onFailure onSuccess) globalState
where
onFailure = pure . Left
onSuccess = pure . Right
runLGLT :: forall m result success localState globalState.
Monad m
=> LGLT localState globalState m success
-> localState
-> globalState
-> (success -> localState -> globalState -> m result -> m result)
-> ( globalState -> m result)
-> m result
runLGLT (LGLT act) localState globalState onSuccess onFailure =
evalStateT (runLogicT (runStateT act localState) onSuccess' onFailure') globalState
where
onFailure' = lift . onFailure =<< get
onSuccess' (r, local) next = do
global <- get
lift $ onSuccess r local global $ evalStateT next global
runLGCT :: forall m localState globalState result.
Monad m
=> LGCT localState globalState result m result
-> localState
-> globalState
-> m ((result, localState), globalState)
runLGCT (LGCT act) localState globalState =
runStateT (runContT (runStateT act localState) return) globalState