packages feed

extensible-effects 1.2.1 → 5.0.0.1

raw patch · 52 files changed

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Oleg Kiselyov, Amr Sabry, Cameron Swords, Ben Foppa++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,312 @@++# Extensible effects (![Hackage](https://img.shields.io/hackage/v/extensible-effects.svg), ![GHC](https://img.shields.io/badge/GHC-8.2.2%20%7C%208.4.4%20%7C%208.6.3-blue.svg))++[![Build Status](https://travis-ci.org/suhailshergill/extensible-effects.svg?branch=master)](https://travis-ci.org/suhailshergill/extensible-effects)+[![Join the chat at https://gitter.im/suhailshergill/extensible-effects](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/suhailshergill/extensible-effects?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)+[![Stories in Ready](https://badge.waffle.io/suhailshergill/extensible-effects.png?label=ready&title=Ready)](http://waffle.io/suhailshergill/extensible-effects)+[![Stories in progress](https://badge.waffle.io/suhailshergill/extensible-effects.png?label=in%20progress&title=In%20progress)](http://waffle.io/suhailshergill/extensible-effects)++*Implement effectful computations in a modular way!*++The main monad of this package is `Eff` from `Control.Eff`.+`Eff r a` is parameterized by the effect-list `r` and the monadic-result type+`a` similar to other monads.+It is the intention that all other monadic computations can be replaced by the+use of `Eff`.++In case you know monad transformers or `mtl`:+This library provides only one monad that includes all your effects instead of+layering different transformers.+It is not necessary to lift the computations through a monad stack.+Also, it is not required to lift every `Monad*` typeclass (like `MonadError`)+though all transformers.++## Quickstart++To experiment with this library, it is suggested to write some lines within+`ghci`.++Recommended Procedure:++1. get `extensible-effects` by doing one of the following:+  * add `extensible-effects` as a dependency to a existing cabal or stack project+  * `git clone https://github.com/suhailshergill/extensible-effects.git`+2. start `stack ghci` or `cabal repl` inside the project+3. import `Control.Eff` and `Control.Eff.QuickStart`+4. start with the examples provided in the documentation of the `Control.Eff.QuickStart` module++## Tour through Extensible Effects++This section explains the basic concepts of this library.++### The Effect List++```haskell+import Control.Eff+```++The effect list `r` in the type `Eff r a` is a central concept in this library.+It is a type-level list containing effect types.++If `r` is the empty list, then the computation `Eff r` (or `Eff '[]`) does not+contain any effects to be handled and therefore is a pure computation.+In this case, the result value can be retrieved by `run :: Eff '[] a -> a`++For programming within the `Eff r` monad, it is almost never necessary to list+all effects that can appear.+It suffices to state what types of effects are at least required.+This is done via the `Member t r` typeclass. It describes that the type `t`+occurs inside the list `r`.+If you really want, you can still list all Effects and their order in which+they are used (e.g. `Eff '[Reader r, State s] a`).++### Handling Effects++Functions containing something like `Eff (x ': r) a -> Eff r a` handle effects.++The transition from the longer list of effects `(x ': r)` to just `r`+is a type-level indicator that the effect `x` has been handled.+Depending on the effect, some additional input might be required or some+different output than just `a` is produced.++The handler functions typically are called `run*`, `eval*` or `exec*`.++### Most common Effects++The most common effects used are `Writer`, `Reader`, `Exception` and `State`.++`Writer`, `Reader` and `State` all provide lazy and strict variants. Each has+its own module that exposes a common interface. Importing one or the other+controls whether the effect is strict or lazy in its inputs and outputs. It's+recommended that you use the lazy variants by default unless you know you need+strictness.++In this section, only the core functions associated with an effect are+presented.+Have a look at the modules for additional details.++#### The Exception Effect++```haskell+import Control.Eff.Exception+```++The exception effect adds the possibility to exit a computation preemptively+with an exception.+Note that the exceptions from this library are handled by the programmer and+have nothing to do with exceptions thrown inside the Haskell run-time.++```haskell+throwError :: Member (Exc e) r => e -> Eff r a+runError :: Eff (Exc e ': r) a -> Eff r (Either e a)+```++An exception can be thrown using the `throwError` function.+Its return type is `Eff r a` with an arbitrary type `a`.+When handling the effect, the result-type changes to `Either e a` instead of+just `a`.+This indicates how the effect is handled: The returned value is either the+thrown exception or the value returned from a successful computation.++#### The State Effect++```haskell+import Control.Eff.State.{Lazy | Strict}+```++The state effect provides readable and writable state during a computation.++```haskell+get :: Member (State s) r => Eff r s+put :: Member (State s) r => s -> Eff r ()+modify :: Member (State s) r => (s -> s) -> Eff r ()+runState :: s -> Eff (State s ': r) a -> Eff r (a, s)+```++The `get` function fetches the current state and makes it available within+subsequent computation. The `put` function sets the state to a given value.+`modify` updates the state using a mapping function by combining `get` and+`put`.++The state-effect is handled using the `runState` function.+It takes the initial state as an argument and returns the final state and+effect-result.++#### The Reader Effect++```haskell+import Control.Eff.Reader.{Strict | Lazy}+```++The reader effect provides an environment that can be read.+Sometimes it is considered as read-only state.++```haskell+ask :: Member (Reader e) r => e -> Eff r e+runReader :: e -> Eff (Reader e ': r) a -> Eff r a+```++`ask` can be used to retrieve the environment provided to `runReader` from+within a computation which has the `Reader` effect.++#### The Writer Effect++```haskell+import Control.Eff.Writer.{Strict | Lazy}+```++The writer effect allows one to collect messages during a computation.+It is sometimes referred to as write-only state, which gets retrieved at the+end of the computation.++```haskell+tell :: Member (Writer w) r => w -> Eff r ()+runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b)+runListWriter :: Eff (Writer w ': r) a -> Eff r (a, [w])+```++Running a writer can be done in several ways.+The most general function is `runWriter` which folds over all written values.+However, if you only want to collect the values written, the `runListWriter`+function does that.++Note that compared to mtl, the value written has no Monoid constraint on it and+can be collected in any way.++### Using multiple Effects++The main benefit of this library is that multiple effects can be included+with ease.++If you need state and want to be able exit the computation with an exception,+the type of your effectful computation would be the one of `myComp` below.+Then, both the state and exception effect-functions can be used.+To handle the effects, both the `runState` and `runError` functions have to be+provided.++```haskell+myComp :: (Member (Exc e) r, Member (State s) r) => Eff r a++run1 :: (Either e a, s)+run1 = run . runState initalState . runError $ myComp++run2 :: Either e (a, s)+run2 = run . runError . runState initalState $ myComp+```++However, the order of the handlers does matter for the final result.+`run1` and `run2` show different executions of the same effectful computation.+In `run1`, the returned state `s` is the last state seen before an eventual+exception gets thrown (similar to the semantics in typical imperative+languages), while in `run2` the final state is returned only if the whole+computation succeeded - transaction style.++### Tips and tricks++There are several constructs that make it easier to work with the effects.++If only a part of the result is necessary for further computation, have a+look at the `eval*` and `exec*` functions which exist for some effects.+The `exec*` functions discard the result of the computation (the `a` type).+The `eval*` functions discard the final result of the effect.++Instead of writing+`(Member (Exc e) r, Member (State s) r) => ...` it is+possible to use the type operator `<::` and write+`[ Exc e, State s ] <:: r => ...`, which has the same meaning.++It might be convenient to include the necessary language extensions and disable+class-constraint warnings in your project's `.cabal` file (or `package.yaml` if+you're using `stack`).++*Explanation is a work in progress.*++## Other Effects++*Work in progress.*++## Integration with IO++`IO` or any other monad can be used as a base type for the `Lift` effect.+There may be at most one instance of the `Lift` effect in the effects list, and it+must be handled last. `Control.Eff.Lift` exports the `runLift` handler and+`lift` function which provide the ability to run arbitrary monadic actions.+Also, there are convenient type aliases that allow for shorter type constraints.++```haskell+f :: IO ()+f = runLift $ do printHello+                 printWorld++-- These two functions' types are equivalent.++printHello :: SetMember Lift (Lift IO) r => Eff r ()+printHello = lift (putStr "Hello")++printWorld :: Lifted IO r => Eff r ()+printWorld = lift (putStrLn " world!")+```++Note that, since `Lift` is a terminal effect, you do not need to use `run` to+extract pure values. Instead, `runLift` returns a value wrapped in whatever+monad you chose to use.++Additionally, the `Lift` effect provides `MonadBase`, `MonadBaseControl`, and+`MonadIO` instances that may be useful, especially with packages like+[lifted-base](http://hackage.haskell.org/package/lifted-base),+[lifted-async](http://hackage.haskell.org/package/lifted-async), and other+code that uses those typeclasses.++## Integration with Monad Transformers++*Work in progress.*++## Writing your own Effects and Handlers++*Work in progress.*++## Other packages++Some other packages may implement various effects. Here is a rather incomplete+list:++* [log-effect](http://hackage.haskell.org/package/log-effect)++## Background++`extensible-effects` is based on the work of+[Extensible Effects: An Alternative to Monad Transformers](http://okmij.org/ftp/Haskell/extensible/).+The [paper](http://okmij.org/ftp/Haskell/extensible/exteff.pdf) and+the followup [freer paper](http://okmij.org/ftp/Haskell/extensible/more.pdf)+contain details. Additional explanation behind the approach can be found on [Oleg's website](http://okmij.org/ftp/Haskell/extensible/).++## Limitations++### Ambiguity-Flexibility tradeoff+The extensibility of `Eff` comes at the cost of some ambiguity. A useful+pattern to mitigate this ambiguity is to specialize calls to effect handlers+using+[type application](https://ghc.haskell.org/trac/ghc/wiki/TypeApplication)+or type annotation. Examples of this pattern can be seen in+[Example/Test.hs](./test/Control/Eff/Example/Test.hs).++Note, however, that the extensibility can also be traded back, but that detracts+from some of the advantages. For details see section 4.1 in the+[paper](http://okmij.org/ftp/Haskell/extensible/exteff.pdf).++Some examples where the cost of extensibility is apparent:++  * Common functions can't be grouped using typeclasses, e.g. the `ask` and+    `getState` functions can't be grouped in the case of:++    ```haskell+    class Get t a where+      ask :: Member (t a) r => Eff r a+    ```++    `ask` is inherently ambiguous, since the type signature only provides+    a constraint on `t`, and nothing more. To specify fully, a parameter+    involving the type `t` would need to be added, which would defeat the+    point of having the grouping in the first place.+  * Code requires a greater number of type annotations. For details see+    [#31](https://github.com/suhailshergill/extensible-effects/issues/31).
+ benchmark/Benchmarks.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- The simplest/silliest of all benchmarks!++import Criterion.Main+import Control.Eff as E+import Control.Eff.Exception as E.Er+import Control.Eff.Logic.NDet as E.ND+import Control.Eff.State.Strict as E.S+import Control.Monad++-- For comparison+-- We use a strict State monad, because of large space leaks with the+-- lazy monad (one test even overflows the stack)+import Control.Monad.State.Strict as S+import Control.Monad.Except  as Er+-- import Control.Monad.Reader as Rd+import Control.Monad.Cont as Ct+import Control.Applicative++-- For sanity-checking+import qualified Test.Framework as TF+import qualified Test.Framework.TH as TF.TH+import Test.Framework.Providers.HUnit (testCase)+import qualified Test.HUnit as HU++main :: IO ()+main = defaultMain [+  bgroup "state" [ bgroup "10k" [ bench "mtl" $ whnf benchCnt_State 10000+                                , bench "eff" $ whnf benchCnt_Eff 10000+                                ]+                 ]+  , bgroup "error" [ bgroup "50k" [ bench "mtl" $ whnf benchMul_Error 50000+                                  , bench "eff" $ whnf benchMul_Eff 50000+                                  ]+                   ]+  , bgroup "st-error" [ bgroup "err : st" [ bench "mtl" $ whnf mainMax_MTL 10000+                                          , bench "eff" $ whnf mainMax_Eff 10000+                                          ]+                      , bgroup "st : err" [ bench "mtl" $ whnf mainMax1_MTL 10000+                                          , bench "eff" $ whnf mainMax1_Eff 10000+                                          ]+                      ]+  , bgroup "pyth" [ bgroup "ndet" [ bench "mtl" $ whnf mainN_MTL 100+                                  , bench "eff" $ whnf mainN_Eff 100+                                  ]+                  , bgroup "ndet : st" [ bench "mtl" $ nf mainNS_MTL 100+                                       , bench "eff" $ nf mainNS_Eff 100+                                       ]+                  ]+  ]+  >> TF.defaultMainWithArgs [ $(TF.TH.testGroupGenerator) ] testOpts+  where+    testOpts = [ "--color" ]++-- ------------------------------------------------------------------------+-- Single State, with very little non-effectful computation+-- This is a micro-benchmark, and hence not particularly realistic.+-- Because of its simplicity, GHC may do a lot of inlining.+-- See a more realistic max benchmark below, which does a fair amount+-- of computation other than accessing the state.++-- Count-down+benchCnt_State :: Int -> ((),Int)+benchCnt_State n = S.runState m n+ where+ m = do+     x <- S.get+     if x > 0 then S.put (x-1) >> m else return ()++benchCnt_Eff :: Int -> ((),Int)+benchCnt_Eff n = run $ E.S.runState n m+ where+ m = do+     x <- E.S.get+     if x > 0 then E.S.put (x-1::Int) >> m else return ()++-- ------------------------------------------------------------------------+-- Single Error++-- Multiply a list of numbers, throwing an exception when encountering 0+-- This is again a mcro-benchmark++-- make a list of n ones followed by 0+be_make_list :: Int -> [Int]+be_make_list n = replicate n 1 ++ [0]++benchMul_Error :: Int -> Int+benchMul_Error n = either id id m+ where+ m = foldM f 1 (be_make_list n)+ f acc 0 = Er.throwError 0+ f acc x = return $! acc * x++benchMul_Eff :: Int -> Int+benchMul_Eff n = either id id . run . runError $ m+ where+ m = foldM f 1 (be_make_list n)+ f acc 0 = E.Er.throwError (0::Int)+ f acc x = return $! acc * x++-- ------------------------------------------------------------------------+-- State and Error and non-effectful computation++benchMax_MTL :: (MonadState Int m, MonadError Int m) => Int -> m Int+benchMax_MTL n = foldM f 1 [n, n-1 .. 0]+ where+ f acc 0 = Er.throwError 0+ f acc x | x `mod` 5 == 0 = do+                            s <- S.get+                            S.put $! (s+1)+                            return $! max acc x+ f acc x = return $! max acc x++mainMax_MTL n = S.runState (Er.runExceptT (benchMax_MTL n)) 0++-- Different order of layers+mainMax1_MTL n = (S.runStateT (benchMax_MTL n) 0 :: Either Int (Int,Int))++benchMax_Eff :: (Member (Exc Int) r, Member (E.S.State Int) r) =>+                Int -> Eff r Int+benchMax_Eff n = foldM f 1 [n, n-1 .. 0]+ where+ f acc 0 = E.Er.throwError (0::Int)+ f acc x | x `mod` 5 == 0 = do+                            s <- E.S.get+                            E.S.put $! (s+1::Int)+                            return $! max acc x+ f acc x = return $! max acc x+++mainMax_Eff n = ((run $ E.S.runState 0 (E.Er.runError (benchMax_Eff n))) ::+                  (Either Int Int,Int))++mainMax1_Eff n = ((run $ E.Er.runError (E.S.runState 0 (benchMax_Eff n))) ::+                     Either Int (Int,Int))++-- ------------------------------------------------------------------------+-- Non-determinism benchmark: Pythagorian triples++-- First benchmark, with non-determinism only++-- Stream from k to n+iota k n = if k > n then mzero else return k `mplus` iota (k+1) n++pyth1 :: MonadPlus m => Int -> m (Int, Int, Int)+pyth1 upbound = do+  x <- iota 1 upbound+  y <- iota 1 upbound+  z <- iota 1 upbound+  if x*x + y*y == z*z then return (x,y,z) else mzero++pyth20 =+  [(3,4,5),(4,3,5),(5,12,13),(6,8,10),(8,6,10),(8,15,17),(9,12,15),(12,5,13),+   (12,9,15),(12,16,20),(15,8,17),(16,12,20)]+++case_pythr_ndet :: HU.Assertion+case_pythr_ndet =+  HU.assertEqual "pythr_MTL" pyth20 ((runCont (pyth1 20) (\x -> [x])) :: [(Int,Int,Int)])+  >> HU.assertEqual "pythr_EFF" pyth20 ((run . E.ND.makeChoice $ pyth1 20) :: [(Int,Int,Int)])+++-- There is no instance of MonadPlus for ContT+-- we have to make our own++instance Monad m => MonadPlus (ContT [r] m) where+  mzero = ContT $ \k -> return []+  mplus (ContT m1) (ContT m2) = ContT $ \k ->+    liftM2 (++) (m1 k) (m2 k)++instance Monad m => Alternative (ContT [r] m) where+  empty = mzero+  (<|>) = mplus++mainN_MTL n = ((runCont (pyth1 n) (\x -> [x])) :: [(Int,Int,Int)])++mainN_Eff n = ((run . E.ND.makeChoice $ pyth1 n) :: [(Int,Int,Int)])++-- Adding state: counting the number of choices++pyth2 :: Int -> ContT [r] (S.State Int) (Int, Int, Int)+pyth2 upbound = do+  x <- iota 1 upbound+  y <- iota 1 upbound+  z <- iota 1 upbound+  cnt <- S.get+  S.put $! (cnt + 1)+  if x*x + y*y == z*z then return (x,y,z) else mzero++pyth2E :: (Member (E.S.State Int) r, Member NDet r) =>+          Int -> Eff r (Int, Int, Int)+pyth2E upbound = do+  x <- iota 1 upbound+  y <- iota 1 upbound+  z <- iota 1 upbound+  cnt <- E.S.get+  E.S.put $! (cnt + 1::Int)+  if x*x + y*y == z*z then return (x,y,z) else mzero+++mainNS_MTL n =+  let (l,cnt) = pythrNS_MTL n+  in ((l::[(Int,Int,Int)]), (cnt::Int))+  where+    pythrNS_MTL :: Int -> ([(Int,Int,Int)],Int)+    pythrNS_MTL n = S.runState (runContT (pyth2 n) (\x -> return [x])) 0++mainNS_Eff n =+  let (l,cnt) = pyth2Er n+  in ((l::[(Int,Int,Int)]), (cnt::Int))+  where+    pyth2Er :: Int -> ([(Int,Int,Int)],Int)+    pyth2Er n = run . E.S.runState 0 . E.ND.makeChoice $ pyth2E n
extensible-effects.cabal view
@@ -1,63 +1,245 @@-Name:                extensible-effects-Version:             1.2.1-Synopsis:            An Alternative to Monad Transformers-Description:         This package introduces datatypes for typeclass-constrained effects,+name:                extensible-effects++-- The package version.  See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             5.0.0.1++-- A short (one-line) description of the package.+synopsis:            An Alternative to Monad Transformers++-- A longer description of the package.+description:         This package introduces datatypes for typeclass-constrained effects,                      as an alternative to monad-transformer based (datatype-constrained)                      approach of multi-layered effects.-                     For more information, see the original paper at-                     <http://okmij.org/ftp/Haskell/extensible/exteff.pdf>.                       Any help is appreciated!-Category:            Control, Effect-Author:              Oleg Kiselyov, Amr Sabry, Cameron Swords, Ben Foppa-Stability:           Experimental-Homepage:            https://github.com/RobotGymnast/extensible-effects-Maintainer:          benjamin.foppa@gmail.com-License:             MIT-Tested-With:         GHC==7.6.3-Build-Type:          Simple-Cabal-Version:       >= 1.9.2 +stability:           Experimental++-- URL for the project homepage or repository.+homepage:            https://github.com/suhailshergill/extensible-effects++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Oleg Kiselyov, Amr Sabry, Cameron Swords, Ben Foppa++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer:          suhailshergill@gmail.com++-- A copyright notice.+-- copyright:++category:            Control, Effect++tested-with:         GHC==8.6.3, GHC==8.4.4, GHC==8.2.2++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a+-- README.+extra-source-files:  README.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10++flag lib-Werror+  default: False+  manual: True++flag dump-core+  description: Dump HTML for the core generated by GHC during compilation+  default:     False+ library-    hs-source-dirs:    src/-    ghc-options:       -Wall-    extensions:        Trustworthy-    exposed-modules:   Control.Eff-                       Control.Eff.Choose+  ghc-options:         -Wall -O2+  -- Modules exported by the library.+  exposed-modules:     Control.Eff                        Control.Eff.Coroutine-                       Control.Eff.Cut+                       Control.Eff.Example                        Control.Eff.Exception-                       Control.Eff.Fail                        Control.Eff.Fresh-                       Control.Eff.Lift+                       Control.Eff.Logic.Core+                       Control.Eff.Logic.NDet+                       Control.Eff.Operational+                       Control.Eff.Operational.Example                        Control.Eff.Reader.Lazy+                       Control.Eff.State.OnDemand                        Control.Eff.Reader.Strict                        Control.Eff.State.Lazy                        Control.Eff.State.Strict+                       Control.Eff.Trace                        Control.Eff.Writer.Lazy                        Control.Eff.Writer.Strict-                       Control.Eff.Trace-    other-modules:     Data.OpenUnion1+                       Data.OpenUnion+                       Control.Eff.QuickStart+                       Control.Eff.Extend -    build-depends: -                    base == 4.*+  -- Modules included in this library but not exported.+  other-modules:       Control.Eff.Internal+                       Data.FTCQueue+                       Control.Eff.Logic.Experimental +  default-extensions:  NoMonomorphismRestriction+                     , MonoLocalBinds+                     , FlexibleContexts+                     , FlexibleInstances+                     , GADTs+                     , MultiParamTypeClasses+                     , RankNTypes+                     , ScopedTypeVariables+                     , DataKinds+                     , TypeOperators+                     , PolyKinds+                     , KindSignatures+  -- LANGUAGE extensions used by modules in this package.+  other-extensions:    BangPatterns+                       , CPP+                       , DeriveDataTypeable+                       , DeriveFunctor+                       , EmptyDataDecls+                       , ExistentialQuantification+                       , FlexibleContexts+                       , FlexibleInstances+                       , FunctionalDependencies+                       , GeneralizedNewtypeDeriving+                       , KindSignatures+                       , MultiParamTypeClasses+                       , NoMonomorphismRestriction+                       , PatternGuards+                       , PolyKinds+                       , RankNTypes+                       , Safe+                       , ScopedTypeVariables+                       , TupleSections+                       , Trustworthy+                       , TypeOperators+                       , UndecidableInstances++  -- Other library packages from which modules are imported.+  build-depends:       base >= 4.7 && < 5+                       -- For MonadBase+                     , transformers-base == 0.4.*+                       -- For MonadBaseControl+                     , monad-control >= 1.0 && < 1.1++  -- Directories containing source files.+  hs-source-dirs:      src++  -- Base language which the package is written in.+  default-language:    Haskell2010++  if flag(lib-Werror)+     ghc-options: -Werror++  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html+ test-suite extensible-effects-tests   type: exitcode-stdio-1.0   main-is: Test.hs   hs-source-dirs: test/+  other-modules:  Utils+                , Control.Eff.Test+                , Control.Eff.Coroutine.Test+                , Control.Eff.Example.Test+                , Control.Eff.Exception.Test+                , Control.Eff.Fresh.Test+                , Control.Eff.Logic.NDet.Bench+                , Control.Eff.Logic.NDet.Test+                , Control.Eff.Logic.Test+                , Control.Eff.Operational.Test+                , Control.Eff.Reader.Lazy.Test+                , Control.Eff.Reader.Strict.Test+                , Control.Eff.State.Lazy.Test+                , Control.Eff.State.OnDemand.Test+                , Control.Eff.State.Strict.Test+                , Control.Eff.Trace.Test+                , Control.Eff.Writer.Lazy.Test+                , Control.Eff.Writer.Strict.Test+                , DoctestRun -  ghc-options: -rtsopts=all -threaded+  ghc-options: -Wall+  if impl(ghc >= 8.0)+     ghc-options:      -Wno-type-defaults -Wno-missing-signatures -Wno-name-shadowing+  if impl(ghc < 8.0)+     ghc-options:      -fno-warn-type-defaults -fno-warn-missing-signatures -fno-warn-name-shadowing    build-depends:-    base == 4.*,-    QuickCheck == 2.*,-    HUnit == 1.2.*,-    test-framework == 0.8.*,-    test-framework-hunit == 0.3.*,-    test-framework-quickcheck2 == 0.3.*,-    extensible-effects+                base >= 4.7 && < 5+              , QuickCheck+              , HUnit+              , monad-control >= 1.0+              , mtl+              , silently >= 1.2+              , test-framework == 0.8.*+              , test-framework-hunit == 0.3.*+              , test-framework-quickcheck2 == 0.3.*+              , test-framework-th >= 0.2+              , doctest+              , extensible-effects +  default-language:    Haskell2010+  default-extensions:  NoMonomorphismRestriction+                     , MonoLocalBinds+                     , FlexibleContexts+                     , FlexibleInstances+                     , GADTs+                     , MultiParamTypeClasses+                     , RankNTypes+                     , ScopedTypeVariables+                     , DataKinds+                     , TypeOperators+                     , PolyKinds+                     , KindSignatures++benchmark extensible-effects-benchmarks+  type: exitcode-stdio-1.0+  main-is: Benchmarks.hs+  hs-source-dirs: benchmark/+  ghc-options: -Wall -O2 -threaded -rtsopts+  if impl(ghc >= 8.0)+     ghc-options:      -Wno-type-defaults -Wno-missing-signatures+                       -Wno-name-shadowing -Wno-unused-matches+  if impl(ghc < 8.0)+     ghc-options:      -fno-warn-type-defaults -fno-warn-missing-signatures+                       -fno-warn-name-shadowing -fno-warn-unused-matches++  build-depends:+                base >= 4.7 && < 5+              , criterion+              , extensible-effects+              , mtl+              , HUnit+              , test-framework == 0.8.*+              , test-framework-hunit == 0.3.*+              , test-framework-quickcheck2 == 0.3.*+              , test-framework-th >= 0.2++  default-language:    Haskell2010+  default-extensions:  NoMonomorphismRestriction+                     , MonoLocalBinds+                     , FlexibleContexts+                     , FlexibleInstances+                     , GADTs+                     , MultiParamTypeClasses+                     , RankNTypes+                     , ScopedTypeVariables+                     , DataKinds+                     , TypeOperators+                     , PolyKinds+                     , KindSignatures+ source-repository head   type: git-  location: https://github.com/RobotGymnast/extensible-effects+  location: https://github.com/suhailshergill/extensible-effects.git
src/Control/Eff.hs view
@@ -1,159 +1,40 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, DeriveFunctor #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE ExplicitNamespaces #-} --- | Original work available at <http://okmij.org/ftp/Hgetell/extensible/Eff.hs>.--- This module implements extensible effects as an alternative to monad transformers,--- as described in <http://okmij.org/ftp/Hgetell/extensible/exteff.pdf>.+-- | A monadic library for implementing effectful computation in a modular way. ----- Extensible Effects are implemented as typeclass constraints on an Eff[ect] datatype.--- A contrived example is:+-- This module provides the @Eff@ monad - the base type for all effectful+-- computation.+-- The @Member@ typeclass is the main interface for describing which effects+-- are necessary for a given function. ----- > {-# LANGUAGE FlexibleContexts #-}--- > import Control.Eff--- > import Control.Eff.Lift--- > import Control.Eff.State--- > import Control.Monad (void)--- > import Data.Typeable--- >--- > -- Write the elements of a list of numbers, in order.--- > writeAll :: (Typeable a, Member (Writer a) e)--- >          => [a]--- >          -> Eff e ()--- > writeAll = mapM_ putWriter--- >--- > -- Add a list of numbers to the current state.--- > sumAll :: (Typeable a, Num a, Member (State a) e)--- >        => [a]--- >        -> Eff e ()--- > sumAll = mapM_ (onState . (+))--- >--- > -- Write a list of numbers and add them to the current state.--- > writeAndAdd :: (Member (Writer Integer) e, Member (State Integer) e)--- >             => [Integer]--- >             -> Eff e ()--- > writeAndAdd l = do--- >     writeAll l--- >     sumAll l--- >--- > -- Sum a list of numbers.--- > sumEff :: (Num a, Typeable a) => [a] -> a--- > sumEff l = let (s, ()) = run $ runState 0 $ sumAll l--- >            in s--- >--- > -- Safely get the last element of a list.--- > -- Nothing for empty lists; Just the last element otherwise.--- > lastEff :: Typeable a => [a] -> Maybe a--- > lastEff l = let (a, ()) = run $ runWriter $ writeAll l--- >             in a--- >--- > -- Get the last element and sum of a list--- > lastAndSum :: (Typeable a, Num a) => [a] -> (Maybe a, a)--- > lastAndSum l = let (lst, (total, ())) = run $ runWriter $ runState 0 $ writeAndAdd l--- >                in (lst, total)-module Control.Eff(-                    Eff-                  , VE (..)-                  , Member-                  , SetMember-                  , Union-                  , (:>)-                  , inj-                  , prj-                  , prjForce-                  , decomp-                  , send-                  , admin-                  , run-                  , interpose-                  , handleRelay-                  , unsafeReUnion-                  ) where--import Control.Applicative (Applicative (..), (<$>))-import Control.Monad (ap)-import Data.OpenUnion1-import Data.Typeable---- | A `VE` is either a value, or an effect of type @`Union` r@ producing another `VE`.--- The result is that a `VE` can produce an arbitrarily long chain of @`Union` r@--- effects, terminated with a pure value.-data VE w r = Val w | E !(Union r (VE w r))-  deriving Typeable--fromVal :: VE w r -> w-fromVal (Val w) = w-fromVal _ = error "extensible-effects: fromVal was called on a non-terminal effect."-{-# INLINE fromVal #-}---- | Basic datatype returned by all computations with extensible effects.--- The type @r@ is the type of effects that can be handled,--- and @a@ is the type of value that is returned.-newtype Eff r a = Eff { runEff :: forall w. (a -> VE w r) -> VE w r }-  deriving Typeable--instance Functor (Eff r) where-    fmap f m = Eff $ \k -> runEff m (k . f)-    {-# INLINE fmap #-}--instance Applicative (Eff r) where-    pure = return-    (<*>) = ap--instance Monad (Eff r) where-    {-# INLINE return #-}-    {-# INLINE (>>=) #-}-    return x = Eff $ \k -> k x-    m >>= f  = Eff $ \k -> runEff m (\v -> runEff (f v) k)---- | Given a method of turning requests into results,--- we produce an effectful computation.-send :: (forall w. (a -> VE w r) -> Union r (VE w r)) -> Eff r a-send f = Eff (E . f)-{-# INLINE send #-}---- | Tell an effectful computation that you're ready to start running effects--- and return a value.-admin :: Eff r w -> VE w r-admin (Eff m) = m Val-{-# INLINE admin #-}---- | Get the result from a pure computation.-run :: Eff () w -> w-run = fromVal . admin-{-# INLINE run #-}---- the other case is unreachable since () has no constructors--- Therefore, run is a total function if m Val terminates.+-- Consult the @Control.Eff.QuickStart@ module and the readme for gentle+-- introductions.+--+-- To use extensible effects effectively some language extensions are+-- necessary/recommended.+--+-- @+-- {-\# LANGUAGE ScopedTypeVariables \#-}+-- {-\# LANGUAGE FlexibleContexts \#-}+-- {-\# LANGUAGE MonoLocalBinds \#-}+-- @+-- --- | Given a request, either handle it or relay it.-handleRelay :: Typeable1 t-            => Union (t :> r) v -- ^ Request-            -> (v -> Eff r a)   -- ^ Relay the request-            -> (t v -> Eff r a) -- ^ Handle the request of type t-            -> Eff r a-handleRelay u loop h = either passOn h $ decomp u-  where passOn u' = send (<$> u') >>= loop-  -- perhaps more efficient:-  -- passOn u' = send (\k -> fmap (\w -> runEff (loop w) k) u')-{-# INLINE handleRelay #-}+module Control.Eff+  ( -- * Effect type+    Internal.run+  , Internal.Eff+    -- * Lift IO computations+  , Internal.lift, Internal.runLift+  , Internal.catchDynE+  , Internal.HandlerDynE(..), Internal.catchesDynE+  , Internal.Lift(..), Internal.Lifted, Internal.LiftedBase+    -- * Effect list+  , OpenUnion.Member+  , OpenUnion.SetMember+  , type(<::)+  ) where --- | Given a request, either handle it or relay it. Both the handler--- and the relay can produce the same type of request that was handled.-interpose :: (Typeable1 t, Functor t, Member t r)-          => Union r v-          -> (v -> Eff r a)-          -> (t v -> Eff r a)-          -> Eff r a-interpose u loop h = maybe (send (<$> u) >>= loop) h $ prj u-{-# INLINE interpose #-}+import Control.Eff.Internal as Internal+import Data.OpenUnion as OpenUnion
− src/Control/Eff/Choose.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}--- | Nondeterministic choice effect-module Control.Eff.Choose( Choose (..)-                         , choose-                         , runChoice-                         , mzero'-                         , mplus'-                         ) where--import Control.Applicative ((<$>))-import Control.Monad (join)-import Data.Typeable--import Control.Eff---- | Nondeterministic choice-data Choose v = forall a. Choose [a] (a -> v)-              deriving (Typeable)--instance Functor Choose where-    fmap f (Choose lst k) = Choose lst (f . k)---- | choose lst non-deterministically chooses one value from the lst--- choose [] thus corresponds to failure-choose :: Member Choose r => [a] -> Eff r a-choose lst = send (inj . Choose lst)---- | MonadPlus-like operators are expressible via choose-mzero' :: Member Choose r => Eff r a-mzero' = choose []---- | MonadPlus-like operators are expressible via choose-mplus' :: Member Choose r => Eff r a -> Eff r a -> Eff r a-mplus' m1 m2 = join $ choose [m1,m2]---- | Run a nondeterministic effect, returning all values.-runChoice :: forall a r. Eff (Choose :> r) a -> Eff r [a]-runChoice m = loop (admin m)- where-  loop (Val x)  = return [x]-  loop (E u)    = handleRelay u loop (\(Choose lst k) -> handle lst k)--  handle :: [t] -> (t -> VE a (Choose :> r)) -> Eff r [a]-  handle [] _  = return []-  handle [x] k = loop (k x)-  handle lst k = concat <$> mapM (loop . k) lst
src/Control/Eff/Coroutine.hs view
@@ -1,27 +1,33 @@ {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE Safe #-} -- | Coroutines implemented with extensible effects-module Control.Eff.Coroutine( Yield+module Control.Eff.Coroutine( Yield (..)+                            , withCoroutine                             , yield                             , runC                             , Y (..)                             ) where -import Data.Typeable- import Control.Eff+import Control.Eff.Extend +import Data.Function (fix)++-- ------------------------------------------------------------------------+-- | Co-routines+-- The interface is intentionally chosen to be the same as in transf.hs+-- -- | The yield request: reporting a value of type e and suspending--- the coroutine. For readability, a coroutine accepts a unit to produce--- its value.-data Yield a v = Yield a (() -> v)-    deriving (Typeable, Functor)+-- the coroutine. Resuming with the value of type b+data Yield a b v where+  Yield :: a -> Yield a b b  -- | Yield a value of type a and suspend the coroutine.-yield :: (Typeable a, Member (Yield a) r) => a -> Eff r ()-yield x = send (inj . Yield x)+yield :: (Member (Yield a b) r) => a -> Eff r b+yield x = send (Yield x)  -- | Status of a thread: done or reporting the value of the type a --   (For simplicity, a co-routine reports a value but accepts unit)@@ -32,13 +38,16 @@ -- --   Type parameter @w@ is the type of the value returned from the --   coroutine when it has completed.-data Y r a w = Y a (() -> Eff r (Y r a w))-             | Done w+data Y r w a = Y (w -> Eff r (Y r w a)) a+             | Done --- | Launch a thread and report its status.-runC :: Typeable a => Eff (Yield a :> r) w -> Eff r (Y r a w)-runC m = loop (admin m)-  where-    loop (Val x) = return (Done x)-    loop (E u)   = handleRelay u loop $-                    \(Yield x k) -> return (Y x (loop . k))+-- | Return a pure value+withCoroutine :: Monad m => b -> m (Y r w a)+withCoroutine = const $ return Done+-- | Given a continuation and a request, respond to it+instance Handle (Yield a b) (Yield a b : r) w (Eff r (Y r b a)) where+  handle step q (Yield a) = return $ Y (step . (q ^$)) a++-- | Launch a thread and report its status+runC :: Eff (Yield a b ': r) w -> Eff r (Y r b a)+runC = fix (handle_relay withCoroutine)
− src/Control/Eff/Cut.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}--- | An example of non-trivial interaction of effects, handling of two--- effects together--- Non-determinism with control (cut)--- For the explanation of cut, see Section 5 of Hinze ICFP 2000 paper.--- Hinze suggests expressing cut in terms of cutfalse:------ > = return () `mplus` cutfalse--- > where--- >  cutfalse :: m a------ satisfies the following laws:------ >  cutfalse >>= k  = cutfalse              (F1)--- >  cutfalse | m    = cutfalse              (F2)------ (note: @m \``mplus`\` cutfalse@ is different from @cutfalse \``mplus`\` m@)--- In other words, cutfalse is the left zero of both bind and mplus.------ Hinze also introduces the operation @`call` :: m a -> m a@ that--- delimits the effect of cut: @`call` m@ executes m. If the cut is--- invoked in m, it discards only the choices made since m was called.--- Hinze postulates the axioms of `call`:------ >  call false = false                          (C1)--- >  call (return a | m) = return a | call m     (C2)--- >  call (m | cutfalse) = call m                (C3)--- >  call (lift m >>= k) = lift m >>= (call . k) (C4)------ @`call` m@ behaves like @m@ except any cut inside @m@ has only a local effect,--- he says.------ Hinze noted a problem with the \"mechanical\" derivation of backtracing--- monad transformer with cut: no axiom specifying the interaction of--- call with bind; no way to simplify nested invocations of call.------ We use exceptions for cutfalse--- Therefore, the law @cutfalse >>= k = cutfalse@--- is satisfied automatically since all exceptions have the above property.-module Control.Eff.Cut( CutFalse-                      , call-                      , cutfalse-                      ) where--import Control.Applicative ((<$>))-import Data.Typeable--import Control.Eff-import Control.Eff.Choose-import Control.Eff.Exception--data CutFalse = CutFalse deriving Typeable--cutfalse :: Member (Exc CutFalse) r => Eff r a-cutfalse = throwExc CutFalse---- | The interpreter -- it is like reify . reflect with a twist--- Compare this implementation with the huge implementation of call--- in Hinze 2000 (Figure 9)--- Each clause corresponds to the axiom of call or cutfalse.--- All axioms are covered.--- The code clearly expresses the intuition that call watches the choice points--- of its argument computation. When it encounteres a cutfalse request,--- it discards the remaining choicepoints.--- It completely handles CutFalse effects but not non-determinism.-call :: Member Choose r => Eff (Exc CutFalse :> r) a -> Eff r a-call m = loop [] (admin m) where- loop jq (Val x) = return x `mplus'` next jq          -- (C2)- loop jq (E u) = case decomp u of-    Right (Exc CutFalse) -> mzero'  -- drop jq (F2)-    Left u' -> check jq u'-- check jq u | Just (Choose [] _) <- prj u  = next jq  -- (C1)- check jq u | Just (Choose [x] k) <- prj u = loop jq (k x)  -- (C3), optim- check jq u | Just (Choose lst k) <- prj u = next $ map k lst ++ jq -- (C3)- check jq u = send (<$> u) >>= loop jq      -- (C4)-- next []    = mzero'- next (h:t) = loop t h
+ src/Control/Eff/Example.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators, GADTs, DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Safe #-}++-- | Example usage of "Control.Eff"+module Control.Eff.Example where++import Control.Eff+import Control.Eff.Extend+import Control.Eff.Exception++import Control.Eff.Reader.Lazy+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 = runError++-- }}}++-- | Multiple Reader effects+sum2 :: ([ Reader Int+         , Reader Float+         ] <:: r) => Eff r Float+sum2 = do+  v1 <- ask+  v2 <- ask+  return $ fromIntegral (v1 + (1 :: Int)) + (v2 + (2 :: Float))++-- | Write the elements of a list of numbers, in order.+writeAll :: (Member (Writer a) e)+         => [a]+         -> Eff e ()+writeAll = mapM_ tell++-- | Add a list of numbers to the current state.+sumAll :: (Num a, Member (State a) e)+       => [a]+       -> Eff e ()+sumAll = mapM_ (modify . (+))++-- | Write a list of numbers and add them to the current state.+writeAndAdd :: ( [ Writer a+                 , State a+                 ] <:: e+               , Num a)+            => [a]+            -> Eff e ()+writeAndAdd l = do+    writeAll l+    sumAll l++-- | Sum a list of numbers.+sumEff :: (Num a) => [a] -> a+sumEff l = let ((), s) = run $ runState 0 (sumAll l)+           in s++-- | Safely get the last element of a list.+-- Nothing for empty lists; Just the last element otherwise.+lastEff :: [a] -> Maybe a+lastEff l = let ((), a) = run $ runLastWriter $ writeAll l+            in a+++-- | Get the last element and sum of a list+lastAndSum :: (Num a) => [a] -> (Maybe a, a)+lastAndSum l = let (((), total), lst) =+                        run $ runLastWriter $ runState 0 (writeAndAdd l)+               in (lst, total)+++-- Example by Oscar Key+data Move x where+  Move :: Move ()++handUp :: Eff (Move ': r) a -> Eff r a+handUp (Val x) = return x+handUp (E q u) = case decomp u of+  Right Move -> handDown $ qApp q ()+  -- Relay other requests+  Left u0     -> E ident u0 >>= handUp . qApp q++handDown :: Eff (Move ': r) a -> Eff r a+handDown (Val x) = return x+handDown (E q u) = case decomp u of+  Right Move -> handUp $ qApp q ()+  -- Relay other requests+  Left u0     -> E ident u0 >>= handDown . qApp q
src/Control/Eff/Exception.hs view
@@ -1,40 +1,144 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Safe #-} -- | Exception-producing and exception-handling effects-module Control.Eff.Exception( Exc(..)-                            , throwExc-                            , runExc-                            , catchExc+module Control.Eff.Exception ( Exc (..)+                            , exc+                            , withException+                            , Fail+                            , throwError+                            , throwError_+                            , die+                            , runError+                            , runFail+                            , catchError+                            , onFail+                            , rethrowError+                            , liftEither+                            , liftEitherM+                            , liftMaybe+                            , liftMaybeM+                            , ignoreFail                             ) where -import Data.Typeable- import Control.Eff+import Control.Eff.Extend --- | These are exceptions of the type e. This is akin to the error monad.+import Control.Monad (void)+import Control.Monad.Base+import Control.Monad.Trans.Control++import Data.Function (fix)++-- ------------------------------------------------------------------------+-- | Exceptions+--+-- exceptions of the type e; no resumption newtype Exc e v = Exc e-    deriving (Functor, Typeable) --- | Throw an exception in an effectful computation.-throwExc :: (Typeable e, Member (Exc e) r) => e -> Eff r a-throwExc e = send (\_ -> inj $ Exc e)+-- | Embed a pure value+withException :: Monad m => a -> m (Either e a)+withException = return . Right+-- | Throw an error+exc :: Monad m => e -> m (Either e a)+exc = return . Left+-- | Given a callback, and an 'Exc' request, respond to it.+instance Monad m => Handle (Exc e) r a (m (Either e a)) where+  handle _ _ (Exc e) = exc e +instance ( MonadBase m m+         , LiftedBase m r+         ) => MonadBaseControl m (Eff (Exc e ': r)) where+    type StM (Eff (Exc e ': r)) a = StM (Eff r) (Either e a)+    liftBaseWith f = raise $ liftBaseWith $ \runInBase ->+                       f (runInBase . runError)+    restoreM x = do r :: Either e a <- raise (restoreM x)+                    liftEither r++type Fail = Exc ()++-- | Throw an exception in an effectful computation. The type is inferred.+throwError :: (Member (Exc e) r) => e -> Eff r a+throwError e = send (Exc e)+{-# INLINE throwError #-}++-- | Throw an exception in an effectful computation. The type is unit,+--   which suppresses the ghc-mod warning "A do-notation statement+--   discarded a result of type"+throwError_ :: (Member (Exc e) r) => e -> Eff r ()+throwError_ = throwError+{-# INLINE throwError_ #-}++-- | Makes an effect fail, preventing future effects from happening.+die :: Member Fail r => Eff r a+die = throwError ()+{-# INLINE die #-}+ -- | Run a computation that might produce an exception.-runExc :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a)-runExc m = loop (admin m)- where-  loop (Val x)  = return (Right x)-  loop (E u)    = handleRelay u loop (\(Exc e) -> return (Left e))+runError :: Eff (Exc e ': r) a -> Eff r (Either e a)+runError = fix (handle_relay withException) --- | Run a computation that might produce exceptions,--- and give it a way to deal with the exceptions that come up.-catchExc :: (Typeable e, Member (Exc e) r)-         => Eff r a-         -> (e -> Eff r a)-         -> Eff r a-catchExc m handle = loop (admin m)- where-  loop (Val x)  = return x-  loop (E u)    = interpose u loop (\(Exc e) -> handle e)+-- | Runs a failable effect, such that failed computation return 'Nothing', and+--   'Just' the return value on success.+runFail :: Eff (Fail ': r) a -> Eff r (Maybe a)+runFail = fmap (either (const Nothing) Just) . runError+{-# INLINE runFail #-}++-- | Run a computation that might produce exceptions, and give it a way to deal+-- with the exceptions that come up. The handler is allowed to rethrow the+-- exception+catchError :: Member (Exc e) r =>+        Eff r a -> (e -> Eff r a) -> Eff r a+catchError m h = fix (respond_relay' (\_ _ (Exc e) -> h e) return) m++-- | Add a default value (i.e. failure handler) to a fallible computation.+-- This hides the fact that a failure happened.+onFail :: Eff (Fail ': r) a -- ^ The fallible computation.+       -> Eff r a           -- ^ The computation to run on failure.+       -> Eff r a+onFail e handle_ = runFail e >>= maybe handle_ return+{-# INLINE onFail #-}++-- | Run a computation until it produces an exception,+-- and convert and throw that exception in a new context.+rethrowError :: (Member (Exc e') r)+           => (e -> e')+           -> Eff (Exc e ': r) a+           -> Eff r a+rethrowError t e = runError e >>= either (throwError . t) return++-- | Treat Lefts as exceptions and Rights as return values.+liftEither :: (Member (Exc e) r) => Either e a -> Eff r a+liftEither = either throwError return+{-# INLINE liftEither #-}++-- | `liftEither` in a lifted Monad+liftEitherM :: (Member (Exc e) r, Lifted m r)+            => m (Either e a)+            -> Eff r a+liftEitherM m = lift m >>= liftEither+{-# INLINE liftEitherM #-}++-- | Lift a maybe into the 'Fail' effect, causing failure if it's 'Nothing'.+liftMaybe :: Member Fail r => Maybe a -> Eff r a+liftMaybe = maybe die return+{-# INLINE liftMaybe #-}++-- | `liftMaybe` in a lifted Monad+liftMaybeM :: (Member Fail r, Lifted m r)+           => m (Maybe a)+           -> Eff r a+liftMaybeM m = lift m >>= liftMaybe+{-# INLINE liftMaybeM #-}++-- | Ignores a failure event. Since the event can fail, you cannot inspect its+--   return type, because it has none on failure. To inspect it, use 'runFail'.+ignoreFail :: Eff (Fail ': r) a+           -> Eff r ()+ignoreFail e = void e `onFail` return ()+{-# INLINE ignoreFail #-}
+ src/Control/Eff/Extend.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE PatternSynonyms #-}++-- | This module exports functions, types, and typeclasses necessary for+-- implementing a custom effect and/or effect handler.+--++module Control.Eff.Extend+  ( -- * The effect monad+    Eff(..)+  , run+  , eff+    -- * Lifting operations+  , Lift(..), Lifted, LiftedBase+  , lift, runLift+  , catchDynE+  , HandlerDynE(..), catchesDynE+    -- * Open Unions+  , OpenUnion.Union+  , OpenUnion.Member+  , inj+  , prj, pattern OpenUnion.U0'+  , decomp, pattern OpenUnion.U0, pattern OpenUnion.U1+  , SetMember+  , weaken+  -- * Helper functions that are used for implementing effect-handlers+  , Handle(..)+  , Relay(..)+  , handle_relay', respond_relay'+  , raise+  , send+  -- * Arrow types and compositions+  , Arr+  , Arrs+  , first+  , singleK+  , qApp+  , (^$)+  , arr+  , ident+  , comp+  , (^|>)+  , qComp+  , qComps+  )+where++import           Data.OpenUnion                as OpenUnion+import           Control.Eff.Internal
− src/Control/Eff/Fail.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}--- | Effects which fail.-module Control.Eff.Fail( Fail-                       , die-                       , runFail-                       , ignoreFail-                       , onFail-                       ) where--import Data.Typeable-import Control.Eff-import Control.Monad---- | 'Fail' represents effects which can fail. This is akin to the Maybe monad.-data Fail v = Fail-  deriving (Functor, Typeable)---- | Makes an effect fail, preventing future effects from happening.-die :: Member Fail r-    => Eff r ()-die = send (const (inj Fail))-{-# INLINE die #-}---- | Runs a failable effect, such that failed computation return 'Nothing', and---   'Just' the return value on success.-runFail :: Eff (Fail :> r) a-        -> Eff r (Maybe a)-runFail m = loop (admin m)- where-  loop (Val x) = return (Just x)-  loop (E u)   = handleRelay u loop (const (return Nothing))-{-# INLINE runFail #-}---- | Given a computation to run on failure, and a computation that can fail,---   this function runs the computation that can fail, and if it fails, gets---   the return value from the other computation. This hides the fact that a---   failure even happened, and returns a default value for when it does.-onFail :: Eff r a           -- ^ The computation to run on failure.-       -> Eff (Fail :> r) a -- ^ The computation which can fail.-       -> Eff r a-onFail sideshow mainEvent = do-  r <- runFail mainEvent-  case r of-    Nothing -> sideshow-    Just y  -> return y-{-# INLINE onFail #-}---- | Ignores a failure event. Since the event can fail, you cannot inspect its---   return type, because it has none on failure. To inspect it, use 'runFail'.-ignoreFail :: Eff (Fail :> r) a-           -> Eff r ()-ignoreFail = onFail (return ()) . void-{-# INLINE ignoreFail #-}
src/Control/Eff/Fresh.hs view
@@ -1,30 +1,126 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE Safe #-} -- | Create unique Enumerable values.-module Control.Eff.Fresh( Fresh+module Control.Eff.Fresh( Fresh (Fresh)+                        , withFresh                         , fresh-                        , runFresh+                        , runFresh'                         ) where -import Data.Typeable- import Control.Eff+import Control.Eff.Extend +import Control.Monad.Base+import Control.Monad.Trans.Control++import Data.Function (fix)++-- There are three possible implementations+-- The first one uses State Fresh where+--    newtype Fresh = Fresh Int+-- We get the `private' effect layer (State Fresh) that does not interfere+-- with with other layers.+-- This is the easiest implementation.++-- The second implementation defines a new effect Fresh+ -- | Create unique Enumerable values.-newtype Fresh i v = Fresh (i -> v)-    deriving (Functor, Typeable)+data Fresh v where+  Fresh :: Fresh Int+  Replace :: !Int -> Fresh () +-- | Embed a pure value. Note that this is a specialized form of+-- State's and we could have reused it.+withFresh :: Monad m => a -> Int -> m (a, Int)+withFresh x s = return (x, s)++-- | Given a continuation and requests, respond to them+instance Handle Fresh r a (Int -> k) where+  handle step q req s = case req of+    Fresh     -> step (q ^$ s) (s+1)+    Replace i -> step (q ^$ ()) i++instance ( MonadBase m m+         , LiftedBase m r+         ) => MonadBaseControl m (Eff (Fresh ': r)) where+    type StM (Eff (Fresh ': r)) a = StM (Eff r) (a, Int)+    liftBaseWith f = do i <- fresh+                        raise $ liftBaseWith $ \runInBase ->+                          f (\k -> runInBase $ runFreshReturn i k)+    restoreM x = do (r,i) <- raise (restoreM x)+                    replace i+                    return r++ -- | Produce a value that has not been previously produced.-fresh :: (Typeable i, Enum i, Member (Fresh i) r) => Eff r i-fresh = send (inj . Fresh)+fresh :: Member Fresh r => Eff r Int+fresh = send Fresh +replace :: Member Fresh r => Int -> Eff r ()+replace = send . Replace+ -- | Run an effect requiring unique values.-runFresh :: (Typeable i, Enum i) => Eff (Fresh i :> r) w -> i -> Eff r w-runFresh m s0 = loop s0 (admin m)-  where-    loop _ (Val x) = return x-    loop s (E u)   = handleRelay u (loop s) $-                          \(Fresh k) -> (loop $! succ s) (k s)+runFresh' :: Int -> Eff (Fresh ': r) w -> Eff r w+runFresh' s m = fst `fmap` runFreshReturn s m++runFreshReturn :: Int -> Eff (Fresh ': r) w -> Eff r (w,Int)+runFreshReturn s m = fix (handle_relay withFresh) m s++{-+-- Finally, the worst implementation but the one that answers+-- reviewer's question: implementing Fresh in terms of State+-- but not revealing that fact.++runFresh :: Eff (Fresh :> r) w -> Int -> Eff r w+runFresh m s = runState m' s >>= return . fst+ where+ m' = loop m+ loop (Val x) = return x+ loop (E u q)   = case decomp u of+  Right Fresh -> do+                 n <- get+                 put (n+1::Int)+                 k n+  Left u  -> send (\k -> weaken $ fmap k u) >>= loop++tfresh = runTrace $ flip runFresh 0 $ do+  n <- fresh+  -- (x::Int) <- get+  trace $ "Fresh " ++ show n+  n <- fresh+  trace $ "Fresh " ++ show n++{-+If we try to meddle with the encapsulated state, by uncommenting the+get statement above, we get:+    No instance for (Member (State Int) Void)+      arising from a use of `get'+-}++-}++-- Encapsulation of effects+-- The example suggested by a reviewer++{- The reviewer outlined an MTL implementation below, writing+  ``This hides the state effect and I can layer another state effect on+  top without getting into conflict with the class system.''++class Monad m => MonadFresh m where+    fresh :: m Int++newtype FreshT m a = FreshT { unFreshT :: State Int m a }+      deriving (Functor, Monad, MonadTrans)++    instance Monad m => MonadFresh (FreshT m) where+      fresh = FreshT $ do n <- get; put (n+1); return n++See EncapsMTL.hs for the complete code.+-}
+ src/Control/Eff/Internal.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}++-- ------------------------------------------------------------------------+-- | A monadic library for communication between a handler and+-- its client, the administered computation+--+-- Original work available at <http://okmij.org/ftp/Haskell/extensible/tutorial.html>.+-- This module implements extensible effects as an alternative to monad transformers,+-- as described in <http://okmij.org/ftp/Haskell/extensible/exteff.pdf> and+-- <http://okmij.org/ftp/Haskell/extensible/more.pdf>.+--+-- 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.Internal where++import qualified Control.Arrow as A+import qualified Control.Category as C+import Control.Monad.Base (MonadBase(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (MonadBaseControl(..))+import qualified Control.Exception as Exc+import safe Data.OpenUnion+import safe Data.FTCQueue+import GHC.Exts (inline)+import Data.Function (fix)++-- | Effectful arrow type: a function from a to b that also does effects+-- denoted by r+type Arr r a b = a -> Eff r b++-- | An effectful function from @a@ to @b@ that is a composition of one or more+-- effectful functions. The paremeter r describes the overall effect.+--+-- The composition members are accumulated in a type-aligned queue. Using a+-- newtype here enables us to define `C.Category' and `A.Arrow' instances.+newtype Arrs r a b = Arrs (FTCQueue (Eff r) a b)++-- | 'Arrs' can be composed and have a natural identity.+instance C.Category (Arrs r) where+  id = ident+  f . g = comp g f++-- | As the name suggests, 'Arrs' also has an 'A.Arrow' instance.+instance A.Arrow (Arrs r) where+  arr = arr+  first = singleK . first . (^$)++first :: Arr r a b -> Arr r (a, c) (b, c)+first x = \(a,c) -> (, c) `fmap` x a++-- | convert single effectful arrow into composable type. i.e., convert 'Arr' to+-- 'Arrs'+{-# INLINE [2] singleK #-}+singleK :: Arr r a b -> Arrs r a b+singleK k = Arrs (tsingleton k)+{-# RULES+"singleK/qApp" [~2] forall q. singleK (qApp q) = q+ #-}++-- | Application to the `generalized effectful function' @Arrs r b w@, i.e.,+-- convert 'Arrs' to 'Arr'+{-# INLINABLE [2] qApp #-}+qApp :: forall r b w. Arrs r b w -> Arr r b w+qApp (Arrs q) x = viewlMap (inline tviewl q) ($ x) cons+  where+    cons :: forall x. Arr r b x -> FTCQueue (Eff r) x w -> Eff r w+    cons = \k t -> case k x of+      Val y -> qApp (Arrs t) y+      E (Arrs q0) u -> E (Arrs (q0 >< t)) u+{-+-- A bit more understandable version+qApp :: Arrs r b w -> b -> Eff r w+qApp q x = case tviewl q of+   TOne k  -> k x+   k :| t -> bind' (k x) t+ where+   bind' :: Eff r a -> Arrs r a b -> Eff r b+   bind' (Pure y) k     = qApp k y+   bind' (Impure u q) k = Impure u (q >< k)+-}++-- | Syntactic sugar for 'qApp'+{-# INLINE [2] (^$) #-}+(^$) :: forall r b w. Arrs r b w -> b -> Eff r w+q ^$ x = q `qApp` x++-- | Lift a function to an arrow+arr :: (a -> b) -> Arrs r a b+arr f = singleK (Val . f)++-- | The identity arrow+ident :: Arrs r a a+ident = arr id++-- | Arrow composition+{-# INLINE comp #-}+comp :: Arrs r a b -> Arrs r b c -> Arrs r a c+comp (Arrs f) (Arrs g) = Arrs (f >< g)++-- | Common pattern: append 'Arr' to 'Arrs'+(^|>) :: Arrs r a b -> Arr r b c -> Arrs r a c+(Arrs f) ^|> g = Arrs (f |> g)++-- | The monad that all effects in this library are based on.+--+-- An effectful computation is a value of type `Eff r a`.+-- In this signature, @r@ is a type-level list of effects that are being+-- requested and need to be handled inside an effectful computation.+-- @a@ is the computation's result similar to other monads.+--+-- A computation's result can be retrieved via the 'run' function.+-- However, all effects used in the computation need to be handled by the use+-- of the effects' @run*@ functions before unwrapping the final result.+-- For additional details, see the documentation of the effects you are using.+data Eff r a = Val a+             | forall b. E (Arrs r b a) (Union r b)+-- | Case analysis for 'Eff' datatype. If the value is @'Val' a@ apply+-- the first function to @a@; if it is @'E' u q@, apply the second+-- function.+{-# INLINE eff #-}+eff :: (a -> b)+    -> (forall v. Arrs r v a -> Union r v -> b)+    -> Eff r a -> b+eff f _ (Val a) = f a+eff _ g (E q u) = g q u++-- | The usual 'bind' fnuction with arguments flipped. This is a+-- common pattern for Eff.+{-# INLINE bind #-}+bind :: Arr r a b -> Eff r a -> Eff r b+bind k e = eff k (E . (^|> k)) e       -- just accumulates continuations++-- | Compose effectful arrows (and possibly change the effect!)+{-# INLINE qComp #-}+qComp :: Arrs r a b -> (Eff r b -> k) -> (a -> k)+-- qComp g h = (h . (g `qApp`))+qComp g h = \a -> h (g ^$ a)++-- | Compose effectful arrows (and possibly change the effect!)+{-# INLINE qComps #-}+qComps :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c+qComps g h = singleK $ qComp g h++instance Functor (Eff r) where+  {-# INLINE fmap #-}+  fmap f x = bind (Val . f) x++instance Applicative (Eff r) where+  {-# INLINE pure #-}+  pure = Val+  mf <*> e = bind (`fmap` e) mf++instance Monad (Eff r) where+  {-# INLINE return #-}+  {-# INLINE [2] (>>=) #-}+  return = pure+  m >>= f = bind f m+{-+  Val _ >> m = m+  E q u >> m = E (q ^|> const m) u+-}++-- | Send a request and wait for a reply (resulting in an effectful+-- computation).+{-# INLINE [2] send #-}+send :: Member t r => t v -> Eff r v+send t = E (singleK Val) (inj t)+-- This seems to be a very beneficial rule! On micro-benchmarks, cuts+-- the needed memory in half and speeds up almost twice.+{-# RULES+  "send/bind" [~3] forall t k. send t >>= k = E (singleK k) (inj t)+ #-}+++-- ------------------------------------------------------------------------+-- | Get the result from a pure computation+--+-- A pure computation has type @Eff '[] a@. The empty effect-list indicates that+-- no further effects need to be handled.+run :: Eff '[] w -> w+run (Val x) = x+-- | @Union []@ has no nonbottom values.+-- Due to laziness it is possible to get into this branch but its union argument+-- cannot terminate.+-- To extract the true error, the evaluation of union is forced.+-- 'run' is a total function if its argument is different from bottom.+run (E _ union) =+  union `seq` error "extensible-effects: the impossible happened!"++-- | Abstract the recursive 'relay' pattern, i.e., "somebody else's problem".+class Relay k r where+  relay :: (v -> k) -> Union r v -> k+instance Relay (Eff r w) r where+  {-# INLINABLE relay #-}+  relay q u = E (singleK q) u+instance Relay k r => Relay (s -> k) r where+  {-# INLINABLE relay #-}+  relay q u s = relay (\x -> q x s) u++-- | Respond to requests of type @t@. The handlers themselves are expressed in+-- open-recursion style.+class Handle t r a k where+  handle :: (Eff r a -> k) -- ^ untied recursive knot+         -> Arrs r v a -- ^ coroutine awaiting response+         -> t v -- ^ request+         -> k++  -- | A convenient pattern: given a request (in an open union), either handle+  -- it (using default Handler) or relay it.+  --+  -- "Handle" implies that all requests of type @t@ are dealt with, i.e., @k@+  -- (the response type) doesn't have @t@ as part of its effect list. The @Relay+  -- k r@ constraint ensures that @k@ is an effectful computation (with+  -- effectlist @r@).+  --+  -- Note that we can only handle the leftmost effect type (a consequence of the+  -- 'Data.OpenUnion' implementation.+  handle_relay :: r ~ (t ': r') => Relay k r'+               => (a -> k) -- ^ return+               -> (Eff r a -> k) -- ^ untied recursive knot+               -> Eff r a -> k+  handle_relay ret step m = eff ret+                            (\q u -> case u of+                                U0 x -> handle step q x+                                U1 u' -> relay (qComp q step) u')+                            m+  -- | Intercept the request and possibly respond to it, but leave it+  -- unhandled. The @Relay k r@ constraint ensures that @k@ is an effectful+  -- computation (with effectlist @r@). As such, the effect type @t@ will show+  -- up in the response type @k@. There are two natural / commmon options for+  -- @k@: the implicit effect domain (i.e., Eff r (f a)), or the explicit effect+  -- domain (i.e., s1 -> s2 -> ... -> sn -> Eff r (f a s1 s2 ... sn)).+  --+  -- There are three different ways in which we may want to alter behaviour:+  --+  -- 1. __Before__: This work should be done before 'respond_relay' is called.+  --+  -- 2. __During__: This work should be done by altering the handler being+  -- passed to 'respond_relay'. This allows us to modify the requests "in+  -- flight".+  --+  -- 3. __After__: This work should be done be altering the @ret@ being passed+  -- to 'respond_relay'. This allows us to overwrite changes or discard them+  -- altogether. If this seems magical, note that we have the flexibility of+  -- altering the target domain @k@. Specifically, the explicit domain+  -- representation gives us access to the "effect" realm allowing us to+  -- manipulate it directly.+  respond_relay :: Member t r => Relay k r+                => (a -> k) -- ^ return+                -> (Eff r a -> k) -- ^ untied recursive knot+                -> Eff r a -> k+  respond_relay ret step m = eff ret+                             (\q u -> case u of+                                 U0' x -> handle @t step q x+                                 _     -> relay (qComp q step) u)+                             m++-- | A less commonly needed variant with an explicit handler (instead+-- of @Handle t r a k@ constraint).+{-# INLINE handle_relay' #-}+handle_relay' :: r ~ (t ': r') => Relay k r'+              => (forall v. (Eff r a -> k) -> Arrs r v a -> t v -> k) -- ^ handler+              -> (a -> k) -- ^ return+              -> (Eff r a -> k) -- ^ untied recursive knot+              -> Eff r a -> k+handle_relay' hdl ret step m = eff ret+                                    (\q u -> case u of+                                        U0 x -> hdl step q x+                                        U1 u' -> relay (qComp q step) u')+                                    m++-- | Variant with an explicit handler (instead of @Handle t r a k@+-- constraint).+{-# INLINE respond_relay' #-}+respond_relay' :: Member t r => Relay k r+               => (forall v. (Eff r a -> k) -> Arrs r v a -> t v -> k) -- ^ handler+               -> (a -> k) -- ^ return+               -> (Eff r a -> k) -- ^ recursive knot+               -> Eff r a -> k+respond_relay' hdl ret step m = eff ret+                                (\q u -> case u of+                                    U0' x -> hdl step q x+                                    _     -> relay (qComp q step) u)+                                m++-- | Embeds a less-constrained 'Eff' into a more-constrained one. Analogous to+-- MTL's 'lift'.+raise :: Eff r a -> Eff (e ': r) a+raise (Val x) = pure x+raise (E q u) = E k (U1 u)+  where k = qComps q raise+{-# INLINE raise #-}++-- ------------------------------------------------------------------------+-- | Lifting: emulating monad transformers+newtype Lift m a = Lift { unLift :: m a }++-- |A convenient alias to @SetMember Lift (Lift m) r@, which allows us+-- to assert that the lifted type occurs ony once in the effect list.+type Lifted m r = SetMember Lift (Lift m) r++-- |Same as 'Lifted' but with additional 'MonadBaseControl' constraint+type LiftedBase m r = ( SetMember Lift (Lift m) r+                      , MonadBaseControl m (Eff r)+                      )++-- | embed an operation of type `m a` into the `Eff` monad when @Lift m@ is in+-- a part of the effect-list.+lift :: Lifted m r => m a -> Eff r a+lift = send . Lift++-- | Handle lifted requests by running them sequentially+instance Monad m => Handle (Lift m) r a (m k) where+  handle step q (Lift x) = x >>= (step . (q ^$))++-- | The handler of Lift requests. It is meant to be terminal: we only+-- allow a single Lifted Monad. Note, too, how this is different from+-- other handlers.+runLift :: Monad m => Eff '[Lift m] w -> m w+runLift m = fix step m+  where+    step :: Monad m => (Eff '[Lift m] w -> m w) -> Eff '[Lift m] w -> m w+    step next m' = eff return+                   (\q u -> case u of+                       U0' x -> handle next q x+                       _     -> error "Impossible: Nothing to relay!")+                   m'++-- | Catching of dynamic exceptions+-- See the problem in+-- http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO+catchDynE :: forall e a r.+             (Lifted IO r, Exc.Exception e) =>+             Eff r a -> (e -> Eff r a) -> Eff r a+catchDynE m eh = fix (respond_relay' h return) m+ where+   -- Polymorphic local binding: signature is needed+   h :: (Eff r a -> Eff r a) -> Arrs r v a -> Lift IO v -> Eff r a+   h step q (Lift em) = lift (Exc.try em) >>= either eh k+     where k = step . (q ^$)++-- | You need this when using 'catchesDynE'.+data HandlerDynE r a =+  forall e. (Exc.Exception e, Lifted IO r) => HandlerDynE (e -> Eff r a)++-- | Catch multiple dynamic exceptions. The implementation follows+-- that in Control.Exception almost exactly. Not yet tested.+-- Could this be useful for control with cut?+catchesDynE :: Lifted IO r => Eff r a -> [HandlerDynE r a] -> Eff r a+catchesDynE m hs = m `catchDynE` catchesHandler hs where+  catchesHandler :: Lifted IO r => [HandlerDynE r a] -> Exc.SomeException -> Eff r a+  catchesHandler handlers e = foldr tryHandler (lift . Exc.throw $ e) handlers+    where+      tryHandler (HandlerDynE h) res = maybe res h (Exc.fromException e)++instance (MonadBase b m, Lifted m r) => MonadBase b (Eff r) where+    liftBase = lift . liftBase+    {-# INLINE liftBase #-}++instance (MonadBase m m)  => MonadBaseControl m (Eff '[Lift m]) where+    type StM (Eff '[Lift m]) a = a+    liftBaseWith f = lift (f runLift)+    {-# INLINE liftBaseWith #-}+    restoreM = return+    {-# INLINE restoreM #-}++instance (MonadIO m, Lifted m r) => MonadIO (Eff r) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}
− src/Control/Eff/Lift.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ExistentialQuantification #-}--- | Lifting primitive Monad types to effectful computations.--- We only allow a single Lifted Monad because Monads aren't commutative--- (e.g. Maybe (IO a) is functionally distinct from IO (Maybe a)).-module Control.Eff.Lift( Lift-                       , lift-                       , runLift-                       ) where--import Control.Eff-import Data.Typeable---- | Lift a Monad m to an effect.-data Lift m v = forall a. Lift (m a) (a -> v)--instance Typeable1 m => Typeable1 (Lift m) where-    typeOf1 _ = mkTyConApp (mkTyCon3 "" "Eff" "Lift")-                           [typeOf1 (undefined :: m ())]--instance Functor (Lift m) where-    fmap f (Lift m k) = Lift m (f . k)--instance SetMember Lift (Lift m) (Lift m :> ())---- | Lift a Monad to an Effect.-lift :: (Typeable1 m, Member (Lift m) r, SetMember Lift (Lift m) r) => m a -> Eff r a-lift m = send (inj . Lift m)---- | The handler of Lift requests. It is meant to be terminal:--- we only allow a single Lifted Monad.-runLift :: (Monad m, Typeable1 m) => Eff (Lift m :> ()) w -> m w-runLift m = loop (admin m) where- loop (Val x) = return x- loop (E u) = prjForce u $ \(Lift m' k) -> m' >>= loop . k
+ src/Control/Eff/Logic/Core.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}++-- | Logic primitives. See @LogicT@ paper for details.+--+-- * [@LogicT@] [LogicT - backtracking monad transformer with fair operations and pruning](http://okmij.org/ftp/Computation/monads.html#LogicT)+module Control.Eff.Logic.Core where++import Control.Monad++import Control.Eff+import Control.Eff.Exception++import Data.Function (fix)++-- | The MSplit primitive from LogicT paper.+class MSplit m where+  -- | The laws for 'msplit' are:+  --+  -- > msplit mzero                = return Nothing+  -- > msplit (return a `mplus` m) = return (Just(a, m))+  msplit :: m a -> m (Maybe (a, m a))++-- | Embed a pure value into MSplit+{-# INLINE withMSplit #-}+withMSplit :: MonadPlus m => a -> m a -> m (Maybe (a, m a))+withMSplit a rest = return (Just (a, rest))+-- The handlers are defined in terms of the specific non-determinism+-- effects (instead of by way of a distinct MSplit handler++-- | Laws for 'reflect':+--+-- > msplit (lift m >> mzero)   >>= reflect = lift m >> mzero+-- > msplit (lift m `mplus` ma) >>= reflect = lift m `mplus` (msplit ma >>= reflect)+{-# INLINE reflect #-}+reflect :: MonadPlus m => Maybe (a, m a) -> m a+reflect Nothing      = mzero+reflect (Just (a,m)) = return a `mplus` m++-- Other committed choice primitives can be implemented in terms of msplit+-- The following implementations are directly from the LogicT paper++-- | Soft-cut: non-deterministic if-then-else, aka Prolog's @*->@+-- Declaratively,+--+-- >  ifte t th el = (t >>= th) `mplus` ((not t) >> el)+--+-- However, @t@ is evaluated only once. In other words, @ifte t th el@+-- is equivalent to @t >>= th@ if @t@ has at least one solution.+-- If @t@ fails, @ifte t th el@ is the same as @el@. Laws:+--+-- > ifte (return a) th el           = th a+-- > ifte mzero th el                = el+-- > ifte (return a `mplus` m) th el = th a `mplus` (m >>= th)+ifte :: (MonadPlus m, MSplit m)+     => m t -> (t -> m b) -> m b -> m b+ifte t th el = msplit t >>= check+ where check Nothing          = el+       check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th)++-- | Another pruning operation (ifte is the other). This selects one+-- solution out of possibly many.+once :: (MSplit m, MonadPlus m) => m b -> m b+once m = msplit m >>= check+ where check Nothing        = mzero+       check (Just (sg1,_)) = return sg1++-- | Negation as failure+gnot :: (MonadPlus m, MSplit m) => m b -> m ()+gnot m = ifte (once m) (const mzero) (return ())++-- | Fair (i.e., avoids starvation) disjunction. It obeys the+-- following laws:+--+-- > interleave mzero m                  = m+-- > interleave (return a `mplus` m1) m2 = return a `mplus` (interleave m2 m1)+--+-- corollary:+--+-- > interleave m mzero = m+interleave :: (MSplit m, MonadPlus m) => m b -> m b -> m b+interleave sg1 sg2 =+  do r <- msplit sg1+     case r of+       Nothing -> sg2+       Just (sg11,sg12) ->+         (return sg11) `mplus` (interleave sg2 sg12)++-- | Fair (i.e., avoids starvation) conjunction. It obeys the+-- following laws:+--+-- > mzero                >>- k = mzero+-- > (return a `mplus` m) >>- k = interleave (k a) (m >>- k)+(>>-) :: (MonadPlus m, MSplit m) => m a -> (a -> m b) -> m b+sg >>- g =+  do r <- msplit sg+     case r of+       Nothing -> mzero+       Just (sg1 ,sg2) -> interleave (g sg1) (sg2 >>- g)++-- | Collect all solutions. This is from Hinze's @Backtr@ monad+-- class. Unsurprisingly, this can be implemented in terms of msplit.+sols :: (Monad m, MSplit m) => m a -> m [a]+sols m = (msplit m) >>= (fix step) [] where+  step _ jq Nothing          = return jq+  step next jq (Just(a, ma)) = (msplit ma) >>= next (a:jq)++-- | Non-determinism with control (@cut@).+--+-- For the explanation of cut, see Section 5 of Hinze ICFP 2000 paper:+--+-- * [@Backtr@] [Deriving Backtracking Monad Transformers](https://dl.acm.org/citation.cfm?id=351240.351258)+--+-- Hinze suggests expressing @cut@ in terms of @cutfalse@:+--+-- > = return () `mplus` cutfalse+-- > where+-- >  cutfalse :: m a+--+-- satisfies the following laws:+--+-- >  cutfalse >>= k  = cutfalse              (F1)+-- >  cutfalse | m    = cutfalse              (F2)+--+-- (note: @m \``mplus`\` cutfalse@ is different from @cutfalse \``mplus`\` m@).+-- In other words, cutfalse is the left zero of both bind and mplus.+--+-- Hinze also introduces the operation @`call` :: m a -> m a@ that+-- delimits the effect of cut: @`call` m@ executes m. If the cut is+-- invoked in m, it discards only the choices made since m was called.+-- Hinze postulates the axioms of `call`:+--+-- >  call false = false                          (C1)+-- >  call (return a | m) = return a | call m     (C2)+-- >  call (m | cutfalse) = call m                (C3)+-- >  call (lift m >>= k) = lift m >>= (call . k) (C4)+--+-- @`call` m@ behaves like @m@ except any cut inside @m@ has only a local effect,+-- he says.+--+-- Hinze noted a problem with the \"mechanical\" derivation of backtracing+-- monad transformer with cut: no axiom specifying the interaction of+-- call with bind; no way to simplify nested invocations of call.+class Call r where+  -- | Mapping @Backtr@ interface to 'MonadPlus' and using exceptions for+  -- @cutfalse@, every instance should ensure that the following laws hold:+  --+  -- >  cutfalse `mplus` m        = cutfalse                --(F2)+  -- >  call mzero                = mzero                   --(C1)+  -- >  call (return a `mplus` m) = return a `mplus` call m --(C2)+  -- >  call (m `mplus` cutfalse) = call m                  --(C3)+  -- >  call (lift m >>= k)       = lift m >>= (call . k)   --(C4)+  call :: MonadPlus (Eff r) => Eff (Exc CutFalse : r) a -> Eff r a++data CutFalse = CutFalse++-- | We use exceptions for cutfalse+-- Therefore, the law @cutfalse >>= k = cutfalse@+-- is satisfied automatically since all exceptions have the above property.+cutfalse :: Member (Exc CutFalse) r => Eff r a+cutfalse = throwError CutFalse++-- | Prolog @cut@, taken from Hinze 2000 (Deriving backtracking monad+-- transformers).+(!) :: (Member (Exc CutFalse) r, MonadPlus (Eff r)) => Eff r ()+(!) = return () `mplus` cutfalse++-- | Case analysis for lists+{-# INLINE list #-}+list :: b -> (a -> [a] -> b)+     -> [a] -> b+list z _ [] = z+list _ k (h:t) = k h t
+ src/Control/Eff/Logic/Experimental.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module is for some experimental implementations and tinkering. Not+-- intended to be exposed or depended on.+module Control.Eff.Logic.Experimental where++import Control.Eff+import Control.Eff.Extend+import Control.Eff.Exception+import Control.Eff.Logic.Core+import Control.Monad++instance (MonadPlus (Eff (Exc CutFalse : r)), MSplit (Eff (Exc CutFalse : r)))+  => Call r where+  call m = loop m [] where+    loop m' jq = case msplit m' of+      Val Nothing       -> next jq                        -- (C1)+      Val (Just (x, q)) -> return x `mplus` next (q : jq) -- (C2)+      E q u -> case u of+        U0 (Exc CutFalse) -> next []                      -- drop jq (F2)+        U1 _              -> loop (E q u >>= reflect) jq  -- (C4?)+        --_                 -> loop m' jq+    next jq = list mzero loop jq                          -- (C3?)+  {-+  call m = loop (msplit m) [] where+    loop (Val Nothing) jq       = next jq                        -- (C1)+    loop (Val (Just (x, q))) jq = return x `mplus` next (q : jq) -- (C2)+    loop (E q u) jq             = case u of+      U0 (Exc CutFalse)        -> next []                        -- drop jq (F2)+      _                        -> loop (E q u) jq          -- (C4?)++    next []    = mzero+    next (h:t) = loop (msplit h) t                               -- (C3?)+  -}
+ src/Control/Eff/Logic/NDet.hs view
@@ -0,0 +1,229 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE Safe #-}+-- The following is needed to define MonadPlus instance. It is decidable+-- (there is no recursion!), but GHC cannot see that.+{-# LANGUAGE UndecidableInstances #-}+-- The following is needed for pattern-synonym bug in ghc 8.2+{-# LANGUAGE CPP #-}++-- | Nondeterministic choice effect via MPlus interface directly. In order to+-- get an understanding of what nondeterministic choice entails the following+-- papers are recommended:+--+-- * [@LogicT@] [LogicT - backtracking monad transformer with fair operations and pruning](http://okmij.org/ftp/Computation/monads.html#LogicT)+-- * [@Backtr@] [Deriving Backtracking Monad Transformers](https://dl.acm.org/citation.cfm?id=351240.351258)+--+-- __TODO__: investigate Fusion regd msplit and associated functions.+module Control.Eff.Logic.NDet (+  -- * Main interface+  NDet+  , withNDet+  , left, right+  , choose+  , makeChoice+  , makeChoiceA+  , module Control.Eff.Logic.Core+    -- * Additional functions for comparison+  , msplit'+  , msplit'_manual+  , makeChoiceA_manual+  , makeChoiceA0+  ) where++import Control.Eff+import Control.Eff.Extend+import Control.Eff.Logic.Core+import Control.Eff.Exception++import Control.Applicative+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control+import Data.Function (fix)++-- | An implementation of non-deterministic choice aka backtracking. The two+-- requests we need to support are: @false@, @(|)@. We map this to the+-- 'MonadPlus' (or 'Alternative') interface: @MZero@ stands for @false@, and+-- @MPlus@ stands for @(|)@.+--+-- This creates a branching structure with a fanout of @2@, resulting in @mplus@+-- node being visited approximately @2x@ (in general, for a fanout of @f@ we'll+-- have the type of internal node being invoked @f/(f-1)@ times).+data NDet a where+  MZero :: NDet a+  MPlus :: NDet Bool++-- | How to embed a pure value in non-deterministic context+{-# INLINE withNDet #-}+withNDet :: Alternative f => Monad m => a -> m (f a)+withNDet x = return (pure x)+-- | The left branch+{-# INLINE left #-}+left :: Arrs r Bool a -> Eff r a+left q = q ^$ True+-- | The right branch+{-# INLINE right #-}+right :: Arrs r Bool a -> Eff r a+right q = q ^$ False+-- | Given a callback and 'NDet' requests respond to them. Note that this makes+-- explicit that we rely on @f@ to have enough room to store all possibilities.+instance Alternative f => Handle NDet r a (Eff r' (f w)) where+  handle _ _ MZero = return empty+  handle step q MPlus = liftM2 (<|>) (step $ left q) (step $ right q)++instance Member NDet r => Alternative (Eff r) where+  empty = mzero+  (<|>) = mplus++-- | Mapping of 'NDet' requests to 'MonadPlus'. We obey the following laws+-- (taken from the @Backtr@ and @LogicT papers):+--+-- > mzero >>= f = mzero                               -- (L1)+-- > mzero `mplus` m = m                               -- (L2)+-- > m `mplus` mzero = m                               -- (L3)+-- > m `mplus` (n `mplus` o) = (m `mplus` n) `mplus` o -- (L4)+-- > (m `mplus` n) >>= k = (m >>= k) `mplus` (n >>= k) -- (L5)+--+-- - @L1@ is the left-zero law for 'mzero'+-- - @L2, L3, L4@ are the @Monoid@ laws+--+-- __NOTE__ that we do __not__ obey the right-zero law for+-- 'mzero'. Specifically, we do __not__ obey:+--+-- > m >> mzero  = mzero+instance Member NDet r => MonadPlus (Eff r) where+  mzero = send MZero+  -- | Applying L2 and L3+#if __GLASGOW_HASKELL__ < 804+  mplus (E _ u) m2 | Just MZero <- prj u = m2+  mplus m1 (E _ u) | Just MZero <- prj u = m1+#else+  mplus (E _ (U0' MZero)) m2 = m2+  mplus m1 (E _ (U0' MZero)) = m1+#endif+  mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2++instance ( MonadBase m m+         , LiftedBase m r+         ) => MonadBaseControl m (Eff (NDet ': r)) where+    type StM (Eff (NDet ': r)) a = StM (Eff r) [a]+    liftBaseWith f = raise $ liftBaseWith $ \runInBase ->+                       f (runInBase . makeChoice)+    restoreM x = do lst :: [a] <- raise (restoreM x)+                    choose lst++-- | @'choose' lst@ non-deterministically chooses one value from the+-- @lst@. @'choose' []@ thus corresponds to failure.+choose :: Member NDet r => [a] -> Eff r a+choose lst = msum $ map return lst++-- | An interpreter: The following is very simple, but leaks a lot of memory The+-- cause probably is mapping every failure to empty It takes then a lot of timne+-- and space to store those empty. When there aren't a lot of failures, this is+-- comparable to 'makeChoiceA'.+makeChoiceA0 :: Alternative f => Eff (NDet ': r) a -> Eff r (f a)+makeChoiceA0 = fix (handle_relay withNDet)++-- | More performant handler; uses reified job queue+instance Alternative f => Handle NDet r a ([Eff r a] -> Eff r' (f w)) where+  handle step _ MZero jq = next step jq+  handle step q MPlus jq = next step (left q : right q : jq)+-- instance Handle NDet r a (k -> [Eff r a] -> k) where+--   handle step _ MZero z jq = list z (flip step z) jq+--   handle step q MPlus z jq = list z (flip step z) (left q : right q : jq)++{-# INLINE next #-}+-- | Progressing the cursor in a reified job queue.+next :: Alternative f => Monad m+     => (t -> [t] -> m (f a))+     -> [t] -> m (f a)+next k jq = list (return empty) k jq++-- | Optimized implementation, faster and taking less memory. The benefit of the+-- effect framework is that we can have many interpreters.+makeChoiceA :: Alternative f => Eff (NDet ': r) a -> Eff r (f a)+makeChoiceA m' = loop m' [] where+  loop m = fix (handle_relay @NDet ret) m+  -- single result; optimization: drop spurious empty+  ret x [] = withNDet x+  -- definite result and perhaps some others+  ret x (h:t) = liftM2 (<|>) (withNDet x) (loop h t)++-- | A different implementation, more involved, but similar complexity to+-- 'makeChoiceA'.+makeChoiceA_manual :: Alternative f => Eff (NDet ': r) a -> Eff r (f a)+makeChoiceA_manual m = loop m [] where+  -- single result; optimization: drop spurious empty+  loop (Val x) []    = withNDet x+  -- definite result and perhaps some others+  loop (Val x) (h:t) = liftM2 (<|>) (withNDet x) (loop h t)+  loop (E q u) jq    = case decomp u of+    Right MZero -> next loop jq+    Right MPlus -> loop (k True) (k False : jq)+    Left  u0    -> relay (loop . k) u0 jq+    where+      k = (q ^$)++-- | Same as 'makeChoiceA', except it has the type hardcoded.+-- Required for 'MonadBaseControl' instance.+makeChoice :: Eff (NDet ': r) a -> Eff r [a]+makeChoice = makeChoiceA++-- | We implement LogicT, the non-determinism reflection, of which soft-cut is+-- one instance. See the LogicT paper for an explanation.+instance Member NDet r => MSplit (Eff r) where+  msplit = msplit'++-- | The implementation of 'MSplit'. Exported as a standalone to make+-- testing/comparison easier.+{-# INLINE msplit' #-}+msplit' :: Member NDet r => Eff r a -> Eff r (Maybe (a, Eff r a))+msplit' m = fix (respond_relay @NDet (\x jq -> withMSplit x (msum jq))) m []++-- | A different implementation, more involved, but similar complexity to+-- 'msplit''.+{-# INLINE msplit'_manual #-}+msplit'_manual :: Member NDet r => Eff r a -> Eff r (Maybe (a, Eff r a))+msplit'_manual m' = loop m' [] where+  -- definite result and perhaps some others+  loop (Val x) jq = withMSplit x (msum jq)+  -- not yet definite answer+  loop (E q u) jq = case u of+    -- try other choices, if any+    U0' MZero -> next loop jq+    -- try left options; add right to job queue+    U0' MPlus -> loop (k True) (k False : jq)+    _         -> relay (loop . k) u jq+    where+      k x = q ^$ x++-- | The call interpreter -- it is like reify . reflect with a twist. Compare+-- this implementation with the huge implementation of call in Hinze 2000+-- (Figure 9). Each clause corresponds to the axiom of call or cutfalse. All+-- axioms are covered.+--+-- The code clearly expresses the intuition that call watches the choice points+-- of its argument computation. When it encounteres a cutfalse request, it+-- discards the remaining choicepoints.  It completely handles CutFalse effects+-- but not non-determinism+instance Member NDet r => Call r where+  call m = loop m [] where+    loop (Val x) jq = return x `mplus` nxt jq          -- (C2)+    loop (E _ (U0 (Exc CutFalse))) _ = nxt []          -- drop jq (F2)+    loop (E q (U1 u)) jq = case u of+        U0' MZero -> nxt jq                            -- (C1)+        U0' MPlus -> nxt (left q : right q : jq)       -- (C3)+        _         -> relay (loop . (q ^$)) u jq        -- (C4)++    nxt jq = list mzero loop jq
+ src/Control/Eff/Operational.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Safe #-}++-- | Operational Monad (<https://wiki.haskell.org/Operational>) implemented with+-- extensible effects.++module Control.Eff.Operational ( Program (..)+                               , withOperational, Intrprtr (..)+                               , singleton+                               , runProgram+                               -- * Usage+                               -- $usage+                               ) where++import Control.Eff as E+import Control.Eff.Extend++import Data.Function (fix)++-- | Lift values to an effect.+-- You can think this is a generalization of @Lift@.+data Program instr v where+  Singleton :: instr a -> Program instr a++-- | General form of an interpreter+newtype Intrprtr f r = Intrprtr { runIntrprtr :: forall x. f x -> Eff r x }++-- | Embed a pure value+withOperational :: a -> Intrprtr f r -> Eff r a+withOperational x _ = return x+-- | Given a continuation and a program, interpret it+-- Usually, we have @r ~ [Program f : r']@+instance Handle (Program f) r a (Intrprtr f r' -> Eff r' a) where+  handle step q (Singleton instr) i = (runIntrprtr i) instr >>=+    \x -> step (q ^$ x) i++-- | Lift a value to a monad.+singleton :: (Member (Program instr) r) => instr a -> Eff r a+singleton = send . Singleton++-- | Convert values using given interpreter to effects.+runProgram :: forall f r a. (forall x. f x -> Eff r x) -> Eff (Program f ': r) a -> Eff r a+runProgram advent m = fix (handle_relay withOperational) m (Intrprtr advent)++-- $usage+--+-- See "Control.Eff.Operational.Example" for an example of defining data using+-- GADTs and implementing interpreters from the data to effects.+--+-- To use the interpreter, see below or consult the tests.+--+-- @+--main :: IO ()+--main = do+--    let comp = 'runProgram' adventPure prog+--    putStrLn . fst . 'run' . 'E.Writer.Strict.runMonoidWriter' $ 'E.State.Strict.evalState' comp [\"foo\",\"bar\"]+--    'runLift' $ 'runProgram' adventIO prog+-- @
+ src/Control/Eff/Operational/Example.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Safe #-}++-- | Example usage of "Control.Eff.Operational".+module Control.Eff.Operational.Example where++import Control.Eff.Operational+import Control.Eff+import Control.Eff.Writer.Lazy+import Control.Eff.State.Lazy++-- | Define data using GADTs.+data Jail a where+   Print :: String -> Jail ()+   Scan :: Jail String++prog :: Member (Program Jail) r => Eff r ()+prog = do+   singleton $ Print "getting input..."+   str <- singleton Scan+   singleton $ Print "ok"+   singleton $ Print ("the input is " ++ str)++-- | Then, implements interpreters from the data to effects.+adventIO :: Lifted IO r => Jail a -> Eff r a+adventIO (Print a) = lift $ putStrLn a+adventIO Scan = lift getLine++adventPure :: [ Writer String, State [String] ] <:: r => Jail a -> Eff r a+adventPure (Print a) = tell (a ++ "\n")+adventPure Scan = do+  x <- get+  case x of+    [] -> return []+    y:ys -> put ys >> return y
+ src/Control/Eff/QuickStart.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}++-- | This module contains several tiny examples of how to use effects.+-- For technical details, see the documentation in the effect-modules.+--+-- Note that most examples given here are very small. For them,+-- using `Eff` monad is more complicated compared to a standard functional+-- approach.+-- The power of extensible effects lie in the fact that these computations can+-- be used to construct much more complicated programs by composing the little+-- pieces shown here.+--+-- This module imports and reexports modules from this library and requires+-- some language extensions:+--+-- @+-- {-\# LANGUAGE ScopedTypeVariables \#-}+-- {-\# LANGUAGE FlexibleContexts \#-}+-- {-\# LANGUAGE MonoLocalBinds \#-}+--+-- import Control.Eff+-- import Control.Eff.Reader.Lazy+-- import Control.Eff.Writer.Lazy+-- import Control.Eff.State.Lazy+-- import Control.Eff.Exception+-- @+--+-- If you want to see what each extension is good for, you can disable it and+-- see what GHC will complain about.+--+module Control.Eff.QuickStart+  ( -- * Examples+    module Control.Eff.QuickStart+    -- * Imported effect modules+  , module Control.Eff.Reader.Lazy+  , module Control.Eff.State.Lazy+  , module Control.Eff.Exception+  ) where++import           Control.Eff+import           Control.Eff.Reader.Lazy+import           Control.Eff.State.Lazy+import           Control.Eff.Exception+import           Control.Monad                            ( when )++-- | an effectful function that can throw an error+--+-- @+-- tooBig i = do+--   when (i > 100) $ throwError $ show i+--   return i+-- @+tooBig :: Member (Exc String) r => Int -> Eff r Int+tooBig i = do+  when (i > 100) $ throwError $ show i+  return i++-- | run the @tooBig@ effect based on a provided Int.+--+-- @+-- runTooBig i = run . runError $ tooBig i+-- @+--+-- >>> runTooBig 1+-- Right 1+--+-- >>> runTooBig 200+-- Left "200"+runTooBig :: Int -> Either String Int+runTooBig i = run . runError $ tooBig i++-- | an effectul computation using state. The state is of type @[Int]@.+-- This function takes the head off the list, if it is there and return it.+-- If state is the empty list, then it stays the same and returns @Nothing@.+--+-- @+-- popState = do+--  stack <- get+--  case stack of+--    []       -> return Nothing+--    (x : xs) -> do+--      put xs+--      return $ Just x+-- @+popState :: Member (State [Int]) r => Eff r (Maybe Int)+popState = do+  stack <- get+  case stack of+    []       -> return Nothing+    (x : xs) -> do+      put xs+      return $ Just x++-- | run the popState effectful computation based on initial state. The+-- result-type is the result of the computation @Maybe Int@ together with the+-- state at the end of the computation @[Int]@+--+-- @+-- runPopState xs = run . runState xs $ popState+-- @+--+-- >>> runPopState  [1, 2, 3]+-- (Just 1,[2,3])+--+-- >>> runPopState []+-- (Nothing,[])+runPopState :: [Int] -> (Maybe Int, [Int])+runPopState xs = run . runState xs $ popState++-- | an effect that returns a number one more than the given+--+-- @+-- oneMore = do+--   x <- ask -- query the environment+--   return $ x + 1 -- add one to the asked value and return it+-- @+oneMore :: Member (Reader Int) r => Eff r Int+oneMore = do+  x <- ask+  return $ x + 1++-- | Run the @oneMore@ effectful function by giving it a value to read.+--+-- @+-- runOneMore i = run . runReader i $ oneMore+-- @+--+-- >>> runOneMore 1+-- 2+runOneMore :: Int -> Int+runOneMore i = run . runReader i $ oneMore++-- | An effectful computation with multiple effects:+--+-- * A value gets read+-- * an error can be thrown depending on the read value+-- * state gets read and transformed+--+-- All these effects are composed using the @Eff@ monad using the corresponding+-- Effect types.+--+-- @+-- something = do+--   readValue :: Float <- ask -- read a value from the environment+--   when (readValue < 0) $ throwError readValue  -- if the value is negative, throw an error+--   modify (\l -> (round readValue :: Integer) : l) -- add the rounded read element to the list+--   currentState :: [Integer] <- get -- get the state after the modification+--   return $ sum currentState -- sum the elements in the list and return that+-- @+something+  :: (Member (Reader Float) r, Member (State [Integer]) r, Member (Exc Float) r)+  => Eff r Integer+something = do+  readValue :: Float <- ask+  when (readValue < 0) $ throwError readValue+  modify (\l -> (round readValue :: Integer) : l)+  currentState :: [Integer] <- get+  return $ sum currentState++-- | Run the @someting@ effectful computation given in the previous function.+-- The handlers apply from bottom to top - so this is the reading direction.+--+-- @+-- runSomething1 initialState newValue =+--   run . -- run the Eff-monad with no effects left+--   runError . -- run the error part of the effect. This introduces the Either in the result.+--   runState initialState . -- handle the state-effect providing an initial state giving back a pair.+--   runReader newValue $ -- provide the computation with the dynamic value to read/ask for+--   something -- the computation - function+-- @+--+-- >>> runSomething1 [] (-0.5)+-- Left (-0.5)+--+-- >>> runSomething1 [2] 1.3+-- Right (3,[1,2])+runSomething1 :: [Integer] -> Float -> Either Float (Integer, [Integer])+runSomething1 initialState newValue =+  run . runError . runState initialState . runReader newValue $ something++-- | Run the @something@ effectful computation given above.+-- This has an alternative ordering of the effect-handlers.+--+-- The used effect-handlers are the same are used in slightly different order:+-- The @runState@ and @runError@ methods are swapped, which results in a+-- different output type and run-semantics.+--+-- @+-- runSomething1 initialState newValue =+--   run .+--   runState initialState .+--   runError .+--   runReader newValue $+--   something -- the computation - function+-- @+--+-- >>> runSomething2 [4] (-2.4)+-- (Left (-2.4),[4])+--+-- >>> runSomething2 [4] 5.9+-- (Right 10,[6,4])+runSomething2 :: [Integer] -> Float -> (Either Float Integer, [Integer])+runSomething2 initialState newValue =+  run . runState initialState . runError . runReader newValue $ something
src/Control/Eff/Reader/Lazy.hs view
@@ -1,50 +1,90 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeApplications #-} -- | Lazy read-only state-module Control.Eff.Reader.Lazy( Reader+module Control.Eff.Reader.Lazy ( Reader (..)+                              , withReader                               , ask                               , local                               , reader                               , runReader                               ) where -import Control.Applicative ((<$>))-import Data.Typeable- import Control.Eff+import Control.Eff.Extend --- | The request for a value of type e from the current environment.--- This environment is analogous to a parameter of type e.-newtype Reader e v = Reader (e -> v)-    deriving (Typeable, Functor)+import Control.Monad.Base+import Control.Monad.Trans.Control +import Data.Function (fix)++-- ------------------------------------------------------------------------+-- | The Reader monad+--+-- The request for a value of type e from the current environment+-- This can be expressed as a GADT because the type of values+-- returned in response to a (Reader e a) request is not any a;+-- 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+  Ask :: Reader e e+-- ^+-- One can also define this as+--+-- @+-- data Reader e v = (e ~ v) => Reader+-- @+-- ^ without GADTs, using explicit coercion as is done here.+--+-- @+-- newtype Reader e v = Reader (e->v)+-- @+-- ^ In the latter case, when we make the request, we make it as Reader id.+-- So, strictly speaking, GADTs are not really necessary.++-- | How to interpret a pure value in a reader context+withReader :: Monad m => a -> e -> m a+withReader x _ = return x+-- | Given a value to read, and a callback, how to respond to+-- requests.+instance Handle (Reader e) r a (e -> k) where+  handle step q Ask e = step (q ^$ e) e+ -- | Get the current value from a Reader.-ask :: (Typeable e, Member (Reader e) r) => Eff r e-ask = send (inj . Reader)+-- The signature is inferred (when using NoMonomorphismRestriction).+ask :: (Member (Reader e) r) => Eff r e+ask = send Ask --- | Locally rebind the value in the dynamic environment.--- This function both requests and admins Reader requests.-local :: (Typeable e, Member (Reader e) r)-      => (e -> e)-      -> Eff r a-      -> Eff r a+-- | The handler of Reader requests. The return type shows that all Reader+-- requests are fully handled.+runReader :: forall e r w. e -> Eff (Reader e ': r) w -> Eff r w+runReader e m = fix (handle_relay withReader) m e++-- | Locally rebind the value in the dynamic environment This function is like a+-- relay; it is both an admin for Reader requests, and a requestor of them.+local :: forall e a r. Member (Reader e) r =>+         (e -> e) -> Eff r a -> Eff r a local f m = do-  e <- f <$> ask-  let loop (Val x) = return x-      loop (E u) = interpose u loop (\(Reader k) -> loop (k e))-  loop (admin m)+  e <- reader f+  (fix (respond_relay @(Reader e) withReader)) m e+  -- note similarity between 'local' and 'State.Lazy.transactionState'  -- | Request the environment value using a transformation function.-reader :: (Typeable e, Member (Reader e) r) => (e -> a) -> Eff r a-reader f = f <$> ask+reader :: (Member (Reader e) r) => (e -> a) -> Eff r a+reader f = f `fmap` ask --- | The handler of Reader requests. The return type shows that--- all Reader requests are fully handled.-runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w-runReader m e = loop (admin m)-  where-    loop (Val x) = return x-    loop (E u) = handleRelay u loop (\(Reader k) -> loop (k e))+instance ( MonadBase m m+         , LiftedBase m s+         ) => MonadBaseControl m (Eff (Reader e ': s)) where+    type StM (Eff (Reader e ': s)) a = StM (Eff s) a+    liftBaseWith f = do e <- ask+                        raise $ liftBaseWith $ \runInBase ->+                          f (runInBase . runReader e)+    restoreM = raise . restoreM
src/Control/Eff/Reader/Strict.hs view
@@ -1,50 +1,91 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE Safe #-} -- | Strict read-only state-module Control.Eff.Reader.Strict( Reader-                                , ask-                                , local-                                , reader-                                , runReader-                                ) where--import Control.Applicative ((<$>))-import Data.Typeable+module Control.Eff.Reader.Strict ( Reader (..)+                                 , withReader+                                 , ask+                                 , local+                                 , reader+                                 , runReader+                                 ) where  import Control.Eff+import Control.Eff.Extend --- | The request for a value of type e from the current environment.--- This environment is analogous to a parameter of type e.-newtype Reader e v = Reader (e -> v)-    deriving (Typeable, Functor)+import Control.Monad.Base+import Control.Monad.Trans.Control +import Data.Function (fix)++-- ------------------------------------------------------------------------+-- | The Reader monad+--+-- The request for a value of type e from the current environment+-- This can be expressed as a GADT because the type of values+-- returned in response to a (Reader e a) request is not any a;+-- 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+  Ask :: Reader e e+-- ^+-- One can also define this as+--+-- @+-- data Reader e v = (e ~ v) => Reader+-- @+-- ^ without GADTs, using explicit coercion as is done here.+--+-- @+-- newtype Reader e v = Reader (e->v)+-- @+-- ^ In the latter case, when we make the request, we make it as Reader id.+-- So, strictly speaking, GADTs are not really necessary.++-- | How to interpret a pure value in a reader context+withReader :: Monad m => a -> e -> m a+withReader x _ = return x+-- | Given a value to read, and a callback, how to respond to+-- requests.+instance Handle (Reader e) r a (e -> k) where+  handle step q Ask e = step (q ^$ e) e+ -- | Get the current value from a Reader.-ask :: (Typeable e, Member (Reader e) r) => Eff r e-ask = send (inj . Reader)+-- The signature is inferred (when using NoMonomorphismRestriction).+ask :: (Member (Reader e) r) => Eff r e+ask = send Ask --- | Locally rebind the value in the dynamic environment.--- This function both requests and admins Reader requests.-local :: (Typeable e, Member (Reader e) r)-      => (e -> e)-      -> Eff r a-      -> Eff r a+-- | The handler of Reader requests. The return type shows that all Reader+-- requests are fully handled.+runReader :: e -> Eff (Reader e ': r) w -> Eff r w+runReader !e m = fix (handle_relay withReader) m e++-- | Locally rebind the value in the dynamic environment This function is like a+-- relay; it is both an admin for Reader requests, and a requestor of them.+local :: forall e a r. Member (Reader e) r =>+         (e -> e) -> Eff r a -> Eff r a local f m = do-  e <- f <$> ask-  let loop (Val x) = return x-      loop (E u) = interpose u loop (\(Reader k) -> loop (k e))-  loop (admin m)+  e <- reader f+  (fix (respond_relay @(Reader e) withReader)) m e+  -- note similarity between 'local' and 'State.Strict.transactionState'  -- | Request the environment value using a transformation function.-reader :: (Typeable e, Member (Reader e) r) => (e -> a) -> Eff r a-reader f = f <$> ask+reader :: (Member (Reader e) r) => (e -> a) -> Eff r a+reader f = f `fmap` ask --- | The handler of Reader requests. The return type shows that--- all Reader requests are fully handled.-runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w-runReader m !e = loop (admin m) where- loop (Val x) = return x- loop (E u) = handleRelay u loop (\(Reader k) -> loop (k e))+instance ( MonadBase m m+         , LiftedBase m s+         ) => MonadBaseControl m (Eff (Reader e ': s)) where+    type StM (Eff (Reader e ': s)) a = StM (Eff s) a+    liftBaseWith f = do !e <- ask+                        raise $ liftBaseWith $ \runInBase ->+                          f (runInBase . runReader e)+    restoreM = raise . restoreM
src/Control/Eff/State/Lazy.hs view
@@ -1,54 +1,141 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-} -- | Lazy state effect-module Control.Eff.State.Lazy( State-                             , get-                             , put-                             , modify-                             , runState-                             , evalState-                             , execState-                             ) where--import Data.Typeable+module Control.Eff.State.Lazy where  import Control.Eff+import Control.Eff.Extend --- | Strict state effect-data State s w = State (s -> s) (s -> w)-  deriving (Typeable, Functor)+import Control.Eff.Writer.Lazy+import Control.Eff.Reader.Lazy +import Control.Monad.Base+import Control.Monad.Trans.Control++import Data.Function (fix)++-- ------------------------------------------------------------------------+-- | State, lazy+--+-- 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 ()++-- | Embed a pure value in a stateful computation, i.e., given an+-- initial state, how to interpret a pure value in a stateful+-- computation.+withState :: Monad m => a -> s -> m (a, s)+withState x s = return (x, s)++-- | Handle 'State s' requests+instance Handle (State s) r a (s -> k) where+  handle step q sreq s = case sreq of+    Get    -> step (q ^$ s) s+    Put s' -> step (q ^$ ()) s'++instance ( MonadBase m m+         , LiftedBase m r+         ) => MonadBaseControl m (Eff (State s ': r)) where+    type StM (Eff (State s ': r)) a = StM (Eff r) (a,s)+    liftBaseWith f = do s <- get+                        raise $ liftBaseWith $ \runInBase ->+                          f (runInBase . runState s)+    restoreM x = do (a, s :: s) <- raise (restoreM x)+                    put s+                    return a++-- | Return the current value of the state. The signatures are inferred+{-# NOINLINE get #-}+get :: Member (State 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.-put :: (Typeable e, Member (State e) r) => e -> Eff r ()-put = modify . const+{-# NOINLINE put #-}+put :: Member (State s) r => s -> Eff r ()+put s = send (Put s)+{-# RULES+  "put/bind"     forall k v. put v >>= k = send (Put v) >>= k+ #-}+{-# RULES+  "put/semibind" forall k v. put v >>  k = send (Put v) >>= (\() -> k)+ #-}+-- 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). --- | Return the current value of the state.-get :: (Typeable e, Member (State e) r) => Eff r e-get = send (inj . State id)+-- | Run a State effect+runState :: s                     -- ^ Initial state+         -> Eff (State s ': r) a  -- ^ Effect incorporating State+         -> Eff r (a, s)          -- ^ Effect containing final state and a return value+runState s m = fix (handle_relay withState) m s  -- | Transform the state with a function.-modify :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r ()-modify f = send $ \k -> inj $ State f $ \_ -> k ()---- | Run a State effect.-runState :: Typeable s-         => s                     -- ^ Initial state-         -> Eff (State s :> r) w  -- ^ Effect incorporating State-         -> Eff r (s, w)          -- ^ Effect containing final state and a return value-runState s0 = loop s0 . admin where- loop s (Val x) = return (s, x)- loop s (E u)   = handleRelay u (loop s) $-                       \(State t k) -> let s' = t s-                                       in loop s' (k s')+modify :: (Member (State s) r) => (s -> s) -> Eff r ()+modify f = get >>= put . f  -- | Run a State effect, discarding the final state.-evalState :: Typeable s => s -> Eff (State s :> r) w -> Eff r w-evalState s = fmap snd . runState s+evalState :: s -> Eff (State s ': r) a -> Eff r a+evalState s = fmap fst . runState s  -- | Run a State effect and return the final state.-execState :: Typeable s => s -> Eff (State s :> r) w -> Eff r s-execState s = fmap fst . runState s+execState :: s -> Eff (State s ': r) a -> Eff r s+execState s = fmap snd . runState s++-- | An encapsulated State handler, for transactional semantics+-- The global state is updated only if the transactionState finished+-- successfully+data TxState s v where+  TxState :: TxState s s+type TxStateT s = TxState s s++-- | Embed Transactional semantics to a stateful computation.+withTxState :: Member (State s) r => a -> s -> Eff r a+withTxState x s = put s >> return x++-- | Confer transactional semantics on a stateful computation.+transactionState :: forall s r a. Member (State s) r+                 => TxStateT s -> Eff r a -> Eff r a+transactionState _ m = do+  s <- get+  (fix $ respond_relay @(State s) (withTxState @s)) m 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 :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s)+runStateR = flip loop+ where+   loop :: Eff (Writer s ': Reader s ': r) a -> s -> Eff r (a, s)+   loop (Val x) = withState x+   loop (E q u) = case u of+     U0 (Tell w) -> handle loop q (Put w)+     U1 (U0 Ask) -> handle loop q Get+     U1 (U1 u') -> relay (qComp q loop) u'
+ src/Control/Eff/State/OnDemand.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# 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.Extend++import Control.Eff.Writer.Lazy+import Control.Eff.Reader.Lazy+import qualified Control.Eff.State.Lazy as S++import Control.Monad.Base+import Control.Monad.Trans.Control++import Data.Function (fix)++-- ------------------------------------------------------------------------+-- | 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++-- | Given a continuation, respond to requests+instance Handle (OnDemandState s) r a (s -> k) where+  handle step q sreq s = case sreq of+    Get     -> step (q ^$ s) s+    Put s'  -> step (q ^$ ()) s'+    Delay m -> let ~(x, s') = run $ (fix (handle_relay S.withState)) m s+                              in step (q ^$ x) s'++instance ( MonadBase m m+         , LiftedBase m r+         ) => MonadBaseControl m (Eff (OnDemandState s ': r)) where+    type StM (Eff (OnDemandState s ': r)) a = StM (Eff r) (a,s)+    liftBaseWith f = do s <- get+                        raise $ liftBaseWith $ \runInBase ->+                          f (runInBase . runState s)+    restoreM x = do (a, s :: s) <- raise (restoreM x)+                    put s+                    return a+++-- | 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++-- | Run a State effect+runState :: s                            -- ^ Initial state+         -> Eff (OnDemandState s ': r) w -- ^ Effect incorporating State+         -> Eff r (w,s)                  -- ^ Effect containing final state and a return value+runState s m = fix (handle_relay S.withState) m s++-- | 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 :: s -> Eff (OnDemandState s ': r) w -> Eff r w+evalState s = fmap fst . runState s++-- | Run a State effect and return the final state.+execState :: s -> Eff (OnDemandState s ': r) w -> Eff r s+execState s = fmap snd . runState 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 :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s)+runStateR s (Val x) = S.withState x s+runStateR s (E q u) = case u of+  U0 (Tell w) -> handle loop q (S.Put w) s+  U1 (U0 Ask) -> handle loop q S.Get s+  U1 (U1 u') -> relay (qComp q loop) u' s+  where loop = flip runStateR++-- | 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 m s in+  (x,s)+ where+   go :: Eff '[OnDemandState s] a -> s -> (a,s)+   go (Val x) s = (x,s)+   go (E q u) s0 = case decomp u of+     Right Get      -> k s0 s0+     Right (Put s1)  -> let ~(x,sp) = k () sp in (x,s1)+     Right (Delay m1) -> let ~(x,s1) = go m1 s0 in k x s1+     Left _ -> error "Impossible happened: Nothing to relay!"+     where+       k = qComp q go++-- | 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,(_,sp)) = run $ go m (sp,[]) in+  (x,head sp)+ where+   go :: Eff '[OnDemandState s] a -> ([s],[s]) -> Eff '[] (a,([s],[s]))+   go = fix (handle_relay' h S.withState)+   h step q Get s0@(sg, _) = step (q ^$ head sg) s0+   h step q (Put s1) (sg, sp) = step (q ^$ ()) (tail sg,sp++[s1])+   h step q (Delay m1) s0 = let ~(x,s1) = run $ go m1 s0 in step (q ^$ x) s1++-- ^ A different notion of backwards is realized if we change the Put handler+-- slightly. How?
src/Control/Eff/State/Strict.hs view
@@ -1,67 +1,143 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-} -- | Strict state effect+module Control.Eff.State.Strict where++import Control.Eff+import Control.Eff.Extend++import Control.Eff.Writer.Strict+import Control.Eff.Reader.Strict++import Control.Monad.Base+import Control.Monad.Trans.Control++import Data.Function (fix)++-- ------------------------------------------------------------------------+-- | State, strict ----- Example: implementing `Control.Eff.Fresh`+-- 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! ----- > runFresh' :: (Typeable i, Enum i, Num i) => Eff (Fresh i :> r) w -> i -> Eff r w--- > runFresh' m s = fst <$> runState s (loop $ admin m)--- >  where--- >   loop (Val x) = return x--- >   loop (E u)   = case decomp u of--- >     Right (Fresh k) -> do--- >                       n <- get--- >                       put (n + 1)--- >                       loop (k n)--- >     Left u' -> send (\k -> unsafeReUnion $ k <$> u') >>= loop-module Control.Eff.State.Strict( State-                               , get-                               , put-                               , modify-                               , runState-                               , evalState-                               , execState-                               ) where+-- > 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 () -import Data.Typeable+-- | Embed a pure value in a stateful computation, i.e., given an+-- initial state, how to interpret a pure value in a stateful+-- computation.+withState :: Monad m => a -> s -> m (a, s)+withState x s = return (x, s) -import Control.Eff+-- | Handle 'State s' requests+instance Handle (State s) r a (s -> k) where+  handle step q sreq s = case sreq of+    Get    -> step (q ^$ s) s+    Put s' -> step (q ^$ ()) s' --- | Strict state effect-data State s w = State (s -> s) (s -> w)-  deriving (Typeable, Functor)+instance ( MonadBase m m+         , LiftedBase m r+         ) => MonadBaseControl m (Eff (State s ': r)) where+    type StM (Eff (State s ': r)) a = StM (Eff r) (a,s)+    liftBaseWith f = do s <- get+                        raise $ liftBaseWith $ \runInBase ->+                          f (runInBase . runState s)+    restoreM x = do !(a, s :: s) <- raise (restoreM x)+                    put s+                    return a ++-- | Return the current value of the state. The signatures are inferred+{-# NOINLINE get #-}+get :: Member (State 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.-put :: (Typeable e, Member (State e) r) => e -> Eff r ()-put !s = modify $ const s+{-# NOINLINE put #-}+put :: Member (State s) r => s -> Eff r ()+put !s = send (Put s)+{-# RULES+  "put/bind"     forall k v. put v >>= k = send (Put v) >>= k+ #-}+{-# RULES+  "put/semibind" forall k v. put v >>  k = send (Put v) >>= (\() -> k)+ #-}+-- 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). --- | Return the current value of the state.-get :: (Typeable e, Member (State e) r) => Eff r e-get = send (inj . State id)+-- | Run a State effect+runState :: s                     -- ^ Initial state+         -> Eff (State s ': r) a  -- ^ Effect incorporating State+         -> Eff r (a, s)          -- ^ Effect containing final state and a return value+runState !s m = fix (handle_relay withState) m s  -- | Transform the state with a function.-modify :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r ()-modify f = send $ \k -> inj $ State f $ \_ -> k ()---- | Run a State effect.-runState :: Typeable s-         => s                     -- ^ Initial state-         -> Eff (State s :> r) w  -- ^ Effect incorporating State-         -> Eff r (s, w)          -- ^ Effect containing final state and a return value-runState s0 = loop s0 . admin where- loop !s (Val x) = return (s, x)- loop !s (E u)   = handleRelay u (loop s) $-                       \(State t k) -> let s' = t s-                                       in loop s' (k s')+modify :: (Member (State s) r) => (s -> s) -> Eff r ()+modify f = get >>= put . f  -- | Run a State effect, discarding the final state.-evalState :: Typeable s => s -> Eff (State s :> r) w -> Eff r w-evalState s = fmap snd . runState s+evalState :: s -> Eff (State s ': r) a -> Eff r a+evalState !s = fmap fst . runState s+{-# INLINE evalState #-}  -- | Run a State effect and return the final state.-execState :: Typeable s => s -> Eff (State s :> r) w -> Eff r s-execState s = fmap fst . runState s+execState :: s -> Eff (State s ': r) a -> Eff r s+execState !s = fmap snd . runState s+{-# INLINE execState #-}++-- | An encapsulated State handler, for transactional semantics+-- The global state is updated only if the transactionState finished+-- successfully+data TxState s = TxState++-- | Embed Transactional semantics to a stateful computation.+withTxState :: Member (State s) r => a -> s -> Eff r a+withTxState x s = put s >> return x++-- | Confer transactional semantics on a stateful computation.+transactionState :: forall s r a. Member (State s) r+                 => TxState s -> Eff r a -> Eff r a+transactionState _ m = do+  s <- get+  (fix $ respond_relay @(State s) (withTxState @s)) m 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 :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s)+runStateR !s m = loop m s+ where+   loop :: Eff (Writer s ': Reader s ': r) a -> s -> Eff r (a, s)+   loop (Val x) = withState x+   loop (E q u) = case u of+     U0 (Tell w) -> handle loop q (Put w)+     U1 (U0 Ask) -> handle loop q Get+     U1 (U1 u') -> relay (qComp q loop) u'
src/Control/Eff/Trace.hs view
@@ -1,28 +1,40 @@ {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs, DataKinds #-}+{-# LANGUAGE Safe #-} -- | A Trace effect for debugging-module Control.Eff.Trace( Trace+module Control.Eff.Trace( Trace (..)+                        , withTrace                         , trace                         , runTrace                         ) where -import Data.Typeable- import Control.Eff+import Control.Eff.Extend+import Data.Function (fix)  -- | Trace effect for debugging-data Trace v = Trace String (() -> v)-    deriving (Typeable, Functor)+data Trace v where+  Trace :: String -> Trace () +-- | Embed a pure value in Trace context+withTrace :: a -> IO a+withTrace = return++-- | Given a callback and request, respond to it+instance Handle Trace r a (IO k) where+  handle step q (Trace s) = putStrLn s >> step (q ^$ ())+ -- | Print a string as a trace. trace :: Member Trace r => String -> Eff r ()-trace x = send (inj . Trace x)+trace = send . Trace  -- | Run a computation producing Traces.-runTrace :: Eff (Trace :> ()) w -> IO w-runTrace m = loop (admin m)-  where-    loop (Val x) = return x-    loop (E u)   = prjForce u $ \(Trace s k) -> putStrLn s >> loop (k ())+-- The handler for IO request: a terminal handler+runTrace :: Eff '[Trace] w -> IO w+runTrace = fix step where+  step next = eff return+              (\q u -> case u of+                  U0 x -> handle next q x+                  _    -> error "Impossible: Nothing to relay!")
src/Control/Eff/Writer/Lazy.hs view
@@ -1,58 +1,133 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}--- | Lazy write-only state.-module Control.Eff.Writer.Lazy( Writer-                              , tell-                              , censor-                              , runWriter-                              , runFirstWriter-                              , runLastWriter-                              , runMonoidWriter-                              ) where+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeApplications #-}+-- | Lazy write-only state+module Control.Eff.Writer.Lazy ( Writer(..)+                               , withWriter+                               , tell+                               , censor+                               , runWriter+                               , runFirstWriter+                               , runLastWriter+                               , runListWriter+                               , runMonoidWriter+                               , execWriter+                               , execFirstWriter+                               , execLastWriter+                               , execListWriter+                               , execMonoidWriter+                               ) where -import Control.Applicative ((<$>), (<|>))+import Control.Eff+import Control.Eff.Extend++import Control.Applicative ((<|>))++import Control.Monad.Base+import Control.Monad.Trans.Control+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid-import Data.Typeable+#endif -import Control.Eff+import Data.Function (fix) --- | The request to remember a value of type w in the current environment-data Writer w v = Writer w v-    deriving (Typeable, Functor)+-- ------------------------------------------------------------------------+-- | The Writer monad+--+-- In MTL's Writer monad, the told value must have a |Monoid| type. Our+-- writer has no such constraints. If we write a |Writer|-like+-- interpreter to accumulate the told values in a monoid, it will have+-- the |Monoid w| constraint then+data Writer w v where+  Tell :: w -> Writer w () +-- | How to interpret a pure value in a writer context, given the+-- value for mempty.+withWriter :: Monad m => a -> b -> (w -> b -> b) -> m (a, b)+withWriter x empty _append = return (x, empty)+-- | Given a value to write, and a callback (which includes empty and+-- append), respond to requests.+instance Monad m => Handle (Writer w) r a (b -> (w -> b -> b) -> m (a, b)) where+  handle step q (Tell w) e append = step (q ^$ ()) e append >>=+    \(x, l) -> return (x, w `append` l)++instance ( MonadBase m m+         , LiftedBase m r+         ) => MonadBaseControl m (Eff (Writer w ': r)) where+    type StM (Eff (Writer w ': r)) a = StM (Eff r) (a, [w])+    liftBaseWith f = raise $ liftBaseWith $ \runInBase ->+                       f (runInBase . runListWriter)+    restoreM x = do (a, ws :: [w]) <- raise (restoreM x)+                    mapM_ tell ws+                    return a+ -- | Write a new value.-tell :: (Typeable w, Member (Writer w) r) => w -> Eff r ()-tell w = send $ \f -> inj $ Writer w $ f ()+tell :: Member (Writer w) r => w -> Eff r ()+tell w = send $ Tell w  -- | Transform the state being produced.-censor :: (Typeable w, Member (Writer w) r) => (w -> w) -> Eff r a -> Eff r a-censor f = loop . admin+censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a+censor f = fix (respond_relay' h return)   where-    loop (Val x) = return x-    loop (E u) = interpose u loop-               $ \(Writer w v) -> tell (f w) >> loop v+    h :: (Eff r b -> Eff r b) -> Arrs r v b -> Writer w v -> Eff r b+    h step q (Tell w) = tell (f w) >>= \x -> step (q ^$ x) --- | Handle Writer requests, using a user-provided function to accumulate values.-runWriter :: Typeable w => (w -> b -> b) -> b -> Eff (Writer w :> r) a -> Eff r (b, a)-runWriter accum b = loop . admin-  where-    first f (x, y) = (f x, y) -    loop (Val x) = return (b, x)-    loop (E u) = handleRelay u loop-                 $ \(Writer w v) -> first (accum w) <$> loop v+-- | Handle Writer requests, using a user-provided function to accumulate+-- values, hence no Monoid constraints.+runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b)+runWriter accum b m = fix (handle_relay withWriter) m b accum +-- | Handle Writer requests, using a List to accumulate values.+runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w])+runListWriter = runWriter (:) []++-- | Handle Writer requests, using a Monoid instance to accumulate values.+runMonoidWriter :: (Monoid w) => Eff (Writer w ': r) a -> Eff r (a, w)+runMonoidWriter = runWriter (<>) mempty+ -- | Handle Writer requests by taking the first value provided.-runFirstWriter :: Typeable w => Eff (Writer w :> r) a -> Eff r (Maybe w, a)+runFirstWriter :: Eff (Writer w ': r) a -> Eff r (a, Maybe w) runFirstWriter = runWriter (\w b -> Just w <|> b) Nothing  -- | Handle Writer requests by overwriting previous values.-runLastWriter :: Typeable w => Eff (Writer w :> r) a -> Eff r (Maybe w, a)+runLastWriter :: Eff (Writer w ': r) a -> Eff r (a, Maybe w) runLastWriter = runWriter (\w b -> b <|> Just w) Nothing --- | Handle Writer requests, using a Monoid instance to accumulate values.-runMonoidWriter :: (Monoid w, Typeable w) => Eff (Writer w :> r) a -> Eff r (w, a)-runMonoidWriter = runWriter (<>) mempty+-- | Handle Writer requests, using a user-provided function to accumulate+--   values and returning the final accumulated values.+execWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r b+execWriter accum b = fmap snd . runWriter accum b+{-# INLINE execWriter #-}++-- | Handle Writer requests, using a List to accumulate values and returning+--   the final accumulated values.+execListWriter :: Eff (Writer w ': r) a -> Eff r [w]+execListWriter = fmap snd . runListWriter+{-# INLINE execListWriter #-}++-- | Handle Writer requests, using a Monoid instance to accumulate values and+--   returning the final accumulated values.+execMonoidWriter :: (Monoid w) => Eff (Writer w ': r) a -> Eff r w+execMonoidWriter = fmap snd . runMonoidWriter+{-# INLINE execMonoidWriter #-}++-- | Handle Writer requests by taking the first value provided and and returning+--   the final accumulated values.+execFirstWriter :: Eff (Writer w ': r) a -> Eff r (Maybe w)+execFirstWriter = fmap snd . runFirstWriter+{-# INLINE execFirstWriter #-}++-- | Handle Writer requests by overwriting previous values and returning+--   the final accumulated values.+execLastWriter :: Eff (Writer w ': r) a -> Eff r (Maybe w)+execLastWriter = fmap snd . runLastWriter+{-# INLINE execLastWriter #-}
src/Control/Eff/Writer/Strict.hs view
@@ -1,59 +1,133 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}--- | Strict write-only state.-module Control.Eff.Writer.Strict( Writer-                                , tell-                                , censor-                                , runWriter-                                , runFirstWriter-                                , runLastWriter-                                , runMonoidWriter-                                ) where+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE CPP #-}+-- | Strict write-only state+module Control.Eff.Writer.Strict ( Writer(..)+                               , withWriter+                               , tell+                               , censor+                               , runWriter+                               , runFirstWriter+                               , runLastWriter+                               , runListWriter+                               , runMonoidWriter+                               , execWriter+                               , execFirstWriter+                               , execLastWriter+                               , execListWriter+                               , execMonoidWriter+                               ) where -import Control.Applicative ((<$>), (<|>))+import Control.Eff+import Control.Eff.Extend++import Control.Applicative ((<|>))++import Control.Monad.Base+import Control.Monad.Trans.Control+#if __GLASGOW_HASKELL__ < 804 import Data.Monoid-import Data.Typeable+#endif -import Control.Eff+import Data.Function (fix) --- | The request to remember a value of type w in the current environment-data Writer w v = Writer !w v-    deriving (Typeable, Functor)+-- ------------------------------------------------------------------------+-- | The Writer monad+--+-- In MTL's Writer monad, the told value must have a |Monoid| type. Our+-- writer has no such constraints. If we write a |Writer|-like+-- interpreter to accumulate the told values in a monoid, it will have+-- the |Monoid w| constraint then+data Writer w v where+  Tell :: !w -> Writer w () +-- | How to interpret a pure value in a writer context, given the+-- value for mempty.+withWriter :: Monad m => a -> b -> (w -> b -> b) -> m (a, b)+withWriter x empty _append = return (x, empty)+-- | Given a value to write, and a callback (which includes empty and+-- append), respond to requests.+instance Monad m => Handle (Writer w) r a (b -> (w -> b -> b) -> m (a, b)) where+  handle step q (Tell w) e append = step (q ^$ ()) e append >>=+    \(x, l) -> return (x, w `append` l)++instance ( MonadBase m m+         , LiftedBase m r+         ) => MonadBaseControl m (Eff (Writer w ': r)) where+    type StM (Eff (Writer w ': r)) a = StM (Eff r) (a, [w])+    liftBaseWith f = raise $ liftBaseWith $ \runInBase ->+                       f (runInBase . runListWriter)+    restoreM x = do !(a, ws :: [w]) <- raise (restoreM x)+                    mapM_ tell ws+                    return a+ -- | Write a new value.-tell :: (Typeable w, Member (Writer w) r) => w -> Eff r ()-tell !w = send $ \f -> inj $ Writer w $ f ()+tell :: Member (Writer w) r => w -> Eff r ()+tell !w = send $ Tell w  -- | Transform the state being produced.-censor :: (Typeable w, Member (Writer w) r) => (w -> w) -> Eff r a -> Eff r a-censor f = loop . admin+censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a+censor f = fix (respond_relay' h return)   where-    loop (Val x) = return x-    loop (E u) = interpose u loop-               $ \(Writer w v) -> tell (f w) >> loop v+    h :: (Eff r b -> Eff r b) -> Arrs r v b -> Writer w v -> Eff r b+    h step q (Tell w) = tell (f w) >>= \x -> step (q ^$ x) --- | Handle Writer requests, using a user-provided function to accumulate values.-runWriter :: Typeable w => (w -> b -> b) -> b -> Eff (Writer w :> r) a -> Eff r (b, a)-runWriter accum !b = loop . admin-  where-    first f (x, y) = (f x, y) -    loop (Val x) = return (b, x)-    loop (E u) = handleRelay u loop-                 $ \(Writer w v) -> first (accum w) <$> loop v+-- | Handle Writer requests, using a user-provided function to accumulate+-- values, hence no Monoid constraints.+runWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r (a, b)+runWriter accum !b m = fix (handle_relay withWriter) m b accum +-- | Handle Writer requests, using a List to accumulate values.+runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w])+runListWriter = runWriter (:) []++-- | Handle Writer requests, using a Monoid instance to accumulate values.+runMonoidWriter :: (Monoid w) => Eff (Writer w ': r) a -> Eff r (a, w)+runMonoidWriter = runWriter (<>) mempty+ -- | Handle Writer requests by taking the first value provided.-runFirstWriter :: Typeable w => Eff (Writer w :> r) a -> Eff r (Maybe w, a)+runFirstWriter :: Eff (Writer w ': r) a -> Eff r (a, Maybe w) runFirstWriter = runWriter (\w b -> Just w <|> b) Nothing  -- | Handle Writer requests by overwriting previous values.-runLastWriter :: Typeable w => Eff (Writer w :> r) a -> Eff r (Maybe w, a)+runLastWriter :: Eff (Writer w ': r) a -> Eff r (a, Maybe w) runLastWriter = runWriter (\w b -> b <|> Just w) Nothing --- | Handle Writer requests, using a Monoid instance to accumulate values.-runMonoidWriter :: (Monoid w, Typeable w) => Eff (Writer w :> r) a -> Eff r (w, a)-runMonoidWriter = runWriter (<>) mempty+-- | Handle Writer requests, using a user-provided function to accumulate+--   values and returning the final accumulated values.+execWriter :: (w -> b -> b) -> b -> Eff (Writer w ': r) a -> Eff r b+execWriter accum b = fmap snd . runWriter accum b+{-# INLINE execWriter #-}++-- | Handle Writer requests, using a List to accumulate values and returning+--   the final accumulated values.+execListWriter :: Eff (Writer w ': r) a -> Eff r [w]+execListWriter = fmap snd . runListWriter+{-# INLINE execListWriter #-}++-- | Handle Writer requests, using a Monoid instance to accumulate values and+--   returning the final accumulated values.+execMonoidWriter :: (Monoid w) => Eff (Writer w ': r) a -> Eff r w+execMonoidWriter = fmap snd . runMonoidWriter+{-# INLINE execMonoidWriter #-}++-- | Handle Writer requests by taking the first value provided and and returning+--   the final accumulated values.+execFirstWriter :: Eff (Writer w ': r) a -> Eff r (Maybe w)+execFirstWriter = fmap snd . runFirstWriter+{-# INLINE execFirstWriter #-}++-- | Handle Writer requests by overwriting previous values and returning+--   the final accumulated values.+execLastWriter :: Eff (Writer w ': r) a -> Eff r (Maybe w)+execLastWriter = fmap snd . runLastWriter+{-# INLINE execLastWriter #-}
+ src/Data/FTCQueue.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe #-}++-- | Fast type-aligned queue optimized to effectful functions @(a -> m b)@+-- (monad continuations have this type). Constant-time append and snoc and+-- average constant-time left-edge deconstruction+module Data.FTCQueue (+  FTCQueue,+  tsingleton,+  (|>), -- snoc+  (><), -- append+  ViewL,+  viewlMap,+  tviewl+  )+  where++-- | Non-empty tree. Deconstruction operations make it more and more+-- left-leaning.+data FTCQueue m a b where+  Leaf :: (a -> m b) -> FTCQueue m a b+  Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b+++-- Exported operations++-- | There is no @tempty@: use (@tsingleton return@), which works just the same.+-- The names are chosen for compatibility with FastTCQueue+{-# INLINE tsingleton #-}+tsingleton :: (a -> m b) -> FTCQueue m a b+tsingleton r = Leaf r++-- | snoc: clearly constant-time+{-# INLINE (|>) #-}+(|>) :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b+t |> r = Node t (Leaf r)++-- | append: clearly constant-time+{-# INLINE (><) #-}+(><) :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b+t1 >< t2 = Node t1 t2+++-- | Left-edge deconstruction+data ViewL m a b where+  TOne  :: (a -> m b) -> ViewL m a b+  (:|)  :: (a -> m x) -> (FTCQueue m x b) -> ViewL m a b++-- | Process the Left-edge deconstruction+{-# INLINE viewlMap #-}+viewlMap :: ViewL m a b+         -> ((a -> m b) -> c)+         -> (forall x. (a -> m x) -> (FTCQueue m x b) -> c)+         -> c+viewlMap view tone cons = case view of+  TOne k -> tone k+  k :| t -> cons k t++{-# INLINABLE tviewl #-}+tviewl :: FTCQueue m a b -> ViewL m a b+tviewl (Leaf r) = TOne r+tviewl (Node t1 t2) = go t1 t2+ where+   go :: FTCQueue m a x -> FTCQueue m x b -> ViewL m a b+   go (Leaf r) tr = r :| tr+   go (Node tl1 tl2) tr = go tl1 (Node tl2 tr)
+ src/Data/OpenUnion.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS_HADDOCK show-extensions #-}+{-# OPTIONS_GHC -Wwarn #-}+{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- Only for SetMember below, when emulating Monad Transformers+{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}++-- | Open unions (type-indexed co-products) for extensible effects+-- All operations are constant-time, and there is no Typeable constraint+--+-- This is a variation of OpenUion5.hs, which relies on overlapping+-- instances instead of closed type families. Closed type families+-- have their problems: overlapping instances can resolve even+-- for unground types, but closed type families are subject to a+-- strict apartness condition.+--+-- This implementation is very similar to OpenUnion1.hs, but without+-- the annoying Typeable constraint. We sort of emulate it:+--+-- Our list r of open union components is a small Universe.+-- Therefore, we can use the Typeable-like evidence in that+-- universe. We hence can define+--+-- @+-- data Union r v where+--   Union :: t v -> TRep t r -> Union r v -- t is existential+-- @+-- where+--+-- @+-- data TRep t r where+--   T0 :: TRep t (t ': r)+--   TS :: TRep t r -> TRep (any ': r)+-- @+-- Then Member is a type class that produces TRep+-- Taken literally it doesn't seem much better than+-- OpenUinion41.hs. However, we can cheat and use the index of the+-- type t in the list r as the TRep. (We will need UnsafeCoerce then).+--+-- The interface is the same as of other OpenUnion*.hs+module Data.OpenUnion ( Union+                      , inj+                      , prj, pattern U0'+                      , decomp, pattern U0, pattern U1+                      , Member+                      , SetMember+                      , type(<::)+                      , weaken+                      ) where++import Unsafe.Coerce(unsafeCoerce)++import Data.Kind (Constraint)+import GHC.TypeLits++-- | The data constructors of Union are not exported+--+-- Strong Sum (Existential with the evidence) is an open union+-- t is can be a GADT and hence not necessarily a Functor.+-- Int is the index of t in the list r; that is, the index of t in the+-- universe r+data Union (r :: [ * -> * ]) v where+  Union :: {-# UNPACK #-} !Int -> t v -> Union r v++{-# INLINE prj' #-}+{-# INLINE inj' #-}+inj' :: Int -> t v -> Union r v+inj' = Union++prj' :: Int -> Union r v -> Maybe (t v)+prj' n (Union n' x) | n == n'   = Just (unsafeCoerce x)+                    | otherwise = Nothing++newtype P t r = P{unP :: Int}++-- | Typeclass that asserts that effect @t@ is contained inside the effect-list+-- @r@.+--+-- The @FindElem@ typeclass is an implementation detail and not required for+-- using the effect list or implementing custom effects.+class (FindElem t r) => Member (t :: * -> *) r where+  inj :: t v -> Union r v+  prj :: Union r v -> Maybe (t v)++-- | Pattern synonym to project the union onto the effect @t@.+pattern U0' :: Member t r => t v -> Union r v+pattern U0' h <- (prj -> Just h) where+  U0' h = inj h++-- | Explicit type-level equality condition is a dirty+-- hack to eliminate the type annotation in the trivial case,+-- such as @run (runReader () get)@.+--+-- There is no ambiguity when finding instances for+-- @Member t (a ': b ': r)@, which the second instance is selected.+--+-- The only case we have to concerned about is  @Member t '[s]@.+-- But, in this case, values of definition is the same (if present),+-- and the first one is chosen according to GHC User Manual, since+-- the latter one is incoherent. This is the optimal choice.+instance {-# OVERLAPPING #-} t ~ s => Member t '[s] where+   {-# INLINE inj #-}+   {-# INLINE prj #-}+   inj x           = Union 0 x+   prj (Union _ x) = Just (unsafeCoerce x)+-- Note that if it weren't for us wanting to use the specialized instance above+-- we wouldn't need the INCOHERENT pragma below+-- TODO: consider impact of disabling specialization+instance {-# INCOHERENT #-}  (FindElem t r) => Member t r where+  {-# INLINE inj #-}+  {-# INLINE prj #-}+  inj = inj' (unP $ (elemNo :: P t r))+  prj = prj' (unP $ (elemNo :: P t r))++-- | A useful operator for reducing boilerplate in signatures.+--+-- The following lines are equivalent.+--+-- @+-- (Member (Exc e) r, Member (State s) r) => ...+-- [ Exc e, State s ] <:: r => ...+-- @+type family (<::) (ms :: [* -> *]) r where+  (<::) '[] r = (() :: Constraint)+  (<::) (m ': ms) r = (Member m r, (<::) ms r)++{-# INLINE [2] decomp #-}+-- | Orthogonal decomposition of the union: head and the rest.+decomp :: Union (t ': r) v -> Either (Union r v) (t v)+decomp (Union 0 v) = Right $ unsafeCoerce v+decomp (Union n v) = Left  $ Union (n-1) v++-- | Some helpful pattern synonyms.+-- U0 : the first element of the union+pattern U0 :: t v -> Union (t ': r) v+pattern U0 h <- (decomp -> Right h) where+  U0 h = inj h+-- | U1 : everything excluding the first element of the union.+pattern U1 t <- (decomp -> Left t) where+  U1 t = weaken t+{-# COMPLETE U0, U1 #-}++-- Specialized version+{-# RULES "decomp/singleton"  decomp = decomp0 #-}+{-# INLINE decomp0 #-}+decomp0 :: Union '[t] v -> Either (Union '[] v) (t v)+decomp0 (Union _ v) = Right $ unsafeCoerce v+-- No other case is possible++weaken :: Union r w -> Union (any ': r) w+weaken (Union n v) = Union (n+1) v++-- | Find the index of an element in a type-level list.+-- The element must exist+-- This is essentially a compile-time computation.+-- Using overlapping instances here is OK since this class is private to this+-- module+class FindElem (t :: * -> *) r where+  elemNo :: P t r++instance FindElem t (t ': r) where+  elemNo = P 0+instance {-# OVERLAPPABLE #-} FindElem t r => FindElem t (t' ': r) where+  elemNo = P $ 1 + (unP $ (elemNo :: P t r))+instance TypeError ('Text "Cannot unify effect types." ':$$:+                    'Text "Unhandled effect: " ':<>: 'ShowType t ':$$:+                    'Text "Perhaps check the type of effectful computation and the sequence of handlers for concordance?")+  => FindElem t '[] where+  elemNo = error "unreachable"++-- | Using overlapping instances here is OK since this class is private to this+-- module+class EQU (a :: k) (b :: k) p | a b -> p+instance EQU a a 'True+instance {-# OVERLAPPABLE #-} (p ~ 'False) => EQU a b p++-- | This class is used for emulating monad transformers+class Member t r => SetMember (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t+instance (EQU t1 t2 p, MemberU' p tag t1 (t2 ': r)) => SetMember tag t1 (t2 ': r)++class Member t r =>+      MemberU' (f::Bool) (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t+instance MemberU' 'True tag (tag e) (tag e ': r)+instance (Member t (t' ': r), SetMember tag t r) =>+           MemberU' 'False tag t (t' ': r)
− src/Data/OpenUnion1.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE UndecidableInstances #-}---- | Original work at <http://okmij.org/ftp/Haskell/extensible/OpenUnion1.hs>.--- Open unions (type-indexed co-products) for extensible effects.--- This implementation relies on _closed_ overlapping instances--- (or closed type function overlapping soon to be added to GHC).-module Data.OpenUnion1( Union-                      , SetMember-                      , Member-                      , (:>)-                      , inj-                      , prj-                      , prjForce-                      , decomp-                      , unsafeReUnion-                      ) where--import Control.Applicative ((<$>))-import Data.Typeable--infixl 4 <?>---- | infix form of `fromMaybe`.-(<?>) :: Maybe a -> a -> a-Just a <?> _ = a-_ <?> a = a---- for the sake of gcast1-newtype Id a = Id { runId :: a }-  deriving Typeable---- | Where @r@ is @t1 :> t2 ... :> tn@, @`Union` r v@ can be constructed with a--- value of type @ti v@.--- Ideally, we should be be able to add the constraint @`Member` t r@.-data Union r v = forall t. (Functor t, Typeable1 t) => Union (t v)--instance Functor (Union r) where-    {-# INLINE fmap #-}-    fmap f (Union v) = Union (fmap f v)---- | A sum data type, for composing effects-infixr 1 :>-data ((a :: * -> *) :> b)---- | The @`Member` t r@ determines whether @t@ is anywhere in the sum type @r@.-class Member t r-instance Member t (t :> r)-instance Member t r => Member t (t' :> r)---- | `SetMember` is similar to `Member`, but it allows types to belong to a--- \"set\". For every set, only one member can be in @r@ at any given time.--- This allows us to specify exclusivity and uniqueness among arbitrary effects:------ > -- Terminal effects (effects which must be run last)--- > data Terminal--- >--- > -- Make Lifts part of the Terminal effects set.--- > -- The fundep assures that there can only be one Terminal effect for any r.--- > instance Member (Lift m) r => SetMember Terminal (Lift m) r--- >--- > -- Only allow a single unique Lift effect, by making a "Lift" set.--- > instance Member (Lift m) r => SetMember Lift (Lift m) r-class Member t r => SetMember set (t :: * -> *) r | r set -> t-instance SetMember set t r => SetMember set t (t' :> r)--{-# INLINE inj #-}--- | Construct a Union.-inj :: (Functor t, Typeable1 t, Member t r) => t v -> Union r v-inj = Union--{-# INLINE prj #-}--- | Try extracting the contents of a Union as a given type.-prj :: (Typeable1 t, Member t r) => Union r v -> Maybe (t v)-prj (Union v) = runId <$> gcast1 (Id v)--{-# INLINE prjForce #-}--- | Extract the contents of a Union as a given type.--- If the Union isn't of that type, a runtime error occurs.-prjForce :: (Typeable1 t, Member t r) => Union r v -> (t v -> a) -> a-prjForce u f = f <$> prj u <?> error "prjForce with an invalid type"--{-# INLINE decomp #-}--- | Try extracting the contents of a Union as a given type.--- If we can't, return a reduced Union that excludes the type we just checked.-decomp :: Typeable1 t => Union (t :> r) v -> Either (Union r v) (t v)-decomp u = Right <$> prj u <?> Left (unsafeReUnion u)--{-# INLINE unsafeReUnion #-}--- | Juggle types for a Union. Use cautiously.-unsafeReUnion :: Union r w -> Union t w-unsafeReUnion (Union v) = Union v
+ test/Control/Eff/Coroutine/Test.hs view
@@ -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+  assertOutput+    "Coroutine: Simple coroutines using Eff"+    ["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 k x) = trace (show (x::Int)) >> k () >>= loop+            loop (Done)    = trace ("Done")++case_Coroutines_c2 :: Assertion+case_Coroutines_c2 = do+  ((), actual1) <- catchOutput c2+  assertOutput "Coroutine: Add dynamic variables"+    ["10", "10", "Done"] actual1+  ((), actual2) <- catchOutput c21+  assertOutput "Coroutine: locally changing the dynamic environment for the suspension"+    ["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 (10::Int) (loop =<< runC th2)+      where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop+            loop Done    = trace "Done"++    -- locally changing the dynamic environment for the suspension+    c21 = runTrace $ runReader (10::Int) (loop =<< runC th2)+      where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+            loop Done    = trace "Done"++case_Coroutines_c3 :: Assertion+case_Coroutines_c3 = do+  ((), actual1) <- catchOutput c3+  assertOutput "Coroutine: two sorts of local rebinding"+    ["10", "10", "20", "20", "Done"] actual1+  ((), actual2) <- catchOutput c31+  let expected2 = ["10", "11", "21", "21", "Done"]+  assertOutput "Coroutine: locally changing the dynamic environment for the suspension"+    expected2 actual2+  ((), actual3) <- catchOutput c4+  assertOutput "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 (10::Int) (loop =<< runC th3)+      where loop (Y k x) = 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 (10::Int) (loop =<< runC th3)+      where loop (Y k x) = 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 (10::Int) (loop =<< runC (th4 client))+      where loop (Y k x) = 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 = ["10"+                 ,"11"+                 ,"12"+                 ,"18"+                 ,"18"+                 ,"18"+                 ,"29"+                 ,"29"+                 ,"29"+                 ,"29"+                 ,"29"+                 ,"29"+                 ,"Done"+                 ]+  assertOutput "Corountine: Even more dynamic example"+    expected actual+  where+    c5 = runTrace $ runReader (10::Int) (loop =<< runC (th client))+      where loop (Y k x) = 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 = ["1010"+                 ,"1021"+                 ,"1032"+                 ,"1048"+                 ,"1064"+                 ,"1080"+                 ,"1101"+                 ,"1122"+                 ,"1143"+                 ,"1169"+                 ,"1195"+                 ,"1221"+                 ,"1252"+                 ,"1283"+                 ,"1314"+                 ,"1345"+                 ,"1376"+                 ,"1407"+                 ,"Done"+                 ]+  assertOutput "Coroutine: And even more dynamic example"+    expected actual+  where+    c7 = runTrace $+          runReader (1000::Double) (runReader (10::Int) (loop =<< runC (th client)))+     where loop (Y k x) = 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 = ["1010"+                 ,"1021"+                 ,"1032"+                 ,"1048"+                 ,"1048"+                 ,"1048"+                 ,"1069"+                 ,"1090"+                 ,"1111"+                 ,"1137"+                 ,"1137"+                 ,"1137"+                 ,"1168"+                 ,"1199"+                 ,"1230"+                 ,"1261"+                 ,"1292"+                 ,"1323"+                 ,"Done"+                 ]+  assertOutput "Coroutine: And even more dynamic example"+    expected actual+  where+    c7' = runTrace $+          runReader (1000::Double) (runReader (10::Int) (loop =<< runC (th client)))+     where loop (Y k x) = 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)
+ test/Control/Eff/Example/Test.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts, AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}++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 throwError (TooBig v)+     else return v++case_Exception1_ex2r :: Assertion+case_Exception1_ex2r = (Right 5) @=? (run ex2r)+  where+    ex2r = runReader (5::Int) (runErrBig (ex2 ask))++case_Exception1_ex2r1 :: Assertion+case_Exception1_ex2r1 = (Left (TooBig 7)) @=? (run ex2r1)+  where+    ex2r1 = runReader (7::Int) (runErrBig (ex2 ask))++-- Different order of handlers (layers)+case_Exception1_ex2r2 :: Assertion+case_Exception1_ex2r2 = (Left (TooBig 7)) @=? (run ex2r2)+  where+    ex2r2 = runErrBig (runReader (7::Int) (ex2 ask))++case_multiple_eff_sum2 :: Assertion+case_multiple_eff_sum2 =+  assertEqual "Int : Float" 33 intThenFloat+  >> assertEqual "Float : Int" intThenFloat floatThenInt+  where+    intThenFloat = run $ runReader (20::Float) (runReader (10::Int) sum2)+    floatThenInt = run $ runReader (10::Int) (runReader (20::Float) sum2)++prop_Documentation_example :: [Integer] -> Property+prop_Documentation_example l = let+  ((), total1) = run $ runState 0 (sumAll l)+  ((), last1) = run $ runLastWriter $ writeAll l+  (((), last2), total2) = run $ runState 0 (runLastWriter (writeAndAdd l))+  (((), total3), last3) = run $ runLastWriter $ runState 0 (writeAndAdd l)+  in+   allEqual [safeLast l, last1, last2, last3]+   .&&. allEqual [sum l, total1, total2, total3]
+ test/Control/Eff/Exception/Test.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}++module Control.Eff.Exception.Test (testGroups) where++import Test.HUnit hiding (State)+import Control.Eff+import Control.Eff.Exception+import Control.Eff.Writer.Strict+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif+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` throwError (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 = runError 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 =+  catchError ma $ \ea ->+  catchError mb $ \eb -> throwError (mappend (ea::e) eb)++case_Exception1_alttry :: Assertion+case_Exception1_alttry =+  [Right 10,Right 10,Right 10,Left "bummer1bummer2"] @=?+  [+  run . runError $+     (return 1 `add` throwError "bummer1") `alttry`+     (return 10),+  run . runError $+     (return 10) `alttry`+     (return 1 `add` throwError "bummer2"),+  run . runError $+     (return 10) `alttry` return 20,+  run . runError $+     (return 1 `add` throwError "bummer1") `alttry`+     (return 1 `add` throwError "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++case_Exception1_monadBaseControl :: Assertion+case_Exception1_monadBaseControl =+    runLift (runError act) @=? Just (Left "Fail")+  where+    act = doThing $ do _ <- throwError "Fail"+                       return "Success"
+ test/Control/Eff/Fresh/Test.hs view
@@ -0,0 +1,34 @@+{-# 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+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'+  assertOutput "Fresh: test"+    ["Fresh 0", "Fresh 1"] actual+  where+    tfresh' = runTrace $ runFresh' 0 $ do+      n <- fresh+      trace $ "Fresh " ++ show n+      n <- fresh+      trace $ "Fresh " ++ show n++case_Fresh_monadBaseControl :: Assertion+case_Fresh_monadBaseControl = runLift (runFresh' i (doThing $ fresh >> fresh)) @=? Just (i + 1)+  where+    i = 0
+ test/Control/Eff/Logic/NDet/Bench.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}++-- A benchmark of shift/reset: Filinski's representing non-determinism monads+--+--  The benchmark is taken from Sec 6.1 of+--    Martin Gasbichler, Michael Sperber: Final Shift for Call/cc: Direct+--    Implementation of Shift and Reset, ICFP'02, pp. 271-282. +--    http://www-pu.informatik.uni-tuebingen.de/users/sperber/papers/shift-reset-direct.pdf+-- This code is a straightforward translation of bench_nondet.ml+--+-- This is a micro-benchmark: it is very non-determinism-intensive. It is+-- *not* representative: the benchmark does nothing else but+-- concatenates lists. The List monad does this directly; whereas+-- continuation monads do the concatenation with more overhead (e.g.,+-- building the closures representing continuations). Therefore,+-- the List monad here outperforms all other implementations of +-- non-determinism.+-- It should be stressed that the delimited control is optimized+-- for the case where control operations are infrequent, so we pay+-- as we go. The use of the delimited control operators is more+-- expensive, but the code that does not use delimited control does not+-- have to pay anything for delimited control. +-- Again, in the present micro-benchmark, there is hardly any code that+-- does not use non-determinism, so the overhead of delimited control+-- is very noticeable. That is why this benchmark is good at estimating+-- the overhead of different implementations of delimited control.++-- To compile this code+-- ghc -O2 -rtsopts -main-is Bench_nondet.main_list5 Bench_nondet.hs+-- To run this code+-- GHCRTS="-tstderr" /usr/bin/time ./Bench_nondet++module Control.Eff.Logic.NDet.Bench where++import Control.Eff+import qualified Control.Eff.Logic.NDet as E++import Data.List (sort)+-- import Control.Monad.Identity+-- import Control.Monad (liftM2)+import Control.Monad (MonadPlus(..), msum)+import Control.Applicative+-- import System.CPUTime++-- Small language with non-determinism: just like the one in our DSL-WC paper++int :: MonadPlus repr => Int -> repr Int+int x = return x++add :: MonadPlus repr => repr Int -> repr Int -> repr Int+-- add xs ys = liftM2 (+) xs ys+add xs ys = do {x <- xs; y <- ys; return $! x+y }++lam :: MonadPlus repr => (repr a -> repr b) -> repr (a -> repr b)+lam f = return $ f . return++app :: MonadPlus repr => repr (a -> repr b) -> (repr a -> repr b)+app xs ys = do {x <- xs; y <- ys; x y}++amb :: MonadPlus repr => [repr Int] -> repr Int+amb = msum++-- Benchmark cases++test_ww :: MonadPlus repr => repr Int+test_ww = + let f = lam (\x ->+              add (add x (amb [int 6, int 4, int 2, int 8])) +                         (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]++ww_answer = + sort [8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 4, 6, 7, 6, 3, 10, 12, 13,+       12, 9, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 12, 14, 15,+       14, 11, 11, 13, 14, 13, 10, 9, 11, 12, 11, 8, 7, 9, 10, 9, 6, 13, 15,+       16, 15, 12, 12, 14, 15, 14, 11, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7,+       14, 16, 17, 16, 13, 13, 15, 16, 15, 12, 11, 13, 14, 13, 10, 9, 11, 12,+       11, 8, 15, 17, 18, 17, 14, 40, 42, 43, 42, 39, 38, 40, 41, 40, 37, 36,+       38, 39, 38, 35, 42, 44, 45, 44, 41]++-- Real benchmark cases++test_www :: MonadPlus repr => repr Int+test_www = + let f = lam (\x ->+              add (add x (amb [int 6, int 4, int 2, int 8])) +                         (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])++test_wwww :: MonadPlus repr => repr Int+test_wwww = + let f = lam (\x ->+              add (add x (amb [int 6, int 4, int 2, int 8])) +                         (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]))++test_w5 :: MonadPlus repr => repr Int+test_w5 = + let f = lam (\x ->+              add (add x (amb [int 6, int 4, int 2, int 8])) +                         (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` +     (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])))+++-- Different implementations of our language (MonadPlus)++-- The List monad: Non-determinism monad as a list of successes++run_list :: [Int] -> [Int]+run_list = id++testl1 = (==) [101, 201, 102, 202] . run_list $+         add (amb [int 1, int 2]) (amb [int 100, int 200])++testl2 = ww_answer == sort (run_list test_ww)+++-- CPS-monad, implemented by hand; it must be quite efficient therefore+-- It is a monad, not a transformer. It cannot do any other effects beside+-- the non-determinism.+newtype CPS a = CPS{unCPS:: (a -> [Int]) -> [Int]}++instance Functor CPS where+  fmap f fa = CPS $ \k -> unCPS fa (k . f)+instance Applicative CPS where+  pure x = CPS $ \k -> k x+  mf <*> fa = CPS $ \k -> unCPS mf (\f -> unCPS fa (k . f))+instance Monad CPS where+  return x = CPS $ \k -> k x+  m >>= f  = CPS $ \k -> unCPS m (\a -> unCPS (f a) k)++instance Alternative CPS where+  empty = mzero+  (<|>) = mplus+instance MonadPlus CPS where+  mzero = CPS $ \_ -> []+  mplus m1 m2 = CPS $ \k -> unCPS m1 k ++ unCPS m2 k++run_cps :: CPS Int -> [Int]+run_cps m = unCPS m (\x -> [x])+++testc1 = (==) [101, 201, 102, 202] . run_cps $+         add (amb [int 1, int 2]) (amb [int 100, int 200])++testc2 = ww_answer == sort (run_cps test_ww)++-- ExtEff implementation+-- Eff is already an instance of MonadPlus. Thus we only need to+-- define the run instance++-- run_eff :: Eff '[E.Choose] Int -> [Int]+-- run_eff = run . E.makeChoice++-- More direct interpreter+-- makeChoiceA :: Eff (E.NDet ': r) a -> Eff r [a]+-- makeChoiceA = handle_relay (\x -> x `seq` return [x] ) $ \m k -> case m of+--     E.MZero -> return []+--     E.MPlus -> liftM2 (++) (k True) (k False)++run_eff :: Eff '[E.NDet] Int -> [Int]+run_eff = run . E.makeChoiceA++teste2 = ww_answer == sort (run_eff test_ww)+++data Count a = Count (Maybe a) !Int+instance Functor Count where+  fmap f (Count (Just x) n) = Count (Just (f x)) n+  fmap _ _                  = Count Nothing 0+  +instance Applicative Count where+  pure x = Count (Just x) 1+  Count (Just f) nf <*> Count (Just x) nx = Count (Just (f x)) (nf + nx)+  _ <*> _  = Count Nothing 0+  +instance Alternative Count where+  empty = Count Nothing 0+  Count m1@Just{} n1 <|> Count _ n2 = Count m1 (n1+n2)+  _ <|> m2 = m2++run_effc :: Eff '[E.NDet] Int -> Int+run_effc m = let Count _ n = run . E.makeChoiceA $ m in n++  +teste12 = length ww_answer == run_effc test_ww++{-+-- CCEx monad+-- Not a very optimal implementation of mplus (a tree would be better)+-- But is suffices as a benchmark of different implementations of CC+instance Monad m => MonadPlus (CC (PS [Int]) m) where+    mzero = abortP ps (return [])+    mplus m1 m2 = takeSubCont ps (\k ->+                     liftM2 (++)+                       (pushPrompt ps (pushSubCont k m1))+                       (pushPrompt ps (pushSubCont k m2)))++run_dir :: CC (PS [Int]) Identity Int -> [Int]+run_dir m = runIdentity . runCC $+            pushPrompt ps (m >>= return . (:[]))+++testd1 = (==) [101, 201, 102, 202] . run_dir $+         add (amb [int 1, int 2]) (amb [int 100, int 200])++testd2 = ww_answer == sort (run_dir test_ww)++-}+++-- Benchmarks themselves++main_list3 = print $ 2400   == (length . run_list $ test_www)+main_list4 = print $ 48000  == (length . run_list $ test_wwww)+main_list5 = print $ 960000 == (length . run_list $ test_w5)++main_cps3 = print $ 2400   == (length . run_cps $ test_www)+main_cps4 = print $ 48000  == (length . run_cps $ test_wwww)+main_cps5 = print $ 960000 == (length . run_cps $ test_w5)++-- We expect the direct implementation to be slower since CC is the transformer,+-- whereas CPS is not. The latter is hand-written for a specific answer-type.+main_eff3 = print $ 2400   == (length . run_eff $ test_www)+main_eff4 = print $ 48000  == (length . run_eff $ test_wwww)+main_eff5 = print $ 960000 == (length . run_eff $ test_w5)++main_eff5c = print $ 960000 == (run_effc $ test_w5)++-- To clarify the effect of building a list+main_eff5m = print $ ((run . E.makeChoiceA $ test_w5) :: Maybe Int)++{-+-- Instantiate CC to the IO as the base monad, attempting to quantify the+-- effect of the Identity transformer+main_dir5io = do+              l <- runCC $ pushPrompt ps (test_w5 >>= return . (:[]))+              print $ length l == 960000+-}++-- ------------------------------------------------------------------------+-- Old results, from 2010++{- Median of 5 runs++main_list5+<<ghc: 186526764 bytes, 356 GCs, 619182/1156760 avg/max bytes residency (3 samples), 4M in use, 0.00 INIT (0.00 elapsed), 0.25 MUT (0.25 elapsed), 0.06 GC (0.06 elapsed) :ghc>>+        0.30 real         0.30 user         0.00 sys++main_cps5+<<ghc: 231580040 bytes, 442 GCs, 4017/4104 avg/max bytes residency (24 samples), 2M in use, 0.00 INIT (0.00 elapsed), 0.28 MUT (0.28 elapsed), 0.31 GC (0.33 elapsed) :ghc>>+        0.60 real         0.58 user         0.01 sys++main_dir5 (CCExc implementation)+<<ghc: 780415108 bytes, 1489 GCs, 10459973/39033060 avg/max bytes residency (14 samples), 110M in use, 0.00 INIT (0.00 elapsed), 1.30 MUT (1.32 elapsed), 2.92 GC (3.14 elapsed) :ghc>>+        4.48 real         4.22 user         0.24 sys++main_dir5io (CCExc implementation)+<<ghc: 1148031880 bytes, 2190 GCs, 10339954/38941944 avg/max bytes residency (14 samples), 108M in use, 0.00 INIT (0.00 elapsed), 2.15 MUT (2.20 elapsed), 3.04 GC (3.24 elapsed) :ghc>>+        5.45 real         5.18 user         0.21 sys+++main_dir5 (CCCxe implementation)+./Bench_nondet +RTS -tstderr +True+<<ghc: 991065016 bytes, 1891 GCs, 10473968/38790660 avg/max bytes residency (14 samples), 110M in use, 0.00 INIT (0.00 elapsed), 1.45 MUT (1.49 elapsed), 2.99 GC (3.20 elapsed) :ghc>>+        4.70 real         4.44 user         0.23 sys++main_dir5io (CCCxe implementation)+./Bench_nondet +RTS -tstderr +True+<<ghc: 991065412 bytes, 1891 GCs, 10364029/37920012 avg/max bytes residency (14 samples), 109M in use, 0.00 INIT (0.00 elapsed), 1.46 MUT (1.50 elapsed), 2.99 GC (3.20 elapsed) :ghc>>+        4.72 real         4.44 user         0.23 sys++main_ref5io (without pushDelimSubCont)+./Bench_nondet +RTS -tstderr +True+<<ghc: 19050261764 bytes, 36337 GCs, 10620542/49328200 avg/max bytes residency (16 samples), 123M in use, 0.00 INIT (0.00 elapsed), 61.45 MUT (62.70 elapsed), 6.06 GC (6.21 elapsed) :ghc>>+       68.94 real        67.51 user         1.03 sys+++main_ref5io (with pushDelimSubCont)+./Bench_nondet +RTS -tstderr +True+<<ghc: 5666546308 bytes, 10809 GCs, 10538302/46414760 avg/max bytes residency (14 samples), 114M in use, 0.00 INIT (0.00 elapsed), 16.27 MUT (16.68 elapsed), 3.65 GC (3.80 elapsed) :ghc>>+       20.50 real        19.92 user         0.46 sys++-}++-- ------------------------------------------------------------------------+-- Newer Benchmarks, July 2015++{-+main_list5+True+<<ghc: 374751856 bytes, 720 GCs, 939265/2386984 avg/max bytes residency (6 samples), 7M in use, 0.00 INIT (0.00 elapsed), 0.11 MUT (0.11 elapsed), 0.02 GC (0.02 elapsed) :ghc>>++main_cps5+True+<<ghc: 463450920 bytes, 889 GCs, 36708/44312 avg/max bytes residency (2 samples), 1M in use, 0.00 INIT (0.00 elapsed), 0.14 MUT (0.15 elapsed), 0.00 GC (0.01 elapsed) :ghc>>++-- using makeChoiceA (setting f as an Alternative)+main_eff5+True+<<ghc: 1013337072 bytes, 1944 GCs, 18671465/83300976 avg/max bytes residency (17 samples), 231M in use, 0.00 INIT (0.00 elapsed), 0.36 MUT (0.39 elapsed), 1.08 GC (1.13 elapsed) :ghc>>++With strict add:+True+<<ghc: 993935088 bytes, 1906 GCs, 15000238/77154800 avg/max bytes residency (19 samples), 199M in use, 0.00 INIT (0.00 elapsed), 0.37 MUT (0.39 elapsed), 0.95 GC (1.02 elapsed) :ghc>>+1.32user 0.08system 0:01.40elapsed 99%CPU (0avgtext+0avgdata 819408maxresident)k+0inputs+0outputs (0major+51485minor)pagefaults 0swaps++It looks like a huge memory leak. Perhaps the list is fully realized?+++Using the counting Alternative Count+True+<<ghc: 591341472 bytes, 1133 GCs, 16603280/76447176 avg/max bytes residency (10 samples), 162M in use, 0.00 INIT (0.00 elapsed), 0.28 MUT (0.28 elapsed), 0.61 GC (0.66 elapsed) :ghc>>++Using Maybe+Just 32+<<ghc: 523838824 bytes, 1003 GCs, 16969712/76447176 avg/max bytes residency (9 samples), 150M in use, 0.00 INIT (0.00 elapsed), 0.21 MUT (0.19 elapsed), 0.46 GC (0.52 elapsed) :ghc>>+0.67user 0.05system 0:00.72elapsed 100%CPU (0avgtext+0avgdata 620752maxresident)k+0inputs+0outputs (0major+38937minor)pagefaults 0swaps++-- using Maybe, but with the better makeChoice+Just 32+<<ghc: 517460016 bytes, 883 GCs, 20215861/91552144 avg/max bytes residency (9 samples), 138M in use, 0.00 INIT (0.00 elapsed), 0.22 MUT (0.24 elapsed), 0.41 GC (0.43 elapsed) :ghc>>+0.63user 0.04system 0:00.68elapsed 100%CPU (0avgtext+0avgdata 570720maxresident)k+0inputs+0outputs (0major+35760minor)pagefaults 0swaps++Better makeChoiceA, full list+True+<<ghc: 454475112 bytes, 839 GCs, 8700298/33304904 avg/max bytes residency (8 samples), 58M in use, 0.00 INIT (0.00 elapsed), 0.23 MUT (0.23 elapsed), 0.19 GC (0.20 elapsed) :ghc>>+0.42user 0.02system 0:00.44elapsed 100%CPU (0avgtext+0avgdata 244064maxresident)k+0inputs+0outputs (0major+15391minor)pagefaults 0swaps++-}
+ test/Control/Eff/Logic/NDet/Test.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Logic.NDet.Test (testGroups, gen_testCA, gen_ifte_test)+where++import Test.HUnit hiding (State)+import Control.Applicative+import Control.Eff+import Control.Eff.Example+import Control.Eff.Example.Test (ex2)+import Control.Eff.Exception+import Control.Eff.Logic.NDet+import Control.Eff.Writer.Strict+import Control.Monad (msum, guard, mzero, mplus)+import Control.Eff.Logic.Test+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++gen_testCA :: (Integral a) => a -> Eff (NDet ': r) a+gen_testCA x = do+  i <- msum . fmap return $ [1..x]+  guard (i `mod` 2 == 0)+  return i++case_NDet_testCA :: Assertion+case_NDet_testCA = [2, 4..10] @=? (run $ makeChoiceA (gen_testCA 10))++case_Choose1_exc11 :: Assertion+case_Choose1_exc11 = [2,3] @=? (run exc11)+  where+    exc11 = makeChoice exc1+    exc1 = return 1 `add` choose [1,2]++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]))+      exRec_4 = run . makeChoice . runErrBig $ 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_3" expected3 exRec_3+    >> assertEqual "Choose: error recovery: exRec_4" expected4 exRec_4+  where+    expected1 = Right [5,7,1]+    expected2 = [Right 5,Right 7,Right 1]+    expected3 = Left (TooBig 11)+    expected4 = [Right 5,Right 7,Left (TooBig 11),Right 1]+    -- 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 = catchError m handler+      where handler (TooBig n) | n <= 7 = return n+            handler e = throwError e++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)++gen_ifte_test x = do+  n <- gen x+  ifte (do+           d <- gen x+           guard $ d < n && n `mod` d == 0+           -- _ <- trace ("d: " ++ show d) (return ())+       )+    (\_ -> mzero)+    (return n)+    where gen x = msum . fmap return $ [2..x]+++case_NDet_ifte :: Assertion+case_NDet_ifte =+  let primes = ifte_test_run+  in+    assertEqual "NDet: test ifte using primes"+    [2,3,5,7,11,13,17,19,23,29] primes+  where+    ifte_test_run :: [Int]+    ifte_test_run = run . makeChoiceA $ (gen_ifte_test 30)+++-- called reflect in the LogicT paper+case_NDet_reflect :: Assertion+case_NDet_reflect =+  let tsplitr10 = run $ runListWriter $ makeChoiceA tsplit+      tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= reflect)+      tsplitr20 = run $ makeChoiceA $ runListWriter tsplit+      tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= reflect)+  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"])]++    tsplit =+      (tell "begin" >> return 1) `mplus`+      (tell "end"   >> return 2)++case_NDet_monadBaseControl :: Assertion+case_NDet_monadBaseControl = runLift (makeChoiceA $ doThing (return 1 <|> return 2)) @=? Just [1,2]++case_Choose_monadBaseControl :: Assertion+case_Choose_monadBaseControl = runLift (makeChoice $ doThing $ choose [1,2,3]) @=? Just [1,2,3]++case_NDet_cut :: Assertion+case_NDet_cut = testCut (run . makeChoice)++case_NDet_monadplus :: Assertion+case_NDet_monadplus =+  let evalnw = run . (runListWriter @Int) . makeChoice+      evalwn = run . makeChoice . (runListWriter @Int)+      casesnw = [+        -- mplus laws+          ("0             | NDet, Writer", evalnw t0, nw0)+        , ("zm0     = 0   | NDet, Writer", evalnw tzm0, nw0)+        , ("0m1           | NDet, Writer", evalnw t0m1, nw0m1)+        , ("zm0mzm1 = 0m1 | NDet, Writer", evalnw tzm0mzm1, nw0m1)+        -- mzero laws+        , ("z         | NDet, Writer", evalnw tz, nwz)+        , ("z0    = z | NDet, Writer", evalnw tz0, nwz)+        , ("0z   /= z | NDet, Writer", evalnw t0z, nw0z)+        , ("z0m1  = 1 | NDet, Writer", evalnw tz0m1, nw1)+        , ("0zm1 /= 1 | NDet, Writer", evalnw t0zm1, nw0zm1)+        ]+      caseswn = [+        -- mplus laws+          ("0             | Writer, NDet", evalwn t0, wn0)+        , ("zm0     = 0   | Writer, NDet", evalwn tzm0, wn0)+        , ("0m1           | Writer, NDet", evalwn t0m1, wn0m1)+        , ("zm0mzm1 = 0m1 | Writer, NDet", evalwn tzm0mzm1, wn0m1)+        -- mzero laws+        , ("z        | Writer, NDet", evalwn tz, wnz)+        , ("z0   = z | Writer, NDet", evalwn tz0, wnz)+        , ("0z   = z | Writer, NDet", evalwn t0z, wnz)+        , ("z0m1 = 1 | Writer, NDet", evalwn tz0m1, wn1)+        , ("0zm1 = 1 | Writer, NDet", evalwn t0zm1, wn1)+        ]+  in runAsserts assertEqual casesnw+  >> runAsserts assertEqual caseswn+  where+    nwz = ([]::[Int],[])+    wnz = [] ::[(Int, [Int])]+    nw0z = ([]::[Int],[0])+    nw0 = ([0],[0])+    nw1 = ([1],[1])+    nw0zm1 = ([1],[0,1])+    wn0 = [(0,[0])]+    wn1 = [(1,[1])]++    nw0m1 = ([0::Int,1],[0,1])+    wn0m1 = [(0,[0]), (1,[1])]++    t0 = wr @Int 0+    t1 = wr @Int 1++    tz = mzero+    tz0 = tz >> t0+    t0z = t0 >> tz+    tz0m1 = tz0 `mplus` t1+    t0zm1 = t0z `mplus` t1++    t0m1 = t0 `mplus` t1+    tzm0 = tz `mplus` t0+    tzm1 = tz `mplus` t1+    tzm0mzm1 = tzm0 `mplus` tzm1++    wr :: forall a r. [Writer a, NDet] <:: r => a -> Eff r a+    wr i = tell i >> return i
+ test/Control/Eff/Logic/Test.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Eff.Logic.Test where++import Test.HUnit hiding (State)+import Control.Eff.Logic.Core+import Control.Monad++-- the inferred signature of testCut is insightful+testCut runChoice =+  let cases = [tcut1, tcut2, tcut3, tcut4, tcut5, tcut6, tcut7, tcut8+              , tcut9]+      runCall = runChoice . call+  in+    forM_ cases $ \(test, result) ->+                    assertEqual "Cut: tcut" result (runCall test)+  where+    -- signature is inferred+    -- tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int+    tc1 = (return (1::Int) `mplus` return 2) `mplus`+          ((cutfalse `mplus` return 4) `mplus`+            return 5)+    rc1 = [1,2]+    tcut1 = (tc1, rc1)+    -- Here we see nested call. It poses no problems...+    tc2 = return (1::Int) `mplus`+          call (return 2 `mplus` (cutfalse `mplus` return 3) `mplus`+                 return 4)+          `mplus` return 5+    rc2 = [1,2,5]+    tcut2 = (tc2, rc2)+    tcut3 = ((call tc1 `mplus` call (tc2 `mplus` cutfalse))+            , rc1 ++ rc2)+    tcut4 = ((call tc1 `mplus`  (tc2 `mplus` cutfalse))+            , rc1 ++ rc2)+    tcut5 = ((call tc1 `mplus`  (cutfalse `mplus` tc2))+            , rc1)+    tcut6 = ((call tc1 `mplus` call (cutfalse `mplus` tc2))+            , rc1)+    tcut7 = ((call tc1 `mplus`  (cutfalse `mplus` tc2) `mplus` tc2)+            , rc1)+    tcut8 = ((call tc1 `mplus` call (cutfalse `mplus` tc2) `mplus` tc2)+            , rc1 ++ rc2)+    incrOrDecr = \x -> (return $! x + 1)+                       `mplus` cutfalse+                       `mplus` (return $! x - 1)+    tc9 = tc1 >>= incrOrDecr+    rc9 = [2]+    tcut9 = (tc9, rc9)+    -- tcut10 = ((return rc1 >>= incrOrDecr)+    --          , rc9)
+ test/Control/Eff/Operational/Test.hs view
@@ -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 ["foo", "bar"] comp+  in+   assertEqual+   "Evaluating Operational Monad example"+   (unlines ["getting input...",+             "ok",+             "the input is foo"]) go
+ test/Control/Eff/Reader/Lazy/Test.hs view
@@ -0,0 +1,104 @@+{-# 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 (10::Int) t1+  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 (10::Int) t2+  t2rr = runReader (20::Float) . 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 (10 :: Int) . runReader (20 :: Float) $ t2)+++case_Lazy1_Reader_t3 :: Assertion+case_Lazy1_Reader_t3 = let+  t3 = t1 `add` local (+ (10::Int)) t1+  in+    212 @=? (run $ runReader (100::Int) t3)++-- 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 (10::Int) . runReader (20::Float) $ t4)++-- The opposite order of layers gives the same result+case_Lazy1_Reader_t4' :: Assertion+case_Lazy1_Reader_t4' = 106.0 @=?+  (run $ runReader (10::Int) . runReader (20::Float) $ t4)++-- 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 (10::Int) tmap)+  where+    f x = ask `add` return x++case_Lazy1_Reader_runReader :: Assertion+case_Lazy1_Reader_runReader = let+  e = run $ runReader (undefined :: ()) voidReader+  in+   assertNoUndefined (e :: ())+  where+    voidReader = do+        _ <- (ask :: Eff '[Reader ()] ())+        return ()++case_Lazy1_Reader_monadBaseControl :: Assertion+case_Lazy1_Reader_monadBaseControl =+      runLift (runReader i act) @=? (Just i)+    where+        act = doThing ask+        i = 10 :: Int
+ test/Control/Eff/Reader/Strict/Test.hs view
@@ -0,0 +1,33 @@+{-# 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 (undefined :: ()) voidReader+  in+   assertUndefined (e :: ())+  where+    voidReader = do+        _ <- (ask :: Eff '[Reader ()] ())+        return ()++case_Strict1_Reader_monadBaseControl :: Assertion+case_Strict1_Reader_monadBaseControl =+      runLift (runReader i act) @=? (Just i)+    where+        act = doThing ask+        i = 10 :: Int
+ test/Control/Eff/State/Lazy/Test.hs view
@@ -0,0 +1,38 @@+{-# 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+            $ runState undefined+            $ getVoid+            >> putVoid undefined+            >> putVoid ()+  in+   assertNoUndefined r+  where+    getVoid :: Eff '[State ()] ()+    getVoid = get++    putVoid :: () -> Eff '[State ()] ()+    putVoid = put++case_Lazy1_State_monadBaseControl :: Assertion+case_Lazy1_State_monadBaseControl = runLift (runState i (doThing $ modify f)) @=? Just ((), i + 1)+  where+    i = 0 :: Int+    f = succ :: Int -> Int
+ test/Control/Eff/State/OnDemand/Test.hs view
@@ -0,0 +1,115 @@+{-# 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 Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit++testGroups = [ $(testGroupGenerator) ]++case_LazierState_ex1 :: Assertion+case_LazierState_ex1 =+  let actual = run $ runState 0 lex1+  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 (undefined::[Int]) lex3+  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 (undefined::[Int]) (runError lex5)+    ex51Run :: Either [Int] ((), [Int]) = run $ runError $ runState (undefined::[Int]) lex5+  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 (0::Int) st+  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)++case_LazierState_monadBaseControl :: Assertion+case_LazierState_monadBaseControl = runLift (runState i (doThing $ modify f)) @=? Just ((), i + 1)+  where+    i = 0 :: Int+    f = succ :: Int -> Int
+ test/Control/Eff/State/Strict/Test.hs view
@@ -0,0 +1,108 @@+{-# 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+            $ 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 (0::Int) ts1))+  where+    ts1 = do+      put (10 ::Int)+      x <- get+      return (x::Int)++case_Strict1_State_ts11 :: Assertion+case_Strict1_State_ts11 =+  (10,10) @=? (run (runStateR (0::Int) ts11))+  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 (0::Int) ts2))+  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 (0::Int) ts21))+  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+  throwError "exc"+  where+    incr = get >>= put . (+ (1::Int))++case_Strict1_State_ter1 :: Assertion+case_Strict1_State_ter1 = (Left "exc" :: Either String Int,2) @=?+  (run $ runState (1::Int) (runError tes1))++case_Strict1_State_ter2 :: Assertion+case_Strict1_State_ter2 = (Left "exc" :: Either String (Int,Int)) @=?+  (run $ runError (runState (1::Int) tes1))++teCatch :: Member (Exc String) r => Eff r a -> Eff r [Char]+teCatch m = catchError (m >> return "done") (\e -> return (e::String))++case_Strict1_State_ter3 :: Assertion+case_Strict1_State_ter3 = (Right "exc" :: Either String String,2) @=?+  (run $ runState (1::Int) (runError (teCatch tes1)))++case_Strict1_State_ter4 :: Assertion+case_Strict1_State_ter4 = (Right ("exc",2) :: Either String (String,Int)) @=?+  (run $ runError (runState (1::Int) (teCatch tes1)))++case_Strict1_State_monadBaseControl :: Assertion+case_Strict1_State_monadBaseControl = runLift (runState i (doThing $ modify f)) @=?+  Just ((), i + 1)+  where+    i = 0 :: Int+    f = succ :: Int -> Int
+ test/Control/Eff/Test.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators, DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Control.Eff.Test (testGroups) where++import Test.HUnit hiding (State)+import Test.QuickCheck+import Control.Eff+import Control.Eff.Reader.Strict+import Control.Eff.State.Strict+import Control.Eff.Exception+import qualified Control.Exception as Exc+import Utils++import Test.Framework.TH+import Test.Framework.Providers.HUnit+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 readerId (readerAp x)++    readerAp :: Bool -> Eff '[Reader (Eff '[Reader Bool] Bool)] Bool+    readerAp x = do+      f <- ask+      return . run $ runReader x f++    readerId :: Eff '[Reader Bool] Bool+    readerId = do+      x <- ask+      return x++-- | 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, Lifted m r) => Eff r ()+    possiblyAmbiguous = lift $ return ()++case_Lift_tl1r :: Assertion+case_Lift_tl1r = do+  ((), output) <- catchOutput tl1r+  assertOutput "Test tl1r" [show input] output+  where+    input = (5::Int)+    -- tl1r :: IO ()+    tl1r = runLift (runReader input tl1)+      where+        tl1 = ask >>= \(x::Int) -> lift . print $ x++case_Lift_tMd' :: Assertion+case_Lift_tMd' = do+  (actualResult, actualOutput) <- catchOutput tMd'+  let expected = (output, map show input)+  assertEqual "Test mapMdebug using Lift" expected (actualResult, lines actualOutput)+  where+    input = [1..5]+    val = (10::Int)+    output = map (+ val) input++    tMd' = runLift $ runReader val $ mapMdebug' f input+      where f x = ask `add` return x++    -- Re-implemenation of mapMdebug using Lifting+    -- The signature is inferred+    mapMdebug'  :: (Show a, Lifted 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)+instance Exc.Exception MyException++exfn :: Lifted IO r => Bool -> Eff r Bool+exfn True = lift . Exc.throw $ (MyException "thrown")+exfn False = return True++testc m = catchDynE (m >>= return . show) (\ (MyException s) -> return s)+test1 m = do runLift (tf m True) >>= print; runLift (tf m False) >>= print+tf m x = runReader (x::Bool) . runState ([]::[String]) $ m++runErrorStr = runError @String++case_catchDynE_test1 :: Assertion+case_catchDynE_test1 = do+  ((), actual) <- catchOutput $ test1 (testc m)+  let expected = [ "(\"thrown\",[\"begin\"])"+                 , "(\"True\",[\"end\",\"begin\"])"]+  assertOutput "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!+    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 (runErrorStr (testc m))+  let expected' = [ "(Left \"thrown\",[\"begin\"])"+                  , "(Right \"True\",[\"end\",\"begin\"])"]+  assertOutput "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!+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x+      modify ("end":)+      return r++    exfn True = throwError $ ("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 $ test1 (runErrorStr (testc m))+  let expected = [ "(Left \"thrown\",[\"begin\"])"+                 , "(Right \"True\",[\"end\",\"begin\"])"]+  assertOutput "catchDynE: test2: Error shouldn't drop Writer's state"+    expected actual+  where+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x `catchDynE` (\ (MyException s) -> throwError s)+      modify ("end":)+      return r++-- Full recovery+case_catchDynE_test2' :: Assertion+case_catchDynE_test2' = do+  ((), actual) <- catchOutput $ test1 (runErrorStr (testc m))+  let expected = [ "(Right \"False\",[\"end\",\"begin\"])"+                 , "(Right \"True\",[\"end\",\"begin\"])"]+  assertOutput "catchDynE: test2': Fully recover from errors"+    expected actual+  where+    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 $ test1 (runErrorStr (testc m))+  let expected = [ "(Right \"rethrow:thrown\",[\"begin\"])"+                 , "(Right \"True\",[\"end\",\"begin\"])"]+  assertOutput "catchDynE: test3: Throwing within a handler"+    expected actual+  where+    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+  ((), actual1) <- catchOutput $ test1 m1+  ((), actual2) <- catchOutput $ test1 m2+  let expected1 = ["(\"thrown\",[\"init\"])"+                  ,"(\"True\",[\"end\",\"begin\",\"init\"])"]+  let expected2 = ["(\"thrown\",[\"begin\",\"init\"])"+                  ,"(\"True\",[\"end\",\"begin\",\"init\"])"]+  assertOutput "catchDynE: tran: Transactional behaviour" expected1 actual1+    >> assertOutput "catchDynE: tran: usual behaviour" expected2 actual2+  where+    m1 = do+      modify ("init":)+      testc (transactionState (TxState :: TxState [String]) m)+    m2 = do+      modify ("init":)+      testc m+    m = do+      modify ("begin":)+      x <- ask+      r <- exfn x+      modify ("end":)+      return r
+ test/Control/Eff/Trace/Test.hs view
@@ -0,0 +1,57 @@+{-# 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"+    ["Asked: 20", "Asked: 10"] (lines actual)+  where+    tdup = runTrace $ runReader (10::Int) m+     where+     m = do+         runReader (20::Int) tr+         tr+     tr = do+          v <- ask+          trace $ "Asked: " ++ show (v::Int)++case_Trace_tMd :: Assertion+case_Trace_tMd = do+  (actualResult, actualOutput) <- catchOutput tMd+  assertEqual "Trace: higher-order effectful function"+    (map (+ val) input, map (("mapMdebug: " ++) . show) input)+    (actualResult, lines actualOutput)+  where+    val = (10::Int)+    input = [1..5]+    tMd = runTrace $ runReader val (mapMdebug f input)+      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')
+ test/Control/Eff/Writer/Lazy/Test.hs view
@@ -0,0 +1,65 @@+{-# 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 :: ())++case_Lazy1_Writer_monadBaseControl :: Assertion+case_Lazy1_Writer_monadBaseControl = runLift (runListWriter act) @=? Just ((), [i])+  where+    i = 10 :: Int+    act = doThing (tell i)
+ test/Control/Eff/Writer/Strict/Test.hs view
@@ -0,0 +1,28 @@+{-# 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 :: ())++case_Strict1_Writer_monadBaseControl :: Assertion+case_Strict1_Writer_monadBaseControl = runLift (runListWriter act) @=? Just ((), [i])+  where+    i = 10 :: Int+    act = doThing (tell i)
+ test/DoctestRun.hs view
@@ -0,0 +1,13 @@+module DoctestRun where++import Test.DocTest (doctest)++runDocTest :: IO ()+runDocTest = do+  putStrLn ""+  putStrLn ""+  putStrLn "Doc Test..."+  doctest ["-i", "-XFlexibleContexts", "-XMultiParamTypeClasses", "-XFlexibleInstances", "-XGADTs", "-XScopedTypeVariables",+           "-isrc", "src/Control/Eff/QuickStart.hs"]+  putStrLn "Doc Test OK"+  putStrLn ""
test/Test.hs view
@@ -1,160 +1,41 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-import Control.Exception (Exception, ErrorCall, catch)-import Control.Monad (void)-import Data.Typeable--import Test.Framework (defaultMain, testGroup)-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2--import Test.HUnit hiding (State)-import Test.QuickCheck--import Control.Eff-import Control.Eff.Fail-import Control.Eff.Lift-import Control.Eff.Reader.Lazy as LazyR-import Control.Eff.State.Lazy as LazyS-import Control.Eff.Writer.Lazy as LazyW-import Control.Eff.Reader.Strict as StrictR-import Control.Eff.State.Strict as StrictS-import Control.Eff.Writer.Strict as StrictW--withError :: a -> ErrorCall -> a-withError a _ = a--assertUndefined :: a -> Assertion-assertUndefined a = catch (seq a $ assertFailure "") (withError $ return ())+import Test.Framework (defaultMain, Test) -assertNoUndefined :: a -> Assertion-assertNoUndefined a = catch (seq a $ return ()) (withError $ assertFailure "")+import qualified Control.Eff.Test+import qualified Control.Eff.Coroutine.Test+import qualified Control.Eff.Example.Test+import qualified Control.Eff.Exception.Test+import qualified Control.Eff.Fresh.Test+import qualified Control.Eff.Logic.NDet.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.OnDemand.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+import DoctestRun (runDocTest)  main :: IO ()-main = defaultMain tests--allEqual :: Eq a => [a] -> Bool-allEqual = all (uncurry (==)) . pairs-  where-    pairs l = zip l $ tail l--safeLast [] = Nothing-safeLast l = Just $ last l--testDocs :: [Integer] -> Property-testDocs l = let-              (total1, ()) = run $ LazyS.runState 0 $ sumAll l-              (last1, ()) = run $ LazyW.runLastWriter $ writeAll l-              (total2, (last2, ())) = run $ LazyS.runState 0 $ LazyW.runLastWriter $ writeAndAdd l-              (last3, (total3, ())) = run $ LazyW.runLastWriter $ LazyS.runState 0 $ writeAndAdd l-             in allEqual [safeLast l, last1, last2, last3]-           .&&. allEqual [sum l, total1, total2, total3]-  where-    writeAll :: (Typeable a, Member (LazyW.Writer a) e)-             => [a]-             -> Eff e ()-    writeAll = mapM_ LazyW.tell--    sumAll :: (Typeable a, Num a, Member (LazyS.State a) e)-           => [a]-           -> Eff e ()-    sumAll = mapM_ (LazyS.modify . (+))-    -    writeAndAdd :: (Member (LazyW.Writer Integer) e, Member (LazyS.State Integer) e)-                => [Integer]-                -> Eff e ()-    writeAndAdd l = do-        writeAll l-        sumAll l--testCensor :: [Integer] -> Property-testCensor 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 = fst . run . LazyW.runWriter (:) []--testReaderLaziness :: Assertion-testReaderLaziness = let e = run $ LazyR.runReader voidReader (undefined :: ())-                     in assertNoUndefined (e :: ())-  where-    voidReader = do-        _ <- (LazyR.ask :: Eff (LazyR.Reader () :> ()) ())-        return ()--testReaderStrictness :: Assertion-testReaderStrictness = let e = run $ StrictR.runReader voidReader (undefined :: ())-                       in assertUndefined (e :: ())-  where-    voidReader = do-        _ <- (StrictR.ask :: Eff (StrictR.Reader () :> ()) ())-        return ()--testStateLaziness :: Assertion-testStateLaziness = let (r, ()) = run-                                $ 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--testStateStrictness :: Assertion-testStateStrictness = let (r, ()) = run-                                  $ 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--testLastWriterLaziness :: Assertion-testLastWriterLaziness = let (Just m, ()) = run $ LazyW.runLastWriter $ mapM_ LazyW.tell [undefined, ()]-                         in assertNoUndefined (m :: ())--testLastWriterStrictness :: Assertion-testLastWriterStrictness = let (Just m, ()) = run $ StrictW.runLastWriter $ mapM_ StrictW.tell [undefined, ()]-                           in assertUndefined (m :: ())--testFirstWriterLaziness :: Assertion-testFirstWriterLaziness = let (Just m, ()) = run $ LazyW.runFirstWriter $ mapM_ LazyW.tell [(), undefined]-                          in assertNoUndefined (m :: ())--testFailure :: Assertion-testFailure =-  let go :: Eff (Fail :> StrictW.Writer Int :> ()) Int-         -> Int-      go = fst . 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+main = do+  runDocTest+  defaultMain testGroups -tests =-  [ testProperty "Documentation example." testDocs-  , testCase "Test runReader laziness." testReaderLaziness-  , testCase "Test runReader strictness." testReaderStrictness-  , testCase "Test runState laziness." testStateLaziness-  , testCase "Test runState strictness." testStateStrictness-  , testCase "Test runLastWriter laziness." testLastWriterLaziness-  , testCase "Test runLastWriter strictness." testLastWriterStrictness-  , testCase "Test runFirstWriter laziness." testFirstWriterLaziness-  , testCase "Test failure effect." testFailure-  ]+testGroups :: [Test]+testGroups = []+             ++ Control.Eff.Test.testGroups+             ++ Control.Eff.Coroutine.Test.testGroups+             ++ Control.Eff.Example.Test.testGroups+             ++ Control.Eff.Exception.Test.testGroups+             ++ Control.Eff.Fresh.Test.testGroups+             ++ Control.Eff.Logic.NDet.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.OnDemand.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
+ test/Utils.hs view
@@ -0,0 +1,48 @@+module Utils where++import Control.Exception (ErrorCall, catch)+import Control.Monad+import Control.Monad.Trans.Control++import System.IO.Silently+import Data.Tuple (swap)++import Test.HUnit hiding (State)++-- | capture stdout+-- [[https://stackoverflow.com/a/11128420][source]]+catchOutput :: IO a -> IO (a, String)+catchOutput f = swap `fmap` capture f++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 "")++assertOutput :: String -> [String] -> String -> Assertion+assertOutput msg expected actual = assertEqual msg expected (lines actual)++runAsserts :: (String -> a -> e -> Assertion) -> [(String, e, a)] -> Assertion+runAsserts run cases = forM_ cases $ \(prop, test, res) -> run prop res test++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 (+)++doThing :: MonadBaseControl b m => m a -> m a+doThing = liftBaseOp_ go+  where+    go :: Monad m => m a -> m a+    go a = return () >> a