extensible-effects 1.11.1.0 → 2.0.0.0

raw patch · 29 files changed

+2196/−1102 lines, 29 filesdep +directorydep −voidPVP ok

version bump matches the API change (PVP)

Dependencies added: directory

Dependencies removed: void

API changes (from Hackage documentation)

Files

• README.md +5/−13
• extensible-effects.cabal +25/−22
• src/Control/Eff.hs +189/−79
• src/Control/Eff/Choose.hs +47/−32
• src/Control/Eff/Coroutine.hs +19/−18
• src/Control/Eff/Cut.hs +0/−95
• src/Control/Eff/Example.hs +34/−11
• src/Control/Eff/Exception.hs +34/−44
• src/Control/Eff/Fresh.hs +75/−14
• src/Control/Eff/Lift.hs +14/−48
• src/Control/Eff/NdetEff.hs +98/−0
• src/Control/Eff/Operational.hs +8/−27
• src/Control/Eff/Operational/Example.hs +3/−2
• src/Control/Eff/Reader/Lazy.hs +45/−36
• src/Control/Eff/Reader/Strict.hs +48/−39
• src/Control/Eff/State/Lazy.hs +130/−42
• src/Control/Eff/State/LazyState.hs +90/−0
• src/Control/Eff/State/Strict.hs +107/−55
• src/Control/Eff/Trace.hs +13/−12
• src/Control/Eff/Writer/Lazy.hs +50/−43
• src/Control/Eff/Writer/Strict.hs +50/−43
• src/Control/Monad/Free/Reflection.hs +0/−89
• src/Data/FTCQueue.hs +57/−0
• src/Data/OpenUnion.hs +167/−85
• src/Data/OpenUnion/Imports.hs +0/−26
• src/Data/OpenUnion/Internal/Base.hs +0/−70
• src/Data/OpenUnion/Internal/OpenUnion1.hs +0/−34
• src/Data/OpenUnion/Internal/OpenUnion2.hs +0/−59
• test/Test.hs +888/−64

