extensible-effects 3.1.0.2 → 4.0.0.0

raw patch · 41 files changed

+1244/−711 lines, 41 filesdep −transformersdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies removed: transformers

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +1/−6
• extensible-effects.cabal +6/−19
• src/Control/Eff.hs +5/−0
• src/Control/Eff/Choose.hs +25/−11
• src/Control/Eff/Coroutine.hs +10/−6
• src/Control/Eff/Cut.hs +8/−2
• src/Control/Eff/Example.hs +4/−4
• src/Control/Eff/Exception.hs +23/−11
• src/Control/Eff/Extend.hs +13/−3
• src/Control/Eff/Fresh.hs +18/−13
• src/Control/Eff/Internal.hs +191/−87
• src/Control/Eff/Lift.hs +0/−40
• src/Control/Eff/Logic.hs +93/−0
• src/Control/Eff/NdetEff.hs +55/−46
• src/Control/Eff/Operational.hs +12/−5
• src/Control/Eff/Operational/Example.hs +2/−4
• src/Control/Eff/Reader/Lazy.hs +14/−11
• src/Control/Eff/Reader/Strict.hs +19/−16
• src/Control/Eff/State/Lazy.hs +39/−28
• src/Control/Eff/State/OnDemand.hs +28/−31
• src/Control/Eff/State/Strict.hs +38/−30
• src/Control/Eff/Trace.hs +15/−5
• src/Control/Eff/Writer/Lazy.hs +17/−13
• src/Control/Eff/Writer/Strict.hs +16/−13
• src/Data/OpenUnion.hs +0/−36
• test/Control/Eff/Choose/Test.hs +4/−2
• test/Control/Eff/Coroutine/Test.hs +9/−9
• test/Control/Eff/Exception/Test.hs +0/−1
• test/Control/Eff/Fresh/Test.hs +3/−3
• test/Control/Eff/Lift/Test.hs +0/−220
• test/Control/Eff/NdetEff/Bench.hs +340/−0
• test/Control/Eff/NdetEff/Test.hs +29/−27
• test/Control/Eff/Reader/Lazy/Test.hs +0/−1
• test/Control/Eff/Reader/Strict/Test.hs +0/−1
• test/Control/Eff/State/Lazy/Test.hs +0/−1
• test/Control/Eff/State/OnDemand/Test.hs +0/−1
• test/Control/Eff/State/Strict/Test.hs +0/−1
• test/Control/Eff/Test.hs +207/−0
• test/Control/Eff/Writer/Lazy/Test.hs +0/−1
• test/Control/Eff/Writer/Strict/Test.hs +0/−1
• test/Test.hs +0/−2

@@ -1,5 +1,5 @@ -# Extensible effects (![Hackage](https://img.shields.io/hackage/v/extensible-effects.svg))+# Extensible effects (![Hackage](https://img.shields.io/hackage/v/extensible-effects.svg), ![GHC](https://img.shields.io/badge/GHC-8.02%20%7C%208.2.2%20%7C%208.4.4%20%7C%208.6.2-blue.svg))  [![Build Status](https://travis-ci.org/suhailshergill/extensible-effects.svg?branch=master)](https://travis-ci.org/suhailshergill/extensible-effects) [![Join the chat at https://gitter.im/suhailshergill/extensible-effects](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/suhailshergill/extensible-effects?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)@@ -310,8 +310,3 @@     point of having the grouping in the first place.   * Code requires a greater number of type annotations. For details see     [#31](https://github.com/suhailshergill/extensible-effects/issues/31).--### Current implementation only supports GHC version 7.8 and above-This is not a fundamental limitation of the design or the approach, but there is-an overhead with making the code compatible across a large number of GHC-versions. If this is needed, patches are welcome :)

@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             3.1.0.2+version:             4.0.0.0  -- A short (one-line) description of the package. synopsis:            An Alternative to Monad Transformers@@ -41,7 +41,7 @@  category:            Control, Effect -tested-with:         GHC==8.4.3, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4+tested-with:         GHC==8.6.2, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2  build-type:          Simple @@ -56,11 +56,6 @@   default: False   manual: True -flag force-openunion-51-  description:         Force usage of OpenUnion51.hs implementation-  default:             False-  manual:              True- library   ghc-options:         -Wall   -- Modules exported by the library.@@ -71,7 +66,7 @@                        Control.Eff.Example                        Control.Eff.Exception                        Control.Eff.Fresh-                       Control.Eff.Lift+                       Control.Eff.Logic                        Control.Eff.NdetEff                        Control.Eff.Operational                        Control.Eff.Operational.Example@@ -90,8 +85,6 @@   -- Modules included in this library but not exported.   other-modules:       Control.Eff.Internal                        Data.FTCQueue-  if flag(force-openunion-51)-    cpp-options:       -DFORCE_OU51    default-extensions:  NoMonomorphismRestriction                      , MonoLocalBinds@@ -128,8 +121,6 @@                        , Trustworthy                        , TypeOperators                        , UndecidableInstances-  if impl(ghc < 7.8.1)-     other-extensions: OverlappingInstances   if impl(ghc >= 8.2)      ghc-options:      -Wno-simplifiable-class-constraints @@ -139,9 +130,6 @@                ,       transformers-base == 0.4.*                        -- For MonadBaseControl                ,       monad-control >= 1.0 && < 1.1-  if impl(ghc < 8.0)-                       -- For MonadIO-     build-depends:    transformers >= 0.2.0.0    -- Directories containing source files.   hs-source-dirs:      src@@ -149,8 +137,6 @@   -- Base language which the package is written in.   default-language:    Haskell2010 -  -- TODO: uncomment when https://github.com/haskell/cabal/issues/2527 is-  -- resolved   if flag(lib-Werror)      ghc-options: -Werror @@ -166,7 +152,7 @@                 , Control.Eff.Example.Test                 , Control.Eff.Exception.Test                 , Control.Eff.Fresh.Test-                , Control.Eff.Lift.Test+                , Control.Eff.NdetEff.Bench                 , Control.Eff.NdetEff.Test                 , Control.Eff.Operational.Test                 , Control.Eff.Reader.Lazy.Test@@ -190,6 +176,7 @@               , QuickCheck               , HUnit               , monad-control >= 1.0+              , mtl               , silently >= 1.2               , test-framework == 0.8.*               , test-framework-hunit == 0.3.*@@ -225,7 +212,7 @@                        -fno-warn-name-shadowing -fno-warn-unused-matches    build-depends:-                base >= 4.7 && < 4.12+                base >= 4.7 && < 5               , criterion               , extensible-effects               , mtl

@@ -24,6 +24,11 @@   ( -- * Effect type     Internal.run   , Internal.Eff+    -- * Lift IO computations+  , Internal.lift, Internal.runLift+  , Internal.catchDynE+  , Internal.HandlerDynE(..), Internal.catchesDynE+  , Internal.Lift(..), Internal.Lifted, Internal.LiftedBase     -- * Effect list   , OpenUnion.Member   , OpenUnion.SetMember

@@ -12,15 +12,17 @@  -- | Nondeterministic choice effect module Control.Eff.Choose ( Choose (..)+                          , withChoose                           , choose                           , makeChoice                           , mzero'                           , mplus'+                          , module Control.Eff.Logic                           ) where  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift+import Control.Eff.Logic        import Control.Applicative import Control.Monad@@ -37,9 +39,17 @@ -- any constraints. newtype Choose a = Choose [a] +-- | Embed a pure value+withChoose :: Monad m => a -> m [a]+withChoose = return . (:[])+-- | Given a continuation and a Choose request, respond to it.+instance Monad m => Handle Choose (m [a]) where+  handle _ (Choose []) = return []+  handle k (Choose [x]) = k x+  handle k (Choose lst) = fmap concat $ mapM k lst+ instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (Choose ': r)) where     type StM (Eff (Choose ': r)) a = StM (Eff r) [a]     liftBaseWith f = raise $ liftBaseWith $ \runInBase ->@@ -71,11 +81,15 @@  -- | 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+makeChoice = handle_relay withChoose++instance Member Choose r => MSplit (Eff r) where+  msplit = respond_relay (flip withMSplit empty)+           (\k (Choose lst) -> hdl k lst)+    where+      hdl :: Arr r v (Maybe (a, Eff r a))+          -> [v] -> Eff r (Maybe (a, Eff r a))+      hdl _ [] = return Nothing             -- definite failure+      hdl k (h:t) = k h >>= \r -> case r of -- possibility+        Nothing -> hdl k t                  -- failure, continue exploring+        Just (a, m) -> withMSplit a (m <|> (hdl k t >>= reflect)) -- definite success

