{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Trustworthy #-}
module Control.Eff.State.OnDemand where
import Control.Eff
import Control.Eff.Extend
import Control.Eff.Writer.Lazy
import Control.Eff.Reader.Lazy
import qualified Control.Eff.State.Lazy as S
import Control.Monad.Base
import Control.Monad.Trans.Control
data OnDemandState s v where
Get :: OnDemandState s s
Put :: s -> OnDemandState s ()
Delay :: Eff '[OnDemandState s] a -> OnDemandState s a
instance Handle (OnDemandState s) (s -> r) where
handle k Get s = k s s
handle k (Put s) _ = k () s
handle k (Delay m) s = let ~(x, s') = run $ handle_relay S.withState m s
in k x s'
instance ( MonadBase m m
, LiftedBase m r
) => MonadBaseControl m (Eff (OnDemandState s ': r)) where
type StM (Eff (OnDemandState 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 (OnDemandState s) r => Eff r s
get = send Get
{-# RULES
"get/bind" forall k. get >>= k = send Get >>= k
#-}
{-# NOINLINE put #-}
put :: Member (OnDemandState 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)
#-}
onDemand :: Member (OnDemandState s) r => Eff '[OnDemandState s] v -> Eff r v
onDemand = send . Delay
runState' :: s -> Eff (OnDemandState s ': r) w -> Eff r (w,s)
runState' s m = handle_relay S.withState m s
runState :: s
-> Eff (OnDemandState s ': r) w
-> Eff r (w,s)
runState s (Val x) = S.withState x s
runState s0 (E q u0) = case decomp u0 of
Right Get -> runState s0 (q ^$ s0)
Right (Put s1) -> runState s1 (q ^$ ())
Right (Delay m1) -> let ~(x,s1) = run $ runState s0 m1
in runState s1 (q ^$ x)
Left u -> E (singleK (\x -> runState s0 (q ^$ x))) u
modify :: (Member (OnDemandState s) r) => (s -> s) -> Eff r ()
modify f = get >>= put . f
evalState :: s -> Eff (OnDemandState s ': r) w -> Eff r w
evalState s = fmap fst . runState s
execState :: s -> Eff (OnDemandState s ': r) w -> Eff r s
execState s = fmap snd . runState s
runStateR :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s)
runStateR s (Val x) = S.withState x s
runStateR s (E q u) = case decomp u of
Right (Tell w) -> handle k (S.Put w) s
Left u1 -> case decomp u1 of
Right Ask -> handle k S.Get s
Left u2 -> relay k u2 s
where k s' x = qComp q (runStateR x) s'
runStateBack0 :: Eff '[OnDemandState s] a -> (a,s)
runStateBack0 m =
let (x,s) = go s m in
(x,s)
where
go :: s -> Eff '[OnDemandState s] a -> (a,s)
go s (Val x) = (x,s)
go s0 (E q u) = case decomp u of
Right Get -> go s0 $ (q ^$ s0)
Right (Put s1) -> let ~(x,sp) = go sp $ (q ^$ ()) in (x,s1)
Right (Delay m1) -> let ~(x,s1) = go s0 m1 in go s1 $ (q ^$ x)
Left _ -> error "Impossible happened: Union []"
runStateBack :: Eff '[OnDemandState s] a -> (a,s)
runStateBack m =
let (x,(_sg,sp)) = run $ go (sp,[]) m in
(x,head sp)
where
go :: ([s],[s]) -> Eff '[OnDemandState s] a -> Eff '[] (a,([s],[s]))
go s m' = handle_relay' S.withState
(\k req ss0@(sg,sp) -> case req of
Get -> k (head sg) ss0
Put s1 -> k () (tail sg,sp++[s1])
Delay m1 -> let ~(x,ss1) = run $ go ss0 m1
in k x ss1)
m' s