extensible-effects 2.4.0.0 → 2.5.0.0

raw patch · 10 files changed

+315/−284 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• extensible-effects.cabal +3/−3
• src/Control/Eff/Reader/Lazy.hs +4/−4
• src/Control/Eff/Reader/Strict.hs +4/−4
• src/Control/Eff/State/Lazy.hs +49/−72
• src/Control/Eff/State/LazyState.hs +0/−90
• src/Control/Eff/State/OnDemand.hs +144/−0
• src/Control/Eff/State/Strict.hs +1/−1
• test/Control/Eff/State/LazyState/Test.hs +0/−108
• test/Control/Eff/State/OnDemand/Test.hs +108/−0
• test/Test.hs +2/−2

@@ -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

@@ -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.

@@ -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.

@@ -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?

@@ -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:--- <http://www.reddit.com/r/haskell/comments/387ex0/are_extensible_effects_a_complete_replacement_for/crt1pzm>------ 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?

@@ -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?

@@ -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)

@@ -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)

@@ -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)

@@ -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