@@ -5,6 +5,7 @@ {-# LANGUAGE Safe #-} -- | Coroutines implemented with extensible effects module Control.Eff.Coroutine( Yield (..)+                            , withCoroutine                             , yield                             , runC                             , Y (..)@@ -35,13 +36,16 @@ -- --   Type parameter @w@ is the type of the value returned from the --   coroutine when it has completed.-data Y r a w = Y a (w -> Eff r (Y r a w))+data Y r w a = Y (w -> Eff r (Y r w a)) a              | Done +-- | Return a pure value+withCoroutine :: Monad m => b -> m (Y r w a)+withCoroutine = const $ return Done+-- | Given a continuation and a request, respond to it+instance Handle (Yield a b) (Eff r (Y r b a)) where+  handle k (Yield a) = return $ Y k a  -- | 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) k -> return $ Y a k)-   m+runC :: Eff (Yield a b ': r) w -> Eff r (Y r b a)+runC = handle_relay withCoroutine

@@ -44,12 +44,18 @@ import Control.Eff.Extend import Control.Eff.Exception import Control.Eff.Choose+import Control.Monad  data CutFalse = CutFalse  cutfalse :: Member (Exc CutFalse) r => Eff r a cutfalse = throwError CutFalse +-- | Prolog 'cut', taken from Hinze 2000 (Deriving backtracking monad+-- transformers).+(!) :: (Member (Exc CutFalse) r, MonadPlus (Eff r)) => Eff r ()+(!) = return () `mplus` cutfalse+ -- | 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@@ -66,7 +72,7 @@        -> Eff (Exc CutFalse ': r) a        -> Eff r a   loop jq (Val x) = return x `mplus'` next jq          -- (C2)-  loop jq (E u q) = case decomp u of+  loop jq (E q u) = case decomp u of     Right (Exc CutFalse) -> mzero'  -- drop jq (F2)     Left u0 -> check jq u0 q @@ -75,7 +81,7 @@   check jq u _ | Just (Choose []) <- prj u  = next jq  -- (C1)   check jq u q | Just (Choose [x]) <- prj u = loop jq (q ^$ x)  -- (C3), optim   check jq u q | Just (Choose lst) <- prj u = next $ map (q ^$) lst ++ jq -- (C3)-  check jq u q = loop jq (E (weaken u) q)     -- (C4)+  check jq u q = loop jq (E q (weaken u))     -- (C4)    next :: Member Choose r        => [Eff (Exc CutFalse ': r) a]

@@ -82,14 +82,14 @@  handUp :: Eff (Move ': r) a -> Eff r a handUp (Val x) = return x-handUp (E u q) = case decomp u of+handUp (E q u) = case decomp u of   Right Move -> handDown $ qApp q ()   -- Relay other requests-  Left u0     -> E u0 ident >>= handUp . qApp q+  Left u0     -> E ident u0 >>= handUp . qApp q  handDown :: Eff (Move ': r) a -> Eff r a handDown (Val x) = return x-handDown (E u q) = case decomp u of+handDown (E q u) = case decomp u of   Right Move -> handUp $ qApp q ()   -- Relay other requests-  Left u0     -> E u0 ident >>= handDown . qApp q+  Left u0     -> E ident u0 >>= handDown . qApp q

@@ -8,6 +8,8 @@ {-# LANGUAGE Safe #-} -- | Exception-producing and exception-handling effects module Control.Eff.Exception ( Exc (..)+                            , exc+                            , withException                             , Fail                             , throwError                             , throwError_@@ -26,7 +28,6 @@  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Monad (void) import Control.Monad.Base@@ -38,9 +39,22 @@ -- exceptions of the type e; no resumption newtype Exc e v = Exc e +-- | Embed a pure value+withException :: Monad m => a -> m (Either e a)+withException = return . Right+-- | Throw an error+exc :: Monad m => e -> m (Either e a)+exc = return . Left+-- | Given a callback, and an 'Exc' request, respond to it.+instance Monad m => Handle (Exc e) (m (Either e a)) where+  handle _ (Exc e) = exc e++-- runError :: (a -> m (Either e a)), (e -> m (Either e a))+-- catchError :: (a -> Eff r a), (e -> Eff r a)+-- exc :: e -> m (Either e a)+ instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (Exc e ': r)) where     type StM (Eff (Exc e ': r)) a = StM (Eff r) (Either e a)     liftBaseWith f = raise $ liftBaseWith $ \runInBase ->@@ -69,9 +83,7 @@  -- | Run a computation that might produce an exception. runError :: Eff (Exc e ': r) a -> Eff r (Either e a)-runError = handle_relay-  (return . Right)-  (\(Exc e) _k -> return (Left e))+runError = handle_relay withException  -- | Runs a failable effect, such that failed computation return 'Nothing', and --   'Just' the return value on success.@@ -84,14 +96,14 @@ -- exception catchError :: Member (Exc e) r =>         Eff r a -> (e -> Eff r a) -> Eff r a-catchError m handle = interpose return (\(Exc e) _k -> handle e) m+catchError m h = respond_relay return (\_ (Exc e) -> h 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.        -> Eff r a           -- ^ The computation to run on failure.        -> Eff r a-onFail e handle = runFail e >>= maybe handle return+onFail e handle_ = runFail e >>= maybe handle_ return {-# INLINE onFail #-}  -- | Run a computation until it produces an exception,@@ -100,7 +112,7 @@            => (e -> e')            -> Eff (Exc e ': r) a            -> Eff r a-rethrowError t eff = runError eff >>= either (throwError . t) return+rethrowError t e = runError e >>= either (throwError . t) return  -- | Treat Lefts as exceptions and Rights as return values. liftEither :: (Member (Exc e) r) => Either e a -> Eff r a@@ -108,7 +120,7 @@ {-# INLINE liftEither #-}  -- | `liftEither` in a lifted Monad-liftEitherM :: (Member (Exc e) r, SetMember Lift (Lift m) r)+liftEitherM :: (Member (Exc e) r, Lifted m r)             => m (Either e a)             -> Eff r a liftEitherM m = lift m >>= liftEither@@ -120,7 +132,7 @@ {-# INLINE liftMaybe #-}  -- | `liftMaybe` in a lifted Monad-liftMaybeM :: (Member Fail r, SetMember Lift (Lift m) r)+liftMaybeM :: (Member Fail r, Lifted m r)            => m (Maybe a)            -> Eff r a liftMaybeM m = lift m >>= liftMaybe

@@ -6,6 +6,12 @@   ( -- * The effect monad     Eff(..)   , run+  , eff, impurePrj, impureDecomp+    -- * Lifting operations+  , Lift(..), Lifted, LiftedBase+  , lift, runLift+  , catchDynE+  , HandlerDynE(..), catchesDynE     -- * Open Unions   , OpenUnion.Union   , OpenUnion.Member@@ -15,9 +21,12 @@   , SetMember   , weaken   -- * Helper functions that are used for implementing effect-handlers+  , Handle, handle+  , Relay, relay   , handle_relay-  , handle_relay_s-  , interpose+  , handle_relay'+  , respond_relay+  , respond_relay'   , raise   , send   -- * Arrow types and compositions@@ -32,7 +41,8 @@   , comp   , (^|>)   , qComp-  , qComps+  , qComps, (^|$^)+  , (~^), qThen, andThen   ) where 

@@ -9,13 +9,13 @@ {-# LANGUAGE Safe #-} -- | Create unique Enumerable values. module Control.Eff.Fresh( Fresh (Fresh)+                        , withFresh                         , fresh                         , runFresh'                         ) where  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Monad.Base import Control.Monad.Trans.Control@@ -35,14 +35,23 @@   Fresh :: Fresh Int   Replace :: !Int -> Fresh () +-- | Embed a pure value. Note that this is a specialized form of+-- State's and we could have reused it.+withFresh :: Monad m => a -> Int -> m (a, Int)+withFresh x s = return (x, s)++-- | Given a continuation and requests, respond to them+instance Handle Fresh (Int -> r) where+  handle k Fresh s = k s (s + 1)+  handle k (Replace i) _ = k () i+ instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (Fresh ': r)) where     type StM (Eff (Fresh ': r)) a = StM (Eff r) (a, Int)     liftBaseWith f = do i <- fresh                         raise $ liftBaseWith $ \runInBase ->-                          f (\k -> runInBase $ runFreshReturn k i)+                          f (\k -> runInBase $ runFreshReturn i k)     restoreM x = do (r,i) <- raise (restoreM x)                     replace i                     return r@@ -56,16 +65,12 @@ replace = send . Replace  -- | Run an effect requiring unique values.-runFresh' :: Eff (Fresh ': r) w -> Int -> Eff r w-runFresh' m s = fst `fmap` runFreshReturn m s+runFresh' :: Int -> Eff (Fresh ': r) w -> Eff r w+runFresh' s m = fst `fmap` runFreshReturn s m -runFreshReturn :: Eff (Fresh ': r) w -> Int -> Eff r (w,Int)-runFreshReturn m s =-  handle_relay_s s (\s' x -> return (x,s'))-                   (\s' e k -> case e of-                                 Fresh -> (k $! s' + 1) s'-                                 Replace i -> k i ())-                   m+runFreshReturn :: Int -> Eff (Fresh ': r) w -> Eff r (w,Int)+runFreshReturn s m = handle_relay withFresh m s+ {- -- Finally, the worst implementation but the one that answers -- reviewer's question: implementing Fresh in terms of State

@@ -7,8 +7,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}--{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}  -- ------------------------------------------------------------------------ -- | A monadic library for communication between a handler and@@ -24,17 +25,16 @@ -- effects, consult the tests. module Control.Eff.Internal where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif import qualified Control.Arrow as A import qualified Control.Category as C import Control.Monad.Base (MonadBase(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Control (MonadBaseControl(..))+import qualified Control.Exception as Exc import safe Data.OpenUnion import safe Data.FTCQueue import GHC.Exts (inline)+import Data.Function (fix)  -- | Effectful arrow type: a function from a to b that also does effects -- denoted by r@@ -65,6 +65,9 @@ {-# INLINE singleK #-} singleK :: Arr r a b -> Arrs r a b singleK = Arrs . tsingleton+{-# INLINE (~^) #-}+(~^) :: Arr r a b -> Arrs r a b+(~^) = singleK  -- | Application to the `generalized effectful function' Arrs r b w, i.e., -- convert 'Arrs' to 'Arr'@@ -75,7 +78,7 @@     cons :: forall x. Arr r b x -> FTCQueue (Eff r) x w -> Eff r w     cons = \k t -> case k x of       Val y -> qApp (Arrs t) y-      E u (Arrs q0) -> E u (Arrs (q0 >< t))+      E (Arrs q0) u -> E (Arrs (q0 >< t)) u {- -- A bit more understandable version qApp :: Arrs r b w -> b -> Eff r w@@ -121,65 +124,91 @@ -- of the effects' @run*@ functions before unwrapping the final result. -- For additional details, see the documentation of the effects you are using. data Eff r a = Val a-             | forall b. E (Union r b) (Arrs r b a)+             | forall b. E (Arrs r b a) (Union r b)+-- | Case analysis for 'Eff' datatype. If the value is @'Val' a@ apply+-- the first function to @a@; if it is @'E' u q@, apply the second+-- function.+{-# INLINE eff #-}+eff :: (a -> b)+    -> (forall v. Arrs r v a -> Union r v -> b)+    -> Eff r a -> b+eff f _ (Val a) = f a+eff _ g (E q u) = g q u +-- | The usual 'bind' fnuction with arguments flipped. This is a+-- common pattern for Eff.+{-# INLINE bind #-}+bind :: Arr r a b -> Eff r a -> Eff r b+bind k = eff k (E . (^|> k))         -- just accumulates continuations++-- | Case analysis for impure computations for 'Eff' datatype. This+-- uses 'decomp'.+{-# INLINE impureDecomp #-}+impureDecomp :: (Arrs (t ': r) v a -> t v -> b)+             -> (Arrs (t ': r) v a -> Union r v -> b)+             -> Arrs (t ': r) v a -> Union (t ': r) v -> b+impureDecomp h rest q u = either (rest q) (h q) (decomp u)+-- | Case analysis for impure computations for 'Eff' datatype. This+-- uses 'prj'.+{-# INLINE impurePrj #-}+impurePrj :: Member t r+          => (Arrs r v a -> t v -> b)+          -> (Arrs r v a -> Union r v -> b)+          -> Arrs r v a -> Union r v -> b+impurePrj h def q u = maybe (def q u) (h q) (prj u)+ -- | 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 :: Arrs r a b -> (Eff r b -> k) -> (a -> k) -- qComp g h = (h . (g `qApp`)) qComp g h = \a -> h $ (g ^$ a)+{-# INLINABLE qThen #-}+qThen :: (Eff r b -> k) -> Arrs r a b -> (a -> k)+qThen = flip qComp +-- | Compose and then apply to function. This is a common pattern when+-- processing requests. Different options of 'f' allow us to handle or+-- relay the request and continue on.+andThen :: ((b -> c) -> t) -> (Eff r w -> c)+        -> Arrs r b w -> t+andThen f next = f . (qThen next)+ -- | Compose effectful arrows (and possibly change the effect!) {-# INLINE qComps #-} qComps :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c qComps g h = singleK $ qComp g h+{-# INLINABLE (^|$^) #-}+(^|$^) :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c+(^|$^) = qComps  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!+  fmap f = bind (Val . f)  instance Applicative (Eff r) where   {-# INLINE pure #-}   pure = Val-  Val f <*> e = f `fmap` e-  E u q <*> e = E u (q ^|> (`fmap` e))+  mf <*> e = bind (`fmap` e) mf  instance Monad (Eff r) where   {-# INLINE return #-}   {-# INLINE [2] (>>=) #-}   return = pure-  Val x >>= k = k x-  E u q >>= k = E u (q ^|> k)          -- just accumulates continuations+  (>>=) = flip bind {-   Val _ >> m = m-  E u q >> m = E u (q ^|> const m)+  E q u >> m = E (q ^|> const m) u -} -instance (MonadBase b m, SetMember Lift (Lift m) r) => MonadBase b (Eff r) where-    liftBase = lift . liftBase-    {-# INLINE liftBase #-}--instance (MonadBase m m)  => MonadBaseControl m (Eff '[Lift m]) where-    type StM (Eff '[Lift m]) a = a-    liftBaseWith f = lift (f runLift)-    {-# INLINE liftBaseWith #-}-    restoreM = return-    {-# INLINE restoreM #-}--instance (MonadIO m, SetMember Lift (Lift m) r) => MonadIO (Eff r) where-    liftIO = lift . liftIO-    {-# INLINE liftIO #-}- -- | 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) (singleK Val)+send t = E (singleK Val) (inj t) -- This seems to be a very beneficial rule! On micro-benchmarks, cuts -- the needed memory in half and speeds up almost twice. {-# RULES-  "send/bind" [~3] forall t k. send t >>= k = E (inj t) (singleK k)+  "send/bind" [~3] forall t k. send t >>= k = E (singleK k) (inj t)  #-}  @@ -195,79 +224,154 @@ -- cannot terminate. -- To extract the true error, the evaluation of union is forced. -- 'run' is a total function if its argument is different from bottom.-run (E union _) =+run (E _ union) =   union `seq` 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 (singleK k)-   where k = qComp q loop+-- | Abstract the recursive 'relay' pattern, i.e., "somebody else's+-- problem".+class Relay k r where+  relay :: (v -> k) -> Union r v -> k+instance Relay (Eff r w) r where+  relay q u = E (singleK q) u+instance Relay k r => Relay (s -> k) r where+  relay q u s = relay (\x -> q x s) u --- | 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+-- | Respond to requests of type 't'.+class Handle t k where+  handle :: (v -> k) -> t v -> k++-- | A convenient pattern: given a request (in an open union), either+-- handle it (using default Handler) or relay it.+--+-- "Handle" implies that all requests of type @t@ are dealt with,+-- i.e., @k@ (the response type) doesn't have @t@ as part of its+-- effect list. The @Relay k r@ constraint ensures that @k@ is an+-- effectful computation (with effectlist @r@).+--+-- Note that we can only handle the leftmost effect type (a+-- consequence of the 'OpenUnion' implementation.+handle_relay :: forall t k r a. Handle t k => Relay k r+             => (a -> k) -- ^ return+             -> Eff (t ': r) a -> k+handle_relay ret = handle_relay' ret handle++-- | A less commonly needed variant with an explicit handler (instead+-- of @Handle t k@ constraint).+handle_relay' :: forall t k r a. Relay k r+              => (a -> k) -- ^ return+              -> (forall v. (v -> k) -> t v -> k) -- ^ handler+              -> Eff (t ': r) a -> k+handle_relay' ret h = fix step   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 (singleK (k s0))-     where k s1 x = loop s1 $ qApp q x+    step next = eff ret+                (impureDecomp+                  (h `andThen` next)+                  (relay `andThen` next)) --- Add something like Control.Exception.catches? It could be useful--- for control with cut.+-- | Intercept the request and possibly respond to it, but leave it+-- unhandled. The @Relay k r@ constraint ensures that @k@ is an+-- effectful computation (with effectlist @r@). As such, the effect+-- type @t@ will show up in the response type @k@.+respond_relay :: Member t r => Relay k r+              => (a -> k)+              -> (forall v. (v -> k) -> t v -> k)+              -> Eff r a -> k+respond_relay ret h = fix step+  where+    step next = eff ret+                (impurePrj+                  (h `andThen` next)+                  (relay `andThen` next)) --- | Intercept the request and possibly reply to it, but leave it unhandled--- (that's why the same r is used 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 (singleK k)-    where k = qComp q loop+-- | A less common variant which uses the default 'handle' from the+-- @Handle t k@ instance (in general, we may need to define new+-- datatypes to call respond_relay with the default handler).+respond_relay' :: forall t k r a. (Member t r, Handle t k, Relay k r)+               => (a -> k)+               -> Eff r a -> k+respond_relay' ret = respond_relay ret (handle @t)  -- | Embeds a less-constrained 'Eff' into a more-constrained one. Analogous to -- MTL's 'lift'. raise :: Eff r a -> Eff (e ': r) a-raise = loop+raise = fix step   where-    loop (Val x) = pure x-    loop (E u q) = E (weaken u) $ qComps q loop+    step next = eff pure+                (\q -> ((E . (~^) . (qThen next)) q) . weaken) {-# INLINE raise #-}  -- ------------------------------------------------------------------------ -- | Lifting: emulating monad transformers-newtype Lift m a = Lift (m a)+newtype Lift m a = Lift { unLift :: m a } +-- |A convenient alias to 'SetMember Lift (Lift m) r', which allows us+-- to assert that the lifted type occurs ony once in the effect list.+type Lifted m r = SetMember Lift (Lift m) r++-- |Same as 'Lifted' but with additional 'MonadBaseControl' constraint+type LiftedBase m r = ( SetMember Lift (Lift m) r+                      , MonadBaseControl m (Eff r)+                      )+ -- | embed an operation of type `m a` into the `Eff` monad when @Lift m@ is in -- a part of the effect-list.------ By using SetMember, it is possible to assert that the lifted type occurs--- only once in the effect list-lift :: (SetMember Lift (Lift m) r) => m a -> Eff r a+lift :: Lifted 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.+-- | Handle lifted requests by running them sequentially+instance Monad m => Handle (Lift m) (m k) where+  handle k (Lift x) = x >>= k++-- | The handler of Lift requests. It is meant to be terminal: we only+-- allow a single Lifted Monad. Note, too, how this is different from+-- other handlers. runLift :: Monad m => Eff '[Lift m] w -> m w-runLift (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"+runLift = fix step+  where+    step :: Monad m => (Eff '[Lift m] w -> m w) -> Eff '[Lift m] w -> m w+    step next = eff return+                (impurePrj+                 (handle `andThen` next)+                 (\_ _ -> error "Impossible: Nothing to relay!")+                )++-- | Catching of dynamic exceptions+-- See the problem in+-- http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO+catchDynE :: forall e a r.+             (Lifted IO r, Exc.Exception e) =>+             Eff r a -> (e -> Eff r a) -> Eff r a+catchDynE m eh = respond_relay return h m+ where+   -- Polymorphic local binding: signature is needed+   h :: Arr r v a -> Lift IO v -> Eff r a+   h k (Lift em) = lift (Exc.try em) >>= either eh k++-- | You need this when using 'catches'.+data HandlerDynE r a =+  forall e. (Exc.Exception e, Lifted IO r) => HandlerDynE (e -> Eff r a)++-- | Catch multiple dynamic exceptions. The implementation follows+-- that in Control.Exception almost exactly. Not yet tested.+-- Could this be useful for control with cut?+catchesDynE :: Lifted IO r => Eff r a -> [HandlerDynE r a] -> Eff r a+catchesDynE m hs = m `catchDynE` catchesHandler hs where+  catchesHandler :: Lifted IO r => [HandlerDynE r a] -> Exc.SomeException -> Eff r a+  catchesHandler handlers e = foldr tryHandler (lift . Exc.throw $ e) handlers+    where+      tryHandler (HandlerDynE h) res = maybe res h (Exc.fromException e)++instance (MonadBase b m, Lifted m r) => MonadBase b (Eff r) where+    liftBase = lift . liftBase+    {-# INLINE liftBase #-}++instance (MonadBase m m)  => MonadBaseControl m (Eff '[Lift m]) where+    type StM (Eff '[Lift m]) a = a+    liftBaseWith f = lift (f runLift)+    {-# INLINE liftBaseWith #-}+    restoreM = return+    {-# INLINE restoreM #-}++instance (MonadIO m, Lifted m r) => MonadIO (Eff r) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}

@@ -1,40 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE Safe #-}--- | 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 (..)-                        , Lifted-                        , LiftedBase-                        , lift-                        , runLift-                        , catchDynE-                        ) where--import Control.Eff.Internal-import qualified Control.Exception as Exc-import Data.OpenUnion--import Control.Monad.Trans.Control (MonadBaseControl)---- |A convenient alias to 'SetMember Lift (Lift m) r'-type Lifted m r = SetMember Lift (Lift m) r---- |Same as 'Lifted' but with additional 'MonadBaseControl' constraint-type LiftedBase m r = ( SetMember Lift (Lift m) r-                      , MonadBaseControl m (Eff r)-                      )---- | Catching of dynamic exceptions--- See the problem in--- http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO-catchDynE :: forall e a r.-             (Lifted IO r, Exc.Exception e) =>-             Eff r a -> (e -> Eff r a) -> Eff r a-catchDynE m eh = interpose return h m- where-   -- Polymorphic local binding: signature is needed-   h :: Lift IO v -> Arr r v a -> Eff r a-   h (Lift em) k = lift (Exc.try em) >>= \x -> case x of-         Right x0 -> k x0-         Left  e -> eh e

@@ -0,0 +1,93 @@+{-# LANGUAGE Safe #-}++-- | Logic primitives. See LogicT paper for details.+module Control.Eff.Logic where++import Control.Monad+import Data.Function (fix)++-- | The MSplit primitive from LogicT paper.+class MSplit m where+  -- | The laws for 'msplit' are:+  --+  -- 1] msplit mzero == return Nothing+  -- 2] msplit (return a `mplus` m) == return (Just(a, m))+  msplit :: m a -> m (Maybe (a, m a))++-- | Embed a pure value into MSplit+withMSplit :: MonadPlus m => a -> m a -> m (Maybe (a, m a))+withMSplit a rest = return (Just (a, rest))+-- The handlers are defined in terms of the specific non-determinism+-- effects (instead of by way of a distinct MSplit handler++reflect :: MonadPlus m => Maybe (a, m a) -> m a+reflect Nothing      = mzero+reflect (Just (a,m)) = return a `mplus` m++-- Other committed choice primitives can be implemented in terms of msplit+-- The following implementations are directly from the LogicT paper++-- | Soft-cut: non-deterministic if-then-else, aka Prolog's *->+-- Declaratively,+--    ifte t th el = (t >>= th) `mplus` ((not t) >> el)+-- However, t is evaluated only once. In other words, ifte t th el+-- is equivalent to t >>= th if t has at least one solution.+-- If t fails, ifte t th el is the same as el.+--+-- Laws:+-- 1] ifte (return a) th el == th a+-- 2] ifte mzero th el == el+-- 3] ifte (return a `mplus` m) th el == th a `mplus` (m >>= th)+ifte :: (MonadPlus m, MSplit m)+     => m t -> (t -> m b) -> m b -> m b+ifte t th el = msplit t >>= check+ where check Nothing          = el+       check (Just (sg1,sg2)) = (th sg1) `mplus` (sg2 >>= th)++-- | Another pruning operation (ifte is the other). This selects one+-- solution out of possibly many.+once :: (MSplit m, MonadPlus m) => m b -> m b+once m = msplit m >>= check+ where check Nothing        = mzero+       check (Just (sg1,_)) = return sg1++-- | Negation as failure+gnot :: (MonadPlus m, MSplit m) => m b -> m ()+gnot m = ifte (once m) (const mzero) (return ())++-- | Fair (i.e., avoids starvation) disjunction. It obeys the+-- following laws:+--+-- 1] interleave mzero m == m+-- 2] interleave (return a `mplus` m1) m2 == return a `mplus` (interleave m2 m1)+--+-- corollary:+--   interleave m mzero == m+interleave :: (MSplit m, MonadPlus m) => m b -> m b -> m b+interleave sg1 sg2 =+  do r <- msplit sg1+     case r of+       Nothing -> sg2+       Just (sg11,sg12) ->+         (return sg11) `mplus` (interleave sg2 sg12)++-- | Fair (i.e., avoids starvation) conjunction. It obeys the+-- following laws:+--+-- 1] mzero >>- k == mzero+-- 2] (return a `mplus` m) >>- k == interleave (k a) (m >>- k)+(>>-) :: (MonadPlus m, MSplit m) => m a -> (a -> m b) -> m b+sg >>- g =+  do r <- msplit sg+     case r of+       Nothing -> mzero+       Just (sg1 ,sg2) -> interleave (g sg1) (sg2 >>- g)++-- | Collect all solutions. This is from Hinze's 'Backtr' monad+-- class. Unsurprisingly, this can be implemented in terms of msplit.+--+-- TODO: use a more efficient data structure.+sols :: (MonadPlus m, MSplit m) => m a -> m [a]+sols m = (msplit m) >>= (fix step) [] where+  step _ jq Nothing = return jq+  step next jq (Just(a, ma)) = (msplit ma) >>= next (a:jq)

@@ -13,11 +13,20 @@ {-# LANGUAGE UndecidableInstances #-}  -- | Another implementation of nondeterministic choice effect-module Control.Eff.NdetEff where+module Control.Eff.NdetEff (+  NdetEff+  , withNdetEff+  , left, right+  , makeChoiceA+  , makeChoiceA0+  , makeChoiceLst+  , msplit1+  , module Control.Eff.Logic+  ) where  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift+import Control.Eff.Logic  import Control.Applicative import Control.Monad@@ -31,6 +40,20 @@   MZero :: NdetEff a   MPlus :: NdetEff Bool +-- | How to embed a pure value in non-deterministic context+withNdetEff :: Alternative f => Monad m => a -> m (f a)+withNdetEff = return . pure+-- | The left branch+left :: (Bool -> k) -> k+left k = k True+-- | The right branch+right :: (Bool -> k) -> k+right k = k False+-- | Given a callback and NdetEff requests respond to them+instance (Alternative f, Monad m) => Handle NdetEff (m (f a)) where+  handle _ MZero = return empty+  handle k MPlus = liftM2 (<|>) (left k) (right k)+ instance Member NdetEff r => Alternative (Eff r) where   empty = mzero   (<|>) = mplus@@ -40,8 +63,7 @@   mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2  instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (NdetEff ': r)) where     type StM (Eff (NdetEff ': r)) a = StM (Eff r) [a]     liftBaseWith f = raise $ liftBaseWith $ \runInBase ->@@ -54,66 +76,53 @@ -- 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)+makeChoiceA0 = handle_relay withNdetEff  -- | 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 (q ^$ False : jq) (q ^$ True)-     Left  u0 -> E u0 (singleK (\x -> loop jq (q ^$ x)))+makeChoiceA m = loop [] m where+  loop [] (Val x)    = withNdetEff x+  loop (h:t) (Val x) = liftM2 (<|>) (withNdetEff x) (loop t h)+  loop jq (E q u) = case  decomp u of+    Right MZero     -> case jq of+      []    -> return empty+      (h:t) -> loop t h+    Right MPlus -> loop (q ^$ False : jq) (q ^$ True)+    Left  u0 -> E (q ^|$^ (loop jq)) u0  -- | Same as makeChoiceA, except it has the type hardcoded. -- Required for MonadBaseControl instance. makeChoiceLst :: Eff (NdetEff ': r) a -> Eff r [a] makeChoiceLst = makeChoiceA--- --------------------------------------------------------------------------- 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 []+-- | We actually implement LogicT, the non-determinism reflection, of+-- which soft-cut is one instance. Straightforward implementation+-- using 'respond_relay'. See the LogicT paper for an explanation.+instance Member NdetEff r => MSplit (Eff r) where+  msplit = respond_relay (flip withMSplit empty) $ \k x -> case x of+    MZero -> return Nothing              -- definite failure+    MPlus -> left k >>= \r -> case r of  -- check left first+      Nothing -> right k                 -- failure, continue exploring+      Just(a, m) -> withMSplit a (m <|> (right k >>= reflect)) -- definite success++-- | A different implementation, more involved. Unclear whether this+-- is faster or not.+msplit1 :: Member NdetEff r => Eff r a -> Eff r (Maybe (a, Eff r a))+msplit1 = loop []  where- -- singleK result- loop [] (Val x)  = return (Just (x,mzero))+ -- single result+ loop [] (Val x)  = withMSplit x mzero  -- definite result and perhaps some others- loop jq (Val x)  = return (Just (x, msum jq))+ loop jq (Val x)  = withMSplit x (msum jq)  -- not yet definite answer- loop jq (E u q)  = case prj u of+ loop jq (E q u)  = 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 ((q ^$ False):jq) (q ^$ True)-  _          -> E u (qComps 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+  _          -> E (q ^|$^ (loop jq)) u

@@ -5,13 +5,13 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-}  -- | Operational Monad (<https://wiki.haskell.org/Operational>) implemented with -- extensible effects.  module Control.Eff.Operational ( Program (..)+                               , withOperational, Intrprtr (..)                                , singleton                                , runProgram                                -- * Usage@@ -26,16 +26,23 @@ data Program instr v where   Singleton :: instr a -> Program instr a +-- | General form of an interpreter+newtype Intrprtr f r = Intrprtr { runIntrprtr :: forall x. f x -> Eff r x }++-- | Embed a pure value+withOperational :: a -> Intrprtr f r -> Eff r a+withOperational x _ = return x+-- | Given a continuation and a program, interpret it+instance Handle (Program f) (Intrprtr f r -> Eff r a) where+  handle k (Singleton instr) i = (runIntrprtr i) instr >>= (flip k i)+ -- | Lift a value to a monad. singleton :: (Member (Program instr) r) => instr a -> Eff r a singleton = send . Singleton  -- | Convert values using given interpreter to effects. runProgram :: forall f r a. (forall x. f x -> Eff r x) -> Eff (Program f ': r) a -> Eff r a-runProgram advent = handle_relay return h-  where-    h :: forall v. Program f v -> (v -> Eff r a) -> Eff r a-    h (Singleton instr) k = advent instr >>= k+runProgram advent m = handle_relay withOperational m (Intrprtr advent)  -- $usage --

@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-}  -- | Example usage of "Control.Eff.Operational".@@ -8,7 +7,6 @@  import Control.Eff.Operational import Control.Eff-import Control.Eff.Lift import Control.Eff.Writer.Lazy import Control.Eff.State.Lazy @@ -25,11 +23,11 @@    singleton $ Print ("the input is " ++ str)  -- | Then, implements interpreters from the data to effects.-adventIO :: (SetMember Lift (Lift IO) r) => Jail a -> Eff r a+adventIO :: Lifted IO r => Jail a -> Eff r a adventIO (Print a) = lift $ putStrLn a adventIO Scan = lift getLine -adventPure :: (Member (Writer String) r, Member (State [String]) r) => Jail a -> Eff r a+adventPure :: [ Writer String, State [String] ] <:: r => Jail a -> Eff r a adventPure (Print a) = tell (a ++ "\n") adventPure Scan = do   x <- get

@@ -7,8 +7,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-}+{-# LANGUAGE TypeApplications #-} -- | Lazy read-only state module Control.Eff.Reader.Lazy ( Reader (..)+                              , withReader                               , ask                               , local                               , reader@@ -17,7 +19,6 @@  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Monad.Base import Control.Monad.Trans.Control@@ -46,6 +47,13 @@ -- ^ In the latter case, when we make the request, we make it as Reader id. -- So, strictly speaking, GADTs are not really necessary. +-- | How to interpret a pure value in a reader context+withReader :: Monad m => a -> e -> m a+withReader x _ = return x+-- | Given a value to read, and a callback, how to respond to+-- requests.+instance Handle (Reader e) (e -> r) where+  handle k Ask e = k e e  -- | Get the current value from a Reader. -- The signature is inferred (when using NoMonomorphismRestriction).@@ -54,10 +62,8 @@  -- | The handler of Reader requests. The return type shows that all Reader -- requests are fully handled.-runReader :: e -> Eff (Reader e ': r) w -> Eff r w-runReader e = handle_relay-  return-  (\Ask -> ($ e))+runReader :: forall e r w. e -> Eff (Reader e ': r) w -> Eff r w+runReader e m = handle_relay withReader m e  -- | Locally rebind the value in the dynamic environment This function is like a -- relay; it is both an admin for Reader requests, and a requestor of them.@@ -65,18 +71,15 @@          (e -> e) -> Eff r a -> Eff r a local f m = do   e <- reader f-  let-    h :: Reader e t -> (t -> Eff r b) -> Eff r b-    h Ask = ($ e)-  interpose return h m+  respond_relay' @(Reader e) withReader m e+  -- or we could redefine handle and pass it to respond_relay  -- | Request the environment value using a transformation function. reader :: (Member (Reader e) r) => (e -> a) -> Eff r a reader f = f `fmap` ask  instance ( MonadBase m m-         , SetMember Lift (Lift m) s-         , MonadBaseControl m (Eff s)+         , LiftedBase m s          ) => MonadBaseControl m (Eff (Reader e ': s)) where     type StM (Eff (Reader e ': s)) a = StM (Eff s) a     liftBaseWith f = do e <- ask

@@ -7,18 +7,19 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE Safe #-} -- | Strict read-only state module Control.Eff.Reader.Strict ( Reader (..)-                              , ask-                              , local-                              , reader-                              , runReader-                              ) where+                                 , withReader+                                 , ask+                                 , local+                                 , reader+                                 , runReader+                                 ) where  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Monad.Base import Control.Monad.Trans.Control@@ -47,6 +48,13 @@ -- ^ In the latter case, when we make the request, we make it as Reader id. -- So, strictly speaking, GADTs are not really necessary. +-- | How to interpret a pure value in a reader context+withReader :: Monad m => a -> e -> m a+withReader x _ = return x+-- | Given a value to read, and a callback, how to respond to+-- requests.+instance Handle (Reader e) (e -> r) where+  handle k Ask e = k e e  -- | Get the current value from a Reader. -- The signature is inferred (when using NoMonomorphismRestriction).@@ -56,28 +64,23 @@ -- | The handler of Reader requests. The return type shows that all Reader -- requests are fully handled. runReader :: e -> Eff (Reader e ': r) w -> Eff r w-runReader !e = handle_relay-  return-  (\Ask -> ($ e))+runReader !e m = handle_relay withReader m e  -- | Locally rebind the value in the dynamic environment This function is like a--- relay; it is both an admin for Reader requests, and a requestor of them+-- 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 <- reader f-  let-    h :: Reader e t -> (t -> Eff r b) -> Eff r b-    h Ask = ($ e)-  interpose return h m+  respond_relay' @(Reader e) withReader m e+  -- or we could redefine handle and pass it to respond_relay  -- | Request the environment value using a transformation function. reader :: (Member (Reader e) r) => (e -> a) -> Eff r a reader f = f `fmap` ask  instance ( MonadBase m m-         , SetMember Lift (Lift m) s-         , MonadBaseControl m (Eff s)+         , LiftedBase m s          ) => MonadBaseControl m (Eff (Reader e ': s)) where     type StM (Eff (Reader e ': s)) a = StM (Eff s) a     liftBaseWith f = do !e <- ask

@@ -8,12 +8,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-} -- | Lazy state effect module Control.Eff.State.Lazy where  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Eff.Writer.Lazy import Control.Eff.Reader.Lazy@@ -42,9 +42,20 @@   Get :: State s s   Put :: s -> State s () +-- | Embed a pure value in a stateful computation, i.e., given an+-- initial state, how to interpret a pure value in a stateful+-- computation.+withState :: Monad m => a -> s -> m (a, s)+withState x s = return (x, s)++-- | Handle 'State s' requests+instance Handle (State s) (s -> r) where+  handle k sreq s = case sreq of+    Get    -> k s s+    Put s' -> k () s'+ instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (State s ': r)) where     type StM (Eff (State s ': r)) a = StM (Eff r) (a,s)     liftBaseWith f = do s <- get@@ -81,11 +92,7 @@ -- | Run a state effect. compared to the @runState@ function, this is --   implemented naively and is expected to perform slower. runState' :: s -> Eff (State s ': r) a -> Eff r (a, s)-runState' s =-  handle_relay_s s (\s0 x -> return (x,s0))-                   (\s0 sreq k -> case sreq of-                       Get    -> k s0 s0-                       Put s1 -> k s1 ())+runState' s m = handle_relay withState m s  -- | Run a State effect. This variant is a bit optimized compared to --   @runState'@.@@ -93,10 +100,10 @@          -> Eff (State s ': r) a  -- ^ Effect incorporating State          -> Eff r (a, s)          -- ^ Effect containing final state and a return value runState s (Val x) = return (x,s)-runState s (E u q) = case decomp u of+runState s (E q u) = case decomp u of   Right Get     -> runState s (q ^$ s)   Right (Put s1) -> runState s1 (q ^$ ())-  Left  u1 -> E u1 (singleK (\x -> runState s (q ^$ x)))+  Left  u1 -> E (singleK (\x -> runState s (q ^$ x))) u1  -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r ()@@ -113,29 +120,33 @@ -- | An encapsulated State handler, for transactional semantics -- The global state is updated only if the transactionState finished -- successfully-data TxState s = TxState-transactionState :: forall s r a. Member (State s) r =>-                    TxState s -> Eff r a -> Eff r a-transactionState _ m = do s <- get; loop s m- where-   loop :: s -> Eff r a -> Eff r a-   loop s (Val x) = put s >> return x-   loop s (E (u::Union r b) q) = case prj u :: Maybe (State s b) of-     Just Get      -> loop s (q ^$ s)-     Just (Put s') -> loop s'(q ^$ ())-     _             -> E u (qComps q (loop s))+data TxState s v where+  TxState :: TxState s s+type TxStateT s = TxState s s +-- | Embed Transactional semantics to a stateful computation.+withTxState :: Member (State s) r => a -> s -> Eff r a+withTxState x s = put s >> return x++-- | Confer transactional semantics on a stateful computation.+transactionState :: forall s r a. Member (State s) r+                 => TxStateT s -> Eff r a -> Eff r a+transactionState _ m = do+  s <- get+  (respond_relay' @(State s) (withTxState @s)) m s+ -- | A different representation of State: decomposing State into mutation -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones.  Thus we define a handler for two effects together. runStateR :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s)-runStateR s m = loop s m+runStateR = loop  where    loop :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s)-   loop s0 (Val x) = return (x,s0)-   loop s0 (E u q) = case decomp u of-     Right (Tell w) -> k w ()+   loop s (Val x) = x `withState` s+   loop s (E q u) = case decomp u of+     Right (Tell w) -> handle k (Put w) s      Left  u1  -> case decomp u1 of-       Right Ask -> k s0 s0-       Left u2 -> E u2 (singleK (k s0))-    where k x = qComp q (loop x)+       Right Ask -> handle k Get s+       Left u2 -> relay k u2 s+    where k = connect loop q+   connect nxt q = \s x -> qComp q (nxt x) s

@@ -13,10 +13,10 @@  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Eff.Writer.Lazy import Control.Eff.Reader.Lazy+import qualified Control.Eff.State.Lazy as S  import Control.Monad.Base import Control.Monad.Trans.Control@@ -33,9 +33,15 @@   Put  :: s -> OnDemandState s ()   Delay :: Eff '[OnDemandState s] a  -> OnDemandState s a --  Eff as a transformer +-- | Given a continuation, respond to requests+instance Handle (OnDemandState s) (s -> r) where+  handle k Get s = k s s+  handle k (Put s) _ = k () s+  handle k (Delay m) s = let ~(x, s') = run $ handle_relay S.withState m s+                         in k x s'+ instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (OnDemandState s ': r)) where     type StM (Eff (OnDemandState s ': r)) a = StM (Eff r) (a,s)     liftBaseWith f = do s <- get@@ -74,27 +80,20 @@ onDemand = send . Delay  runState' :: s -> Eff (OnDemandState s ': r) w -> Eff r (w,s)-runState' 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' s0 m1-                  in k s1 x)+runState' s m = handle_relay S.withState m s  -- Since State is so frequently used, we optimize it a bit -- | Run a State effect runState :: s                            -- ^ Initial state          -> Eff (OnDemandState s ': r) w -- ^ Effect incorporating State          -> Eff r (w,s)                  -- ^ Effect containing final state and a return value-runState s (Val x) = return (x,s)-runState s0 (E u0 q) = case decomp u0 of+runState s (Val x) = S.withState x s+runState s0 (E q u0) = case decomp u0 of   Right Get     -> runState s0 (q ^$ s0)   Right (Put s1) -> runState s1 (q ^$ ())   Right (Delay m1) -> let ~(x,s1) = run $ runState s0 m1                       in runState s1 (q ^$ x)-  Left  u -> E u (singleK (\x -> runState s0 (q ^$ x)))+  Left  u -> E (singleK (\x -> runState s0 (q ^$ x))) u  -- | Transform the state with a function. modify :: (Member (OnDemandState s) r) => (s -> s) -> Eff r ()@@ -112,16 +111,13 @@ -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones.  Thus we define a handler for two effects together. runStateR :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s)-runStateR s0 m0 = loop s0 m0- where-   loop :: s -> Eff (Writer s ': Reader s ': r) w -> Eff r (w,s)-   loop s (Val x) = return (x,s)-   loop s (E u0 q) = case decomp u0 of-     Right (Tell w) -> k w ()-     Left  u  -> case decomp u of-       Right Ask -> k s s-       Left u1 -> E u1 (singleK (k s))-    where k x = qComp q (loop x)+runStateR s (Val x) = S.withState x s+runStateR s (E q u) = case decomp u of+  Right (Tell w) -> handle k (S.Put w) s+  Left  u1  -> case decomp u1 of+    Right Ask -> handle k S.Get s+    Left u2 -> relay k u2 s+  where k s' x = qComp q (runStateR x) s'  -- | Backwards state -- The overall state is represented with two attributes: the inherited@@ -136,7 +132,7 @@  where    go :: s -> Eff '[OnDemandState s] a -> (a,s)    go s (Val x) = (x,s)-   go s0 (E u q) = case decomp u of+   go s0 (E q u) = case decomp u of          Right Get      -> go s0 $ (q ^$ s0)          Right (Put s1)  -> let ~(x,sp) = go sp $ (q ^$ ()) in (x,s1)          Right (Delay m1) -> let ~(x,s1) = go s0 m1 in go s1 $ (q ^$ x)@@ -152,12 +148,13 @@   (x,head sp)  where    go :: ([s],[s]) -> Eff '[OnDemandState s] a -> Eff '[] (a,([s],[s]))-   go ss = handle_relay_s ss (\ss0 x -> return (x,ss0))-                   (\ss0@(sg,sp) req k -> case req of-                       Get    -> k ss0 (head sg)-                       Put s1  -> k (tail sg,sp++[s1]) ()-                       Delay m1 -> let ~(x,ss1) = run $ go ss0 m1-                                   in k ss1 x)+   go s m' = handle_relay' S.withState+             (\k req ss0@(sg,sp) -> case req of+                 Get    -> k (head sg) ss0+                 Put s1  -> k () (tail sg,sp++[s1])+                 Delay m1 -> let ~(x,ss1) = run $ go ss0 m1+                             in k x ss1)+             m' s  -- ^ A different notion of `backwards' is realized if we change the Put -- handler slightly. How?

@@ -9,12 +9,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-} -- | Strict state effect module Control.Eff.State.Strict where  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Eff.Writer.Strict import Control.Eff.Reader.Strict@@ -43,9 +43,20 @@   Get :: State s s   Put :: !s -> State s () +-- | Embed a pure value in a stateful computation, i.e., given an+-- initial state, how to interpret a pure value in a stateful+-- computation.+withState :: Monad m => a -> s -> m (a, s)+withState x s = return (x, s)++-- | Handle 'State s' requests+instance Handle (State s) (s -> r) where+  handle k sreq s = case sreq of+    Get    -> k s s+    Put s' -> k () s'+ instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (State s ': r)) where     type StM (Eff (State s ': r)) a = StM (Eff r) (a,s)     liftBaseWith f = do s <- get@@ -80,23 +91,19 @@ -- inline get/put, even if I put the INLINE directives and play with phases. -- (Inlining works if I use 'inline' explicitly). -runState' :: s -> Eff (State s ': r) a -> Eff r (a, s)-runState' !s =-  handle_relay_s s (\s0 x -> return (x,s0))-                   (\s0 sreq k -> case sreq of-                       Get    -> k s0 s0-                       Put s1 -> k s1 ())+runState' :: forall s r a. s -> Eff (State s ': r) a -> Eff r (a, s)+runState' !s m = handle_relay withState m s  -- Since State is so frequently used, we optimize it a bit -- | Run a State effect-runState :: s                     -- ^ Effect incorporating State-         -> Eff (State s ': r) a  -- ^ Initial state+runState :: s                     -- ^ Initial state+         -> Eff (State s ': r) a  -- ^ Effect incorporating State          -> Eff r (a, s)          -- ^ Effect containing final state and a return value-runState !s (Val x) = return (x,s)-runState !s (E u q) = case decomp u of+runState !s (Val x) = withState x s+runState !s (E q u) = case decomp u of   Right Get     -> runState s (q ^$ s)   Right (Put s1) -> runState  s1 (q ^$ ())-  Left  u1 -> E u1 (singleK (\x -> runState s (q ^$ x)))+  Left  u1 -> E (qComps q (runState s)) u1  -- | Transform the state with a function. modify :: (Member (State s) r) => (s -> s) -> Eff r ()@@ -116,17 +123,18 @@ -- The global state is updated only if the transactionState finished -- successfully data TxState s = TxState-transactionState :: forall s r a. Member (State s) r =>-                    TxState s -> Eff r a -> Eff r a-transactionState _ m = do s <- get; loop s m- where-   loop :: s -> Eff r a -> Eff r a-   loop s (Val x) = put s >> return x-   loop s (E (u::Union r b) q) = case prj u :: Maybe (State s b) of-     Just Get      -> loop s (q ^$ s)-     Just (Put s') -> loop s'(q ^$ ())-     _             -> E u (qComps q (loop s)) +-- | Embed Transactional semantics to a stateful computation.+withTxState :: Member (State s) r => a -> s -> Eff r a+withTxState x s = put s >> return x++-- | Confer transactional semantics on a stateful computation.+transactionState :: forall s r a. Member (State s) r+                 => TxState s -> Eff r a -> Eff r a+transactionState _ m = do+  s <- get+  (respond_relay' @(State s) (withTxState @s)) m s+ -- | A different representation of State: decomposing State into mutation -- (Writer) and Reading. We don't define any new effects: we just handle the -- existing ones.  Thus we define a handler for two effects together.@@ -134,10 +142,10 @@ runStateR !s m = loop s m  where    loop :: s -> Eff (Writer s ': Reader s ': r) a -> Eff r (a, s)-   loop s0 (Val x) = return (x,s0)-   loop s0 (E u q) = case decomp u of-     Right (Tell w) -> k w ()+   loop s0 (Val x) = x `withState` s0+   loop s0 (E q u) = case decomp u of+     Right (Tell w) -> handle k (Put w) s0      Left  u1  -> case decomp u1 of-       Right Ask -> k s0 s0-       Left u2 -> E u2 (singleK (k s0))-    where k x = qComp q (loop x)+       Right Ask -> handle k Get s0+       Left u2 -> relay k u2 s0+    where k s' x = qComp q (loop x) s'

@@ -5,17 +5,27 @@ {-# LANGUAGE Safe #-} -- | A Trace effect for debugging module Control.Eff.Trace( Trace (..)+                        , withTrace                         , trace                         , runTrace                         ) where  import Control.Eff import Control.Eff.Extend+import Data.Function (fix)  -- | Trace effect for debugging data Trace v where   Trace :: String -> Trace () +-- | Embed a pure value in Trace context+withTrace :: a -> IO a+withTrace = return++-- | Given a callback and request, respond to it+instance Handle Trace (IO k) where+  handle k (Trace s) = putStrLn s >> k ()+ -- | Print a string as a trace. trace :: Member Trace r => String -> Eff r () trace = send . Trace@@ -23,8 +33,8 @@ -- | Run a computation producing Traces. -- 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 (q ^$ ())-     -- Nothing more can occur-     Left _ -> error "runTrace: the impossible happened!: Union []"+runTrace = fix step where+  step next = eff return+              (impureDecomp+                (handle `andThen` next)+                (\_ _ -> error "Impossible: Nothing to relay!"))

@@ -8,8 +8,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeApplications #-} -- | Lazy write-only state module Control.Eff.Writer.Lazy ( Writer(..)+                               , withWriter                                , tell                                , censor                                , runWriter@@ -26,7 +28,6 @@  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Applicative ((<|>)) @@ -46,9 +47,18 @@ data Writer w v where   Tell :: w -> Writer w () +-- | How to interpret a pure value in a writer context, given the+-- value for mempty.+withWriter :: Monad m => a -> b -> (w -> b -> b) -> m (a, b)+withWriter x empty _append = return (x, empty)+-- | Given a value to write, and a callback (which includes empty and+-- append), respond to requests.+instance Monad m => Handle (Writer w) (b -> (w -> b -> b) -> m (a, b)) where+  handle k (Tell w) e append = k () e append >>=+    \(x, l) -> return (x, w `append` l)+ instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (Writer w ': r)) where     type StM (Eff (Writer w ': r)) a = StM (Eff r) (a, [w])     liftBaseWith f = raise $ liftBaseWith $ \runInBase ->@@ -63,22 +73,16 @@  -- | Transform the state being produced. censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a-censor f = interpose return h+censor f = respond_relay return h   where-    h :: Writer w t -> (t -> Eff r b) -> Eff r b-    h (Tell w) k = tell (f w) >>= k+    h :: (v -> Eff r b) -> Writer w v -> Eff r b+    h k (Tell w) = tell (f w) >>= k   -- | 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))-  (\(Tell w) k -> k () >>= \(x, l) -> return (x, w `accum` l))-  -- the second arg to 'handle_relay' above is same as:-  -- (\(Tell w) k -> second (accum w) `fmap` k ())-  -- where-  --   second f (x, y) = (x, f y)+runWriter accum b m = handle_relay withWriter m b accum  -- | Handle Writer requests, using a List to accumulate values. runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w])

@@ -11,6 +11,7 @@ {-# LANGUAGE CPP #-} -- | Strict write-only state module Control.Eff.Writer.Strict ( Writer(..)+                               , withWriter                                , tell                                , censor                                , runWriter@@ -27,7 +28,6 @@  import Control.Eff import Control.Eff.Extend-import Control.Eff.Lift  import Control.Applicative ((<|>)) @@ -47,9 +47,18 @@ data Writer w v where   Tell :: !w -> Writer w () +-- | How to interpret a pure value in a writer context, given the+-- value for mempty.+withWriter :: Monad m => a -> b -> (w -> b -> b) -> m (a, b)+withWriter x empty _append = return (x, empty)+-- | Given a value to write, and a callback (which includes empty and+-- append), respond to requests.+instance Monad m => Handle (Writer w) (b -> (w -> b -> b) -> m (a, b)) where+  handle k (Tell w) e append = k () e append >>=+    \(x, l) -> return (x, w `append` l)+ instance ( MonadBase m m-         , SetMember Lift (Lift m) r-         , MonadBaseControl m (Eff r)+         , LiftedBase m r          ) => MonadBaseControl m (Eff (Writer w ': r)) where     type StM (Eff (Writer w ': r)) a = StM (Eff r) (a, [w])     liftBaseWith f = raise $ liftBaseWith $ \runInBase ->@@ -64,22 +73,16 @@  -- | Transform the state being produced. censor :: forall w a r. Member (Writer w) r => (w -> w) -> Eff r a -> Eff r a-censor f = interpose return h+censor f = respond_relay return h   where-    h :: Writer w t -> (t -> Eff r b) -> Eff r b-    h (Tell w) k = tell (f w) >>= k+    h :: (v -> Eff r b) -> Writer w v -> Eff r b+    h k (Tell w) = tell (f w) >>= k   -- | 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))-  (\(Tell w) k -> k () >>= \(x, l) -> return (x, w `accum` l))-  -- the second arg to 'handle_relay' above is same as:-  -- (\(Tell w) k -> second (accum w) `fmap` k ())-  -- where-  --   second f (x, y) = (x, f y)+runWriter accum !b m = handle_relay withWriter m b accum  -- | Handle Writer requests, using a List to accumulate values. runListWriter :: Eff (Writer w ': r) a -> Eff r (a,[w])

@@ -1,8 +1,6 @@ {-# OPTIONS_HADDOCK show-extensions #-} {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE CPP #-}- {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -15,10 +13,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51-{-# LANGUAGE OverlappingInstances #-}-#endif- -- Only for SetMember below, when emulating Monad Transformers {-# LANGUAGE FunctionalDependencies, UndecidableInstances #-} @@ -67,12 +61,8 @@  import Unsafe.Coerce(unsafeCoerce) -#if __GLASGOW_HASKELL__ > 800 import Data.Kind (Constraint) import GHC.TypeLits-#else-import GHC.Exts (Constraint)-#endif  -- | The data constructors of Union are not exported --@@ -103,21 +93,6 @@   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)@.@@ -142,7 +117,6 @@   {-# INLINE prj #-}   inj = inj' (unP $ (elemNo :: P t r))   prj = prj' (unP $ (elemNo :: P t r))-#endif  -- | A useful operator for reducing boilerplate in signatures. --@@ -181,29 +155,19 @@  instance FindElem t (t ': r) where   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))-#if __GLASGOW_HASKELL__ > 800 instance TypeError ('Text "Cannot unify effect types." ':$$:                     'Text "Unhandled effect: " ':<>: 'ShowType t ':$$:                     'Text "Perhaps check the type of effectful computation and the sequence of handlers for concordance?")   => FindElem t '[] where   elemNo = error "unreachable"-#endif  -- | 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-#if __GLASGOW_HASKELL__ < 710 || FORCE_OU51-instance (p ~ 'False) => EQU a b p-#else instance {-# OVERLAPPABLE #-} (p ~ 'False) => EQU a b p-#endif  -- | This class is used for emulating monad transformers class Member t r => SetMember (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t

@@ -8,7 +8,6 @@ import Control.Eff.Example import Control.Eff.Example.Test (ex2) import Control.Eff.Exception-import Control.Eff.Lift import Control.Eff.Choose import Utils @@ -41,14 +40,17 @@   let exRec_1 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,1]))       exRec_2 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,1]))       exRec_3 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,11,1]))+      exRec_4 = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,11,1]))   in     assertEqual "Choose: error recovery: exRec_1" expected1 exRec_1     >> assertEqual "Choose: error recovery: exRec_2" expected2 exRec_2-    >> assertEqual "Choose: error recovery: exRec_1" expected3 exRec_3+    >> assertEqual "Choose: error recovery: exRec_3" expected3 exRec_3+    >> assertEqual "Choose: error recovery: exRec_4" expected4 exRec_4   where     expected1 = Right [5,7,1]     expected2 = [Right 5,Right 7,Right 1]     expected3 = Left (TooBig 11)+    expected4 = [Right 5,Right 7,Left (TooBig 11),Right 1]     -- Errror recovery part     -- The code is the same as in transf1.hs. The inferred signatures differ     -- Was: exRec :: MonadError TooBig m => m Int -> m Int

