extensible-effects 2.0.1.0 → 2.1.0.0

raw patch · 41 files changed

+1527/−1132 lines, 41 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +7/−1
• extensible-effects.cabal +23/−4
• src/Control/Eff.hs +4/−1
• src/Control/Eff/Choose.hs +15/−9
• src/Control/Eff/Coroutine.hs +0/−1
• src/Control/Eff/Cut.hs +0/−1
• src/Control/Eff/Example.hs +12/−2
• src/Control/Eff/Exception.hs +0/−1
• src/Control/Eff/Fresh.hs +0/−1
• src/Control/Eff/Lift.hs +17/−2
• src/Control/Eff/NdetEff.hs +0/−1
• src/Control/Eff/Operational.hs +0/−1
• src/Control/Eff/Operational/Example.hs +1/−2
• src/Control/Eff/Reader/Lazy.hs +0/−1
• src/Control/Eff/Reader/Strict.hs +0/−1
• src/Control/Eff/State/Lazy.hs +0/−1
• src/Control/Eff/State/LazyState.hs +0/−1
• src/Control/Eff/State/Strict.hs +0/−1
• src/Control/Eff/Trace.hs +0/−1
• src/Control/Eff/Writer/Lazy.hs +0/−1
• src/Control/Eff/Writer/Strict.hs +0/−1
• test/Control/Eff/Choose/Test.hs +57/−0
• test/Control/Eff/Coroutine/Test.hs +225/−0
• test/Control/Eff/Cut/Test.hs +40/−0
• test/Control/Eff/Example/Test.hs +53/−0
• test/Control/Eff/Exception/Test.hs +91/−0
• test/Control/Eff/Fresh/Test.hs +28/−0
• test/Control/Eff/Lift/Test.hs +220/−0
• test/Control/Eff/NdetEff/Test.hs +72/−0
• test/Control/Eff/Operational/Test.hs +32/−0
• test/Control/Eff/Reader/Lazy/Test.hs +97/−0
• test/Control/Eff/Reader/Strict/Test.hs +26/−0
• test/Control/Eff/State/Lazy/Test.hs +32/−0
• test/Control/Eff/State/LazyState/Test.hs +108/−0
• test/Control/Eff/State/Strict/Test.hs +101/−0
• test/Control/Eff/Test.hs +31/−0
• test/Control/Eff/Trace/Test.hs +56/−0
• test/Control/Eff/Writer/Lazy/Test.hs +59/−0
• test/Control/Eff/Writer/Strict/Test.hs +22/−0
• test/Test.hs +44/−1097
• test/Utils.hs +54/−0

@@ -14,9 +14,15 @@   * Effects can be added, removed, and interwoven without changes to code not     dealing with those effects. -## Disadvantages+## Limitations  ### Current implementation only supports GHC version 7.8 and above+This is not a fundamental limitation of the design or the approach, but there is+an overhead with making the code compatible across a large number of GHC+versions. If this is needed, patches are welcome :)++## Disadvantages+ ### Ambiguity-Flexibility tradeoff   * The extensibility comes at the cost of some ambiguity. Note, however, that     the extensibility can be traded back, but that detracts from some of the

@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             2.0.1.0+version:             2.1.0.0  -- A short (one-line) description of the package. synopsis:            An Alternative to Monad Transformers@@ -75,16 +75,16 @@                        Control.Eff.Fresh                        Control.Eff.Lift                        Control.Eff.NdetEff+                       Control.Eff.Operational+                       Control.Eff.Operational.Example                        Control.Eff.Reader.Lazy                        Control.Eff.Reader.Strict                        Control.Eff.State.LazyState                        Control.Eff.State.Lazy                        Control.Eff.State.Strict+                       Control.Eff.Trace                        Control.Eff.Writer.Lazy                        Control.Eff.Writer.Strict-                       Control.Eff.Trace-                       Control.Eff.Operational-                       Control.Eff.Operational.Example                        Data.OpenUnion    -- Modules included in this library but not exported.@@ -143,6 +143,25 @@   type: exitcode-stdio-1.0   main-is: Test.hs   hs-source-dirs: test/+  other-modules:  Utils+                , Control.Eff.Test+                , Control.Eff.Choose.Test+                , Control.Eff.Coroutine.Test+                , Control.Eff.Cut.Test+                , Control.Eff.Example.Test+                , Control.Eff.Exception.Test+                , Control.Eff.Fresh.Test+                , Control.Eff.Lift.Test+                , Control.Eff.NdetEff.Test+                , Control.Eff.Operational.Test+                , Control.Eff.Reader.Lazy.Test+                , Control.Eff.Reader.Strict.Test+                , Control.Eff.State.Lazy.Test+                , Control.Eff.State.LazyState.Test+                , Control.Eff.State.Strict.Test+                , Control.Eff.Trace.Test+                , Control.Eff.Writer.Lazy.Test+                , Control.Eff.Writer.Strict.Test    ghc-options: -Wall 

@@ -20,7 +20,10 @@ -- Extensible Effects are implemented as typeclass constraints on an Eff[ect] datatype. -- A contrived example can be found under "Control.Eff.Example". To run the -- effects, consult the tests.-module Control.Eff where+module Control.Eff (+  module Control.Eff+  , module Data.OpenUnion+  ) where  #if __GLASGOW_HASKELL__ < 710 import Control.Applicative

@@ -1,9 +1,11 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-}+{-# LANGUAGE CPP #-} -- The following is needed to define MonadPlus instance. It is decidable -- (there is no recursion!), but GHC cannot see that. {-# LANGUAGE UndecidableInstances #-}@@ -17,7 +19,10 @@                           ) where  import Control.Eff-import Data.OpenUnion+#if __GLASGOW_HASKELL__ > 708+import Control.Applicative+import Control.Monad+#endif  -- ------------------------------------------------------------------------ -- | Non-determinism (choice)@@ -42,15 +47,16 @@ mplus' :: Member Choose r => Eff r a -> Eff r a -> Eff r a mplus' m1 m2 = choose [m1,m2] >>= id --- FIXME: find a way to uncomment--- -- MonadPlus-like operators are expressible via choose--- instance Member Choose r => Alternative (Eff r) where---   empty     = choose []---   m1 <|> m2 = choose [m1,m2] >>= id+#if __GLASGOW_HASKELL__ > 708+-- | MonadPlus-like operators are expressible via choose+instance Member Choose r => Alternative (Eff r) where+  empty = mzero'+  (<|>) = mplus' --- instance Member Choose r => MonadPlus (Eff r) where---   mzero = empty---   mplus = (<|>)+instance Member Choose r => MonadPlus (Eff r) where+  mzero = empty+  mplus = (<|>)+#endif  -- | Run a nondeterministic effect, returning all values. makeChoice :: forall a r. Eff (Choose ': r) a -> Eff r [a]

@@ -11,7 +11,6 @@                             ) where  import Control.Eff-import Data.OpenUnion  -- ------------------------------------------------------------------------ -- | Co-routines

@@ -43,7 +43,6 @@ import Control.Eff import Control.Eff.Exception import Control.Eff.Choose-import Data.OpenUnion  data CutFalse = CutFalse 

@@ -3,15 +3,25 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Safe #-} --- | Example usage of "Control.Eff1"+-- | Example usage of "Control.Eff" module Control.Eff.Example where  import Control.Eff-import Data.OpenUnion+import Control.Eff.Exception  import Control.Eff.State.Lazy import Control.Eff.Writer.Lazy +  -- {{{ TooBig++-- | The datatype for the example from the paper. See the tests for the example+newtype TooBig = TooBig Int deriving (Eq, Show)++-- | specialization to tell the type of the exception+runErrBig :: Eff (Exc TooBig ': r) a -> Eff r (Either TooBig a)+runErrBig = runExc++  -- }}}  -- | Write the elements of a list of numbers, in order. writeAll :: (Member (Writer a) e)

@@ -23,7 +23,6 @@  import Control.Eff import Control.Eff.Lift-import Data.OpenUnion  import Control.Monad (void) 

@@ -12,7 +12,6 @@                         ) where  import Control.Eff-import Data.OpenUnion  -- There are three possible implementations -- The first one uses State Fresh where

@@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} {-# LANGUAGE Safe #-} -- | Lifting primitive Monad types to effectful computations. -- We only allow a single Lifted Monad because Monads aren't commutative@@ -8,10 +8,11 @@ module Control.Eff.Lift ( Lift (..)                        , lift                        , runLift+                       , catchDynE                        ) where  import Control.Eff-import Data.OpenUnion+import qualified Control.Exception as Exc  -- ------------------------------------------------------------------------ -- | Lifting: emulating monad transformers@@ -28,3 +29,17 @@ runLift (E u q) = case prj u of                   Just (Lift m) -> m >>= runLift . qApp q                   Nothing -> error "Impossible: Nothing cannot occur"++-- | Catching of dynamic exceptions+-- See the problem in+-- http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO+catchDynE :: forall e a r.+             (SetMember Lift (Lift IO) r, Exc.Exception e) =>+             Eff r a -> (e -> Eff r a) -> Eff r a+catchDynE m eh = interpose return h m+ where+   -- Polymorphic local binding: signature is needed+   h :: Lift IO v -> Arr r v a -> Eff r a+   h (Lift em) k = lift (Exc.try em) >>= \x -> case x of+         Right x0 -> k x0+         Left  e -> eh e

@@ -14,7 +14,6 @@ module Control.Eff.NdetEff where  import Control.Eff-import Data.OpenUnion  import Control.Monad import Control.Applicative

@@ -19,7 +19,6 @@                                ) where  import Control.Eff-import Data.OpenUnion  -- | Lift values to an effect. -- You can think this is a generalization of @Lift@.

@@ -7,8 +7,7 @@ module Control.Eff.Operational.Example where  import Control.Eff.Operational-import Control.Eff (Eff(..))-import Data.OpenUnion+import Control.Eff import Control.Eff.Lift import Control.Eff.Writer.Lazy import Control.Eff.State.Lazy

@@ -13,7 +13,6 @@                               ) where  import Control.Eff-import Data.OpenUnion  -- ------------------------------------------------------------------------ -- | The Reader monad

@@ -14,7 +14,6 @@                               ) where  import Control.Eff-import Data.OpenUnion  -- ------------------------------------------------------------------------ -- | The Reader monad

@@ -13,7 +13,6 @@ import Control.Eff import Control.Eff.Writer.Lazy import Control.Eff.Reader.Lazy-import Data.OpenUnion  -- ------------------------------------------------------------------------ -- | State, lazy (i.e., on-demand)

@@ -16,7 +16,6 @@ module Control.Eff.State.LazyState where  import Control.Eff-import Data.OpenUnion  -- | 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

@@ -14,7 +14,6 @@ import Control.Eff import Control.Eff.Writer.Strict import Control.Eff.Reader.Strict-import Data.OpenUnion  -- ------------------------------------------------------------------------ -- | State, strict

