{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}
module Control.Eff.State.Lazy where
import Control.Eff
import Control.Eff.Extend
import Control.Eff.Writer.Lazy
import Control.Eff.Reader.Lazy
import Control.Monad.Base
import Control.Monad.Trans.Control
data State s v where
Get :: State s s
Put :: s -> State s ()
withState :: Monad m => a -> s -> m (a, s)
withState x s = return (x, s)
instance Handle (State s) (s -> r) where
handle k sreq s = case sreq of
Get -> k s s
Put s' -> k () s'
instance ( MonadBase m m
, LiftedBase m r
) => MonadBaseControl m (Eff (State s ': r)) where
type StM (Eff (State s ': r)) a = StM (Eff r) (a,s)
liftBaseWith f = do s <- get
raise $ liftBaseWith $ \runInBase ->
f (runInBase . runState s)
restoreM x = do (a, s :: s) <- raise (restoreM x)
put s
return a
{-# NOINLINE get #-}
get :: Member (State s) r => Eff r s
get = send Get
{-# RULES
"get/bind" forall k. get >>= k = send Get >>= k
#-}
{-# NOINLINE put #-}
put :: Member (State s) r => s -> Eff r ()
put s = send (Put s)
{-# RULES
"put/bind" forall k v. put v >>= k = send (Put v) >>= k
#-}
{-# RULES
"put/semibind" forall k v. put v >> k = send (Put v) >>= (\() -> k)
#-}
runState' :: s -> Eff (State s ': r) a -> Eff r (a, s)
runState' s m = handle_relay withState m s
runState :: s
-> Eff (State s ': r) a
-> Eff r (a, s)
runState s (Val x) = return (x,s)
runState s (E q u) = case decomp u of
Right Get -> runState s (q ^$ s)
Right (Put s1) -> runState s1 (q ^$ ())
Left u1 -> E (singleK (\x -> runState s (q ^$ x))) u1
modify :: (Member (State s) r) => (s -> s) -> Eff r ()
modify f = get >>= put . f
evalState :: s -> Eff (State s ': r) a -> Eff r a
evalState s = fmap fst . runState s
execState :: s -> Eff (State s ': r) a -> Eff r s
execState s = fmap snd . runState s
data TxState s v where
TxState :: TxState s s
type TxStateT s = TxState s s
withTxState :: Member (State s) r => a -> s -> Eff r a
withTxState x s = put s >> return x
transactionState :: forall s r a. Member (State s) r
=> TxStateT s -> Eff r a -> Eff r a
transactionState _ m = do
s <- get
(respond_relay' @(State s) (withTxState @s)) m s
runStateR :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s)
runStateR = loop
where
loop :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s)
loop s (Val x) = x `withState` s
loop s (E q u) = case decomp u of
Right (Tell w) -> handle k (Put w) s
Left u1 -> case decomp u1 of
Right Ask -> handle k Get s
Left u2 -> relay k u2 s
where k = connect loop q
connect nxt q = \s x -> qComp q (nxt x) s