diff --git a/extensible-effects.cabal b/extensible-effects.cabal --- a/extensible-effects.cabal +++ b/extensible-effects.cabal @@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 2.4.0.0 +version: 2.5.0.0 -- A short (one-line) description of the package. synopsis: An Alternative to Monad Transformers @@ -78,8 +78,8 @@ Control.Eff.Operational Control.Eff.Operational.Example Control.Eff.Reader.Lazy + Control.Eff.State.OnDemand Control.Eff.Reader.Strict - Control.Eff.State.LazyState Control.Eff.State.Lazy Control.Eff.State.Strict Control.Eff.Trace @@ -168,7 +168,7 @@ , Control.Eff.Reader.Lazy.Test , Control.Eff.Reader.Strict.Test , Control.Eff.State.Lazy.Test - , Control.Eff.State.LazyState.Test + , Control.Eff.State.OnDemand.Test , Control.Eff.State.Strict.Test , Control.Eff.Trace.Test , Control.Eff.Writer.Lazy.Test diff --git a/src/Control/Eff/Reader/Lazy.hs b/src/Control/Eff/Reader/Lazy.hs --- a/src/Control/Eff/Reader/Lazy.hs +++ b/src/Control/Eff/Reader/Lazy.hs @@ -24,7 +24,7 @@ -- we expect in reply the value of type 'e', the value from the -- environment. So, the return type is restricted: 'a ~ e' data Reader e v where - Reader :: Reader e e + Ask :: Reader e e -- ^ -- One can also define this as -- @@ -43,14 +43,14 @@ -- | Get the current value from a Reader. -- The signature is inferred (when using NoMonomorphismRestriction). ask :: (Member (Reader e) r) => Eff r e -ask = send Reader +ask = send Ask -- | The handler of Reader requests. The return type shows that all Reader -- requests are fully handled. runReader :: Eff (Reader e ': r) w -> e -> Eff r w runReader m e = handle_relay return - (\Reader k -> k e) + (\Ask -> ($ e)) m -- | Locally rebind the value in the dynamic environment This function is like a @@ -61,7 +61,7 @@ e <- reader f let h :: Reader e t -> (t -> Eff r b) -> Eff r b - h Reader g = g e + h Ask = ($ e) interpose return h m -- | Request the environment value using a transformation function. diff --git a/src/Control/Eff/Reader/Strict.hs b/src/Control/Eff/Reader/Strict.hs --- a/src/Control/Eff/Reader/Strict.hs +++ b/src/Control/Eff/Reader/Strict.hs @@ -25,7 +25,7 @@ -- we expect in reply the value of type 'e', the value from the -- environment. So, the return type is restricted: 'a ~ e' data Reader e v where - Reader :: Reader e e + Ask :: Reader e e -- ^ -- One can also define this as -- @@ -44,14 +44,14 @@ -- | Get the current value from a Reader. -- The signature is inferred (when using NoMonomorphismRestriction). ask :: (Member (Reader e) r) => Eff r e -ask = send Reader +ask = send Ask -- | The handler of Reader requests. The return type shows that all Reader -- requests are fully handled. runReader :: Eff (Reader e ': r) w -> e -> Eff r w runReader m !e = handle_relay return - (\Reader k -> k e) + (\Ask -> ($ e)) m -- | Locally rebind the value in the dynamic environment This function is like a @@ -62,7 +62,7 @@ e <- reader f let h :: Reader e t -> (t -> Eff r b) -> Eff r b - h Reader g = g e + h Ask = ($ e) interpose return h m -- | Request the environment value using a transformation function. diff --git a/src/Control/Eff/State/Lazy.hs b/src/Control/Eff/State/Lazy.hs --- a/src/Control/Eff/State/Lazy.hs +++ b/src/Control/Eff/State/Lazy.hs @@ -15,16 +15,25 @@ import Control.Eff.Reader.Lazy -- ------------------------------------------------------------------------ --- | State, lazy (i.e., on-demand) +-- | State, lazy -- --- Extensible effects make it clear that where the computation is delayed --- (which I take as an advantage) and they do maintain the degree of --- extensibility (the delayed computation must be effect-closed, but the --- whole computation does not have to be). +-- Initial design: +-- The state request carries with it the state mutator function +-- We can use this request both for mutating and getting the state. +-- But see below for a better design! +-- +-- > data State s v where +-- > State :: (s->s) -> State s s +-- +-- In this old design, we have assumed that the dominant operation is +-- modify. Perhaps this is not wise. Often, the reader is most nominant. +-- +-- See also below, for decomposing the State into Reader and Writer! +-- +-- The conventional design of State data State s v where - Get :: State s s - Put :: s -> State s () - Delay :: Eff '[State s] a -> State s a -- Eff as a transformer + Get :: State s s + Put :: s -> State s () -- | Return the current value of the state. The signatures are inferred {-# NOINLINE get #-} @@ -50,32 +59,24 @@ -- inline get/put, even if I put the INLINE directives and play with phases. -- (Inlining works if I use 'inline' explicitly). -onDemand :: Member (State s) r => Eff '[State s] v -> Eff r v -onDemand = send . Delay - 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 () - Delay m1 -> let ~(x,s1) = run $ runState' m1 s0 - in k s1 x) - m + handle_relay_s s (\s0 x -> return (x,s0)) + (\s0 sreq k -> case sreq of + Get -> k s0 s0 + Put s1 -> k s1 ()) + m -- Since State is so frequently used, we optimize it a bit -- | Run a State effect -runState :: Eff (State s ': r) w -- ^ Effect incorporating State - -> s -- ^ Initial state - -> Eff r (w,s) -- ^ Effect containing final state and a return value +runState :: Eff (State s ': r) w -- ^ Effect incorporating State + -> s -- ^ Initial state + -> Eff r (w,s) -- ^ Effect containing final state and a return value runState (Val x) s = return (x,s) -runState (E u0 q) s0 = case decomp u0 of - Right Get -> runState (q ^$ s0) s0 +runState (E u q) s = case decomp u of + Right Get -> runState (q ^$ s) s Right (Put s1) -> runState (q ^$ ()) s1 - Right (Delay m1) -> let ~(x,s1) = run $ runState m1 s0 - in runState (q ^$ x) s1 - Left u -> E u (singleK (\x -> runState (q ^$ x) s0)) + Left u1 -> E u1 (singleK (\x -> runState (q ^$ x) s)) -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r () @@ -89,56 +90,32 @@ execState :: Eff (State s ': r) w -> s -> Eff r s execState m s = fmap snd . flip runState s $ m +-- | An encapsulated State handler, for transactional semantics +-- The global state is updated only if the transactionState finished +-- successfully +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)) + -- | A different representation of State: decomposing State into mutation -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones. Thus we define a handler for two effects together. runStateR :: Eff (Writer s ': Reader s ': r) w -> s -> Eff r (w,s) -runStateR m0 s0 = loop s0 m0 +runStateR m s = loop s m where loop :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s) - loop s (Val x) = return (x,s) - loop s (E u0 q) = case decomp u0 of + loop s0 (Val x) = return (x,s0) + loop s0 (E u q) = case decomp u of Right (Tell w) -> k w () - Left u -> case decomp u of - Right Reader -> k s s - Left u1 -> E u1 (singleK (k s)) + 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) - --- | Backwards state --- The overall state is represented with two attributes: the inherited --- getAttr and the synthesized putAttr. --- At the root node, putAttr becomes getAttr, tying the knot. --- As usual, the inherited attribute is the argument (i.e., the `environment') --- and the synthesized is the result of the handler |go| below. -runStateBack0 :: Eff '[State s] a -> (a,s) -runStateBack0 m = - let (x,s) = go s m in - (x,s) - where - go :: s -> Eff '[State s] a -> (a,s) - go s (Val x) = (x,s) - go s0 (E u q) = 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 []" - --- | Another implementation, exploring Haskell's laziness to make putAttr --- also technically inherited, to accumulate the sequence of --- updates. This implementation is compatible with deep handlers, and --- lets us play with different notions of `backwardness' -runStateBack :: Eff '[State s] a -> (a,s) -runStateBack m = - let (x,(_sg,sp)) = run $ go (sp,[]) m in - (x,head sp) - where - go :: ([s],[s]) -> Eff '[State s] a -> Eff '[] (a,([s],[s])) - go ss = handle_relay_s ss (\ss0 x -> return (x,ss0)) - (\ss0@(sg,sp) req k -> case req of - Get -> k ss0 (head sg) - Put s1 -> k (tail sg,sp++[s1]) () - Delay m1 -> let ~(x,ss1) = run $ go ss0 m1 - in k ss1 x) - --- ^ A different notion of `backwards' is realized if we change the Put --- handler slightly. How? diff --git a/src/Control/Eff/State/LazyState.hs b/src/Control/Eff/State/LazyState.hs deleted file mode 100644 --- a/src/Control/Eff/State/LazyState.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE Safe #-} - --- | On-demand state computation: --- example taken from Edward Kmett's comment here: --- --- --- Extensible effects make it clear that where the computation is delayed and --- they do maintain the degree of extensibility (the delayed computation must be --- effect-closed, but the whole computation does not have to be). -module Control.Eff.State.LazyState where - -import Control.Eff - --- | Define a new effect for state on-demand (in ExtEff, the state is --- by default strict -- as it should be if we want the predictable performance --- and effect sequencing) -data LazyState s v where - LGet :: LazyState s s - LPut :: s -> LazyState s () - Delay :: Eff '[LazyState s] a -> LazyState s a -- Eff as a transformer - --- | Primitive state operations -lget :: Member (LazyState s) r => Eff r s -lget = send LGet - -lput :: Member (LazyState s) r => s -> Eff r () -lput = send . LPut - -lmodify :: (Member (LazyState s) r, Member (LazyState t) r) - => (t -> s) -> Eff r () -lmodify f = do - s <- lget - lput (f s) - -onDemand :: Member (LazyState s) r => Eff '[LazyState s] v -> Eff r v -onDemand = send . Delay - --- | The handler -runStateLazy :: s -> Eff (LazyState s ': r) a -> Eff r (a,s) -runStateLazy s = handle_relay_s s (\s0 x -> return (x,s0)) - (\s0 req k -> case req of - LGet -> k s0 s0 - LPut s1 -> k s1 () - Delay m -> let ~(x,s1) = run $ runStateLazy s0 m - in k s1 x) - --- | Backwards state --- The overall state is represented with two attributes: the inherited --- getAttr and the synthesized putAttr. --- At the root node, putAttr becomes getAttr, tying the knot. --- As usual, the inherited attribute is the argument (i.e., the `environment') --- and the synthesized is the result of the handler |go| below. -runStateBack0 :: Eff '[LazyState s] a -> (a,s) -runStateBack0 m = - let (x,s) = go s m in - (x,s) - where - go :: s -> Eff '[LazyState s] a -> (a,s) - go s (Val x) = (x,s) - go s (E u q) = case decomp u of - Right LGet -> go s $ (q ^$ s) - Right (LPut s1) -> let ~(x,sp) = go sp $ (q ^$ ()) in (x,s1) - Right (Delay m1) -> let ~(x,s1) = go s m1 in go s1 $ (q ^$ x) - Left _ -> error "LazyState: the impossible happened: Union []" - --- | Another implementation, exploring Haskell's laziness to make putAttr --- also technically inherited, to accumulate the sequence of --- updates. This implementation is compatible with deep handlers, and --- lets us play with different notions of `backwardness' -runStateBack :: Eff '[LazyState s] a -> (a,s) -runStateBack m = - let (x,(_,sp)) = run $ go (sp,[]) m in - (x,head sp) - where - go :: ([s],[s]) -> Eff '[LazyState s] a -> Eff '[] (a,([s],[s])) - go ss = handle_relay_s ss (\ss1 x -> return (x,ss1)) - (\ss1@(sg,sp) req k -> case req of - LGet -> k ss1 (head sg) - LPut s -> k (tail sg,sp++[s]) () - Delay m1 -> let ~(x,ss2) = run $ go ss1 m1 - in k ss2 x) - --- A different notion of `backwards' is realized if we change the LPut --- handler slightly. How? diff --git a/src/Control/Eff/State/OnDemand.hs b/src/Control/Eff/State/OnDemand.hs new file mode 100644 --- /dev/null +++ b/src/Control/Eff/State/OnDemand.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -Werror #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Trustworthy #-} +-- | Lazy state effect +module Control.Eff.State.OnDemand where + +import Control.Eff +import Control.Eff.Writer.Lazy +import Control.Eff.Reader.Lazy + +-- ------------------------------------------------------------------------ +-- | State, lazy (i.e., on-demand) +-- +-- Extensible effects make it clear that where the computation is delayed +-- (which I take as an advantage) and they do maintain the degree of +-- extensibility (the delayed computation must be effect-closed, but the +-- whole computation does not have to be). +data OnDemandState s v where + Get :: OnDemandState s s + Put :: s -> OnDemandState s () + Delay :: Eff '[OnDemandState s] a -> OnDemandState s a -- Eff as a transformer + +-- | Return the current value of the state. The signatures are inferred +{-# NOINLINE get #-} +get :: Member (OnDemandState s) r => Eff r s +get = send Get +{-# RULES + "get/bind" forall k. get >>= k = send Get >>= k + #-} + +-- | Write a new value of the state. +{-# 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) + #-} +-- The purpose of the rules is to expose send, which is then being +-- fuzed by the send/bind rule. The send/bind rule is very profitable! +-- These rules are essentially inlining of get/put. Somehow GHC does not +-- inline get/put, even if I put the INLINE directives and play with phases. +-- (Inlining works if I use 'inline' explicitly). + +onDemand :: Member (OnDemandState s) r => Eff '[OnDemandState s] v -> Eff r v +onDemand = send . Delay + +runState' :: Eff (OnDemandState 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 () + Delay m1 -> let ~(x,s1) = run $ runState' m1 s0 + in k s1 x) + m + +-- Since State is so frequently used, we optimize it a bit +-- | Run a State effect +runState :: Eff (OnDemandState s ': r) w -- ^ Effect incorporating State + -> s -- ^ Initial state + -> Eff r (w,s) -- ^ Effect containing final state and a return value +runState (Val x) s = return (x,s) +runState (E u0 q) s0 = case decomp u0 of + Right Get -> runState (q ^$ s0) s0 + Right (Put s1) -> runState (q ^$ ()) s1 + Right (Delay m1) -> let ~(x,s1) = run $ runState m1 s0 + in runState (q ^$ x) s1 + Left u -> E u (singleK (\x -> runState (q ^$ x) s0)) + +-- | Transform the state with a function. +modify :: (Member (OnDemandState s) r) => (s -> s) -> Eff r () +modify f = get >>= put . f + +-- | Run a State effect, discarding the final state. +evalState :: Eff (OnDemandState s ': r) w -> s -> Eff r w +evalState m s = fmap fst . flip runState s $ m + +-- | Run a State effect and return the final state. +execState :: Eff (OnDemandState s ': r) w -> s -> Eff r s +execState m s = fmap snd . flip runState s $ m + +-- | A different representation of State: decomposing State into mutation +-- (Writer) and Reading. We don't define any new effects: we just handle the +-- existing ones. Thus we define a handler for two effects together. +runStateR :: Eff (Writer s ': Reader s ': r) w -> s -> Eff r (w,s) +runStateR m0 s0 = loop s0 m0 + where + loop :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s) + loop s (Val x) = return (x,s) + loop s (E u0 q) = case decomp u0 of + Right (Tell w) -> k w () + Left u -> case decomp u of + Right Ask -> k s s + Left u1 -> E u1 (singleK (k s)) + where k x = qComp q (loop x) + +-- | Backwards state +-- The overall state is represented with two attributes: the inherited +-- getAttr and the synthesized putAttr. +-- At the root node, putAttr becomes getAttr, tying the knot. +-- As usual, the inherited attribute is the argument (i.e., the `environment') +-- and the synthesized is the result of the handler |go| below. +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 u q) = 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 []" + +-- | Another implementation, exploring Haskell's laziness to make putAttr +-- also technically inherited, to accumulate the sequence of +-- updates. This implementation is compatible with deep handlers, and +-- lets us play with different notions of `backwardness' +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 ss = handle_relay_s ss (\ss0 x -> return (x,ss0)) + (\ss0@(sg,sp) req k -> case req of + Get -> k ss0 (head sg) + Put s1 -> k (tail sg,sp++[s1]) () + Delay m1 -> let ~(x,ss1) = run $ go ss0 m1 + in k ss1 x) + +-- ^ A different notion of `backwards' is realized if we change the Put +-- handler slightly. How? diff --git a/src/Control/Eff/State/Strict.hs b/src/Control/Eff/State/Strict.hs --- a/src/Control/Eff/State/Strict.hs +++ b/src/Control/Eff/State/Strict.hs @@ -117,6 +117,6 @@ loop s0 (E u q) = case decomp u of Right (Tell w) -> k w () Left u1 -> case decomp u1 of - Right Reader -> k s0 s0 + Right Ask -> k s0 s0 Left u2 -> E u2 (singleK (k s0)) where k x = qComp q (loop x) diff --git a/test/Control/Eff/State/LazyState/Test.hs b/test/Control/Eff/State/LazyState/Test.hs deleted file mode 100644 --- a/test/Control/Eff/State/LazyState/Test.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} -{-# LANGUAGE TypeOperators, DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - -module Control.Eff.State.LazyState.Test (testGroups) where - -import Test.HUnit hiding (State) -import Control.Eff -import Control.Eff.Exception -import Control.Eff.State.LazyState - -import Test.Framework.TH -import Test.Framework.Providers.HUnit - -testGroups = [ $(testGroupGenerator) ] - -case_LazierState_ex1 :: Assertion -case_LazierState_ex1 = - let actual = run $ runStateLazy 0 lex1 - in - assertEqual "LazyState: ex1" - ((), 1::Int) actual - where - lex1 = do - onDemand lex1 - lput (1::Int) - -case_LazierState_ex3 :: Assertion -case_LazierState_ex3 = - let (x,s) = run $ runStateLazy (undefined::[Int]) lex3 - in assertEqual "LazyState: ex3" - ((),[1,1,1,1,1]) (x,take 5 s) - where - lex3 = do - onDemand lex3 - lmodify ((1::Int):) - --- a bit more interesting -case_LazierState_ex4 = - let (x,s) = run $ runStateLazy [] lex4 - in assertEqual "LazyState: ex4" - expect (take 7 $ x,take 5 $ s) - where - expect = ([3,2,3,2,3,2,3],[3,2,3,2,3]) - lex4 :: Eff '[LazyState [Int]] [Int] - lex4 = do - lmodify ((0::Int):) - onDemand lex4 - lmodify ((1::Int):) - onDemand (onDemand lex4 :: Eff '[LazyState [Int]] [Int]) - lmodify ((2::Int):) - lmodify ((3::Int):) - lget - - --- Edward's example plus exceptions -case_LazierState_ex5 :: Assertion -case_LazierState_ex5 = - let - -- the annotations below are needed for assertEqual - ex5Run :: Either [Int] () = fst . run . runStateLazy (undefined::[Int]) . runError $ lex5 - ex51Run :: Either [Int] ((), [Int]) = run . runError . runStateLazy (undefined::[Int]) $ lex5 - in - assertEqual "LazyState ex5" (Left ones) ex5Run - >> assertEqual "LazyState ex51" (Left ones) ex51Run - where - ones = take 5 $ repeat (1::Int) - lex31 :: Member (LazyState [Int]) r => Eff r () - lex31 = do - onDemand (lex31 :: Eff '[LazyState [Int]] ()) - lmodify ((1::Int):) - - lex5 = do - lex31 - x <- lget - throwError ((take 5 x)::[Int]) - -case_LazierState_st :: Assertion -case_LazierState_st = let - stF :: ((Int,Int,Int),Int) = run $ runStateLazy (0::Int) st - stB0 :: ((Int,Int,Int),Int) = runStateBack0 st - stB :: ((Int,Int,Int),Int) = runStateBack st - in - assertEqual "LazyState stF" ((0,1,3),4) stF - >> assertEqual "LazyState stB0" ((1,2,4),1) stB0 - >> assertEqual "LazyState stB" ((1,2,4),1) stB - where - st = do - x <- lget - lput (1::Int) - lput (1::Int) - y <- lget - lput (2::Int) - lput (10::Int) - lput (3::Int) - z <- lget - lput (4::Int) - return (x,y,z) - -case_LazierState_ones :: Assertion -case_LazierState_ones = - let ones :: [Int] = snd $ runStateBack $ do - s <- lget - lput ((1::Int):s) - in - assertEqual "LazyState ones" [1,1,1,1,1] (take 5 ones) diff --git a/test/Control/Eff/State/OnDemand/Test.hs b/test/Control/Eff/State/OnDemand/Test.hs new file mode 100644 --- /dev/null +++ b/test/Control/Eff/State/OnDemand/Test.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# LANGUAGE TypeOperators, DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module Control.Eff.State.OnDemand.Test (testGroups) where + +import Test.HUnit hiding (State) +import Control.Eff +import Control.Eff.Exception +import Control.Eff.State.OnDemand + +import Test.Framework.TH +import Test.Framework.Providers.HUnit + +testGroups = [ $(testGroupGenerator) ] + +case_LazierState_ex1 :: Assertion +case_LazierState_ex1 = + let actual = run $ runState lex1 0 + in + assertEqual "OnDemandState: ex1" + ((), 1::Int) actual + where + lex1 = do + onDemand lex1 + put (1::Int) + +case_LazierState_ex3 :: Assertion +case_LazierState_ex3 = + let (x,s) = run $ runState lex3 (undefined::[Int]) + in assertEqual "OnDemandState: ex3" + ((),[1,1,1,1,1]) (x,take 5 s) + where + lex3 = do + onDemand lex3 + modify ((1::Int):) + +-- a bit more interesting +case_LazierState_ex4 = + let (x,s) = run $ runState lex4 [] + in assertEqual "OnDemandState: ex4" + expect (take 7 $ x,take 5 $ s) + where + expect = ([3,2,3,2,3,2,3],[3,2,3,2,3]) + lex4 :: Eff '[OnDemandState [Int]] [Int] + lex4 = do + modify ((0::Int):) + onDemand lex4 + modify ((1::Int):) + onDemand (onDemand lex4 :: Eff '[OnDemandState [Int]] [Int]) + modify ((2::Int):) + modify ((3::Int):) + get + + +-- Edward's example plus exceptions +case_LazierState_ex5 :: Assertion +case_LazierState_ex5 = + let + -- the annotations below are needed for assertEqual + ex5Run :: Either [Int] () = fst . run $ runState (runError lex5) (undefined::[Int]) + ex51Run :: Either [Int] ((), [Int]) = run $ runError $ runState lex5 (undefined::[Int]) + in + assertEqual "OnDemandState ex5" (Left ones) ex5Run + >> assertEqual "OnDemandState ex51" (Left ones) ex51Run + where + ones = take 5 $ repeat (1::Int) + lex31 :: Member (OnDemandState [Int]) r => Eff r () + lex31 = do + onDemand (lex31 :: Eff '[OnDemandState [Int]] ()) + modify ((1::Int):) + + lex5 = do + lex31 + x <- get + throwError ((take 5 x)::[Int]) + +case_LazierState_st :: Assertion +case_LazierState_st = let + stF :: ((Int,Int,Int),Int) = run $ runState st (0::Int) + stB0 :: ((Int,Int,Int),Int) = runStateBack0 st + stB :: ((Int,Int,Int),Int) = runStateBack st + in + assertEqual "OnDemandState stF" ((0,1,3),4) stF + >> assertEqual "OnDemandState stB0" ((1,2,4),1) stB0 + >> assertEqual "OnDemandState stB" ((1,2,4),1) stB + where + st = do + x <- get + put (1::Int) + put (1::Int) + y <- get + put (2::Int) + put (10::Int) + put (3::Int) + z <- get + put (4::Int) + return (x,y,z) + +case_LazierState_ones :: Assertion +case_LazierState_ones = + let ones :: [Int] = snd $ runStateBack $ do + s <- get + put ((1::Int):s) + in + assertEqual "OnDemandState ones" [1,1,1,1,1] (take 5 ones) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -13,7 +13,7 @@ import qualified Control.Eff.Reader.Lazy.Test import qualified Control.Eff.Reader.Strict.Test import qualified Control.Eff.State.Lazy.Test -import qualified Control.Eff.State.LazyState.Test +import qualified Control.Eff.State.OnDemand.Test import qualified Control.Eff.State.Strict.Test import qualified Control.Eff.Trace.Test import qualified Control.Eff.Writer.Lazy.Test @@ -37,7 +37,7 @@ ++ Control.Eff.Reader.Lazy.Test.testGroups ++ Control.Eff.Reader.Strict.Test.testGroups ++ Control.Eff.State.Lazy.Test.testGroups - ++ Control.Eff.State.LazyState.Test.testGroups + ++ Control.Eff.State.OnDemand.Test.testGroups ++ Control.Eff.State.Strict.Test.testGroups ++ Control.Eff.Trace.Test.testGroups ++ Control.Eff.Writer.Lazy.Test.testGroups