{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Trustworthy #-}
module Control.Eff.State.Strict where
import Control.Eff.Internal
import Control.Eff.Writer.Strict
import Control.Eff.Reader.Strict
import Data.OpenUnion
import Control.Monad.Base
import Control.Monad.Trans.Control
data State s v where
Get :: State s s
Put :: !s -> State s ()
instance ( MonadBase m m
, SetMember Lift (Lift m) r
, MonadBaseControl m (Eff 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 (\k -> runInBase $ runState k 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' :: Eff (State s ': r) w -> s -> Eff r (w,s)
runState' m !s =
handle_relay_s s (\s0 x -> return (x,s0))
(\s0 sreq k -> case sreq of
Get -> k s0 s0
Put s1 -> k s1 ())
m
runState :: Eff (State s ': r) w
-> s
-> Eff r (w,s)
runState (Val x) !s = return (x,s)
runState (E u q) !s = case decomp u of
Right Get -> runState (q ^$ s) s
Right (Put s1) -> runState (q ^$ ()) s1
Left u1 -> E u1 (singleK (\x -> runState (q ^$ x) s))
modify :: (Member (State s) r) => (s -> s) -> Eff r ()
modify f = get >>= put . f
evalState :: Eff (State s ': r) w -> s -> Eff r w
evalState m !s = fmap fst . flip runState s $ m
execState :: Eff (State s ': r) w -> s -> Eff r s
execState m !s = fmap snd . flip runState s $ m
data TxState s = TxState
transactionState :: forall s r w. Member (State s) r =>
TxState s -> Eff r w -> Eff r w
transactionState _ m = do s <- get; loop s m
where
loop :: s -> Eff r w -> Eff r w
loop s (Val x) = put s >> return x
loop s (E (u::Union r b) q) = case prj u :: Maybe (State s b) of
Just Get -> loop s (q ^$ s)
Just (Put s') -> loop s'(q ^$ ())
_ -> E u (qComps q (loop s))
runStateR :: Eff (Writer s ': Reader s ': r) w -> s -> Eff r (w,s)
runStateR m !s = loop s m
where
loop :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s)
loop s0 (Val x) = return (x,s0)
loop s0 (E u q) = case decomp u of
Right (Tell w) -> k w ()
Left u1 -> case decomp u1 of
Right Ask -> k s0 s0
Left u2 -> E u2 (singleK (k s0))
where k x = qComp q (loop x)