@@ -32,7 +32,7 @@     th1 = yieldInt 1 >> yieldInt 2      c1 = runTrace (loop =<< runC th1)-      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+      where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop             loop (Done)    = trace ("Done")  case_Coroutines_c2 :: Assertion@@ -54,12 +54,12 @@      -- Code is essentially the same as in transf.hs; no liftIO though     c2 = runTrace $ runReader (10::Int) (loop =<< runC th2)-      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+      where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop             loop Done    = trace "Done"      -- locally changing the dynamic environment for the suspension     c21 = runTrace $ runReader (10::Int) (loop =<< runC th2)-      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+      where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop             loop Done    = trace "Done"  case_Coroutines_c3 :: Assertion@@ -80,20 +80,20 @@       where ay = ask >>= yieldInt      c3 = runTrace $ runReader (10::Int) (loop =<< runC th3)-      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop+      where loop (Y k x) = trace (show (x::Int)) >> k () >>= loop             loop Done    = trace "Done"      -- The desired result: the coroutine shares the dynamic environment with its     -- parent; however, when the environment is locally rebound, it becomes     -- private to coroutine.     c31 = runTrace $ runReader (10::Int) (loop =<< runC th3)-      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+      where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop             loop Done    = trace "Done"      -- We now make explicit that the client computation, run by th4,     -- is abstract. We abstract it out of th4     c4 = runTrace $ runReader (10::Int) (loop =<< runC (th4 client))-      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop+      where loop (Y k x) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop             loop Done    = trace "Done"              -- cl, client, ay are monomorphic bindings@@ -122,7 +122,7 @@     expected actual   where     c5 = runTrace $ runReader (10::Int) (loop =<< runC (th client))-      where loop (Y x k) = trace (show (x::Int)) >> local (\_y->x+1) (k ()) >>= loop+      where loop (Y k x) = trace (show (x::Int)) >> local (\_y->x+1) (k ()) >>= loop             loop Done    = trace "Done"              -- cl, client, ay are monomorphic bindings@@ -164,7 +164,7 @@   where     c7 = runTrace $           runReader (1000::Double) (runReader (10::Int) (loop =<< runC (th client)))-     where loop (Y x k) = trace (show (x::Int)) >>+     where loop (Y k x) = trace (show (x::Int)) >>                           local (\_y->fromIntegral (x+1)::Double) (k ()) >>= loop            loop Done    = trace "Done" @@ -208,7 +208,7 @@   where     c7' = runTrace $           runReader (1000::Double) (runReader (10::Int) (loop =<< runC (th client)))-     where loop (Y x k) = trace (show (x::Int)) >>+     where loop (Y k x) = trace (show (x::Int)) >>                           local (\_y->fromIntegral (x+1)::Double) (k ()) >>= loop            loop Done    = trace "Done" 