@@ -11,7 +11,6 @@                         ) where  import Control.Eff-import Data.OpenUnion  -- | Trace effect for debugging data Trace v where

@@ -16,7 +16,6 @@                                ) where  import Control.Eff-import Data.OpenUnion  import Data.Monoid import Control.Applicative ((<|>))

@@ -17,7 +17,6 @@                                ) where  import Control.Eff-import Data.OpenUnion  import Data.Monoid import Control.Applicative ((<|>))

@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleContexts, AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Choose.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Example+import Control.Eff.Example.Test (ex2)+import Control.Eff.Exception+import Control.Eff.Choose+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Choose1_exc11 :: Assertion+case_Choose1_exc11 = [2,3] @=? (run exc11)+  where+    exc11 = makeChoice exc1+    exc1 = return 1 `add` choose [1,2]++case_Choose_ex2 :: Assertion+case_Choose_ex2 =+  let ex2_1 = run . makeChoice . runErrBig $ ex2 (choose [5,7,1])+      ex2_2 = run . runErrBig . makeChoice $ ex2 (choose [5,7,1])+  in+    assertEqual "Choose: Combining exceptions and non-determinism: ex2_1"+    expected1 ex2_1+    >> assertEqual "Choose: Combining exceptions and non-determinism: ex2_2"+    expected2 ex2_2+  where+    expected1 = [Right 5,Left (TooBig 7),Right 1]+    expected2 = Left (TooBig 7)++case_Choose_exRec :: Assertion+case_Choose_exRec =+  let exRec_1 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,1]))+      exRec_2 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,1]))+      exRec_3 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,11,1]))+  in+    assertEqual "Choose: error recovery: exRec_1" expected1 exRec_1+    >> assertEqual "Choose: error recovery: exRec_2" expected2 exRec_2+    >> assertEqual "Choose: error recovery: exRec_1" expected3 exRec_3+  where+    expected1 = Right [5,7,1]+    expected2 = [Right 5,Right 7,Right 1]+    expected3 = Left (TooBig 11)+    -- Errror recovery part+    -- The code is the same as in transf1.hs. The inferred signatures differ+    -- Was: exRec :: MonadError TooBig m => m Int -> m Int+    -- exRec :: Member (Exc TooBig) r => Eff r Int -> Eff r Int+    exRec m = catchExc m handler+      where handler (TooBig n) | n <= 7 = return n+            handler e = throwExc e

@@ -0,0 +1,225 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Control.Eff.Coroutine.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Coroutine+import Control.Eff.Trace+import Control.Eff.Reader.Strict+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++yieldInt :: Member (Yield Int ()) r => Int -> Eff r ()+yieldInt = yield++case_Coroutines_c1 :: Assertion+case_Coroutines_c1 = do+  ((), actual) <- catchOutput c1+  assertEqual+    "Coroutine: Simple coroutines using Eff"+    (unlines ["1", "2", "Done"]) actual+  where+    th1 :: Member (Yield Int ()) r => Eff r ()+    th1 = yieldInt 1 >> yieldInt 2++    c1 = runTrace (loop =<< runC th1)+      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+            loop (Done)    = trace ("Done")++case_Coroutines_c2 :: Assertion+case_Coroutines_c2 = do+  ((), actual1) <- catchOutput c2+  assertEqual "Coroutine: Add dynamic variables"+    (unlines ["10", "10", "Done"]) actual1+  ((), actual2) <- catchOutput c21+  assertEqual "Coroutine: locally changing the dynamic environment for the suspension"+    (unlines ["10", "11", "Done"]) actual2+  where+    -- The code is essentially the same as that in transf.hs (only added+    -- a type specializtion on yield). The inferred signature is different though.+    -- Before it was+    --    th2 :: MonadReader Int m => CoT Int m ()+    -- Now it is more general:+    th2 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r ()+    th2 = ask >>= yieldInt >> (ask >>= yieldInt)++    -- Code is essentially the same as in transf.hs; no liftIO though+    c2 = runTrace $ runReader (loop =<< runC th2) (10::Int)+      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+            loop Done    = trace "Done"++    -- locally changing the dynamic environment for the suspension+    c21 = runTrace $ runReader (loop =<< runC th2) (10::Int)+      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+            loop Done    = trace "Done"++case_Coroutines_c3 :: Assertion+case_Coroutines_c3 = do+  ((), actual1) <- catchOutput c3+  assertEqual "Coroutine: two sorts of local rebinding"+    (unlines ["10", "10", "20", "20", "Done"]) actual1+  ((), actual2) <- catchOutput c31+  let expected2 = (unlines ["10", "11", "21", "21", "Done"])+  assertEqual "Coroutine: locally changing the dynamic environment for the suspension"+    expected2 actual2+  ((), actual3) <- catchOutput c4+  assertEqual "Coroutine: abstracting the client computation"+    expected2 actual3+  where+    th3 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r ()+    th3 = ay >> ay >> local (+(10::Int)) (ay >> ay)+      where ay = ask >>= yieldInt++    c3 = runTrace $ runReader (loop =<< runC th3) (10::Int)+      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+            loop Done    = trace "Done"++    -- The desired result: the coroutine shares the dynamic environment with its+    -- parent; however, when the environment is locally rebound, it becomes+    -- private to coroutine.+    c31 = runTrace $ runReader (loop =<< runC th3) (10::Int)+      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+            loop Done    = trace "Done"++    -- We now make explicit that the client computation, run by th4,+    -- is abstract. We abstract it out of th4+    c4 = runTrace $ runReader (loop =<< runC (th4 client)) (10::Int)+      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+            loop Done    = trace "Done"++            -- cl, client, ay are monomorphic bindings+            th4 cl = cl >> local (+(10::Int)) cl+            client = ay >> ay+            ay     = ask >>= yieldInt++case_Corountines_c5 :: Assertion+case_Corountines_c5 = do+  ((), actual) <- catchOutput c5+  let expected = unlines ["10"+                         ,"11"+                         ,"12"+                         ,"18"+                         ,"18"+                         ,"18"+                         ,"29"+                         ,"29"+                         ,"29"+                         ,"29"+                         ,"29"+                         ,"29"+                         ,"Done"+                         ]+  assertEqual "Corountine: Even more dynamic example"+    expected actual+  where+    c5 = runTrace $ runReader (loop =<< runC (th client)) (10::Int)+      where loop (Y x k) = trace (show (x::Int)) >> local (\_y->x+1) (k ()) >>= loop+            loop Done    = trace "Done"++            -- cl, client, ay are monomorphic bindings+            client = ay >> ay >> ay+            ay     = ask >>= yieldInt++            -- There is no polymorphic recursion here+            th cl = do+              cl+              v <- ask+              (if v > (20::Int) then id else local (+(5::Int))) cl+              if v > (20::Int) then return () else local (+(10::Int)) (th cl)++case_Coroutines_c7 :: Assertion+case_Coroutines_c7 = do+  ((), actual) <- catchOutput c7+  let expected = unlines ["1010"+                         ,"1021"+                         ,"1032"+                         ,"1048"+                         ,"1064"+                         ,"1080"+                         ,"1101"+                         ,"1122"+                         ,"1143"+                         ,"1169"+                         ,"1195"+                         ,"1221"+                         ,"1252"+                         ,"1283"+                         ,"1314"+                         ,"1345"+                         ,"1376"+                         ,"1407"+                         ,"Done"+                         ]+  assertEqual "Coroutine: And even more dynamic example"+    expected actual+  where+    c7 = runTrace $+          runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double)+     where loop (Y x k) = trace (show (x::Int)) >>+                          local (\_y->fromIntegral (x+1)::Double) (k ()) >>= loop+           loop Done    = trace "Done"++           -- cl, client, ay are monomorphic bindings+           client = ay >> ay >> ay+           ay     = ask >>= \x -> ask >>=+                     \y -> yieldInt (x + round (y::Double))++           -- There is no polymorphic recursion here+           th cl = do+             cl+             v <- ask+             (if v > (20::Int) then id else local (+(5::Int))) cl+             if v > (20::Int) then return () else local (+(10::Int)) (th cl)++case_Coroutines_c7' :: Assertion+case_Coroutines_c7' = do+  ((), actual) <- catchOutput c7'+  let expected = unlines ["1010"+                         ,"1021"+                         ,"1032"+                         ,"1048"+                         ,"1048"+                         ,"1048"+                         ,"1069"+                         ,"1090"+                         ,"1111"+                         ,"1137"+                         ,"1137"+                         ,"1137"+                         ,"1168"+                         ,"1199"+                         ,"1230"+                         ,"1261"+                         ,"1292"+                         ,"1323"+                         ,"Done"+                         ]+  assertEqual "Coroutine: And even more dynamic example"+    expected actual+  where+    c7' = runTrace $+          runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double)+     where loop (Y x k) = trace (show (x::Int)) >>+                          local (\_y->fromIntegral (x+1)::Double) (k ()) >>= loop+           loop Done    = trace "Done"++           -- cl, client, ay are monomorphic bindings+           client = ay >> ay >> ay+           ay     = ask >>= \x -> ask >>=+                     \y -> yieldInt (x + round (y::Double))++           -- There is no polymorphic recursion here+           th cl = do+             cl+             v <- ask+             (if v > (20::Int) then id else local (+(5::Double))) cl+             if v > (20::Int) then return () else local (+(10::Int)) (th cl)

@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Cut.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Choose+import Control.Eff.Cut++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Cut_tcut :: Assertion+case_Cut_tcut =+  let tcut1r = run . makeChoice $ call tcut1+      tcut2r = run . makeChoice $ call tcut2+      tcut3r = run . makeChoice $ call tcut3+      tcut4r = run . makeChoice $ call tcut4+  in+    assertEqual "Cut: tcut1" [1,2] tcut1r+    >> assertEqual "Cut: nested call: tcut2" [1,2,5] tcut2r+    >> assertEqual "Cut: nested call: tcut3" [1,2,1,2,5] tcut3r+    >> assertEqual "Cut: nested call: tcut4" [1,2,1,2,5] tcut4r+  where+    -- signature is inferred+    -- tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int+    tcut1 = (return (1::Int) `mplus'` return 2) `mplus'`+            ((cutfalse `mplus'` return 4) `mplus'`+             return 5)+    -- Here we see nested call. It poses no problems...+    tcut2 = return (1::Int) `mplus'`+            call (return 2 `mplus'` (cutfalse `mplus'` return 3) `mplus'`+                  return 4)+            `mplus'` return 5+    tcut3 = call tcut1 `mplus'` call (tcut2 `mplus'` cutfalse)+    tcut4 = call tcut1 `mplus'`  (tcut2 `mplus'` cutfalse)