@@ -1,6 +1,8 @@ extensible-effects is based on the work [Extensible Effects: An Alternative to Monad Transformers](http://okmij.org/ftp/Haskell/extensible/).-Please read the [paper](http://okmij.org/ftp/Haskell/extensible/exteff.pdf) for details.+Please read the [paper](http://okmij.org/ftp/Haskell/extensible/exteff.pdf) and+the followup [freer paper](http://okmij.org/ftp/Haskell/extensible/more.pdf) for+details. Additional explanation behind the approach can be found on [Oleg's website](http://okmij.org/ftp/Haskell/extensible/).  [![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)@@ -9,13 +11,13 @@  ## Advantages -   * Effects can be added, removed, and interwoven without changes to code not     dealing with those effects.  ## Disadvantages -### For GHC version 7.8 and upwards+### Current implementation only supports GHC version 7.8 and above+### Ambiguity-Flexibility tradeoff   * The extensibility comes at the cost of some ambiguity. Note, however, that     the extensibility can be traded back, but that detracts from some of the     advantages. For details see section 4.1 in the@@ -33,13 +35,3 @@       point of having the grouping in the first place.     * Code requires greater number of type annotations. For details see       [#31](https://github.com/suhailshergill/extensible-effects/issues/31).-  * Requires a `Typeable` instance on the return type. This is no longer a-    limitation on GHC versions 7.8 and above.-    * fixed by-      [#38](https://github.com/suhailshergill/extensible-effects/issues/38).--### For GHC versions prior to 7.8-  * Neither `Eff` nor `(:>)` has a `Typeable` instance, and can thus often not-    be used as a return type (e.g. `State` type) for other `Eff`s. -    * fixed by-      [#38](https://github.com/suhailshergill/extensible-effects/issues/38). 

@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.11.1.0+version:             2.0.0.0  -- A short (one-line) description of the package. synopsis:            An Alternative to Monad Transformers@@ -43,7 +43,7 @@  category:            Control, Effect -tested-with:         GHC==8.0.1, GHC==7.10.3, GHC==7.10.1, GHC==7.8.4, GHC==7.6.3+tested-with:         GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4  build-type:          Simple @@ -58,19 +58,25 @@   default: False   manual: True +flag force-openunion-51+  description:         Force usage of OpenUnion51.hs implementation+  default:             True+  manual:              True+ library   ghc-options:         -Wall   -- Modules exported by the library.   exposed-modules:     Control.Eff                        Control.Eff.Choose                        Control.Eff.Coroutine-                       Control.Eff.Cut                        Control.Eff.Example                        Control.Eff.Exception                        Control.Eff.Fresh                        Control.Eff.Lift+                       Control.Eff.NdetEff                        Control.Eff.Reader.Lazy                        Control.Eff.Reader.Strict+                       Control.Eff.State.LazyState                        Control.Eff.State.Lazy                        Control.Eff.State.Strict                        Control.Eff.Writer.Lazy@@ -78,16 +84,12 @@                        Control.Eff.Trace                        Control.Eff.Operational                        Control.Eff.Operational.Example-                       Control.Monad.Free.Reflection                        Data.OpenUnion-                       Data.OpenUnion.Imports    -- Modules included in this library but not exported.-  other-modules:       Data.OpenUnion.Internal.Base-  if impl(ghc >= 7.8.1)-     other-modules:    Data.OpenUnion.Internal.OpenUnion2-  else-     other-modules:    Data.OpenUnion.Internal.OpenUnion1+  other-modules:       Data.FTCQueue+  if flag(force-openunion-51)+    cpp-options:       -DFORCE_OU51    -- LANGUAGE extensions used by modules in this package.   other-extensions:    BangPatterns@@ -114,6 +116,8 @@                        , UndecidableInstances   if impl(ghc < 7.8.1)      other-extensions: OverlappingInstances+  if impl(ghc >= 8.2)+     ghc-options:      -Wno-simplifiable-class-constraints    -- Other library packages from which modules are imported.   build-depends:       base >= 4.6 && < 5@@ -122,7 +126,6 @@                        , transformers >= 0.3 && < 0.6                        -- For MonadBase instance                        , transformers-base == 0.4.*-                       , void >= 0.6 && < 0.8    -- Directories containing source files.   hs-source-dirs:      src@@ -132,8 +135,8 @@    -- TODO: uncomment when https://github.com/haskell/cabal/issues/2527 is   -- resolved-  -- if flag(lib-Werror)-  --   ghc-options: -Werror+  if flag(lib-Werror)+     ghc-options: -Werror  test-suite extensible-effects-tests   type: exitcode-stdio-1.0@@ -143,15 +146,15 @@   ghc-options: -Wall    build-depends:-    base >= 4.6 && < 5-    , QuickCheck == 2.*-    , HUnit >= 1.2 && < 1.4-    , test-framework == 0.8.*-    , test-framework-hunit == 0.3.*-    , test-framework-quickcheck2 == 0.3.*-    , test-framework-th >= 0.2-    , extensible-effects-    , void >= 0.6 && < 0.8+                base >= 4.6 && < 5+              , QuickCheck == 2.*+              , HUnit >= 1.2 && < 1.4+              , test-framework == 0.8.*+              , test-framework-hunit == 0.3.*+              , test-framework-quickcheck2 == 0.3.*+              , test-framework-th >= 0.2+              , extensible-effects+              , directory >= 1.2 && < 1.4    default-language:    Haskell2010 

@@ -1,98 +1,208 @@-{-# OPTIONS_HADDOCK show-extensions #-}--{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+ {-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-} --- | Original work available at <http://okmij.org/ftp/Haskell/extensible/Eff.hs>.+-- | 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>.+-- 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(-                    Eff-                  , module Reflection-                  , Member-                  , SetMember-                  , Union-                  , (:>)-                  , inj-                  , prj-                  , prjForce-                  , decomp-                  , send-                  , run-                  , interpose-                  , handleRelay-                  , unsafeReUnion-                  ) where--import Control.Monad.Free.Reflection as Reflection-import Data.OpenUnion-import Data.Typeable-import Data.Void+module Control.Eff where -#if __GLASGOW_HASKELL__ >= 708-#define Typeable1 Typeable+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative #endif+import safe Data.OpenUnion+import safe Data.FTCQueue+import GHC.Exts (inline) --- | Basic type returned by all computations with extensible effects. The @`Eff`--- r@ type is a type synonym where the type @r@ is the type of effects that can--- be handled, and the missing type @a@ (from the type application) is the type--- of value that is returned.+-- ------------------------------------------------------------------------+-- | A monadic library for communication between a handler and+-- its client, the administered computation ----- Expressed another way: an `Eff` can either be a value (i.e., 'Pure' case), or--- an effect of type @`Union` r@ producing another `Eff` (i.e., 'Impure'--- case). The result is that an `Eff` can produce an arbitrarily long chain of--- @`Union` r@ effects, terminated with a pure value.+-- 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++arr :: (a -> b) -> Arrs r a b+arr f = tsingleton (Val . f)++ident :: Arrs r a a+ident = arr id++single :: Arr r a b -> Arrs r a b+single = tsingleton++-- FIXME: convert to 'Arrs'+first :: Arr r a b -> Arr r (a, c) (b, c)+first x = \(a,c) -> (, c) `fmap` x a++comp :: Arrs r a b -> Arrs r b c -> Arrs r a c+comp = (><)++-- | An effectful function from 'a' to 'b' that is a composition+-- of several effectful functions. The paremeter r describes the overall+-- effect.+-- The composition members are accumulated in a type-aligned queue+type Arrs r a b = FTCQueue (Eff r) a b++-- | The Eff monad (not a transformer!). It is a fairly standard coroutine monad+-- where the type @r@ is the type of effects that can be handled, and the+-- missing type @a@ (from the type application) is the type of value that is+-- returned.  It is NOT a Free monad! There are no Functor constraints. ----- As is made explicit below, the `Eff` type is simply the Free monad resulting from the--- @`Union` r@ functor.+-- The two constructors denote the status of a coroutine (client): done with the+-- value of type a, or sending a request of type Union r with the continuation+-- Arrs r b a. Expressed another way: an `Eff` can either be a value (i.e.,+-- 'Val' case), or an effect of type @`Union` r@ producing another `Eff` (i.e.,+-- 'E' case). The result is that an `Eff` can produce an arbitrarily long chain+-- of @`Union` r@ effects, terminated with a pure value. -----     @type `Eff` r a = `Free` (`Union` r) a@-type Eff r = Free (Union r)+-- Potentially, inline Union into E+data Eff r a = Val a+             | forall b. E  (Union r b) (Arrs r b a) --- | Given a method of turning requests into results,--- we produce an effectful computation.-send :: Union r a -> Eff r a-send = freeImpure . (fmap freePure)-{-# INLINE send #-}+-- | Application to the `generalized effectful function' Arrs r b w+{-# INLINABLE qApp #-}+qApp :: Arrs r b w -> b -> Eff r w+qApp q x =+  case inline tviewl q of+    TOne k  -> k x+    k :| t -> case k x of+      Val y -> qApp t y+      E u q0 -> E u (q0 >< t) --- | Get the result from a pure computation.-run :: Eff Void w -> w-run = freeMap id-      (\_ -> error "extensible-effects: the impossible happened!")-{-# INLINE run #-}--- the other case is unreachable since Void has no constructors--- Therefore, run is a total function if m Val terminates.+{-+-- 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)+-} --- | 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-{-# INLINE handleRelay #-}+-- | Compose effectful arrows (and possibly change the effect!)+{-# INLINE qComp #-}+qComp :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arr r' a c+-- qComp g h = (h . (g `qApp`))+qComp g h = \a -> h $ qApp g a --- | 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+-- | Eff is still a monad and a functor (and Applicative)+-- (despite the lack of the Functor constraint)+instance Functor (Eff r) where+  {-# INLINE fmap #-}+  fmap f (Val x) = Val (f x)+  fmap f (E u q) = E u (q |> (Val . f)) -- does no mapping yet!++instance Applicative (Eff r) where+  pure = Val+  Val f <*> Val x = Val $ f x+  Val f <*> E u q = E u (q |> (Val . f))+  E u q <*> Val x = E u (q |> (Val . ($ x)))+  E u q <*> m     = E u (q |> (`fmap` m))++instance Monad (Eff r) where+  {-# INLINE return #-}+  {-# INLINE [2] (>>=) #-}+  return x = Val x+  Val x >>= k = k x+  E u q >>= k = E u (q |> k)          -- just accumulates continuations+{-+  Val _ >> m = m+  E u q >> m = E u (q |> const m)+-}++-- | 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 (inj t) (tsingleton Val)+-- 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 (inj t) (tsingleton k)+ #-}+++{-+-- The opposite of admin, occasionally useful+-- See the soft-cut for an example+-- It is currently quite inefficient. There are better ways+reflect :: VE a r -> Eff r a+reflect (Val x) = return x+reflect (E u) = Eff (\k -> E $ fmap (loop k) u)+ where+ loop :: (a -> VE w r) -> VE a r -> VE w r+ loop k (Val x) = k x+ loop k (E u)   = E $ fmap (loop k) u+-}+++-- ------------------------------------------------------------------------+-- | The initial case, no effects. Get the result from a pure computation.+--+-- The type of run ensures that all effects must be handled:+-- only pure computations may be run.+run :: Eff '[] w -> w+run (Val x) = x+-- | the other case is unreachable since Union [] a cannot be+-- constructed.+-- Therefore, run is a total function if its argument terminates.+run (E _ _) = error "extensible-effects: the impossible happened!"++-- | A convenient pattern: given a request (open union), either+-- handle it or relay it.+{-# INLINE handle_relay #-}+handle_relay :: (a -> Eff r w) ->+                (forall v. t v -> Arr r v w -> Eff r w) ->+                Eff (t ': r) a -> Eff r w+handle_relay ret h m = loop m+ where+  loop (Val x)  = ret x+  loop (E u q)  = case decomp u of+    Right x -> h x k+    Left  u0 -> E u0 (tsingleton k)+   where k = qComp q loop++-- | Parameterized handle_relay+{-# INLINE handle_relay_s #-}+handle_relay_s :: s ->+                (s -> a -> Eff r w) ->+                (forall v. s -> t v -> (s -> Arr r v w) -> Eff r w) ->+                Eff (t ': r) a -> Eff r w+handle_relay_s s ret h m = loop s m+  where+    loop s0 (Val x)  = ret s0 x+    loop s0 (E u q)  = case decomp u of+      Right x -> h s0 x k+      Left  u0 -> E u0 (tsingleton (k s0))+     where k s1 x = loop s1 $ qApp q x++-- | Add something like Control.Exception.catches? It could be useful+-- for control with cut.+--+-- Intercept the request and possibly reply to it, but leave it unhandled+-- (that's why we use the same r all throuout) {-# INLINE interpose #-}+interpose :: Member t r =>+             (a -> Eff r w) -> (forall v. t v -> Arr r v w -> Eff r w) ->+             Eff r a -> Eff r w+interpose ret h m = loop m+ where+   loop (Val x)  = ret x+   loop (E u q)  = case prj u of+     Just x -> h x k+     _      -> E u (tsingleton k)+    where k = qComp q loop

@@ -1,32 +1,39 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}+--{-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE Safe #-}--- | Nondeterministic choice effect-module Control.Eff.Choose( Choose (..)-                         , choose-                         , runChoice-                         , mzero'-                         , mplus'-                         ) where+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-} -import Data.Typeable-import Control.Monad (join)+-- The following is needed to define MonadPlus instance. It is decidable+-- (there is no recursion!), but GHC cannot see that.+{-# LANGUAGE UndecidableInstances #-} -import Control.Eff+-- | Nondeterministic choice effect+module Control.Eff.Choose ( Choose (..)+                          , choose+                          , makeChoice+                          , mzero'+                          , mplus'+                          ) where --- | Nondeterministic choice-data Choose v = forall a. Choose [a] (a -> v)-    deriving (Typeable)+import Control.Eff+import Data.OpenUnion -instance Functor Choose where-    fmap f (Choose lst k) = Choose lst (f . k)+-- ------------------------------------------------------------------------+-- | Non-determinism (choice)+--+-- choose lst non-deterministically chooses one value from the lst+-- choose [] thus corresponds to failure+-- Unlike Reader, Choose is not a GADT because the type of values+-- returned in response to a (Choose a) request is just a, without+-- any constraints.+newtype Choose a = Choose [a]  -- | 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 id+choose lst = send $ Choose lst  -- | MonadPlus-like operators are expressible via choose mzero' :: Member Choose r => Eff r a@@ -34,17 +41,25 @@  -- | 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]+mplus' m1 m2 = choose [m1,m2] >>= id --- | Run a nondeterministic effect, returning all values.-runChoice :: forall a r. Eff (Choose :> r) a -> Eff r [a]-runChoice = loop- where-  loop = freeMap-         (\x -> return [x])-         (\u -> handleRelay u loop (\(Choose lst k) -> handle lst k))+-- FIXME: find a way to uncomment+-- -- MonadPlus-like operators are expressible via choose+-- instance Member Choose r => Alternative (Eff r) where+--   empty     = choose []+--   m1 <|> m2 = choose [m1,m2] >>= id -  handle :: [t] -> (t -> Eff (Choose :> r) a) -> Eff r [a]-  handle [] _  = return []-  handle [x] k = loop (k x)-  handle lst k = concat `fmap` mapM (loop . k) lst+-- instance Member Choose r => MonadPlus (Eff r) where+--   mzero = empty+--   mplus = (<|>)++-- | Run a nondeterministic effect, returning all values.+makeChoice :: forall a r. Eff (Choose ': r) a -> Eff r [a]+makeChoice = handle_relay+  (return . (:[]))+  (\(Choose lst) k -> handle lst k)+  where+    handle :: [t] -> (t -> Eff r [a]) -> Eff r [a]+    handle []  _ = return []+    handle [x] k = k x+    handle lst k = fmap concat $ mapM k lst

@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE Safe #-} -- | Coroutines implemented with extensible effects module Control.Eff.Coroutine( Yield (..)@@ -10,19 +11,20 @@                             , Y (..)                             ) where -import Data.Typeable- import Control.Eff+import Data.OpenUnion +-- ------------------------------------------------------------------------+-- | 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 = Yield a (b -> v)  -- | 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 id+yield :: (Member (Yield a b) r) => a -> Eff r b+yield x = send (Yield x id)  -- | Status of a thread: done or reporting the value of the type a --   (For simplicity, a co-routine reports a value but accepts unit)@@ -33,14 +35,13 @@ -- --   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 a w = Y a (w -> Eff r (Y r a w))+             | Done --- | Launch a thread and report its status.-runC :: Typeable a => Eff (Yield a :> r) w -> Eff r (Y r a w)-runC = loop-  where-    loop = freeMap-           (return . Done)-           (\u -> handleRelay u loop $-                  \(Yield x k) -> return (Y x (loop . k)))++-- | Launch a thread and report its status+runC :: Eff (Yield a b ': r) w -> Eff r (Y r a b)+runC m = handle_relay+  (const $ return Done)+  (\(Yield a f) k -> return $ Y a (k . f))+   m

@@ -1,95 +0,0 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-#if __GLASGOW_HASKELL_ >= 708-{-# LANGUAGE TypeFamilies #-}-#endif-{-# LANGUAGE Safe #-}--- | 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 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 :: forall r a . Member Choose r => Eff (Exc CutFalse :> r) a -> Eff r a-call = loop [] where- loop jq = freeMap-           (\x -> return x `mplus'` next jq)          -- (C2)-           (\u -> case decomp u of-               Right (Exc CutFalse) -> mzero'  -- drop jq (F2)-               Left u' -> check jq u')-- check :: Member Choose r-          => [Eff (Exc CutFalse :> r) a]-          -> Union r (Eff (Exc CutFalse :> r) a)-          -> Eff r a- 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 :: Member Choose r-         => [Eff (Exc CutFalse :> r) a]-         -> Eff r a- next []    = mzero'- next (h:t) = loop t h

@@ -1,27 +1,31 @@+{-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE TypeOperators, GADTs, DataKinds #-} {-# LANGUAGE FlexibleContexts #-} --- | Example usage of "Control.Eff"+-- | Example usage of "Control.Eff1" module Control.Eff.Example where  import Control.Eff+import Data.OpenUnion+ import Control.Eff.State.Lazy import Control.Eff.Writer.Lazy-import Data.Typeable + -- | Write the elements of a list of numbers, in order.-writeAll :: (Typeable a, Member (Writer a) e)+writeAll :: (Member (Writer a) e)          => [a]          -> Eff e () writeAll = mapM_ tell  -- | Add a list of numbers to the current state.-sumAll :: (Typeable a, Num a, Member (State a) e)+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 :: (Member (Writer a) e, Member (State a) e, Num a, Typeable a)+writeAndAdd :: (Member (Writer a) e, Member (State a) e, Num a)             => [a]             -> Eff e () writeAndAdd l = do@@ -29,18 +33,37 @@     sumAll l  -- | Sum a list of numbers.-sumEff :: (Num a, Typeable a) => [a] -> a-sumEff l = let (s, ()) = run $ runState 0 $ sumAll l+sumEff :: (Num a) => [a] -> a+sumEff l = let ((), s) = run $ runState (sumAll l) 0            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 $ runLastWriter $ writeAll l+lastEff :: [a] -> Maybe a+lastEff l = let ((), a) = run $ runLastWriter $ 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 $ runLastWriter $ runState 0 $ writeAndAdd l+lastAndSum :: (Num a) => [a] -> (Maybe a, a)+lastAndSum l = let (((), total), lst) = run $ runLastWriter $ runState (writeAndAdd l) 0                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 u q) = case decomp u of+  Right Move -> handDown $ qApp q ()+  -- Relay other requests+  Left u0     -> E u0 ident >>= handUp . qApp q++handDown :: Eff (Move ': r) a -> Eff r a+handDown (Val x) = return x+handDown (E u q) = case decomp u of+  Right Move -> handUp $ qApp q ()+  -- Relay other requests+  Left u0     -> E u0 ident >>= handDown . qApp q

@@ -1,11 +1,11 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}+--{-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-} -- | Exception-producing and exception-handling effects-module Control.Eff.Exception( Exc (..)+module Control.Eff.Exception ( Exc (..)                             , Fail                             , throwExc                             , die@@ -21,25 +21,23 @@                             , ignoreFail                             ) where -import Control.Monad (void)-import Data.Typeable- import Control.Eff import Control.Eff.Lift+import Data.OpenUnion -#if __GLASGOW_HASKELL__ >= 708-#define Typeable1 Typeable-#endif+import Control.Monad (void) --- | These are exceptions of the type e. This is akin to the error monad.+-- ------------------------------------------------------------------------+-- | Exceptions+--+-- exceptions of the type e; no resumption newtype Exc e v = Exc e-    deriving (Functor, Typeable)  type Fail = Exc () --- | Throw an exception in an effectful computation.-throwExc :: (Typeable e, Member (Exc e) r) => e -> Eff r a-throwExc e = send . inj $ Exc e+-- | Throw an exception in an effectful computation. The type is inferred.+throwExc :: (Member (Exc e) r) => e -> Eff r a+throwExc e = send (Exc e) {-# INLINE throwExc #-}  -- | Makes an effect fail, preventing future effects from happening.@@ -48,34 +46,27 @@ {-# INLINE die #-}  -- | Run a computation that might produce an exception.-runExc :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a)-runExc = loop- where-  loop = freeMap-         (return . Right)-         (\u -> handleRelay u loop (\(Exc e) -> return (Left e)))+runExc :: Eff (Exc e ': r) a -> Eff r (Either e a)+runExc = handle_relay+  (return . Right)+  (\(Exc e) _k -> return (Left 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 :: Eff (Fail ': r) a -> Eff r (Maybe a) runFail = fmap (either (const Nothing) Just) . runExc {-# INLINE runFail #-} --- | 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 m- where-  loop = freeMap-         return-         (\u -> interpose u loop (\(Exc e) -> handle e))+-- | 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+catchExc :: Member (Exc e) r =>+        Eff r a -> (e -> Eff r a) -> Eff r a+catchExc m handle = interpose return (\(Exc e) _k -> handle e) 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.+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@@ -83,20 +74,19 @@  -- | Run a computation until it produces an exception, -- and convert and throw that exception in a new context.-rethrowExc :: (Typeable e, Typeable e', Member (Exc e') r)+rethrowExc :: (Member (Exc e') r)            => (e -> e')-           -> Eff (Exc e :> r) a+           -> Eff (Exc e ': r) a            -> Eff r a rethrowExc t eff = runExc eff >>= either (throwExc . t) return  -- | Treat Lefts as exceptions and Rights as return values.-liftEither :: (Typeable e, Member (Exc e) r) => Either e a -> Eff r a-liftEither (Left e) = throwExc e-liftEither (Right a) = return a+liftEither :: (Member (Exc e) r) => Either e a -> Eff r a+liftEither = either throwExc return {-# INLINE liftEither #-}  -- | `liftEither` in a lifted Monad-liftEitherM :: (Typeable1 m, Typeable e, Member (Exc e) r, SetMember Lift (Lift m) r)+liftEitherM :: (Member (Exc e) r, SetMember Lift (Lift m) r)             => m (Either e a)             -> Eff r a liftEitherM m = lift m >>= liftEither@@ -108,7 +98,7 @@ {-# INLINE liftMaybe #-}  -- | `liftMaybe` in a lifted Monad-liftMaybeM :: (Typeable1 m, Member Fail r, SetMember Lift (Lift m) r)+liftMaybeM :: (Member Fail r, SetMember Lift (Lift m) r)            => m (Maybe a)            -> Eff r a liftMaybeM m = lift m >>= liftMaybe@@ -116,7 +106,7 @@  -- | 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+ignoreFail :: Eff (Fail ': r) a            -> Eff r () ignoreFail e = void e `onFail` return () {-# INLINE ignoreFail #-}

@@ -1,32 +1,93 @@+--{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE Safe #-} -- | Create unique Enumerable values. module Control.Eff.Fresh( Fresh (..)                         , fresh-                        , runFresh+                        , runFresh'                         ) where -import Data.Typeable- import Control.Eff+import Data.OpenUnion +-- 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  -- | 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 id+fresh :: Member Fresh r => Eff r Int+fresh = send Fresh  -- | 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 m-  where-    loop s = freeMap-             return-             (\u -> handleRelay u (loop s) $-                    \(Fresh k) -> (loop $! succ s) (k s))+runFresh' :: Eff (Fresh ': r) w -> Int -> Eff r w+runFresh' m s =+  handle_relay_s s (\_s x -> return x)+                   (\s' Fresh k -> (k $! s' + 1) s')+                   m++{-+-- 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.+-}

@@ -1,68 +1,34 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} #else {-# LANGUAGE Safe #-} #endif-{-# LANGUAGE DeriveDataTypeable #-}-{-# OPTIONS -fno-warn-orphans #-} -- | 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 (..)+module Control.Eff.Lift ( Lift (..)                        , lift                        , runLift                        ) where  import Control.Eff-import Control.Monad.Base-import Control.Monad.IO.Class (MonadIO (..))-import Data.Typeable-import Data.Void--#if __GLASGOW_HASKELL__ >= 708-#define Typeable1 Typeable-#endif---- | Lift a Monad m to an effect.-data Lift m v = forall a. Lift (m a) (a -> v)-#if __GLASGOW_HASKELL__ >= 708-    deriving (Typeable) -- starting from ghc-7.8 Typeable can only be derived-#else--instance Typeable1 m => Typeable1 (Lift m) where-    typeOf1 _ = mkTyConApp (mkTyCon3 "" "Eff" "Lift")-                           [typeOf1 (undefined :: m ())]-#endif--instance Functor (Lift m) where-    fmap f (Lift m k) = Lift m (f . k)-    {-# INLINE fmap #-}--instance (Typeable1 m, MonadIO m, SetMember Lift (Lift m) r) => MonadIO (Eff r) where-    liftIO = lift . liftIO-    {-# INLINE liftIO #-}+import Data.OpenUnion -instance (MonadBase b m, Typeable1 m, SetMember Lift (Lift m) r) => MonadBase b (Eff r) where-    liftBase = lift . liftBase-    {-# INLINE liftBase #-}+-- ------------------------------------------------------------------------+-- | Lifting: emulating monad transformers+newtype Lift m a = Lift (m a) --- | Lift a Monad to an Effect.-lift :: (Typeable1 m, SetMember Lift (Lift m) r) => m a -> Eff r a-lift m = send . inj $ Lift m id+-- | We make the Lift layer to be unique, using SetMember+lift :: (SetMember Lift (Lift m) r) => m a -> Eff r a+lift = send . Lift  -- | 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 :> Void) w -> m w-runLift = loop-  where-    loop = freeMap-           return-           (\u -> prjForce u $ \(Lift m' k) -> m' >>= loop . k)+runLift :: Monad m => Eff '[Lift m] w -> m w+runLift (Val x) = return x+runLift (E u q) = case prj u of+                  Just (Lift m) -> m >>= runLift . qApp q+                  Nothing -> error "Impossible: Nothing cannot occur"

@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -Werror -fno-warn-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+-- The following is needed to define MonadPlus instance. It is decidable+-- (there is no recursion!), but GHC cannot see that.+{-# LANGUAGE UndecidableInstances #-}++-- | Another implementation of nondeterministic choice effect+module Control.Eff.NdetEff where++import Control.Eff+import Data.OpenUnion++import Control.Monad+import Control.Applicative++-- | A different implementation, more directly mapping to MonadPlus+-- interface+data NdetEff a where+  MZero :: NdetEff a+  MPlus :: NdetEff Bool++instance Member NdetEff r => Alternative (Eff r) where+  empty = mzero+  (<|>) = mplus++instance Member NdetEff r => MonadPlus (Eff r) where+  mzero = send MZero+  mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2++-- | 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+makeChoiceA0 :: Alternative f => Eff (NdetEff ': r) a -> Eff r (f a)+makeChoiceA0 = handle_relay (return . pure) $ \m k -> case m of+    MZero -> return empty+    MPlus -> liftM2 (<|>) (k True) (k False)++-- | A different implementation, more involved but faster and taking+-- much less (100 times) less memory.+-- The benefit of the effect framework is that we can have many+-- interpreters.+makeChoiceA :: Alternative f => Eff (NdetEff ': r) a -> Eff r (f a)+makeChoiceA m = loop [] m+ where+   loop [] (Val x)    = return (pure x)+   loop (h:t) (Val x) = loop t h >>= \r -> return (pure x <|> r)+   loop jq (E u q) = case  decomp u of+     Right MZero     -> case jq of+       []    -> return empty+       (h:t) -> loop t h+     Right MPlus -> loop (qApp q False : jq) (qApp q True)+     Left  u0 -> E u0 (single (\x -> loop jq (qApp q x)))++-- ------------------------------------------------------------------------+-- 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.++-- We actually implement LogicT, the non-determinism reflection,+-- of which soft-cut is one instance.+-- See the LogicT paper for an explanation+msplit :: Member NdetEff r => Eff r a -> Eff r (Maybe (a, Eff r a))+msplit = loop []+ where+ -- single result+ loop [] (Val x)  = return (Just (x,mzero))+ -- definite result and perhaps some others+ loop jq (Val x)  = return (Just (x, msum jq))+ -- not yet definite answer+ loop jq (E u q)  = case prj u of+  Just MZero -> case jq of+                   -- no futher choices+                   []     -> return Nothing+                   -- other choices remain, try them+                   (j:jqT) -> loop jqT j+  Just MPlus -> loop ((qApp q False):jq) (qApp q True)+  _      -> E u (single k) where k = qComp q (loop jq)++-- Other committed choice primitives can be implemented in terms of msplit+-- The following implementations are directly from the LogicT paper+ifte :: Member NdetEff r => Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b+ifte t th el = msplit t >>= check+ where check Nothing          = el+       check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th)++once :: Member NdetEff r => Eff r a -> Eff r a+once m = msplit m >>= check+ where check Nothing        = mzero+       check (Just (sg1,_)) = return sg1

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -22,42 +23,22 @@                                -- $usage                                ) where -import Data.Typeable import Control.Eff--#if __GLASGOW_HASKELL__ >= 708-#define Typeable1 Typeable-#endif+import Data.OpenUnion  -- | Lift values to an effect. -- You can think this is a generalization of @Lift@. data Program instr v = forall a. Program (instr a) (a -> v)-#if __GLASGOW_HASKELL__ >= 708-         deriving (Typeable) -- starting from ghc-7.8 Typeable can only be derived-#else -instance Typeable1 instr => Typeable1 (Program instr) where-    typeOf1 _ = mkTyConApp (mkTyCon3-                            "extensible-effects"-                            "Control.Eff.Operational"-                            "Program")-                           [typeOf1 (undefined :: instr ())]-#endif--instance Functor (Program instr) where-    fmap f (Program instr k) = Program instr (f . k)- -- | Lift a value to a monad.-singleton :: (Typeable1 instr, Member (Program instr) r) => instr a -> Eff r a-singleton instr = send . inj $ (Program instr) id+singleton :: (Member (Program instr) r) => instr a -> Eff r a+singleton instr = send $ (Program instr) id  -- | Convert values using given interpreter to effects.-runProgram :: Typeable1 f => (forall x. f x -> Eff r x) -> Eff (Program f :> r) a -> Eff r a-runProgram advent = loop where-  loop = freeMap-         return-         (\u -> handleRelay u loop (\ (Program instr k) -> advent instr >>= loop . k))-+runProgram :: (forall x. f x -> Eff r x) -> Eff (Program f ': r) a -> Eff r a+runProgram advent = handle_relay return h+  where+    h (Program instr v) k = advent instr >>= k . v  -- $usage --

@@ -2,13 +2,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}+-- {-# LANGUAGE Safe #-}  -- | Example usage of "Control.Eff.Operational". module Control.Eff.Operational.Example where  import Control.Eff.Operational-import Control.Eff+import Control.Eff (Eff(..))+import Data.OpenUnion import Control.Eff.Lift import Control.Eff.Writer.Lazy import Control.Eff.State.Lazy

@@ -1,52 +1,61 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-} -- | Lazy read-only state-module Control.Eff.Reader.Lazy( Reader (..)+module Control.Eff.Reader.Lazy ( Reader (..)                               , ask                               , local                               , reader                               , runReader                               ) where -import Data.Typeable- import Control.Eff+import Data.OpenUnion --- | 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)+-- ------------------------------------------------------------------------+-- | 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+--   Reader :: Reader e e+--+-- One can also define this as+--    data Reader e v = (e ~ v) => Reader+-- and even 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. + -- | Get the current value from a Reader.-ask :: (Typeable e, Member (Reader e) r) => Eff r e-ask = send . inj $ Reader id+-- The signature is inferred (when using NoMonomorphismRestriction).+ask :: (Member (Reader e) r) => Eff r e+ask = send $ Reader id --- | Locally rebind the value in the dynamic environment.--- This function both requests and handles Reader requests.-local :: (Typeable e, Member (Reader e) r)-      => (e -> e)-      -> Eff r a-      -> Eff r a-local f m = do-  e <- f `fmap` ask-  let loop = freeMap-             return-             (\u -> interpose u loop (\(Reader k) -> loop (k e)))-  loop m+-- | The handler of Reader requests. The return type shows that all Reader+-- requests are fully handled.+runReader :: Eff (Reader e ': r) w -> e -> Eff r w+runReader m e = handle_relay+  return+  (\(Reader f) k -> k (f e))+  m +-- | 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.+-- The underscore is used to disable name-shadowing warning.+local :: forall e a r. Member (Reader e) r =>+         (e -> e) -> Eff r a -> Eff r a+local _f m = do+  e <- reader _f+  let h (Reader _f) g = g (_f e)+  interpose return h m+ -- | Request the environment value using a transformation function.-reader :: (Typeable e, Member (Reader e) r) => (e -> a) -> Eff r a+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 m-  where-    loop = freeMap-           return-           (\u -> handleRelay u loop (\(Reader k) -> loop (k e)))

@@ -1,52 +1,61 @@-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-} -- | Strict read-only state-module Control.Eff.Reader.Strict( Reader (..)-                                , ask-                                , local-                                , reader-                                , runReader-                                ) where--import Data.Typeable+module Control.Eff.Reader.Strict ( Reader (..)+                              , ask+                              , local+                              , reader+                              , runReader+                              ) where  import Control.Eff+import Data.OpenUnion --- | 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)+-- ------------------------------------------------------------------------+-- | 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+--   Reader :: Reader e e+--+-- One can also define this as+--    data Reader e v = (e ~ v) => Reader+-- and even 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. + -- | Get the current value from a Reader.-ask :: (Typeable e, Member (Reader e) r) => Eff r e-ask = send . inj $ Reader id+-- The signature is inferred (when using NoMonomorphismRestriction).+ask :: (Member (Reader e) r) => Eff r e+ask = send $ Reader id --- | 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 :: Eff (Reader e ': r) w -> e -> Eff r w+runReader m !e = handle_relay+  return+  (\(Reader f) k -> k (f e))+  m++-- | 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 `fmap` ask-  let loop = freeMap-             return-             (\u -> interpose u loop (\(Reader k) -> loop (k e)))-  loop m+  e <- reader f+  let h (Reader f0) g = g (f0 e)+  interpose return h m  -- | Request the environment value using a transformation function.-reader :: (Typeable e, Member (Reader e) r) => (e -> a) -> Eff r a+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 m where-  loop = freeMap-         return-         (\u -> handleRelay u loop (\(Reader k) -> loop (k e)))

@@ -1,56 +1,144 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Werror #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} -- | 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.Writer.Lazy+import Control.Eff.Reader.Lazy+import Data.OpenUnion --- | Strict state effect-data State s w = State (s -> s) (s -> w)-  deriving (Typeable, Functor)+-- ------------------------------------------------------------------------+-- | 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 State s v where+  Get  :: State s s+  Put  :: s -> State s ()+  Delay :: Eff '[State s] a  -> State s a --  Eff as a transformer +-- | 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 id+onDemand :: Member (State s) r => Eff '[State s] v -> Eff r v+onDemand = send . Delay --- | Transform the state with a function.-modify :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r ()-modify f = send . inj $ State f $ const ()+runState' :: Eff (State s ': r) w -> s -> Eff r (w,s)+runState' m s =+  handle_relay_s s+  (\s0 x -> return (x,s0))+  (\s0 sreq k -> case sreq of+      Get    -> k s0 s0+      Put s1 -> k s1 ()+      Delay m1 -> let ~(x,s1) = run $ runState' m1 s0+                  in k s1 x)+  m --- | 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 = loop-  where-    loop s = freeMap-             (\x -> return (s, x))-             (\u -> handleRelay u (loop s) $-                    \(State t k) -> let s' = t s-                                    in loop s' (k s'))+-- Since State is so frequently used, we optimize it a bit+-- | Run a State effect+runState :: Eff (State s ': r) w -- ^ Effect incorporating State+         -> s                    -- ^ Initial state+         -> Eff r (w,s)          -- ^ Effect containing final state and a return value+runState (Val x) s = return (x,s)+runState (E u0 q) s0 = case decomp u0 of+  Right Get     -> runState (qApp q s0) s0+  Right (Put s1) -> runState (qApp q ()) s1+  Right (Delay m1) -> let ~(x,s1) = run $ runState m1 s0+                      in runState (qApp q x) s1+  Left  u -> E u (single (\x -> runState (qApp q x) s0)) +-- | Transform the state with a function.+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 :: Eff (State s ': r) w -> s -> Eff r w+evalState m s = fmap fst . flip runState s $ m  -- | Run a State effect and return the final state.-execState :: Typeable s => s -> Eff (State s :> r) w -> Eff r s-execState s = fmap fst . runState s+execState :: Eff (State s ': r) w -> s -> Eff r s+execState m s = fmap snd . flip runState s $ m++-- | A different representation of State: decomposing State into mutation+-- (Writer) and Reading. We don't define any new effects: we just handle the+-- existing ones.  Thus we define a handler for two effects together.+runStateR :: Eff (Writer s ': Reader s ': r) w -> s -> Eff r (w,s)+runStateR m0 s0 = loop s0 m0+ where+   loop :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s)+   loop s (Val x) = return (x,s)+   loop s (E u0 q) = case decomp u0 of+     Right (Writer w v) -> k w v+     Left  u  -> case decomp u of+       Right (Reader f) -> k s (f s)+       Left u1 -> E u1 (single (k s))+    where k x = qComp q (loop x)++-- | Backwards state+-- The overall state is represented with two attributes: the inherited+-- getAttr and the synthesized putAttr.+-- At the root node, putAttr becomes getAttr, tying the knot.+-- As usual, the inherited attribute is the argument (i.e., the `environment')+-- and the synthesized is the result of the handler |go| below.+runStateBack0 :: Eff '[State s] a -> (a,s)+runStateBack0 m =+  let (x,s) = go s m in+  (x,s)+ where+   go :: s -> Eff '[State s] a -> (a,s)+   go s (Val x) = (x,s)+   go s0 (E u q) = case decomp u of+         Right Get      -> go s0 $ qApp q s0+         Right (Put s1)  -> let ~(x,sp) = go sp $ qApp q () in (x,s1)+         Right (Delay m1) -> let ~(x,s1) = go s0 m1 in go s1 $ qApp q x+         Left _ -> error "Impossible happened: Union []"++-- | Another implementation, exploring Haskell's laziness to make putAttr+-- also technically inherited, to accumulate the sequence of+-- updates. This implementation is compatible with deep handlers, and+-- lets us play with different notions of `backwardness'+runStateBack :: Eff '[State s] a -> (a,s)+runStateBack m =+  let (x,(_sg,sp)) = run $ go (sp,[]) m in+  (x,head sp)+ where+   go :: ([s],[s]) -> Eff '[State s] a -> Eff '[] (a,([s],[s]))+   go ss = handle_relay_s ss (\ss0 x -> return (x,ss0))+                   (\ss0@(sg,sp) req k -> case req of+                       Get    -> k ss0 (head sg)+                       Put s1  -> k (tail sg,sp++[s1]) ()+                       Delay m1 -> let ~(x,ss1) = run $ go ss0 m1+                                   in k ss1 x)++-- ^ A different notion of `backwards' is realized if we change the Put+-- handler slightly. How?

@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++-- | On-demand state computation:+-- example taken from Edward Kmett's comment here:+-- <http://www.reddit.com/r/haskell/comments/387ex0/are_extensible_effects_a_complete_replacement_for/crt1pzm>+--+-- Extensible effects make it clear that where the computation is delayed and+-- they do maintain the degree of extensibility (the delayed computation must be+-- effect-closed, but the whole computation does not have to be).+module Control.Eff.State.LazyState where++import Control.Eff+import Data.OpenUnion++-- | Define a new effect for state on-demand (in ExtEff, the state is+-- by default strict -- as it should be if we want the predictable performance+-- and effect sequencing)+data LazyState s v where+  LGet  :: LazyState s s+  LPut  :: s -> LazyState s ()+  Delay :: Eff '[LazyState s] a  -> LazyState s a --  Eff as a transformer++-- | Primitive state operations+lget :: Member (LazyState s) r => Eff r s+lget = send LGet++lput :: Member (LazyState s) r => s -> Eff r ()+lput = send . LPut++lmodify :: (Member (LazyState s) r, Member (LazyState t) r)+        => (t -> s) -> Eff r ()+lmodify f = do+  s <- lget+  lput (f s)++onDemand :: Member (LazyState s) r => Eff '[LazyState s] v -> Eff r v+onDemand = send . Delay++-- | The handler+runStateLazy :: s -> Eff (LazyState s ': r) a -> Eff r (a,s)+runStateLazy s = handle_relay_s s (\s0 x -> return (x,s0))+                   (\s0 req k -> case req of+                       LGet    -> k s0 s0+                       LPut s1  -> k s1 ()+                       Delay m -> let ~(x,s1) = run $ runStateLazy s0 m+                                  in k s1 x)++-- | Backwards state+-- The overall state is represented with two attributes: the inherited+-- getAttr and the synthesized putAttr.+-- At the root node, putAttr becomes getAttr, tying the knot.+-- As usual, the inherited attribute is the argument (i.e., the `environment')+-- and the synthesized is the result of the handler |go| below.+runStateBack0 :: Eff '[LazyState s] a -> (a,s)+runStateBack0 m =+  let (x,s) = go s m in+  (x,s)+ where+   go :: s -> Eff '[LazyState s] a -> (a,s)+   go s (Val x) = (x,s)+   go s (E u q) = case decomp u of+         Right LGet      -> go s $ qApp q s+         Right (LPut s1)  -> let ~(x,sp) = go sp $ qApp q () in (x,s1)+         Right (Delay m1) -> let ~(x,s1) = go s m1 in go s1 $ qApp q x+         Left _ -> error "LazyState: the impossible happened"++-- | Another implementation, exploring Haskell's laziness to make putAttr+-- also technically inherited, to accumulate the sequence of+-- updates. This implementation is compatible with deep handlers, and+-- lets us play with different notions of `backwardness'+runStateBack :: Eff '[LazyState s] a -> (a,s)+runStateBack m =+  let (x,(_,sp)) = run $ go (sp,[]) m in+  (x,head sp)+ where+   go :: ([s],[s]) -> Eff '[LazyState s] a -> Eff '[] (a,([s],[s]))+   go ss = handle_relay_s ss (\ss1 x -> return (x,ss1))+                   (\ss1@(sg,sp) req k -> case req of+                       LGet    -> k ss1 (head sg)+                       LPut s  -> k (tail sg,sp++[s]) ()+                       Delay m1 -> let ~(x,ss2) = run $ go ss1 m1+                                  in k ss2 x)++-- A different notion of `backwards' is realized if we change the LPut+-- handler slightly. How?

@@ -1,70 +1,122 @@-{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} -- | Strict state effect------ Example: implementing `Control.Eff.Fresh`------ > 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--import Data.Typeable+module Control.Eff.State.Strict where  import Control.Eff+import Control.Eff.Writer.Strict+import Control.Eff.Reader.Strict+import Data.OpenUnion --- | Strict state effect-data State s w = State (s -> s) (s -> w)-  deriving (Typeable, Functor)+-- ------------------------------------------------------------------------+-- | State, strict+--+-- 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 () +-- | 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 id+runState' :: Eff (State s ': r) w -> s -> Eff r (w,s)+runState' m !s =+  handle_relay_s s (\s0 x -> return (x,s0))+                   (\s0 sreq k -> case sreq of+                       Get    -> k s0 s0+                       Put s1 -> k s1 ())+                   m --- | Transform the state with a function.-modify :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r ()-modify f = send . inj $ State f $ const ()+-- Since State is so frequently used, we optimize it a bit+-- | Run a State effect+runState :: Eff (State s ': r) w  -- ^ Effect incorporating State+         -> s                     -- ^ Initial state+         -> Eff r (w,s)           -- ^ Effect containing final state and a return value+runState (Val x) !s = return (x,s)+runState (E u q) !s = case decomp u of+  Right Get     -> runState (qApp q s) s+  Right (Put s1) -> runState (qApp q ()) s1+  Left  u1 -> E u1 (single (\x -> runState (qApp q x) s)) --- | 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 = loop-  where-    loop !s = freeMap-              (\x -> return (s, x))-              (\u -> handleRelay u (loop s) $-                     \(State t k) -> let s' = t s-                                     in loop s' (k s'))+-- | Transform the state with a function.+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 :: Eff (State s ': r) w -> s -> Eff r w+evalState m !s = fmap fst . flip runState s $ m  -- | Run a State effect and return the final state.-execState :: Typeable s => s -> Eff (State s :> r) w -> Eff r s-execState s = fmap fst . runState s+execState :: Eff (State s ': r) w -> s -> Eff r s+execState m !s = fmap snd . flip runState s $ m++-- | An encapsulated State handler, for transactional semantics+-- The global state is updated only if the transactionState finished+-- successfully+data ProxyState s = ProxyState+transactionState :: forall s r w. Member (State s) r =>+                    ProxyState s -> Eff r w -> Eff r w+transactionState _ m = do s <- get; loop s m+ where+   loop :: s -> Eff r w -> Eff r w+   loop s (Val x) = put s >> return x+   loop s (E (u::Union r b) q) = case prj u :: Maybe (State s b) of+     Just Get      -> loop s (qApp q s)+     Just (Put s') -> loop s'(qApp q ())+     _      -> E u (single k) where k = qComp q (loop s)++-- | A different representation of State: decomposing State into mutation+-- (Writer) and Reading. We don't define any new effects: we just handle the+-- existing ones.  Thus we define a handler for two effects together.+runStateR :: Eff (Writer s ': Reader s ': r) w -> s -> Eff r (w,s)+runStateR m !s = loop s m+ where+   loop :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s)+   loop s0 (Val x) = return (x,s0)+   loop s0 (E u q) = case decomp u of+     Right (Writer w v) -> k w v+     Left  u1  -> case decomp u1 of+       Right (Reader f) -> k s0 (f s0)+       Left u2 -> E u2 (single (k s0))+    where k x = qComp q (loop x)

@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -Werror #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs, DataKinds #-} {-# LANGUAGE Safe #-} -- | A Trace effect for debugging module Control.Eff.Trace( Trace (..)@@ -9,23 +11,22 @@                         , runTrace                         ) where -import Data.Typeable-import Data.Void- import Control.Eff+import Data.OpenUnion  -- | Trace effect for debugging-data Trace v = Trace String (() -> v)-    deriving (Typeable, Functor)+data Trace v where+  Trace :: String -> Trace ()  -- | Print a string as a trace. trace :: Member Trace r => String -> Eff r ()-trace x = send . inj $ Trace x id+trace = send . Trace  -- | Run a computation producing Traces.-runTrace :: Eff (Trace :> Void) w -> IO w-runTrace = loop-  where-    loop = freeMap-           return-           (\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 (Val x) = return x+runTrace (E u q) = case decomp u of+     Right (Trace s) -> putStrLn s >> runTrace (qApp q ())+     -- Nothing more can occur+     Left _ -> error "runTrace: the impossible happened!"

@@ -1,61 +1,68 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}--- | Lazy write-only state.-module Control.Eff.Writer.Lazy( Writer (..)-                              , tell-                              , censor-                              , runWriter-                              , runFirstWriter-                              , runLastWriter-                              , runMonoidWriter-                              ) where--import Data.Typeable-import Control.Applicative ((<|>))-import Data.Monoid+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+-- | Lazy write-only state+module Control.Eff.Writer.Lazy ( Writer(..)+                               , tell+                               , censor+                               , runWriter+                               , runFirstWriter+                               , runLastWriter+                               , runListWriter+                               , runMonoidWriter+                               ) where  import Control.Eff+import Data.OpenUnion --- | The request to remember a value of type w in the current environment+import Data.Monoid+import Control.Applicative ((<|>))++-- ------------------------------------------------------------------------+-- | 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 = Writer w v-    deriving (Typeable, Functor)  -- | Write a new value.-tell :: (Typeable w, Member (Writer w) r) => w -> Eff r ()-tell w = send . inj $ Writer w ()+tell :: Member (Writer w) r => w -> Eff r ()+tell w = send $ Writer w ()  -- | Transform the state being produced.-censor :: (Typeable w, Member (Writer w) r) => (w -> w) -> Eff r a -> Eff r a-censor f = loop+censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a+censor f = interpose return h   where-    loop = freeMap-           return-           (\u -> interpose u loop-                  $ \(Writer w v) -> tell (f w) >> loop v)+    h (Writer w v) k = tell (f w) >> k v --- | 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-  where-    first f (x, y) = (f x, y) -    loop = freeMap-           (\x -> return (b, x))-           (\u -> handleRelay u loop-                  $ \(Writer w v) -> first (accum w) `fmap` 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 = handle_relay+  (\x -> return (x, b))+  (\(Writer w v) k -> k v >>= \(x, l) -> return (x, w `accum` l))+  -- the second arg to 'handle_relay' above is same as:+  -- (\(Writer w v) k -> second (accum w) `fmap` k v)+  -- where+  --   second f (x, y) = (x, f y) +-- | 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

@@ -1,62 +1,69 @@-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}--- | Strict write-only state.-module Control.Eff.Writer.Strict( Writer (..)-                                , tell-                                , censor-                                , runWriter-                                , runFirstWriter-                                , runLastWriter-                                , runMonoidWriter-                                ) where--import Data.Typeable-import Control.Applicative ((<|>))-import Data.Monoid+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+-- | Strict write-only state+module Control.Eff.Writer.Strict ( Writer(..)+                               , tell+                               , censor+                               , runWriter+                               , runFirstWriter+                               , runLastWriter+                               , runListWriter+                               , runMonoidWriter+                               ) where  import Control.Eff+import Data.OpenUnion --- | The request to remember a value of type w in the current environment+import Data.Monoid+import Control.Applicative ((<|>))++-- ------------------------------------------------------------------------+-- | 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 = Writer !w v-    deriving (Typeable, Functor)  -- | Write a new value.-tell :: (Typeable w, Member (Writer w) r) => w -> Eff r ()-tell !w = send . inj $ Writer w ()+tell :: Member (Writer w) r => w -> Eff r ()+tell !w = send $ Writer w ()  -- | Transform the state being produced.-censor :: (Typeable w, Member (Writer w) r) => (w -> w) -> Eff r a -> Eff r a-censor f = loop+censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a+censor f = interpose return h   where-    loop = freeMap-           return-           (\u -> interpose u loop-                  $ \(Writer w v) -> tell (f w) >> loop v)+    h (Writer w v) k = tell (f w) >> k v --- | 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-  where-    first f (x, y) = (f x, y) -    loop = freeMap-           (\x -> return (b, x))-           (\u -> handleRelay u loop-                  $ \(Writer w v) -> first (accum w) `fmap` 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 = handle_relay+  (\x -> return (x, b))+  (\(Writer w v) k -> k v >>= \(x, l) -> return (x, w `accum` l))+  -- the second arg to 'handle_relay' above is same as:+  -- (\(Writer o) k -> second (accum o) `fmap` k ())+  -- where+  --   second f (x, y) = (x, f y) +-- | 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

@@ -1,89 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GADTs #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE AutoDeriveTypeable #-}-#endif-{-# LANGUAGE Safe #-}--module Control.Monad.Free.Reflection(-  Free-  , freePure-  , freeImpure-  , freeMap-  , FreeView (..)-  , fromView-  , toView-  ) where--import Control.Arrow (Kleisli (..))-import qualified Data.OpenUnion.Imports as P-import Control.Monad-import Data.TASequence-import Data.TASequence.FastCatQueue (FastTCQueue)---- | Specific type-aligned sequence used to store chain of monadic binds.-type TCQ = FastTCQueue---- | Type used to denote monadic chain of binds. As expected this builds on the--- Kleisli representation.-type FreeExp f a b = TCQ (Kleisli (Free f)) a b---- | The abstract Free datatype. Original work available at--- <http://okmij.org/ftp/Haskell/AlgorithmsH1.html#reflection-without-remorse>.-data Free f a =-  forall x. Free (FreeView f x) (FreeExp f x a)---- | Inject a pure value into Free-freePure :: a -> Free f a-freePure = fromView . Pure---- | Inject an impure value into Free-freeImpure :: f (Free f a) -> Free f a-freeImpure = fromView . Impure---- | Case analysis for the 'Free' construction. Similar in spirit to 'either'--- and 'maybe'.-freeMap :: Functor f-           => (a -> t) -- ^ function to be applied if value is Pure-           -> (f (Free f a) -> t) -- ^ function to be applied on Impure value-           -> Free f a -- ^ Free value to be mapped over-           -> t -- ^ result-freeMap f g mx = case toView mx of-  Pure x -> f x-  Impure u -> g u--instance Functor f => Functor (Free f) where-  fmap = liftM-instance Functor f => P.Applicative (Free f) where-  pure = return-  (<*>) = ap-instance Functor f => Monad (Free f) where-  return = freePure-  mx >>= f = mx ^>>= tsingleton (Kleisli f)---- | The traditional 'view' of Free constructions-data FreeView f a = Pure a -- ^ case embedding pure values-                  | Impure (f (Free f a)) -- ^ case embedding impure values-                                          -- nested in @f@. Traditionally this-                                          -- is the @Control.Monad.Free.Free@-                                          -- constructor, but that's confusing.---- | A way to get a 'Free' construction from the view by constructing an--- explicit expression with one element.-fromView :: FreeView f a -> Free f a-fromView x = Free x tempty---- | A way to evaluate the 'Free' construction to its view (i.e., head normal--- form). This includes the logic to perform one level of monadic bind as needed--- from the 'FreeExp' representation.-toView :: Functor f => Free f a -> FreeView f a-toView (Free h t) = case h of-  Pure x -> case tviewl t of-    TAEmptyL -> Pure x-    hc :< tc -> toView (runKleisli hc x ^>>= tc)-  Impure f -> Impure (fmap (^>>= t) f)---- | The essence of monadic '>>=', i.e., append/concatenation (of sorts)-(^>>=) :: Free f a -> FreeExp f a b -> Free f b-(Free x ys) ^>>= r = Free x (ys >< r)

@@ -0,0 +1,57 @@+{-# LANGUAGE GADTs #-}+{-# 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(..),+  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++{-# 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)

@@ -1,107 +1,189 @@ {-# OPTIONS_HADDOCK show-extensions #-} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-} --- Only for SetMember below, when emulating Monad Transformers-{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}+{-# OPTIONS_GHC -Wwarn #-}  #if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wwarn -Wno-redundant-constraints #-} #endif -#if __GLASGOW_HASKELL__ >= 708-#define Typeable1 Typeable+#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+{-# LANGUAGE OverlappingInstances #-}+#else #endif--- | Original work at <http://okmij.org/ftp/Haskell/extensible/OpenUnion1.hs>--- and <http://okmij.org/ftp/Haskell/extensible/OpenUnion2.hs>.--- Open unions (type-indexed co-products) for extensible effects.++-- Only for MemberU 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 ----- TODO: see if we can do away with Typeable constraints, perhaps by--- incorporating ideas from <http://okmij.org/ftp/Haskell/extensible/TList.hs>-module Data.OpenUnion(-  -- * Classes-  -- | @`Member` t r@ specifies whether @t@ is present anywhere in the sum type-  -- @r@, where @t@ is some effectful type, e.g. @`Lift` `IO`@, @`State` Int`@-  Member-  -- ** Monad transformer related-  -- | @`SetMember` set t r@ is used to emulate monad transformers.-  , SetMember-    -- * Type-indexed co-product-    -- ** Datatypes-  , Union-  , (:>)-    -- ** Functions-  , inj-  , prj-  , prjForce-  , decomp-  , unsafeReUnion-  , weaken-  ) where+-- 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, decomp,+                   Member, SetMember, weaken+                  ) where -import Data.OpenUnion.Imports-import Data.Typeable+import Unsafe.Coerce(unsafeCoerce) -infixl 4 <?>+-- The data constructors of Union are not exported --- | infix form of `fromMaybe`.-(<?>) :: Maybe a -> a -> a-Just a <?> _ = a-_ <?> a = a+-- 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 --- | for the sake of @gcast1@ used below in @`prj`@-newtype Id a = Id { runId :: a }-  deriving Typeable+{-# INLINE prj' #-}+{-# INLINE inj' #-}+inj' :: Int -> t v -> Union r v+inj' = Union --- | `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:+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}++class (FindElem t r) => Member (t :: * -> *) r where+  inj :: t v -> Union r v+  prj :: Union r v -> Maybe (t v)++#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51+{-+-- Optimized specialized instance+instance Member t '[t] where+  {-# INLINE inj #-}+  {-# INLINE prj #-}+  inj x           = Union 0 x+  prj (Union _ x) = Just (unsafeCoerce x)+-}+instance (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))+#else+-- | Explicit type-level equality condition is a dirty+-- hack to eliminate the type annotation in the trivial case,+-- such as @run (runReader get ())@. ----- > -- 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 (MemberU set t r) => SetMember set t r+-- 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) -{-# INLINE inj #-}--- | Construct a Union.-inj :: (Functor t, Typeable1 t, Member t r) => t v -> Union r v-inj = Union+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))+#endif -{-# 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 `fmap` 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 `fmap` 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 `fmap` prj u <?> Left (unsafeReUnion u)+{-# INLINE [2] decomp #-}+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 -{-# INLINE weaken #-}-weaken :: (Typeable1 t, Functor t) => Union r w -> Union (t :> r) w-weaken (Union x) = Union x -{-# INLINE unsafeReUnion #-}--- | Juggle types for a Union. Use cautiously.-unsafeReUnion :: Union r w -> Union t w-unsafeReUnion (Union v) = Union v+-- 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 an index of an element in a `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++#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51+instance FindElem t (t ': r) where+#else+-- Stopped Using Obsolete -XOverlappingInstances+-- and explicitly specify to choose the topmost+-- one for multiple occurence, which is the same+-- behaviour as OpenUnion51 with GHC 7.10.+instance {-# INCOHERENT  #-} t ~ s => FindElem t '[s] where+  elemNo = P 0+instance {-# INCOHERENT #-} FindElem t (t ': r) where+#endif+  elemNo = P 0++#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51+instance FindElem t r => FindElem t (t' ': r) where+#else+instance {-# OVERLAPPABLE #-} FindElem t r => FindElem t (t' ': r) where+#endif+  elemNo = P $ 1 + (unP $ (elemNo :: P t r))+++-- | 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 (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)

@@ -1,26 +0,0 @@-{-# OPTIONS_HADDOCK ignore-exports, show-extensions #-}--{-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}---- For 'Member' and 'MemberU' aliases below-{-# LANGUAGE ConstraintKinds, PolyKinds #-}--module Data.OpenUnion.Imports( Applicative(..)-                             , module Impl-                             , Member-                             , MemberU-                             ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative(Applicative(..))-#endif-#if __GLASGOW_HASKELL__ >= 708-import Data.OpenUnion.Internal.OpenUnion2 as Impl-type Member = MemberImpl OU2-type MemberU = MemberUImpl OU2-#else-import Data.OpenUnion.Internal.OpenUnion1 as Impl-type Member = MemberImpl OU1-type MemberU = MemberUImpl OU1-#endif

@@ -1,70 +0,0 @@-{-# OPTIONS_HADDOCK hide, show-extensions #-}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE MultiParamTypeClasses, ConstraintKinds, UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE PolyKinds, FunctionalDependencies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE Trustworthy #-} -- GHC.Exts.Constraint makes module not 'Safe'--#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE UndecidableSuperClasses #-}-#endif--#if __GLASGOW_HASKELL__ >= 708-#define Typeable1 Typeable-#endif---- | Adapted from <http://okmij.org/ftp/Haskell/extensible/OpenUnion1.hs> and--- <http://okmij.org/ftp/Haskell/extensible/OpenUnion2.hs>-module Data.OpenUnion.Internal.Base(-  -- * Datatypes-  Union (..)-  , (:>)-  -- * Classes-  , MemberConstraint-  , MemberImpl-  -- ** Monad transformer related-  , MemberUConstraint-  , MemberUImpl-  ) where--import Data.Typeable-import GHC.Exts (Constraint)---- | Parameter @r@ is phantom: it just tells what could be in the union.--- Where @r@ is @t1 :> t2 ... :> tn@, @`Union` r v@ can be constructed with a--- value of type @ti v@.--- Ideally, we should be able to add the constraint @`Member` t r@.------ NOTE: exposing the constructor below allows users to bypass the type--- system. See 'Data.OpenUnion.unsafeReUnion' for example.-data Union (r :: *) (v :: *) =-  forall t. (Functor t, Typeable1 t) => Union (t v)-  deriving Typeable--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 :: *))-#if __GLASGOW_HASKELL__ >= 708-  deriving Typeable-#endif--type family MemberConstraint impl (t :: * -> *) r :: Constraint--- | The @`MemberImpl` impl t r@ specifies whether @t@ is present anywhere in--- the sum type @r@, where @t@ is some effectful type--- (e.g. @`Lift` `IO`@, @`State` Int`@), for a particular implementation ('impl'--- label, eg. 'OU1' representing 'OpenUnion1').-class (MemberConstraint impl t r) => MemberImpl impl (t :: * -> *) r--type family MemberUConstraint impl (t :: * -> *) r :: Constraint--- | This class is used for emulating monad transformers-class MemberUConstraint impl (t :: * -> *) r-      => MemberUImpl impl (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t

@@ -1,34 +0,0 @@-{-# OPTIONS_HADDOCK hide, show-extensions #-}--{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Safe #-}---- Only for MemberU below, when emulating Monad Transformers-{-# LANGUAGE OverlappingInstances, 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.OpenUnion.Internal.OpenUnion1( OU1-                                         , module Base-                                         ) where--import Data.OpenUnion.Internal.Base as Base---- | Label to represent 'OpenUnion1' implementation-data OU1---- | @`MemberImpl` OU1 t r@ specifies whether @t@ is present anywhere in the--- sum type @r@, where @t@ is some effectful type-type instance MemberConstraint OU1 t r = ()-instance MemberImpl OU1 t (t :> r)-instance MemberImpl OU1 t r => MemberImpl OU1 t (t' :> r)---- | For emulating monad transformers-type instance MemberUConstraint OU1 t r = (MemberImpl OU1 t r)-instance MemberUImpl OU1 tag (tag e) (tag e :> r)-instance MemberUImpl OU1 tag t r => MemberUImpl OU1 tag t (t' :> r)

@@ -1,59 +0,0 @@-{-# OPTIONS_HADDOCK hide, show-extensions #-}--{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds, PolyKinds #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Safe #-}---- Only for MemberU below, when emulating Monad Transformers-{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}--{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE UndecidableSuperClasses #-}-#endif----- | Original work at <http://okmij.org/ftp/Haskell/extensible/OpenUnion2.hs>.--- Open unions (type-indexed co-products) for extensible effects.--- This implementation relies on _closed_ type families added to GHC 7.8. It has--- NO overlapping instances-module Data.OpenUnion.Internal.OpenUnion2( OU2-                                         , module Base-                                         ) where--import Data.OpenUnion.Internal.Base as Base---- | Label to represent 'OpenUnion1' implementation-data OU2---- | Instance MemberImpl is defined only for the sake of the interface--- compatibility with OpenUnion1. Generally, the closed type family Member'--- below could be used instead.------ @`MemberImpl` OU2 t r@ specifies whether @t@ is present anywhere in the sum--- type @r@, where @t@ is some effectful type-type instance MemberConstraint OU2 t r = (Member' t r ~ 'True)-instance (MemberConstraint OU2 t r) => MemberImpl OU2 t r--type family Member' (t :: * -> *) r :: Bool where-  Member' t (t :> r)  = 'True-  Member' t ()        = 'False-  Member' t (t' :> r) = Member' t r--type family EQU (a :: k) (b :: k) :: Bool where-  EQU a a = 'True-  EQU a b = 'False---- | For emulating monad transformers-type instance MemberUConstraint OU2 t r = (MemberImpl OU2 t r)-instance (MemberU' (EQU t1 t2) tag t1 (t2 :> r)) => MemberUImpl OU2 tag t1 (t2 :> r)--class MemberImpl OU2 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) ~ 'True, MemberUImpl OU2 tag t r) =>-           MemberU' 'False tag t (t' :> r)

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