@@ -9,7 +9,6 @@ import Test.HUnit hiding (State) import Control.Eff import Control.Eff.Exception-import Control.Eff.Lift import Control.Eff.Writer.Strict #if __GLASGOW_HASKELL__ < 710 import Data.Monoid

@@ -6,8 +6,8 @@ module Control.Eff.Fresh.Test (testGroups) where  import Test.HUnit hiding (State)+import Control.Eff import Control.Eff.Fresh-import Control.Eff.Lift import Control.Eff.Trace import Utils @@ -22,13 +22,13 @@   assertEqual "Fresh: test"     (unlines ["Fresh 0", "Fresh 1"]) actual   where-    tfresh' = runTrace $ flip runFresh' 0 $ do+    tfresh' = runTrace $ runFresh' 0 $ do       n <- fresh       trace $ "Fresh " ++ show n       n <- fresh       trace $ "Fresh " ++ show n  case_Fresh_monadBaseControl :: Assertion-case_Fresh_monadBaseControl = runLift (runFresh' (doThing $ fresh >> fresh) i) @=? Just (i + 1)+case_Fresh_monadBaseControl = runLift (runFresh' i (doThing $ fresh >> fresh)) @=? Just (i + 1)   where     i = 0

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

@@ -0,0 +1,340 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}++-- A benchmark of shift/reset: Filinski's representing non-determinism monads+--+--  The benchmark is taken from Sec 6.1 of+--    Martin Gasbichler, Michael Sperber: Final Shift for Call/cc: Direct+--    Implementation of Shift and Reset, ICFP'02, pp. 271-282. +--    http://www-pu.informatik.uni-tuebingen.de/users/sperber/papers/shift-reset-direct.pdf+-- This code is a straightforward translation of bench_nondet.ml+--+-- This is a micro-benchmark: it is very non-determinism-intensive. It is+-- *not* representative: the benchmark does nothing else but+-- concatenates lists. The List monad does this directly; whereas+-- continuation monads do the concatenation with more overhead (e.g.,+-- building the closures representing continuations). Therefore,+-- the List monad here outperforms all other implementations of +-- non-determinism.+-- It should be stressed that the delimited control is optimized+-- for the case where control operations are infrequent, so we pay+-- as we go. The use of the delimited control operators is more+-- expensive, but the code that does not use delimited control does not+-- have to pay anything for delimited control. +-- Again, in the present micro-benchmark, there is hardly any code that+-- does not use non-determinism, so the overhead of delimited control+-- is very noticeable. That is why this benchmark is good at estimating+-- the overhead of different implementations of delimited control.++-- To compile this code+-- ghc -O2 -rtsopts -main-is Bench_nondet.main_list5 Bench_nondet.hs+-- To run this code+-- GHCRTS="-tstderr" /usr/bin/time ./Bench_nondet++module Control.Eff.NdetEff.Bench where++import Control.Eff+import qualified Control.Eff.NdetEff as E++import Data.List (sort)+-- import Control.Monad.Identity+-- import Control.Monad (liftM2)+import Control.Monad (MonadPlus(..), msum)+import Control.Applicative+-- import System.CPUTime++-- Small language with non-determinism: just like the one in our DSL-WC paper++int :: MonadPlus repr => Int -> repr Int+int x = return x++add :: MonadPlus repr => repr Int -> repr Int -> repr Int+-- add xs ys = liftM2 (+) xs ys+add xs ys = do {x <- xs; y <- ys; return $! x+y }++lam :: MonadPlus repr => (repr a -> repr b) -> repr (a -> repr b)+lam f = return $ f . return++app :: MonadPlus repr => repr (a -> repr b) -> (repr a -> repr b)+app xs ys = do {x <- xs; y <- ys; x y}++amb :: MonadPlus repr => [repr Int] -> repr Int+amb = msum++-- Benchmark cases++test_ww :: MonadPlus repr => repr Int+test_ww = + let f = lam (\x ->+              add (add x (amb [int 6, int 4, int 2, int 8])) +                         (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]++ww_answer = + sort [8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 4, 6, 7, 6, 3, 10, 12, 13,+       12, 9, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 12, 14, 15,+       14, 11, 11, 13, 14, 13, 10, 9, 11, 12, 11, 8, 7, 9, 10, 9, 6, 13, 15,+       16, 15, 12, 12, 14, 15, 14, 11, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7,+       14, 16, 17, 16, 13, 13, 15, 16, 15, 12, 11, 13, 14, 13, 10, 9, 11, 12,+       11, 8, 15, 17, 18, 17, 14, 40, 42, 43, 42, 39, 38, 40, 41, 40, 37, 36,+       38, 39, 38, 35, 42, 44, 45, 44, 41]++-- Real benchmark cases++test_www :: MonadPlus repr => repr Int+test_www = + let f = lam (\x ->+              add (add x (amb [int 6, int 4, int 2, int 8])) +                         (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])++test_wwww :: MonadPlus repr => repr Int+test_wwww = + let f = lam (\x ->+              add (add x (amb [int 6, int 4, int 2, int 8])) +                         (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]))++test_w5 :: MonadPlus repr => repr Int+test_w5 = + let f = lam (\x ->+              add (add x (amb [int 6, int 4, int 2, int 8])) +                         (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` +     (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])))+++-- Different implementations of our language (MonadPlus)++-- The List monad: Non-determinism monad as a list of successes++run_list :: [Int] -> [Int]+run_list = id++testl1 = (==) [101, 201, 102, 202] . run_list $+         add (amb [int 1, int 2]) (amb [int 100, int 200])++testl2 = ww_answer == sort (run_list test_ww)+++-- CPS-monad, implemented by hand; it must be quite efficient therefore+-- It is a monad, not a transformer. It cannot do any other effects beside+-- the non-determinism.+newtype CPS a = CPS{unCPS:: (a -> [Int]) -> [Int]}++instance Functor CPS where+  fmap f fa = CPS $ \k -> unCPS fa (k . f)+instance Applicative CPS where+  pure x = CPS $ \k -> k x+  mf <*> fa = CPS $ \k -> unCPS mf (\f -> unCPS fa (k . f))+instance Monad CPS where+  return x = CPS $ \k -> k x+  m >>= f  = CPS $ \k -> unCPS m (\a -> unCPS (f a) k)++instance Alternative CPS where+  empty = mzero+  (<|>) = mplus+instance MonadPlus CPS where+  mzero = CPS $ \_ -> []+  mplus m1 m2 = CPS $ \k -> unCPS m1 k ++ unCPS m2 k++run_cps :: CPS Int -> [Int]+run_cps m = unCPS m (\x -> [x])+++testc1 = (==) [101, 201, 102, 202] . run_cps $+         add (amb [int 1, int 2]) (amb [int 100, int 200])++testc2 = ww_answer == sort (run_cps test_ww)++-- ExtEff implementation+-- Eff is already an instance of MonadPlus. Thus we only need to+-- define the run instance++-- run_eff :: Eff '[E.Choose] Int -> [Int]+-- run_eff = run . E.makeChoice++-- More direct interpreter+-- makeChoiceA :: Eff (E.NdetEff ': r) a -> Eff r [a]+-- makeChoiceA = handle_relay (\x -> x `seq` return [x] ) $ \m k -> case m of+--     E.MZero -> return []+--     E.MPlus -> liftM2 (++) (k True) (k False)++run_eff :: Eff '[E.NdetEff] Int -> [Int]+run_eff = run . E.makeChoiceA++teste2 = ww_answer == sort (run_eff test_ww)+++data Count a = Count (Maybe a) !Int+instance Functor Count where+  fmap f (Count (Just x) n) = Count (Just (f x)) n+  fmap _ _                  = Count Nothing 0+  +instance Applicative Count where+  pure x = Count (Just x) 1+  Count (Just f) nf <*> Count (Just x) nx = Count (Just (f x)) (nf + nx)+  _ <*> _  = Count Nothing 0+  +instance Alternative Count where+  empty = Count Nothing 0+  Count m1@Just{} n1 <|> Count _ n2 = Count m1 (n1+n2)+  _ <|> m2 = m2++run_effc :: Eff '[E.NdetEff] Int -> Int+run_effc m = let Count _ n = run . E.makeChoiceA $ m in n++  +teste12 = length ww_answer == run_effc test_ww++{-+-- CCEx monad+-- Not a very optimal implementation of mplus (a tree would be better)+-- But is suffices as a benchmark of different implementations of CC+instance Monad m => MonadPlus (CC (PS [Int]) m) where+    mzero = abortP ps (return [])+    mplus m1 m2 = takeSubCont ps (\k ->+                     liftM2 (++)+                       (pushPrompt ps (pushSubCont k m1))+                       (pushPrompt ps (pushSubCont k m2)))++run_dir :: CC (PS [Int]) Identity Int -> [Int]+run_dir m = runIdentity . runCC $+            pushPrompt ps (m >>= return . (:[]))+++testd1 = (==) [101, 201, 102, 202] . run_dir $+         add (amb [int 1, int 2]) (amb [int 100, int 200])++testd2 = ww_answer == sort (run_dir test_ww)++-}+++-- Benchmarks themselves++main_list3 = print $ 2400   == (length . run_list $ test_www)+main_list4 = print $ 48000  == (length . run_list $ test_wwww)+main_list5 = print $ 960000 == (length . run_list $ test_w5)++main_cps3 = print $ 2400   == (length . run_cps $ test_www)+main_cps4 = print $ 48000  == (length . run_cps $ test_wwww)+main_cps5 = print $ 960000 == (length . run_cps $ test_w5)++-- We expect the direct implementation to be slower since CC is the transformer,+-- whereas CPS is not. The latter is hand-written for a specific answer-type.+main_eff3 = print $ 2400   == (length . run_eff $ test_www)+main_eff4 = print $ 48000  == (length . run_eff $ test_wwww)+main_eff5 = print $ 960000 == (length . run_eff $ test_w5)++main_eff5c = print $ 960000 == (run_effc $ test_w5)++-- To clarify the effect of building a list+main_eff5m = print $ ((run . E.makeChoiceA $ test_w5) :: Maybe Int)++{-+-- Instantiate CC to the IO as the base monad, attempting to quantify the+-- effect of the Identity transformer+main_dir5io = do+              l <- runCC $ pushPrompt ps (test_w5 >>= return . (:[]))+              print $ length l == 960000+-}++-- ------------------------------------------------------------------------+-- Old results, from 2010++{- Median of 5 runs++main_list5+<<ghc: 186526764 bytes, 356 GCs, 619182/1156760 avg/max bytes residency (3 samples), 4M in use, 0.00 INIT (0.00 elapsed), 0.25 MUT (0.25 elapsed), 0.06 GC (0.06 elapsed) :ghc>>+        0.30 real         0.30 user         0.00 sys++main_cps5+<<ghc: 231580040 bytes, 442 GCs, 4017/4104 avg/max bytes residency (24 samples), 2M in use, 0.00 INIT (0.00 elapsed), 0.28 MUT (0.28 elapsed), 0.31 GC (0.33 elapsed) :ghc>>+        0.60 real         0.58 user         0.01 sys++main_dir5 (CCExc implementation)+<<ghc: 780415108 bytes, 1489 GCs, 10459973/39033060 avg/max bytes residency (14 samples), 110M in use, 0.00 INIT (0.00 elapsed), 1.30 MUT (1.32 elapsed), 2.92 GC (3.14 elapsed) :ghc>>+        4.48 real         4.22 user         0.24 sys++main_dir5io (CCExc implementation)+<<ghc: 1148031880 bytes, 2190 GCs, 10339954/38941944 avg/max bytes residency (14 samples), 108M in use, 0.00 INIT (0.00 elapsed), 2.15 MUT (2.20 elapsed), 3.04 GC (3.24 elapsed) :ghc>>+        5.45 real         5.18 user         0.21 sys+++main_dir5 (CCCxe implementation)+./Bench_nondet +RTS -tstderr +True+<<ghc: 991065016 bytes, 1891 GCs, 10473968/38790660 avg/max bytes residency (14 samples), 110M in use, 0.00 INIT (0.00 elapsed), 1.45 MUT (1.49 elapsed), 2.99 GC (3.20 elapsed) :ghc>>+        4.70 real         4.44 user         0.23 sys++main_dir5io (CCCxe implementation)+./Bench_nondet +RTS -tstderr +True+<<ghc: 991065412 bytes, 1891 GCs, 10364029/37920012 avg/max bytes residency (14 samples), 109M in use, 0.00 INIT (0.00 elapsed), 1.46 MUT (1.50 elapsed), 2.99 GC (3.20 elapsed) :ghc>>+        4.72 real         4.44 user         0.23 sys++main_ref5io (without pushDelimSubCont)+./Bench_nondet +RTS -tstderr +True+<<ghc: 19050261764 bytes, 36337 GCs, 10620542/49328200 avg/max bytes residency (16 samples), 123M in use, 0.00 INIT (0.00 elapsed), 61.45 MUT (62.70 elapsed), 6.06 GC (6.21 elapsed) :ghc>>+       68.94 real        67.51 user         1.03 sys+++main_ref5io (with pushDelimSubCont)+./Bench_nondet +RTS -tstderr +True+<<ghc: 5666546308 bytes, 10809 GCs, 10538302/46414760 avg/max bytes residency (14 samples), 114M in use, 0.00 INIT (0.00 elapsed), 16.27 MUT (16.68 elapsed), 3.65 GC (3.80 elapsed) :ghc>>+       20.50 real        19.92 user         0.46 sys++-}++-- ------------------------------------------------------------------------+-- Newer Benchmarks, July 2015++{-+main_list5+True+<<ghc: 374751856 bytes, 720 GCs, 939265/2386984 avg/max bytes residency (6 samples), 7M in use, 0.00 INIT (0.00 elapsed), 0.11 MUT (0.11 elapsed), 0.02 GC (0.02 elapsed) :ghc>>++main_cps5+True+<<ghc: 463450920 bytes, 889 GCs, 36708/44312 avg/max bytes residency (2 samples), 1M in use, 0.00 INIT (0.00 elapsed), 0.14 MUT (0.15 elapsed), 0.00 GC (0.01 elapsed) :ghc>>++-- using makeChoiceA (setting f as an Alternative)+main_eff5+True+<<ghc: 1013337072 bytes, 1944 GCs, 18671465/83300976 avg/max bytes residency (17 samples), 231M in use, 0.00 INIT (0.00 elapsed), 0.36 MUT (0.39 elapsed), 1.08 GC (1.13 elapsed) :ghc>>++With strict add:+True+<<ghc: 993935088 bytes, 1906 GCs, 15000238/77154800 avg/max bytes residency (19 samples), 199M in use, 0.00 INIT (0.00 elapsed), 0.37 MUT (0.39 elapsed), 0.95 GC (1.02 elapsed) :ghc>>+1.32user 0.08system 0:01.40elapsed 99%CPU (0avgtext+0avgdata 819408maxresident)k+0inputs+0outputs (0major+51485minor)pagefaults 0swaps++It looks like a huge memory leak. Perhaps the list is fully realized?+++Using the counting Alternative Count+True+<<ghc: 591341472 bytes, 1133 GCs, 16603280/76447176 avg/max bytes residency (10 samples), 162M in use, 0.00 INIT (0.00 elapsed), 0.28 MUT (0.28 elapsed), 0.61 GC (0.66 elapsed) :ghc>>++Using Maybe+Just 32+<<ghc: 523838824 bytes, 1003 GCs, 16969712/76447176 avg/max bytes residency (9 samples), 150M in use, 0.00 INIT (0.00 elapsed), 0.21 MUT (0.19 elapsed), 0.46 GC (0.52 elapsed) :ghc>>+0.67user 0.05system 0:00.72elapsed 100%CPU (0avgtext+0avgdata 620752maxresident)k+0inputs+0outputs (0major+38937minor)pagefaults 0swaps++-- using Maybe, but with the better makeChoice+Just 32+<<ghc: 517460016 bytes, 883 GCs, 20215861/91552144 avg/max bytes residency (9 samples), 138M in use, 0.00 INIT (0.00 elapsed), 0.22 MUT (0.24 elapsed), 0.41 GC (0.43 elapsed) :ghc>>+0.63user 0.04system 0:00.68elapsed 100%CPU (0avgtext+0avgdata 570720maxresident)k+0inputs+0outputs (0major+35760minor)pagefaults 0swaps++Better makeChoiceA, full list+True+<<ghc: 454475112 bytes, 839 GCs, 8700298/33304904 avg/max bytes residency (8 samples), 58M in use, 0.00 INIT (0.00 elapsed), 0.23 MUT (0.23 elapsed), 0.19 GC (0.20 elapsed) :ghc>>+0.42user 0.02system 0:00.44elapsed 100%CPU (0avgtext+0avgdata 244064maxresident)k+0inputs+0outputs (0major+15391minor)pagefaults 0swaps++-}