@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts, AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Example.Test (testGroups, ex2) where++import Test.HUnit hiding (State)+import Test.QuickCheck+import Test.Framework.TH+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2++import Control.Eff+import Control.Eff.Example+import Control.Eff.Exception+import Control.Eff.Reader.Lazy+import Control.Eff.Writer.Lazy+import Control.Eff.State.Lazy+import Utils++testGroups = [ $(testGroupGenerator) ]++-- The type is inferred+-- ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int+ex2 m = do+  v <- m+  if v > 5 then throwExc (TooBig v)+     else return v++case_Exception1_ex2r :: Assertion+case_Exception1_ex2r = (Right 5) @=? (run ex2r)+  where+    ex2r = runReader (runErrBig (ex2 ask)) (5::Int)++case_Exception1_ex2r1 :: Assertion+case_Exception1_ex2r1 = (Left (TooBig 7)) @=? (run ex2r1)+  where+    ex2r1 = runReader (runErrBig (ex2 ask)) (7::Int)++-- Different order of handlers (layers)+case_Exception1_ex2r2 :: Assertion+case_Exception1_ex2r2 = (Left (TooBig 7)) @=? (run ex2r2)+  where+    ex2r2 = runErrBig (runReader (ex2 ask) (7::Int))++prop_Documentation_example :: [Integer] -> Property+prop_Documentation_example l = let+  ((), total1) = run $ runState (sumAll l) 0+  ((), last1) = run $ runLastWriter $ writeAll l+  (((), last2), total2) = run $ runState (runLastWriter (writeAndAdd l)) 0+  (((), total3), last3) = run $ runLastWriter $ runState (writeAndAdd l) 0+  in+   allEqual [safeLast l, last1, last2, last3]+   .&&. allEqual [sum l, total1, total2, total3]

@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Exception.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Exception+import Control.Eff.Writer.Strict+import Data.Monoid+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++-- The type is inferred+-- et1 :: Eff r Int+et1 = return 1 `add` return 2++case_Exception1_et1 :: Assertion+case_Exception1_et1 = 3 @=? (run et1)++-- The type is inferred+-- et2 :: Member (Exc Int) r => Eff r Int+et2 = return 1 `add` throwExc (2::Int)++-- The following won't type: unhandled exception!+-- ex2rw = run et2+{-+    Could not deduce (Data.OpenUnion.FindElem (Exc Int) '[])+      arising from a use of `et2'+-}++case_Exception1_et21 :: Assertion+case_Exception1_et21 = (Left (2::Int)) @=?+  (run et21)+  where+    -- The inferred type shows that ex21 is now pure+    -- et21 :: Eff r (Either Int Int)++    et21 = runExc et2++-- Implementing the operator <|> from Alternative:+--  a <|> b does+--   -- tries a, and if succeeds, returns its result+--   -- otherwise, tries b, and if succeeds, returns its result+--   -- otherwise, throws mappend of exceptions of a and b++-- We use SetMember in the signature rather than Member to+-- ensure that the computation throws only one type of exceptions.+-- Otherwise, this construction is not very useful.+alttry :: forall e r a. (Monoid e, SetMember Exc (Exc e) r) =>+          Eff r a -> Eff r a -> Eff r a+alttry ma mb =+  catchExc ma $ \ea ->+  catchExc mb $ \eb -> throwExc (mappend (ea::e) eb)++case_Exception1_alttry :: Assertion+case_Exception1_alttry =+  [Right 10,Right 10,Right 10,Left "bummer1bummer2"] @=?+  [+  run . runExc $+     (return 1 `add` throwExc "bummer1") `alttry`+     (return 10),+  run . runExc $+     (return 10) `alttry`+     (return 1 `add` throwExc "bummer2"),+  run . runExc $+     (return 10) `alttry` return 20,+  run . runExc $+     (return 1 `add` throwExc "bummer1") `alttry`+     (return 1 `add` throwExc "bummer2")+     ]++case_Failure1_Effect :: Assertion+case_Failure1_Effect =+  let go :: Eff (Exc () ': Writer Int ': '[]) Int+         -> Int+      go = snd . run . runWriter (+) 0 . ignoreFail+      ret = go $ do+        tell (1 :: Int)+        tell (2 :: Int)+        tell (3 :: Int)+        () <- die+        tell (4 :: Int)+        return 5+   in assertEqual "Fail should stop writing" 6 ret

@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Fresh.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff.Fresh+import Control.Eff.Trace+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Fresh_tfresh' :: Assertion+case_Fresh_tfresh' = do+  ((), actual) <- catchOutput tfresh'+  assertEqual "Fresh: test"+    (unlines ["Fresh 0", "Fresh 1"]) actual+  where+    tfresh' = runTrace $ flip runFresh' 0 $ do+      n <- fresh+      trace $ "Fresh " ++ show n+      n <- fresh+      trace $ "Fresh " ++ show n

@@ -0,0 +1,220 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, NoMonomorphismRestriction #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Lift.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Exception+import Control.Eff.Lift+import Control.Eff.Reader.Strict+import Control.Eff.State.Strict+import qualified Control.Exception as Exc+import Data.Typeable+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++-- | Ensure that https://github.com/RobotGymnast/extensible-effects/issues/11 stays resolved.+case_Lift_building :: Assertion+case_Lift_building = runLift possiblyAmbiguous+  where+    possiblyAmbiguous :: (Monad m, SetMember Lift (Lift m) r) => Eff r ()+    possiblyAmbiguous = lift $ return ()++case_Lift_tl1r :: Assertion+case_Lift_tl1r = do+  ((), output) <- catchOutput tl1r+  assertEqual "Test tl1r" (showLn input) output+  where+    input = (5::Int)+    -- tl1r :: IO ()+    tl1r = runLift (runReader tl1 input)+      where+        tl1 = ask >>= \(x::Int) -> lift . print $ x++case_Lift_tMd' :: Assertion+case_Lift_tMd' = do+  actual <- catchOutput tMd'+  let expected = (output, (showLines input))+  assertEqual "Test mapMdebug using Lift" expected actual+  where+    input = [1..5]+    val = (10::Int)+    output = map (+ val) input++    tMd' = runLift $ runReader (mapMdebug' f input) val+      where f x = ask `add` return x++    -- Re-implemenation of mapMdebug using Lifting+    -- The signature is inferred+    mapMdebug'  :: (Show a, SetMember Lift (Lift IO) r) =>+                   (a -> Eff r b) -> [a] -> Eff r [b]+    mapMdebug' _f [] = return []+    mapMdebug' f (h:t) = do+      lift $ print h+      h' <- f h+      t' <- mapMdebug' f t+      return (h':t')++-- tests from <http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO>+data MyException = MyException String deriving (Show, Typeable)+instance Exc.Exception MyException++exfn True = lift . Exc.throw $ (MyException "thrown")+exfn False = return True++testc m = catchDynE (m >>= return . show) (\ (MyException s) -> return s)++case_catchDynE_test1 :: Assertion+case_catchDynE_test1 = do+  ((), actual) <- catchOutput test1+  let expected = unlines [ "(\"thrown\",[\"begin\"])"+                         , "(\"True\",[\"end\",\"begin\"])"]+  assertEqual "catchDynE: test1: exception shouldn't drop Writer's state"+    expected actual+  where+    -- In CatchMonadIO, the result of tf True is ("thrown",[]) --+    -- that is, an exception will drop the Writer's state, even if that+    -- exception is caught. Here, the state is preserved!+    -- So, this is an advantage over MTL!+    test1 = do runLift (tf True) >>= print; runLift (tf False) >>= print+    tf x = runReader (runState (testc m) ([]::[String])) (x::Bool)+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x+      modify ("end":)+      return r++-- Let us use an Error effect instead+case_catchDynE_test1' :: Assertion+case_catchDynE_test1' = do+  ((), actual') <- catchOutput test1'+  let expected' = unlines [ "(Left \"thrown\",[\"begin\"])"+                         , "(Right \"True\",[\"end\",\"begin\"])"]+  assertEqual "catchDynE: test1': Error shouldn't drop Writer's state"+    expected' actual'+  where+    -- In CatchMonadIO, the result of tf True is ("thrown",[]) --+    -- that is, an exception will drop the Writer's state, even if that+    -- exception is caught. Here, the state is preserved!+    -- So, this is an advantage over MTL!+    test1' = do runLift (tf True) >>= print; runLift (tf False) >>= print+    tf x = runReader (runState (runErrorStr (testc m)) ([]::[String])) (x::Bool)+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x+      modify ("end":)+      return r++    runErrorStr = asEStr . runExc+    asEStr :: m (Either String a) -> m (Either String a)+    asEStr = id+    exfn True = throwExc $ ("thrown")+    exfn False = return True++-- Now, the behavior of the dynamic Exception and Error effect is consistent.+-- The state is preserved. Before it wasn't.+case_catchDynE_test2 :: Assertion+case_catchDynE_test2 = do+  ((), actual) <- catchOutput test2+  let expected = unlines [ "(Left \"thrown\",[\"begin\"])"+                         , "(Right \"True\",[\"end\",\"begin\"])"]+  assertEqual "catchDynE: test2: Error shouldn't drop Writer's state"+    expected actual+  where+    test2 = do runLift (tf True) >>= print; runLift (tf False) >>= print+    tf x = runReader (runState (runErrorStr (testc m)) ([]::[String])) (x::Bool)+    runErrorStr = asEStr . runExc+    asEStr :: m (Either String a) -> m (Either String a)+    asEStr = id+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x `catchDynE` (\ (MyException s) -> throwExc s)+      modify ("end":)+      return r++-- Full recovery+case_catchDynE_test2' :: Assertion+case_catchDynE_test2' = do+  ((), actual) <- catchOutput test2'+  let expected = unlines [ "(Right \"False\",[\"end\",\"begin\"])"+                         , "(Right \"True\",[\"end\",\"begin\"])"]+  assertEqual "catchDynE: test2': Fully recover from errors"+    expected actual+  where+    test2' = do runLift (tf True) >>= print; runLift (tf False) >>= print+    tf x = runReader (runState (runErrorStr (testc m)) ([]::[String])) (x::Bool)+    runErrorStr = asEStr . runExc+    asEStr :: m (Either String a) -> m (Either String a)+    asEStr = id+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x `catchDynE` (\ (MyException _s) -> return False)+      modify ("end":)+      return r++-- Throwing within a handler+case_catchDynE_test3 :: Assertion+case_catchDynE_test3 = do+  ((), actual) <- catchOutput test3+  let expected = unlines [ "(Right \"rethrow:thrown\",[\"begin\"])"+                         , "(Right \"True\",[\"end\",\"begin\"])"]+  assertEqual "catchDynE: test3: Throwing within a handler"+    expected actual+  where+    test3 = do runLift (tf True) >>= print; runLift (tf False) >>= print+    tf x = runReader (runState (runErrorStr (testc m)) ([]::[String])) (x::Bool)+    runErrorStr = asEStr . runExc+    asEStr :: m (Either String a) -> m (Either String a)+    asEStr = id+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x `catchDynE` (\ (MyException s) ->+                                 lift . Exc.throw . MyException $+                                 ("rethrow:" ++ s))+      modify ("end":)+      return r++-- Implement the transactional behavior: when the exception is raised,+-- the state is rolled back to what it existed at the entrance to+-- the catch block.+-- This is the ``scoping behavior'' of `Handlers in action'+case_catchDynE_tran :: Assertion+case_catchDynE_tran = do+  ((), actual) <- catchOutput tran+  let expected = unlines ["(\"thrown\",[\"init\"])"+                         ,"(\"True\",[\"end\",\"begin\",\"init\"])"]+  assertEqual "catchDynE: tran: Transactional behaviour"+    expected actual+  where+    tran = do runLift (tf True) >>= print; runLift (tf False) >>= print+    tf x = runReader (runState m1 ([]::[String])) (x::Bool)+    m1 = do+      modify ("init":)+      testc (transactionState (ProxyState :: ProxyState [String]) m)+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x+      modify ("end":)+      return r+{- -- without transaction+("thrown",["begin","init"])+("True",["end","begin","init"])+-}++-- With transaction+{-+("thrown",["init"])+("True",["end","begin","init"])+-}