@@ -2,12 +2,11 @@ {-# LANGUAGE TypeOperators, DataKinds #-} {-# LANGUAGE TemplateHaskell #-} -module Control.Eff.NdetEff.Test (testGroups) where+module Control.Eff.NdetEff.Test (testGroups, gen_testCA, gen_ifte_test) where  import Test.HUnit hiding (State) import Control.Applicative import Control.Eff-import Control.Eff.Lift import Control.Eff.NdetEff import Control.Eff.Writer.Strict import Control.Monad (msum, guard, mzero, mplus)@@ -18,15 +17,33 @@  testGroups = [ $(testGroupGenerator) ] +-- TODO: add quickcheck test to test conformance of different+-- implementations of 'makeChoiceA' and 'msplit'.++-- TODO: add benchmarks for different implementations of 'makeChoiceA'+-- and 'msplit'.++gen_testCA :: (Integral a) => a -> Eff (NdetEff ': r) a+gen_testCA x = do+  i <- msum . fmap return $ [1..x]+  guard (i `mod` 2 == 0)+  return i+ 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_testCA = [2, 4..10] @=? (run $ makeChoiceA (gen_testCA 10)) +gen_ifte_test x = do+  n <- gen x+  ifte (do+           d <- gen x+           guard $ d < n && n `mod` d == 0+           -- _ <- trace ("d: " ++ show d) (return ())+       )+    (\_ -> mzero)+    (return n)+    where gen x = msum . fmap return $ [2..x]++ case_NdetEff_ifte :: Assertion case_NdetEff_ifte =   let primes = ifte_test_run@@ -34,28 +51,17 @@     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+    ifte_test_run = run . makeChoiceA $ (gen_ifte_test 30)   -- called reflect in the LogicT paper case_NdetEff_reflect :: Assertion case_NdetEff_reflect =   let tsplitr10 = run $ runListWriter $ makeChoiceA tsplit-      tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= unmsplit)+      tsplitr11 = run $ runListWriter $ makeChoiceA (msplit tsplit >>= reflect)       tsplitr20 = run $ makeChoiceA $ runListWriter tsplit-      tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= unmsplit)+      tsplitr21 = run $ makeChoiceA $ runListWriter (msplit tsplit >>= reflect)   in     assertEqual "tsplitr10" expected1 tsplitr10     >> assertEqual "tsplitr11" expected1 tsplitr11@@ -65,10 +71,6 @@     expected1 = ([1, 2],["begin", "end"])     expected2 = [(1, ["begin"]), (2, ["end"])]     expected21 = [(1, ["begin"]), (2, ["begin", "end"])]--    unmsplit :: Member NdetEff r => (Maybe (a, Eff r a)) -> Eff r a-    unmsplit Nothing      = mzero-    unmsplit (Just (a,m)) = return a `mplus` m      tsplit =       (tell "begin" >> return 1) `mplus`

@@ -8,7 +8,6 @@  import Test.HUnit hiding (State) import Control.Eff-import Control.Eff.Lift import Control.Eff.Reader.Lazy import Control.Monad import Utils

@@ -7,7 +7,6 @@  import Test.HUnit hiding (State) import Control.Eff-import Control.Eff.Lift import Control.Eff.Reader.Strict import Utils 

@@ -7,7 +7,6 @@  import Test.HUnit hiding (State) import Control.Eff-import Control.Eff.Lift import Control.Eff.State.Lazy import Utils 

@@ -9,7 +9,6 @@ import Test.HUnit hiding (State) import Control.Eff import Control.Eff.Exception-import Control.Eff.Lift import Control.Eff.State.OnDemand import Utils 

@@ -8,7 +8,6 @@ import Test.HUnit hiding (State) import Control.Eff import Control.Eff.Exception-import Control.Eff.Lift import Control.Eff.State.Strict import Control.Eff.Reader.Strict import Control.Eff.Writer.Strict

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

@@ -9,7 +9,6 @@ import Test.QuickCheck  import Control.Eff-import Control.Eff.Lift import Control.Eff.Reader.Lazy import Control.Eff.Writer.Lazy import Utils

@@ -7,7 +7,6 @@  import Test.HUnit hiding (State) import Control.Eff-import Control.Eff.Lift import Control.Eff.Writer.Strict import Utils 

@@ -7,7 +7,6 @@ import qualified Control.Eff.Example.Test import qualified Control.Eff.Exception.Test import qualified Control.Eff.Fresh.Test-import qualified Control.Eff.Lift.Test import qualified Control.Eff.NdetEff.Test import qualified Control.Eff.Operational.Test import qualified Control.Eff.Reader.Lazy.Test@@ -34,7 +33,6 @@              ++ Control.Eff.Example.Test.testGroups              ++ Control.Eff.Exception.Test.testGroups              ++ Control.Eff.Fresh.Test.testGroups-             ++ Control.Eff.Lift.Test.testGroups              ++ Control.Eff.NdetEff.Test.testGroups              ++ Control.Eff.Operational.Test.testGroups              ++ Control.Eff.Reader.Lazy.Test.testGroups