@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.NdetEff.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.NdetEff+import Control.Eff.Writer.Strict+import Control.Monad (msum, guard, mzero, mplus)++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_NdetEff_testCA :: Assertion+case_NdetEff_testCA = [2, 4..10] @=? (run $ makeChoiceA testCA)+  where+    testCA :: (Integral a) => Eff (NdetEff ': r) a+    testCA = do+      i <- msum . fmap return $ [1..10]+      guard (i `mod` 2 == 0)+      return i++case_NdetEff_ifte :: Assertion+case_NdetEff_ifte =+  let primes = ifte_test_run+  in+    assertEqual "NdetEff: test ifte using primes"+    [2,3,5,7,11,13,17,19,23,29] primes+  where+    ifte_test = do+      n <- gen+      ifte (do+               d <- gen+               guard $ d < n && n `mod` d == 0+               -- _ <- trace ("d: " ++ show d) (return ())+           )+        (\_ -> mzero)+        (return n)+        where gen = msum . fmap return $ [2..30]++    ifte_test_run :: [Int]+    ifte_test_run = run . makeChoiceA $ ifte_test+++-- called reflect in the LogicT paper+case_NdetEff_reflect :: Assertion+case_NdetEff_reflect =+  let tsplitr10 = run $ runListWriter $ makeChoiceA tsplit+      tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= unmsplit)+      tsplitr20 = run $ makeChoiceA $ runListWriter tsplit+      tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= unmsplit)+  in+    assertEqual "tsplitr10" expected1 tsplitr10+    >> assertEqual "tsplitr11" expected1 tsplitr11+    >> assertEqual "tsplitr20" expected2 tsplitr20+    >> assertEqual "tsplitr21" expected21 tsplitr21+  where+    expected1 = ([1, 2],["begin", "end"])+    expected2 = [(1, ["begin"]), (2, ["end"])]+    expected21 = [(1, ["begin"]), (2, ["begin", "end"])]++    unmsplit :: Member NdetEff r => (Maybe (a, Eff r a)) -> Eff r a+    unmsplit Nothing      = mzero+    unmsplit (Just (a,m)) = return a `mplus` m++    tsplit =+      (tell "begin" >> return 1) `mplus`+      (tell "end"   >> return 2)

@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DataKinds, TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Operational.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Operational+import Control.Eff.Operational.Example as Eg+import Control.Eff.State.Lazy+import Control.Eff.Writer.Lazy++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Operational_Monad :: Assertion+case_Operational_Monad =+  let comp :: (Member (State [String]) r+               , Member (Writer String) r)+              => Eff r ()+      comp = runProgram Eg.adventPure Eg.prog+      go = snd . run . runMonoidWriter $ evalState comp ["foo", "bar"]+  in+   assertEqual+   "Evaluating Operational Monad example"+   (unlines ["getting input...",+             "ok",+             "the input is foo"]) go

@@ -0,0 +1,97 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++module Control.Eff.Reader.Lazy.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Monad+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++t1 = ask `add` return (1::Int)++case_Lazy1_Reader_t1 :: Assertion+case_Lazy1_Reader_t1 = let+  t1' = do v <- ask; return (v + 1 :: Int)+  t1r = runReader t1 (10::Int)+  in+    -- 'run t1' should result in type-error+    11 @=? (run t1r)++t2 = do+  v1 <- ask+  v2 <- ask+  return $ fromIntegral (v1 + (1::Int)) + (v2 + (2::Float))+++case_Lazy1_Reader_t2 :: Assertion+case_Lazy1_Reader_t2 = let+  t2r = runReader t2 (10::Int)+  t2rr = flip runReader (20::Float) . flip runReader (10::Int) $ t2+  in+    33.0 @=? (run t2rr)++-- The opposite order of layers+{- If we mess up, we get an error+t2rrr1' = run $ runReader (runReader t2 (20::Float)) (10::Float)+    No instance for (Member (Reader Int) [])+      arising from a use of `t2'+-}+case_Lazy1_Reader_t2' :: Assertion+case_Lazy1_Reader_t2' = 33.0 @=?+  (run $ runReader (runReader t2 (20::Float)) (10::Int))+++case_Lazy1_Reader_t3 :: Assertion+case_Lazy1_Reader_t3 = let+  t3 = t1 `add` local (+ (10::Int)) t1+  in+    212 @=? (run $ runReader t3 (100::Int))++-- The following example demonstrates true interleaving of Reader Int+-- and Reader Float layers+{-+t4+  :: (Member (Reader Int) r, Member (Reader Float) r) =>+     () -> Eff r Float+-}+t4 = liftM2 (+) (local (+ (10::Int)) t2)+                (local (+ (30::Float)) t2)++case_Lazy1_Reader_t4 :: Assertion+case_Lazy1_Reader_t4 = 106.0 @=?+  (run $ runReader (runReader t4 (20::Float)) (10::Int))++-- The opposite order of layers gives the same result+case_Lazy1_Reader_t4' :: Assertion+case_Lazy1_Reader_t4' = 106.0 @=?+  (run $ runReader (runReader t4 (20::Float)) (10::Int))++-- Map an effectful function+case_Lazy1_Reader_tmap :: Assertion+case_Lazy1_Reader_tmap = let+  tmap = mapM f [1..5]+  in+    ([11,12,13,14,15] :: [Int]) @=?+    (run $ runReader tmap (10::Int))+  where+    f x = ask `add` return x++case_Lazy1_Reader_runReader :: Assertion+case_Lazy1_Reader_runReader = let+  e = run $ runReader voidReader (undefined :: ())+  in+   assertNoUndefined (e :: ())+  where+    voidReader = do+        _ <- (ask :: Eff '[Reader ()] ())+        return ()

@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Reader.Strict.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Reader.Strict+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Strict1_Reader_runReader :: Assertion+case_Strict1_Reader_runReader = let+  e = run $ runReader voidReader (undefined :: ())+  in+   assertUndefined (e :: ())+  where+    voidReader = do+        _ <- (ask :: Eff '[Reader ()] ())+        return ()

@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.State.Lazy.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.State.Lazy+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Lazy1_State_runState :: Assertion+case_Lazy1_State_runState = let+  (r, ()) = run+            $ flip runState undefined+            $ getVoid+            >> putVoid undefined+            >> putVoid ()+  in+   assertNoUndefined r+  where+    getVoid :: Eff '[State ()] ()+    getVoid = get++    putVoid :: () -> Eff '[State ()] ()+    putVoid = put

@@ -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.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]) . runExc $ lex5+    ex51Run :: Either [Int] ((), [Int]) = run . runExc . 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+      throwExc ((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,101 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.State.Strict.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Exception+import Control.Eff.State.Strict+import Control.Eff.Reader.Strict+import Control.Eff.Writer.Strict+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Strict1_State_runState :: Assertion+case_Strict1_State_runState = let+  (r, ()) = run+            $ (flip runState) undefined+            $ getVoid+            >> putVoid undefined+            >> putVoid ()+  in+   assertUndefined r+  where+    getVoid :: Eff '[State ()] ()+    getVoid = get++    putVoid :: () -> Eff '[State ()] ()+    putVoid = put++case_Strict1_State_ts1 :: Assertion+case_Strict1_State_ts1 = (10,10) @=? (run (runState ts1 (0::Int)))+  where+    ts1 = do+      put (10 ::Int)+      x <- get+      return (x::Int)++case_Strict1_State_ts11 :: Assertion+case_Strict1_State_ts11 =+  (10,10) @=? (run (runStateR ts11 (0::Int)))+  where+    ts11 = do+      tell (10 ::Int)+      x <- ask+      return (x::Int)++case_Strict1_State_ts2 :: Assertion+case_Strict1_State_ts2 = (30::Int,20::Int) @=?+  (run (runState ts2 (0::Int)))+  where+    ts2 = do+      put (10::Int)+      x <- get+      put (20::Int)+      y <- get+      return (x+y)++case_Strict1_State_ts21 :: Assertion+case_Strict1_State_ts21 = (30::Int,20::Int) @=?+  (run (runStateR ts21 (0::Int)))+  where+    ts21 = do+      tell (10::Int)+      x <- ask+      tell (20::Int)+      y <- ask+      return (x+y)++tes1 :: (Member (State Int) r+        , Member (Exc [Char]) r) => Eff r b+tes1 = do+  incr+  throwExc "exc"+  where+    incr = get >>= put . (+ (1::Int))++case_Strict1_State_ter1 :: Assertion+case_Strict1_State_ter1 = (Left "exc" :: Either String Int,2) @=?+  (run $ runState (runExc tes1) (1::Int))++case_Strict1_State_ter2 :: Assertion+case_Strict1_State_ter2 = (Left "exc" :: Either String (Int,Int)) @=?+  (run $ runExc (runState tes1 (1::Int)))++teCatch :: Member (Exc String) r => Eff r a -> Eff r [Char]+teCatch m = catchExc (m >> return "done") (\e -> return (e::String))++case_Strict1_State_ter3 :: Assertion+case_Strict1_State_ter3 = (Right "exc" :: Either String String,2) @=?+  (run $ runState (runExc (teCatch tes1)) (1::Int))++case_Strict1_State_ter4 :: Assertion+case_Strict1_State_ter4 = (Right ("exc",2) :: Either String (String,Int)) @=?+  (run $ runExc (runState (teCatch tes1) (1::Int)))

@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Test (testGroups) where++import Test.QuickCheck+import Control.Eff+import Control.Eff.Reader.Strict++import Test.Framework.TH+import Test.Framework.Providers.QuickCheck2++testGroups = [ $(testGroupGenerator) ]++prop_NestedEff :: Property+prop_NestedEff = forAll arbitrary (\x -> property (qu x == x))+  where+    qu :: Bool -> Bool+    qu x = run $ runReader (readerAp x) readerId++    readerAp :: Bool -> Eff '[Reader (Eff '[Reader Bool] Bool)] Bool+    readerAp x = do+      f <- ask+      return . run $ runReader f x++    readerId :: Eff '[Reader Bool] Bool+    readerId = do+      x <- ask+      return x

@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Trace.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Reader.Strict+import Control.Eff.Trace+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Trace_tdup :: Assertion+case_Trace_tdup = do+  ((), actual) <- catchOutput tdup+  assertEqual "Trace: duplicate layers"+    (unlines ["Asked: 20", "Asked: 10"]) actual+  where+    tdup = runTrace $ runReader m (10::Int)+     where+     m = do+         runReader tr (20::Int)+         tr+     tr = do+          v <- ask+          trace $ "Asked: " ++ show (v::Int)++case_Trace_tMd :: Assertion+case_Trace_tMd = do+  actual <- catchOutput tMd+  assertEqual "Trace: higher-order effectful function"+    (map (+ val) input, unlines $ map (("mapMdebug: " ++) . show) input) actual+  where+    val = (10::Int)+    input = [1..5]+    tMd = runTrace $ runReader (mapMdebug f input) val+      where+        f x = ask `add` return x++        -- Higher-order effectful function+        -- The inferred type shows that the Trace affect is added to the effects+        -- of r+        mapMdebug:: (Show a, Member Trace r) =>+                    (a -> Eff r b) -> [a] -> Eff r [b]+        mapMdebug _f [] = return []+        mapMdebug f (h:t) = do+          trace $ "mapMdebug: " ++ show h+          h' <- f h+          t' <- mapMdebug f t+          return (h':t')

@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Writer.Lazy.Test (testGroups) where++import Test.HUnit hiding (State)+import Test.QuickCheck++import Control.Eff+import Control.Eff.Reader.Lazy+import Control.Eff.Writer.Lazy+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2++testGroups = [ $(testGroupGenerator) ]++addGet :: Member (Reader Int) r  => Int -> Eff r Int+addGet x = ask >>= \i -> return (i+x)++addN n = foldl (>>>) return (replicate n addGet) 0+ where f >>> g = (>>= g) . f++case_Lazy1_Writer_rdwr :: Assertion+case_Lazy1_Writer_rdwr = (10, ["begin", "end"]) @=?+  (run . (`runReader` (1::Int)) . runListWriter $ rdwr)+  where+    rdwr = do+      tell "begin"+      r <- addN 10+      tell "end"+      return r++prop_Lazy1_Writer_censor :: [Integer] -> Property+prop_Lazy1_Writer_censor l =+  property+  $ listE (mapM_ (tell . inc) l) == listE (censor inc $ mapM_ tell l)+  where+    inc :: Integer -> Integer+    inc = (+1)++    listE :: Eff '[Writer Integer] () -> [Integer]+    listE = snd . run . runListWriter++case_Lazy1_Writer_runFirstWriter :: Assertion+case_Lazy1_Writer_runFirstWriter = let+  ((), Just m) = run $ runFirstWriter $ mapM_ tell [(), undefined]+  in+   assertNoUndefined (m :: ())++case_Lazy1_Writer_runLastWriter :: Assertion+case_Lazy1_Writer_runLastWriter = let+  ((), Just m) = run $ runLastWriter $ mapM_ tell [undefined, ()]+  in+   assertNoUndefined (m :: ())

@@ -0,0 +1,22 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Writer.Strict.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Writer.Strict+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_Strict1_Writer_runLastWriter :: Assertion+case_Strict1_Writer_runLastWriter = let+  ((), Just m) = run $ runLastWriter $ mapM_ tell [undefined, ()]+  in+   assertUndefined (m :: ())

@@ -1,1097 +1,44 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# OPTIONS -fno-warn-missing-signatures #-}-import Control.Exception (ErrorCall, catch)-import Data.Typeable--import Test.Framework (defaultMain)-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.Framework.TH--import Test.HUnit hiding (State)-import Test.QuickCheck--import Control.Eff-import Data.OpenUnion-import qualified Control.Eff.Reader.Lazy as LazyR-import qualified Control.Eff.Reader.Strict as StrictR-import qualified Control.Eff.Writer.Lazy as LazyW-import qualified Control.Eff.Writer.Strict as StrictW-import qualified Control.Eff.State.Strict as StrictS-import qualified Control.Eff.State.Lazy as LazyS-import qualified Control.Eff.State.LazyState as LazierS-import Control.Eff.Exception-import Control.Eff.Choose as Choose-import Control.Eff.NdetEff-import Control.Monad (liftM2, msum, guard, mzero, mplus)-import Data.Monoid--import Control.Eff.Example as Eg-import Control.Eff.Fresh-import Control.Eff.Lift-import Control.Eff.Operational as Op-import Control.Eff.Operational.Example as Op.Eg-import Control.Eff.Trace-import Control.Eff.Coroutine-import Control.Eff.Cut---- {{{ utils: TODO: move them out--import GHC.IO.Handle-import System.IO-import System.Directory---- | capture stdout--- [[https://stackoverflow.com/a/9664017][source]]-catchOutput :: IO a -> IO (a, String)-catchOutput f = do-  tmpd <- getTemporaryDirectory-  (tmpf, tmph) <- openTempFile tmpd "haskell_stdout"-  stdout_dup <- hDuplicate stdout-  hDuplicateTo tmph stdout-  hClose tmph-  fVal <- f-  hDuplicateTo stdout_dup stdout-  str <- readFile tmpf-  removeFile tmpf-  return (fVal, str)--showLn :: Show a => a -> String-showLn x = unlines $ [show x]--showLines :: Show a => [a] -> String-showLines xs = unlines $ map show xs--withError :: a -> ErrorCall -> a-withError a _ = a--assertUndefined :: a -> Assertion-assertUndefined a = catch (seq a $ assertFailure "") (withError $ return ())--assertNoUndefined :: a -> Assertion-assertNoUndefined a = catch (seq a $ return ()) (withError $ assertFailure "")--allEqual :: Eq a => [a] -> Bool-allEqual = all (uncurry (==)) . pairs-  where-    pairs l = zip l $ tail l--safeLast [] = Nothing-safeLast l = Just $ last l---- }}}--main :: IO ()-main = $(defaultMainGenerator)---- {{{ Documentation example--prop_Documentation_example :: [Integer] -> Property-prop_Documentation_example l = let-  ((), total1) = run $ LazyS.runState (Eg.sumAll l) 0-  ((), last1) = run $ LazyW.runLastWriter $ Eg.writeAll l-  (((), last2), total2) = run $ LazyS.runState (LazyW.runLastWriter (Eg.writeAndAdd l)) 0-  (((), total3), last3) = run $ LazyW.runLastWriter $ LazyS.runState (Eg.writeAndAdd l) 0-  in-   allEqual [safeLast l, last1, last2, last3]-   .&&. allEqual [sum l, total1, total2, total3]---- }}}---- {{{ Reader--add :: Monad m => m Int -> m Int -> m Int-add = liftM2 (+)-t1 = LazyR.ask `add` return (1::Int)--case_Lazy1_Reader_t1 :: Assertion-case_Lazy1_Reader_t1 = let-  t1' = do v <- LazyR.ask; return (v + 1 :: Int)-  t1r = LazyR.runReader t1 (10::Int)-  in-    -- 'LazyR.run t1' should result in type-error-    11 @=? (run t1r)--t2 = do-  v1 <- LazyR.ask-  v2 <- LazyR.ask-  return $ fromIntegral (v1 + (1::Int)) + (v2 + (2::Float))---case_Lazy1_Reader_t2 :: Assertion-case_Lazy1_Reader_t2 = let-  t2r = LazyR.runReader t2 (10::Int)-  t2rr = flip LazyR.runReader (20::Float) . flip LazyR.runReader (10::Int) $ t2-  in-    33.0 @=? (run t2rr)---- The opposite order of layers-{- If we mess up, we get an error-t2rrr1' = run $ runReader (runReader t2 (20::Float)) (10::Float)-    No instance for (Member (Reader Int) [])-      arising from a use of `t2'--}-case_Lazy1_Reader_t2' :: Assertion-case_Lazy1_Reader_t2' = 33.0 @=?-  (run $ LazyR.runReader (LazyR.runReader t2 (20::Float)) (10::Int))---case_Lazy1_Reader_t3 :: Assertion-case_Lazy1_Reader_t3 = let-  t3 = t1 `add` LazyR.local (+ (10::Int)) t1-  in-    212 @=? (run $ LazyR.runReader t3 (100::Int))---- The following example demonstrates true interleaving of Reader Int--- and Reader Float layers-{--t4-  :: (Member (Reader Int) r, Member (Reader Float) r) =>-     () -> Eff r Float--}-t4 = liftM2 (+) (LazyR.local (+ (10::Int)) t2)-                (LazyR.local (+ (30::Float)) t2)--case_Lazy1_Reader_t4 :: Assertion-case_Lazy1_Reader_t4 = 106.0 @=?-  (run $ LazyR.runReader (LazyR.runReader t4 (20::Float)) (10::Int))---- The opposite order of layers gives the same result-case_Lazy1_Reader_t4' :: Assertion-case_Lazy1_Reader_t4' = 106.0 @=?-  (run $ LazyR.runReader (LazyR.runReader t4 (20::Float)) (10::Int))---- Map an effectful function-case_Lazy1_Reader_tmap :: Assertion-case_Lazy1_Reader_tmap = let-  tmap = mapM f [1..5]-  in-    ([11,12,13,14,15] :: [Int]) @=?-    (run $ LazyR.runReader tmap (10::Int))-  where-    f x = LazyR.ask `add` return x---- {{{ Reader.runReader--case_Lazy1_Reader_runReader :: Assertion-case_Lazy1_Reader_runReader = let-  e = run $ LazyR.runReader voidReader (undefined :: ())-  in-   assertNoUndefined (e :: ())-  where-    voidReader = do-        _ <- (LazyR.ask :: Eff '[LazyR.Reader ()] ())-        return ()--case_Strict1_Reader_runReader :: Assertion-case_Strict1_Reader_runReader = let-  e = run $ StrictR.runReader voidReader (undefined :: ())-  in-   assertUndefined (e :: ())-  where-    voidReader = do-        _ <- (StrictR.ask :: Eff '[StrictR.Reader ()] ())-        return ()---- }}}---- }}}---- {{{ State.runState---- {{{ Lazy--case_Lazy1_State_runState :: Assertion-case_Lazy1_State_runState = let-  (r, ()) = run-            $ flip LazyS.runState undefined-            $ getVoid-            >> putVoid undefined-            >> putVoid ()-  in-   assertNoUndefined r-  where-    getVoid :: Eff '[LazyS.State ()] ()-    getVoid = LazyS.get--    putVoid :: () -> Eff '[LazyS.State ()] ()-    putVoid = LazyS.put---- }}}---- {{{ Strict1--case_Strict1_State_runState :: Assertion-case_Strict1_State_runState = let-  (r, ()) = run-            $ (flip StrictS.runState) undefined-            $ getVoid-            >> putVoid undefined-            >> putVoid ()-  in-   assertUndefined r-  where-    getVoid :: Eff '[StrictS.State ()] ()-    getVoid = StrictS.get--    putVoid :: () -> Eff '[StrictS.State ()] ()-    putVoid = StrictS.put--case_Strict1_State_ts1 :: Assertion-case_Strict1_State_ts1 = (10,10) @=? (run (StrictS.runState ts1 (0::Int)))-  where-    ts1 = do-      StrictS.put (10 ::Int)-      x <- StrictS.get-      return (x::Int)--case_Strict1_State_ts11 :: Assertion-case_Strict1_State_ts11 =-  (10,10) @=? (run (StrictS.runStateR ts11 (0::Int)))-  where-    ts11 = do-      StrictW.tell (10 ::Int)-      x <- StrictR.ask-      return (x::Int)--case_Strict1_State_ts2 :: Assertion-case_Strict1_State_ts2 = (30::Int,20::Int) @=?-  (run (StrictS.runState ts2 (0::Int)))-  where-    ts2 = do-      StrictS.put (10::Int)-      x <- StrictS.get-      StrictS.put (20::Int)-      y <- StrictS.get-      return (x+y)--case_Strict1_State_ts21 :: Assertion-case_Strict1_State_ts21 = (30::Int,20::Int) @=?-  (run (StrictS.runStateR ts21 (0::Int)))-  where-    ts21 = do-      StrictW.tell (10::Int)-      x <- StrictR.ask-      StrictW.tell (20::Int)-      y <- StrictR.ask-      return (x+y)--tes1 :: (Member (StrictS.State Int) r-        , Member (Exc [Char]) r) => Eff r b-tes1 = do-  incr-  throwExc "exc"-  where-    incr = StrictS.get >>= StrictS.put . (+ (1::Int))--case_Strict1_State_ter1 :: Assertion-case_Strict1_State_ter1 = (Left "exc" :: Either String Int,2) @=?-  (run $ StrictS.runState (runExc tes1) (1::Int))--case_Strict1_State_ter2 :: Assertion-case_Strict1_State_ter2 = (Left "exc" :: Either String (Int,Int)) @=?-  (run $ runExc (StrictS.runState tes1 (1::Int)))--teCatch :: Member (Exc String) r => Eff r a -> Eff r [Char]-teCatch m = catchExc (m >> return "done") (\e -> return (e::String))--case_Strict1_State_ter3 :: Assertion-case_Strict1_State_ter3 = (Right "exc" :: Either String String,2) @=?-  (run $ StrictS.runState (runExc (teCatch tes1)) (1::Int))--case_Strict1_State_ter4 :: Assertion-case_Strict1_State_ter4 = (Right ("exc",2) :: Either String (String,Int)) @=?-  (run $ runExc (StrictS.runState (teCatch tes1) (1::Int)))---- }}}---- }}}---- {{{ Writer--addGet :: Member (LazyR.Reader Int) r  => Int -> Eff r Int-addGet x = LazyR.ask >>= \i -> return (i+x)--addN n = foldl (>>>) return (replicate n addGet) 0- where f >>> g = (>>= g) . f--case_Lazy1_Writer_rdwr :: Assertion-case_Lazy1_Writer_rdwr = (10, ["begin", "end"]) @=?-  (run . (`LazyR.runReader` (1::Int)) . LazyW.runListWriter $ rdwr)-  where-    rdwr = do-      LazyW.tell "begin"-      r <- addN 10-      LazyW.tell "end"-      return r---- {{{ Writer.censor--prop_Lazy1_Writer_censor :: [Integer] -> Property-prop_Lazy1_Writer_censor l =-  property-  $ listE (mapM_ (LazyW.tell . inc) l) == listE (LazyW.censor inc $ mapM_ LazyW.tell l)-  where-    inc :: Integer -> Integer-    inc = (+1)--    listE :: Eff '[LazyW.Writer Integer] () -> [Integer]-    listE = snd . run . LazyW.runListWriter---- }}}---- {{{ Writer.runFirstWriter--case_Lazy1_Writer_runFirstWriter :: Assertion-case_Lazy1_Writer_runFirstWriter = let-  ((), Just m) = run $ LazyW.runFirstWriter $ mapM_ LazyW.tell [(), undefined]-  in-   assertNoUndefined (m :: ())---- }}}---- {{{ Writer.runLastWriter--case_Lazy1_Writer_runLastWriter :: Assertion-case_Lazy1_Writer_runLastWriter = let-  ((), Just m) = run $ LazyW.runLastWriter $ mapM_ LazyW.tell [undefined, ()]-  in-   assertNoUndefined (m :: ())--case_Strict1_Writer_runLastWriter :: Assertion-case_Strict1_Writer_runLastWriter = let-  ((), Just m) = run $ StrictW.runLastWriter $ mapM_ StrictW.tell [undefined, ()]-  in-   assertUndefined (m :: ())---- }}}---- }}}---- {{{ Exception---- The type is inferred--- et1 :: Eff r Int-et1 = return 1 `add` return 2--case_Exception1_et1 :: Assertion-case_Exception1_et1 = 3 @=? (run et1)---- The type is inferred--- et2 :: Member (Exc Int) r => Eff r Int-et2 = return 1 `add` throwExc (2::Int)---- The following won't type: unhandled exception!--- ex2rw = run et2-{--    Could not deduce (Data.OpenUnion51.FindElem (Exc Int) '[])-      arising from a use of `et2'--}--case_Exception1_et21 :: Assertion-case_Exception1_et21 = (Left (2::Int)) @=?-  (run et21)-  where-    -- The inferred type shows that ex21 is now pure-    -- et21 :: Eff r (Either Int Int)--    et21 = runExc et2---- {{{ TooBig example from paper---- The example from the paper-newtype TooBig = TooBig Int deriving (Eq, Show)--- The type is inferred-ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int-ex2 m = do-  v <- m-  if v > 5 then throwExc (TooBig v)-     else return v---- specialization to tell the type of the exception-runErrBig :: Eff (Exc TooBig ': r) a -> Eff r (Either TooBig a)-runErrBig = runExc--case_Exception1_ex2r :: Assertion-case_Exception1_ex2r = (Right 5) @=? (run ex2r)-  where-    ex2r = LazyR.runReader (runErrBig (ex2 LazyR.ask)) (5::Int)--case_Exception1_ex2r1 :: Assertion-case_Exception1_ex2r1 = (Left (TooBig 7)) @=? (run ex2r1)-  where-    ex2r1 = LazyR.runReader (runErrBig (ex2 LazyR.ask)) (7::Int)---- Different order of handlers (layers)-case_Exception1_ex2r2 :: Assertion-case_Exception1_ex2r2 = (Left (TooBig 7)) @=? (run ex2r2)-  where-    ex2r2 = runErrBig (LazyR.runReader (ex2 LazyR.ask) (7::Int))---- }}}---- {{{ Alternative---- Implementing the operator <|> from Alternative:---  a <|> b does---   -- tries a, and if succeeds, returns its result---   -- otherwise, tries b, and if succeeds, returns its result---   -- otherwise, throws mappend of exceptions of a and b---- We use SetMember in the signature rather than Member to--- ensure that the computation throws only one type of exceptions.--- Otherwise, this construction is not very useful.-alttry :: forall e r a. (Monoid e, SetMember Exc (Exc e) r) =>-          Eff r a -> Eff r a -> Eff r a-alttry ma mb =-  catchExc ma $ \ea ->-  catchExc mb $ \eb -> throwExc (mappend (ea::e) eb)--case_Exception1_alttry :: Assertion-case_Exception1_alttry =-  [Right 10,Right 10,Right 10,Left "bummer1bummer2"] @=?-  [-  run . runExc $-     (return 1 `add` throwExc "bummer1") `alttry`-     (return 10),-  run . runExc $-     (return 10) `alttry`-     (return 1 `add` throwExc "bummer2"),-  run . runExc $-     (return 10) `alttry` return 20,-  run . runExc $-     (return 1 `add` throwExc "bummer1") `alttry`-     (return 1 `add` throwExc "bummer2")-     ]---- }}}---- {{{ Eff Failure--case_Failure1_Effect :: Assertion-case_Failure1_Effect =-  let go :: Eff (Exc () ': StrictW.Writer Int ': '[]) Int-         -> Int-      go = snd . run . StrictW.runWriter (+) 0 . ignoreFail-      ret = go $ do-        StrictW.tell (1 :: Int)-        StrictW.tell (2 :: Int)-        StrictW.tell (3 :: Int)-        () <- die-        StrictW.tell (4 :: Int)-        return 5-   in assertEqual "Fail should stop writing" 6 ret---- }}}---- }}}---- {{{ Choose--case_Choose1_exc11 :: Assertion-case_Choose1_exc11 = [2,3] @=? (run exc11)-  where-    exc11 = Choose.makeChoice exc1-    exc1 = return 1 `add` Choose.choose [1,2]--case_Choose_ex2 :: Assertion-case_Choose_ex2 =-  let ex2_1 = run . makeChoice . runErrBig $ ex2 (Choose.choose [5,7,1])-      ex2_2 = run . runErrBig . makeChoice $ ex2 (Choose.choose [5,7,1])-  in-    assertEqual "Choose: Combining exceptions and non-determinism: ex2_1"-    expected1 ex2_1-    >> assertEqual "Choose: Combining exceptions and non-determinism: ex2_2"-    expected2 ex2_2-  where-    expected1 = [Right 5,Left (TooBig 7),Right 1]-    expected2 = Left (TooBig 7)--case_Choose_exRec :: Assertion-case_Choose_exRec =-  let exRec_1 = run . runErrBig . makeChoice $ exRec (ex2 (Choose.choose [5,7,1]))-      exRec_2 = run . makeChoice . runErrBig $ exRec (ex2 (Choose.choose [5,7,1]))-      exRec_3 = run . runErrBig . makeChoice $ exRec (ex2 (Choose.choose [5,7,11,1]))-  in-    assertEqual "Choose: error recovery: exRec_1" expected1 exRec_1-    >> assertEqual "Choose: error recovery: exRec_2" expected2 exRec_2-    >> assertEqual "Choose: error recovery: exRec_1" expected3 exRec_3-  where-    expected1 = Right [5,7,1]-    expected2 = [Right 5,Right 7,Right 1]-    expected3 = Left (TooBig 11)-    -- Errror recovery part-    -- The code is the same as in transf1.hs. The inferred signatures differ-    -- Was: exRec :: MonadError TooBig m => m Int -> m Int-    -- exRec :: Member (Exc TooBig) r => Eff r Int -> Eff r Int-    exRec m = catchExc m handler-      where handler (TooBig n) | n <= 7 = return n-            handler e = throwExc e---- }}}---- {{{ NdetEff--case_NdetEff_testCA :: Assertion-case_NdetEff_testCA = [2, 4..10] @=? (run $ makeChoiceA testCA)-  where-    testCA :: (Integral a) => Eff (NdetEff ': r) a-    testCA = do-      i <- msum . fmap return $ [1..10]-      guard (i `mod` 2 == 0)-      return i--case_NdetEff_ifte :: Assertion-case_NdetEff_ifte =-  let primes = ifte_test_run-  in-    assertEqual "NdetEff: test ifte using primes"-    [2,3,5,7,11,13,17,19,23,29] primes-  where-    ifte_test = do-      n <- gen-      ifte (do-               d <- gen-               guard $ d < n && n `mod` d == 0-               -- _ <- trace ("d: " ++ show d) (return ())-           )-        (\_ -> mzero)-        (return n)-        where gen = msum . fmap return $ [2..30]--    ifte_test_run :: [Int]-    ifte_test_run = run . makeChoiceA $ ifte_test----- called reflect in the LogicT paper-case_NdetEff_reflect :: Assertion-case_NdetEff_reflect =-  let tsplitr10 = run $ StrictW.runListWriter $ makeChoiceA tsplit-      tsplitr11 = run $ StrictW.runListWriter $ makeChoiceA (msplit tsplit >>= unmsplit)-      tsplitr20 = run $ makeChoiceA $ StrictW.runListWriter tsplit-      tsplitr21 = run $ makeChoiceA $ StrictW.runListWriter (msplit tsplit >>= unmsplit)-  in-    assertEqual "tsplitr10" expected1 tsplitr10-    >> assertEqual "tsplitr11" expected1 tsplitr11-    >> assertEqual "tsplitr20" expected2 tsplitr20-    >> assertEqual "tsplitr21" expected21 tsplitr21-  where-    expected1 = ([1, 2],["begin", "end"])-    expected2 = [(1, ["begin"]), (2, ["end"])]-    expected21 = [(1, ["begin"]), (2, ["begin", "end"])]--    unmsplit :: Member NdetEff r => (Maybe (a, Eff r a)) -> Eff r a-    unmsplit Nothing      = mzero-    unmsplit (Just (a,m)) = return a `mplus` m--    tsplit =-      (StrictW.tell "begin" >> return 1) `mplus`-      (StrictW.tell "end"   >> return 2)---- }}}---- {{{ test Lift building---- | Ensure that https://github.com/RobotGymnast/extensible-effects/issues/11 stays resolved.-case_Lift_building :: Assertion-case_Lift_building = runLift possiblyAmbiguous-  where-    possiblyAmbiguous :: (Monad m, SetMember Lift (Lift m) r) => Eff r ()-    possiblyAmbiguous = lift $ return ()---- }}}---- {{{ Nested Eff--prop_NestedEff :: Property-prop_NestedEff = forAll arbitrary (\x -> property (qu x == x))-  where-    qu :: Bool -> Bool-    qu x = run $ StrictR.runReader (readerAp x) readerId--    readerAp :: Bool -> Eff '[StrictR.Reader (Eff '[StrictR.Reader Bool] Bool)] Bool-    readerAp x = do-      f <- StrictR.ask-      return . run $ StrictR.runReader f x--    readerId :: Eff '[StrictR.Reader Bool] Bool-    readerId = do-      x <- StrictR.ask-      return x---- }}}---- {{{ Operational Monad--case_Operational_Monad :: Assertion-case_Operational_Monad =-  let comp :: (Member (LazyS.State [String]) r-               , Member (LazyW.Writer String) r)-              => Eff r ()-      comp = Op.runProgram Op.Eg.adventPure Op.Eg.prog-      go = snd . run . LazyW.runMonoidWriter $ LazyS.evalState comp ["foo", "bar"]-  in-   assertEqual-   "Evaluating Operational Monad example"-   (unlines ["getting input...",-             "ok",-             "the input is foo"]) go---- }}}---- {{{ Yield--yieldInt :: Member (Yield Int ()) r => Int -> Eff r ()-yieldInt = yield--case_Coroutines_c1 :: Assertion-case_Coroutines_c1 = do-  ((), actual) <- catchOutput c1-  assertEqual-    "Coroutine: Simple coroutines using Eff"-    (unlines ["1", "2", "Done"]) actual-  where-    th1 :: Member (Yield Int ()) r => Eff r ()-    th1 = yieldInt 1 >> yieldInt 2--    c1 = runTrace (loop =<< runC th1)-      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop-            loop (Done)    = trace ("Done")--case_Coroutines_c2 :: Assertion-case_Coroutines_c2 = do-  ((), actual1) <- catchOutput c2-  assertEqual "Coroutine: Add dynamic variables"-    (unlines ["10", "10", "Done"]) actual1-  ((), actual2) <- catchOutput c21-  assertEqual "Coroutine: locally changing the dynamic environment for the suspension"-    (unlines ["10", "11", "Done"]) actual2-  where-    -- The code is essentially the same as that in transf.hs (only added-    -- a type specializtion on yield). The inferred signature is different though.-    -- Before it was-    --    th2 :: MonadReader Int m => CoT Int m ()-    -- Now it is more general:-    th2 :: (Member (Yield Int ()) r, Member (StrictR.Reader Int) r) => Eff r ()-    th2 = StrictR.ask >>= yieldInt >> (StrictR.ask >>= yieldInt)--    -- Code is essentially the same as in transf.hs; no liftIO though-    c2 = runTrace $ StrictR.runReader (loop =<< runC th2) (10::Int)-      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop-            loop Done    = trace "Done"--    -- locally changing the dynamic environment for the suspension-    c21 = runTrace $ StrictR.runReader (loop =<< runC th2) (10::Int)-      where loop (Y x k) = trace (show (x::Int)) >> StrictR.local (+(1::Int)) (k ()) >>= loop-            loop Done    = trace "Done"--case_Coroutines_c3 :: Assertion-case_Coroutines_c3 = do-  ((), actual1) <- catchOutput c3-  assertEqual "Coroutine: two sorts of local rebinding"-    (unlines ["10", "10", "20", "20", "Done"]) actual1-  ((), actual2) <- catchOutput c31-  let expected2 = (unlines ["10", "11", "21", "21", "Done"])-  assertEqual "Coroutine: locally changing the dynamic environment for the suspension"-    expected2 actual2-  ((), actual3) <- catchOutput c4-  assertEqual "Coroutine: abstracting the client computation"-    expected2 actual3-  where-    local = StrictR.local-    ask = StrictR.ask-    runReader = StrictR.runReader--    th3 :: (Member (Yield Int ()) r, Member (StrictR.Reader Int) r) => Eff r ()-    th3 = ay >> ay >> local (+(10::Int)) (ay >> ay)-      where ay = ask >>= yieldInt--    c3 = runTrace $ runReader (loop =<< runC th3) (10::Int)-      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop-            loop Done    = trace "Done"--    -- The desired result: the coroutine shares the dynamic environment with its-    -- parent; however, when the environment is locally rebound, it becomes-    -- private to coroutine.-    c31 = runTrace $ runReader (loop =<< runC th3) (10::Int)-      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop-            loop Done    = trace "Done"--    -- We now make explicit that the client computation, run by th4,-    -- is abstract. We abstract it out of th4-    c4 = runTrace $ runReader (loop =<< runC (th4 client)) (10::Int)-      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop-            loop Done    = trace "Done"--            -- cl, client, ay are monomorphic bindings-            th4 cl = cl >> local (+(10::Int)) cl-            client = ay >> ay-            ay     = ask >>= yieldInt--case_Corountines_c5 :: Assertion-case_Corountines_c5 = do-  ((), actual) <- catchOutput c5-  let expected = unlines ["10"-                         ,"11"-                         ,"12"-                         ,"18"-                         ,"18"-                         ,"18"-                         ,"29"-                         ,"29"-                         ,"29"-                         ,"29"-                         ,"29"-                         ,"29"-                         ,"Done"-                         ]-  assertEqual "Corountine: Even more dynamic example"-    expected actual-  where-    local = StrictR.local-    ask = StrictR.ask-    runReader = StrictR.runReader--    c5 = runTrace $ runReader (loop =<< runC (th client)) (10::Int)-      where loop (Y x k) = trace (show (x::Int)) >> local (\y->x+1) (k ()) >>= loop-            loop Done    = trace "Done"--            -- cl, client, ay are monomorphic bindings-            client = ay >> ay >> ay-            ay     = ask >>= yieldInt--            -- There is no polymorphic recursion here-            th cl = do-              cl-              v <- ask-              (if v > (20::Int) then id else local (+(5::Int))) cl-              if v > (20::Int) then return () else local (+(10::Int)) (th cl)--case_Coroutines_c7 :: Assertion-case_Coroutines_c7 = do-  ((), actual) <- catchOutput c7-  let expected = unlines ["1010"-                         ,"1021"-                         ,"1032"-                         ,"1048"-                         ,"1064"-                         ,"1080"-                         ,"1101"-                         ,"1122"-                         ,"1143"-                         ,"1169"-                         ,"1195"-                         ,"1221"-                         ,"1252"-                         ,"1283"-                         ,"1314"-                         ,"1345"-                         ,"1376"-                         ,"1407"-                         ,"Done"-                         ]-  assertEqual "Coroutine: And even more dynamic example"-    expected actual-  where-    local = StrictR.local-    ask = StrictR.ask-    runReader = StrictR.runReader--    c7 = runTrace $-          runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double)-     where loop (Y x k) = trace (show (x::Int)) >>-                          local (\y->fromIntegral (x+1)::Double) (k ()) >>= loop-           loop Done    = trace "Done"--           -- cl, client, ay are monomorphic bindings-           client = ay >> ay >> ay-           ay     = ask >>= \x -> ask >>=-                     \y -> yieldInt (x + round (y::Double))--           -- There is no polymorphic recursion here-           th cl = do-             cl-             v <- ask-             (if v > (20::Int) then id else local (+(5::Int))) cl-             if v > (20::Int) then return () else local (+(10::Int)) (th cl)--case_Coroutines_c7' :: Assertion-case_Coroutines_c7' = do-  ((), actual) <- catchOutput c7'-  let expected = unlines ["1010"-                         ,"1021"-                         ,"1032"-                         ,"1048"-                         ,"1048"-                         ,"1048"-                         ,"1069"-                         ,"1090"-                         ,"1111"-                         ,"1137"-                         ,"1137"-                         ,"1137"-                         ,"1168"-                         ,"1199"-                         ,"1230"-                         ,"1261"-                         ,"1292"-                         ,"1323"-                         ,"Done"-                         ]-  assertEqual "Coroutine: And even more dynamic example"-    expected actual-  where-    local = StrictR.local-    ask = StrictR.ask-    runReader = StrictR.runReader--    c7' = runTrace $-          runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double)-     where loop (Y x k) = trace (show (x::Int)) >>-                          local (\y->fromIntegral (x+1)::Double) (k ()) >>= loop-           loop Done    = trace "Done"--           -- cl, client, ay are monomorphic bindings-           client = ay >> ay >> ay-           ay     = ask >>= \x -> ask >>=-                     \y -> yieldInt (x + round (y::Double))--           -- There is no polymorphic recursion here-           th cl = do-             cl-             v <- ask-             (if v > (20::Int) then id else local (+(5::Double))) cl-             if v > (20::Int) then return () else local (+(10::Int)) (th cl)---- }}}---- {{{ Lift--case_Lift_tl1r :: Assertion-case_Lift_tl1r = do-  ((), output) <- catchOutput tl1r-  assertEqual "Test tl1r" (showLn input) output-  where-    input = (5::Int)-    -- tl1r :: IO ()-    tl1r = runLift (StrictR.runReader tl1 input)-      where-        tl1 = StrictR.ask >>= \(x::Int) -> lift . print $ x--case_Lift_tMd' :: Assertion-case_Lift_tMd' = do-  actual <- catchOutput tMd'-  let expected = (output, (showLines input))-  assertEqual "Test mapMdebug using Lift" expected actual-  where-    input = [1..5]-    val = (10::Int)-    output = map (+ val) input--    tMd' = runLift $ StrictR.runReader (mapMdebug' f input) val-      where f x = StrictR.ask `add` return x--    -- Re-implemenation of mapMdebug using Lifting-    -- The signature is inferred-    mapMdebug'  :: (Show a, SetMember Lift (Lift IO) r) =>-                   (a -> Eff r b) -> [a] -> Eff r [b]-    mapMdebug' f [] = return []-    mapMdebug' f (h:t) = do-      lift $ print h-      h' <- f h-      t' <- mapMdebug' f t-      return (h':t')---- }}}---- {{{ Trace--case_Trace_tdup :: Assertion-case_Trace_tdup = do-  ((), actual) <- catchOutput tdup-  assertEqual "Trace: duplicate layers"-    (unlines ["Asked: 20", "Asked: 10"]) actual-  where-    tdup = runTrace $ StrictR.runReader m (10::Int)-     where-     m = do-         StrictR.runReader tr (20::Int)-         tr-     tr = do-          v <- StrictR.ask-          trace $ "Asked: " ++ show (v::Int)--case_Trace_tMd :: Assertion-case_Trace_tMd = do-  actual <- catchOutput tMd-  assertEqual "Trace: higher-order effectful function"-    (map (+ val) input, unlines $ map (("mapMdebug: " ++) . show) input) actual-  where-    val = (10::Int)-    input = [1..5]-    tMd = runTrace $ StrictR.runReader (mapMdebug f input) val-      where-        f x = StrictR.ask `add` return x--        -- Higher-order effectful function-        -- The inferred type shows that the Trace affect is added to the effects-        -- of r-        mapMdebug:: (Show a, Member Trace r) =>-                    (a -> Eff r b) -> [a] -> Eff r [b]-        mapMdebug f [] = return []-        mapMdebug f (h:t) = do-          trace $ "mapMdebug: " ++ show h-          h' <- f h-          t' <- mapMdebug f t-          return (h':t')---- }}}---- {{{ Fresh--case_Fresh_tfresh' :: Assertion-case_Fresh_tfresh' = do-  ((), actual) <- catchOutput tfresh'-  assertEqual "Fresh: test"-    (unlines ["Fresh 0", "Fresh 1"]) actual-  where-    tfresh' = runTrace $ flip runFresh' 0 $ do-      n <- fresh-      trace $ "Fresh " ++ show n-      n <- fresh-      trace $ "Fresh " ++ show n---- }}}---- {{{ LazyState--case_LazierState_ex1 :: Assertion-case_LazierState_ex1 =-  let actual = run $ LazierS.runStateLazy 0 lex1-  in-    assertEqual "LazyState: ex1"-    ((), 1::Int) actual-  where-    lex1 = do-      LazierS.onDemand lex1-      LazierS.lput (1::Int)--case_LazierState_ex3 :: Assertion-case_LazierState_ex3 =-  let (x,s) = run $ LazierS.runStateLazy (undefined::[Int]) lex3-  in assertEqual "LazyState: ex3"-     ((),[1,1,1,1,1]) (x,take 5 s)-  where-    lex3 = do-      LazierS.onDemand lex3-      LazierS.lmodify ((1::Int):)---- a bit more interesting-case_LazierState_ex4 =-  let (x,s) = run $ LazierS.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 '[LazierS.LazyState [Int]] [Int]-    lex4 = do-      LazierS.lmodify ((0::Int):)-      LazierS.onDemand lex4-      LazierS.lmodify ((1::Int):)-      LazierS.onDemand (LazierS.onDemand lex4 :: Eff '[LazierS.LazyState [Int]] [Int])-      LazierS.lmodify ((2::Int):)-      LazierS.lmodify ((3::Int):)-      LazierS.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 . LazierS.runStateLazy (undefined::[Int]) . runExc $ lex5-    ex51Run :: Either [Int] ((), [Int]) = run . runExc . LazierS.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 (LazierS.LazyState [Int]) r => Eff r ()-    lex31 = do-      LazierS.onDemand (lex31 :: Eff '[LazierS.LazyState [Int]] ())-      LazierS.lmodify ((1::Int):)--    lex5 = do-      lex31-      x <- LazierS.lget-      throwExc ((take 5 x)::[Int])--case_LazierState_st :: Assertion-case_LazierState_st = let-  stF :: ((Int,Int,Int),Int) = run $ LazierS.runStateLazy (0::Int) st-  stB0 :: ((Int,Int,Int),Int) = LazierS.runStateBack0 st-  stB :: ((Int,Int,Int),Int) = LazierS.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 <- LazierS.lget-      LazierS.lput (1::Int)-      LazierS.lput (1::Int)-      y <- LazierS.lget-      LazierS.lput (2::Int)-      LazierS.lput (10::Int)-      LazierS.lput (3::Int)-      z <- LazierS.lget-      LazierS.lput (4::Int)-      return (x,y,z)--case_LazierState_ones :: Assertion-case_LazierState_ones =-  let ones :: [Int] = snd $ LazierS.runStateBack $ do-        s <- LazierS.lget-        LazierS.lput ((1::Int):s)-  in-    assertEqual "LazyState ones" [1,1,1,1,1] (take 5 ones)---- }}}---- {{{ Cut--case_Cut_tcut :: Assertion-case_Cut_tcut =-  let tcut1r = run . makeChoice $ call tcut1-      tcut2r = run . makeChoice $ call tcut2-      tcut3r = run . makeChoice $ call tcut3-      tcut4r = run . makeChoice $ call tcut4-  in-    assertEqual "Cut: tcut1" [1,2] tcut1r-    >> assertEqual "Cut: nested call: tcut2" [1,2,5] tcut2r-    >> assertEqual "Cut: nested call: tcut3" [1,2,1,2,5] tcut3r-    >> assertEqual "Cut: nested call: tcut4" [1,2,1,2,5] tcut4r-  where-    -- signature is inferred-    -- tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int-    tcut1 = (return (1::Int) `mplus'` return 2) `mplus'`-            ((cutfalse `mplus'` return 4) `mplus'`-             return 5)-    -- Here we see nested call. It poses no problems...-    tcut2 = return (1::Int) `mplus'`-            call (return 2 `mplus'` (cutfalse `mplus'` return 3) `mplus'`-                  return 4)-            `mplus'` return 5-    tcut3 = call tcut1 `mplus'` call (tcut2 `mplus'` cutfalse)-    tcut4 = call tcut1 `mplus'`  (tcut2 `mplus'` cutfalse)---- }}}+import Test.Framework (defaultMain, Test)++import qualified Control.Eff.Test+import qualified Control.Eff.Choose.Test+import qualified Control.Eff.Coroutine.Test+import qualified Control.Eff.Cut.Test+import qualified Control.Eff.Example.Test+import qualified Control.Eff.Exception.Test+import qualified Control.Eff.Fresh.Test+import qualified Control.Eff.Lift.Test+import qualified Control.Eff.NdetEff.Test+import qualified Control.Eff.Operational.Test+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.Strict.Test+import qualified Control.Eff.Trace.Test+import qualified Control.Eff.Writer.Lazy.Test+import qualified Control.Eff.Writer.Strict.Test++main :: IO ()+main = defaultMain testGroups++testGroups :: [Test]+testGroups = []+             ++ Control.Eff.Test.testGroups+             ++ Control.Eff.Choose.Test.testGroups+             ++ Control.Eff.Coroutine.Test.testGroups+             ++ Control.Eff.Cut.Test.testGroups+             ++ Control.Eff.Example.Test.testGroups+             ++ Control.Eff.Exception.Test.testGroups+             ++ Control.Eff.Fresh.Test.testGroups+             ++ Control.Eff.Lift.Test.testGroups+             ++ Control.Eff.NdetEff.Test.testGroups+             ++ Control.Eff.Operational.Test.testGroups+             ++ 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.Strict.Test.testGroups+             ++ Control.Eff.Trace.Test.testGroups+             ++ Control.Eff.Writer.Lazy.Test.testGroups+             ++ Control.Eff.Writer.Strict.Test.testGroups

@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -Werror #-}++module Utils where++import Control.Exception (ErrorCall, catch)+import Control.Monad++import GHC.IO.Handle+import System.IO+import System.Directory++import Test.HUnit hiding (State)++-- | capture stdout+-- [[https://stackoverflow.com/a/9664017][source]]+catchOutput :: IO a -> IO (a, String)+catchOutput f = do+  tmpd <- getTemporaryDirectory+  (tmpf, tmph) <- openTempFile tmpd "haskell_stdout"+  stdout_dup <- hDuplicate stdout+  hDuplicateTo tmph stdout+  hClose tmph+  fVal <- f+  hDuplicateTo stdout_dup stdout+  str <- readFile tmpf+  removeFile tmpf+  return (fVal, str)++showLn :: Show a => a -> String+showLn x = unlines $ [show x]++showLines :: Show a => [a] -> String+showLines xs = unlines $ map show xs++withError :: a -> ErrorCall -> a+withError a _ = a++assertUndefined :: a -> Assertion+assertUndefined a = catch (seq a $ assertFailure "") (withError $ return ())++assertNoUndefined :: a -> Assertion+assertNoUndefined a = catch (seq a $ return ()) (withError $ assertFailure "")++allEqual :: Eq a => [a] -> Bool+allEqual = all (uncurry (==)) . pairs+  where+    pairs l = zip l $ tail l++safeLast :: [a] -> Maybe a+safeLast [] = Nothing+safeLast l = Just $ last l++add :: Monad m => m Int -> m Int -> m Int+add = liftM2 (+)