fused-effects 0.2.0.2 → 0.3.0.0

raw patch · 34 files changed

+1068/−782 lines, 34 filesdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +31/−0
• README.md +37/−35
• benchmark/Bench.hs +45/−10
• examples/Parser.hs +18/−19
• examples/Teletype.hs +25/−27
• fused-effects.cabal +9/−9
• src/Control/Effect.hs +7/−4
• src/Control/Effect/Carrier.hs +18/−7
• src/Control/Effect/Cull.hs +52/−20
• src/Control/Effect/Cut.hs +59/−21
• src/Control/Effect/Error.hs +47/−12
• src/Control/Effect/Fail.hs +32/−9
• src/Control/Effect/Fail/Internal.hs +0/−18
• src/Control/Effect/Fresh.hs +26/−13
• src/Control/Effect/Internal.hs +0/−115
• src/Control/Effect/Lift.hs +25/−7
• src/Control/Effect/Lift/Internal.hs +0/−17
• src/Control/Effect/NonDet.hs +65/−34
• src/Control/Effect/NonDet/Internal.hs +0/−60
• src/Control/Effect/Pure.hs +50/−0
• src/Control/Effect/Random.hs +61/−16
• src/Control/Effect/Random/Internal.hs +0/−25
• src/Control/Effect/Reader.hs +50/−13
• src/Control/Effect/Resource.hs +37/−28
• src/Control/Effect/Resumable.hs +32/−24
• src/Control/Effect/State.hs +2/−89
• src/Control/Effect/State/Internal.hs +67/−0
• src/Control/Effect/State/Lazy.hs +95/−0
• src/Control/Effect/State/Strict.hs +84/−0
• src/Control/Effect/Sum.hs +1/−2
• src/Control/Effect/Trace.hs +34/−21
• src/Control/Effect/Void.hs +0/−53
• src/Control/Effect/Writer.hs +35/−52
• test/Control/Effect/Spec.hs +24/−22

@@ -1,3 +1,34 @@+# 0.3.0.0++## Backwards-incompatible changes++- Adds `Monad` as a superclass of `Carrier`, obviating the need for a lot of constraints, and `Monad` instances for all carrier types.+  This is a backwards-incompatible change, as any carriers users have defined now require `Monad` instances. Note that in many cases carriers can be composed out of existing carriers and monad transformers, and thus these instances can often be derived using `-XGeneralizedNewtypeDeriving`. We also recommend compiling with `-Wredundant-constraints` as many of these can now be removed.+- Replaces `AltC` with a new carrier, `NonDetC`, based on Ralf Hinze’s work in _[Deriving Backtracking Monad Transformers](https://www.cs.ox.ac.uk/ralf.hinze/publications/#P12)_.+  This is a backwards-incompatible change. `AltC` was equivalent to the `ListT` monad transformer, and had the same well-known limitation to commutative monads. Therefore, the elimination of `Eff` required a more durable approach.+- Removes `Branch`.+  This is a backwards-incompatible change, but was necessitated by the difficulty of implementing correct `Applicative` & `Monad` instances for carriers which used it. Carriers which were employing `Branch` internally should be reimplemented using `NonDetC` or a similar approach; see `CutC` and `CullC` for examples.+- Renames `Control.Effect.Void`, `Void`, and `VoidC` to `Control.Effect.Pure`, `Pure`, and `PureC` respectively.+  This is a backwards-incompatible change for code mentioning `VoidC`; it should be updated to reference `PureC` instead.++## Deprecations++- `Eff` and `interpret`, in favour of computing directly in the carriers. This enables the compiler to perform significant optimizations; see the benchmarks for details.+   Handlers can simply remove the `Eff` wrapping the carrier type & any use of `interpret`. As above, we also recommend compiling with `-Wredundant-constraints` as many of these can now be removed.+- `ret`, in favor of `pure` or `return`.+- `handleEither`, `handleReader`, `handleState`, `handleSum`, and `handleTraversable` in favour of composing carrier types directly.+   Carriers can be composed from other carriers and `eff` defined with `handleCoercible`; and other definitions can use `handlePure` & `handle` directly.++All deprecated APIs will be removed in the next release.++## Other changes++- Adds a lazy `State` carrier in `Control.Effect.State.Lazy`+- Rewrites `CutC` using an approach related to `NonDetC`, with the addition of a continuation to distinguish `empty` from `cutfail`.+- Rewrites `CullC` using `ListC` and `ReaderC`.+- Moves `OnceC` from `Control.Effect.NonDet` to `Control.Effect.Cull` to avoid cyclic dependencies.+- Adds a `runCutAll` handler for `Cut` effects, returning a collection of all results.+ # 0.2.0.2  - Loosens the bounds on QuickCheck to accommodate 2.x.

@@ -1,6 +1,6 @@ # A fast, flexible, fused effect system for Haskell -[![Build Status](https://travis-ci.com/robrix/fused-effects.svg?branch=master)](https://travis-ci.com/robrix/fused-effects)+[![Build Status](https://travis-ci.com/fused-effects/fused-effects.svg?branch=master)](https://travis-ci.com/fused-effects/fused-effects)  - [Overview][]   - [Algebraic effects][]@@ -20,28 +20,28 @@   - [Comparison to `mtl`][]   - [Comparison to `freer-simple`][] -[Overview]: https://github.com/robrix/fused-effects#overview-[Algebraic effects]: https://github.com/robrix/fused-effects#algebraic-effects-[Higher-order effects]: https://github.com/robrix/fused-effects#higher-order-effects-[Fusion]: https://github.com/robrix/fused-effects#fusion+[Overview]: https://github.com/fused-effects/fused-effects#overview+[Algebraic effects]: https://github.com/fused-effects/fused-effects#algebraic-effects+[Higher-order effects]: https://github.com/fused-effects/fused-effects#higher-order-effects+[Fusion]: https://github.com/fused-effects/fused-effects#fusion -[Usage]: https://github.com/robrix/fused-effects#usage-[Using built-in effects]: https://github.com/robrix/fused-effects#using-built-in-effects-[Running effects]: https://github.com/robrix/fused-effects#running-effects-[Required compiler extensions]: https://github.com/robrix/fused-effects#required-compiler-extensions-[Defining new effects]: https://github.com/robrix/fused-effects#defining-new-effects-[Defining effect handlers]: https://github.com/robrix/fused-effects#defining-effect-handlers+[Usage]: https://github.com/fused-effects/fused-effects#usage+[Using built-in effects]: https://github.com/fused-effects/fused-effects#using-built-in-effects+[Running effects]: https://github.com/fused-effects/fused-effects#running-effects+[Required compiler extensions]: https://github.com/fused-effects/fused-effects#required-compiler-extensions+[Defining new effects]: https://github.com/fused-effects/fused-effects#defining-new-effects+[Defining effect handlers]: https://github.com/fused-effects/fused-effects#defining-effect-handlers -[Project overview]: https://github.com/robrix/fused-effects#project-overview-[Development]: https://github.com/robrix/fused-effects#development-[Versioning]: https://github.com/robrix/fused-effects#versioning+[Project overview]: https://github.com/fused-effects/fused-effects#project-overview+[Development]: https://github.com/fused-effects/fused-effects#development+[Versioning]: https://github.com/fused-effects/fused-effects#versioning -[Benchmarks]: https://github.com/robrix/fused-effects#benchmarks+[Benchmarks]: https://github.com/fused-effects/fused-effects#benchmarks -[Related work]: https://github.com/robrix/fused-effects#related-work-[Contributed packages]: https://github.com/robrix/fused-effects#contributed-packages-[Comparison to `mtl`]: https://github.com/robrix/fused-effects#comparison-to-mtl-[Comparison to `freer-simple`]: https://github.com/robrix/fused-effects#comparison-to-freer-simple+[Related work]: https://github.com/fused-effects/fused-effects#related-work+[Contributed packages]: https://github.com/fused-effects/fused-effects#contributed-packages+[Comparison to `mtl`]: https://github.com/fused-effects/fused-effects#comparison-to-mtl+[Comparison to `freer-simple`]: https://github.com/fused-effects/fused-effects#comparison-to-freer-simple   ## Overview@@ -69,9 +69,9 @@  In order to maximize efficiency, `fused-effects` applies _fusion laws_, avoiding the construction of intermediate representations of effectful computations between effect handlers. In fact, this is applied as far as the initial construction as well: there is no representation of the computation as a free monad parameterized by some syntax type. As such, `fused-effects` avoids the overhead associated with constructing and evaluating any underlying free or freer monad. -Instead, computations are performed in a monad named `Eff`, parameterized by the carrier type for the syntax. This carrier is specific to the effect handler selected, but since it isn’t described until the handler is applied, the separation between specification and interpretation is maintained. Computations are written against an abstract effectful signature, and only specialized to some concrete carrier when their effects are interpreted.+Instead, computations are performed in a carrier type for the syntax, typically a monad wrapping further monads, via an instance of the `Carrier` class. This carrier is specific to the effect handler selected, but since it isn’t described until the handler is applied, the separation between specification and interpretation is maintained. Computations are written against an abstract effectful signature, and only specialized to some concrete carrier when their effects are interpreted. -Carriers needn’t be `Functor`s (let alone `Monad`s), allowing a great deal of freedom in the interpretation of effects. And since the interpretation is written as a typeclass instance which `ghc` is eager to inline, performance is excellent: approximately on par with `mtl`.+Since the interpretation of effects is written as a typeclass instance which `ghc` is eager to inline, performance is excellent: approximately on par with `mtl`.  Finally, since the fusion of carrier algebras occurs as a result of the selection of the carriers, it doesn’t depend on complex `RULES` pragmas, making it very easy to reason about and tune. @@ -138,9 +138,9 @@   put (length (list :: String)) ``` -`run` is itself actually an effect handler for the `Void` effect, which has no operations and thus can only represent a final result value.+`run` is itself actually an effect handler for the `Pure` effect, which has no operations and thus can only represent a final result value. -Alternatively, arbitrary `Monad`s can be embedded into effectful computations using the `Lift` effect. In this case, the underlying `Monad`ic computation can be extracted using `runM`. Here, we use the `MonadIO` instance for `Eff` to lift `putStrLn` into the middle of our computation:+Alternatively, arbitrary `Monad`s can be embedded into effectful computations using the `Lift` effect. In this case, the underlying `Monad`ic computation can be extracted using `runM`. Here, we use the `MonadIO` instance for the `LiftC` carrier to lift `putStrLn` into the middle of our computation:  ```haskell example4 :: IO (Int, ())@@ -156,22 +156,22 @@  To use effects, you'll need a relatively-uncontroversial set of extensions: `-XFlexibleContexts`, `-XFlexibleInstances`, and `-XMultiParamTypeClasses`. -When defining your own effects, you'll need `-XTypeOperators` to declare a `Carrier` instance over (`:+:`), and `-XUndecidableInstances` to satisfy the coverage condition for this instance. `-XLambdaCase` provides a measure of syntactic convenience when handling an effect type with `handleSum.`  You may need `-XKindSignatures` if GHC cannot correctly infer the type of your handler; see the [documentation on common errors][common] for more information about this case.+When defining your own effects, you'll need `-XTypeOperators` to declare a `Carrier` instance over (`:+:`), and `-XUndecidableInstances` to satisfy the coverage condition for this instance. You may need `-XKindSignatures` if GHC cannot correctly infer the type of your handler; see the [documentation on common errors][common] for more information about this case. -[common]: https://github.com/robrix/fused-effects/blob/master/docs/common_errors.md+[common]: https://github.com/fused-effects/fused-effects/blob/master/docs/common_errors.md  The following invocation, taken from the teletype example, should suffice for any use or construction of effects:  ```haskell {-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,-    KindSignatures, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+    KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} ```  ### Defining new effects  The process of defining new effects is outlined in [`docs/defining_effects.md`][], using the classic `Teletype` effect as an example. -[`docs/defining_effects.md`]: https://github.com/robrix/fused-effects/blob/master/docs/defining_effects.md+[`docs/defining_effects.md`]: https://github.com/fused-effects/fused-effects/blob/master/docs/defining_effects.md  ## Project overview @@ -181,12 +181,12 @@  Finally, this project is licensed under the BSD 3-clause [license][]. -[`src`]: https://github.com/robrix/fused-effects/tree/master/src-[`test`]: https://github.com/robrix/fused-effects/tree/master/test-[`examples`]: https://github.com/robrix/fused-effects/tree/master/examples-[`docs`]: https://github.com/robrix/fused-effects/tree/master/docs-[code of conduct]: https://github.com/robrix/fused-effects/blob/master/CODE_OF_CONDUCT.md-[license]: https://github.com/robrix/fused-effects/blob/master/LICENSE.md+[`src`]: https://github.com/fused-effects/fused-effects/tree/master/src+[`test`]: https://github.com/fused-effects/fused-effects/tree/master/test+[`examples`]: https://github.com/fused-effects/fused-effects/tree/master/examples+[`docs`]: https://github.com/fused-effects/fused-effects/tree/master/docs+[code of conduct]: https://github.com/fused-effects/fused-effects/blob/master/CODE_OF_CONDUCT.md+[license]: https://github.com/fused-effects/fused-effects/blob/master/LICENSE.md   ### Development@@ -225,8 +225,10 @@  Though we aim to keep the `fused-effects` core minimal, we encourage the development of external `fused-effects`-compatible libraries. If you've written one that you'd like to be mentioned here, get in touch! -* [`fused-effects-lens`][felens] provides combinators to use the [`lens`][lens] library fluently inside effectful computatios.+* [`fused-effects-lens`][felens] provides combinators to use the [`lens`][lens] library fluently inside effectful computations.+* [`fused-effects-exceptions`][exc] provides handlers for exceptions thrown in the `IO` monad. +[exc]: https://github.com/fused-effects/fused-effects-exceptions [felens]: http://hackage.haskell.org/package/fused-effects-lens [lens]: http://hackage.haskell.org/package/lens @@ -241,7 +243,7 @@ Also unlike `mtl`, there can be more than one `State` or `Reader` effect in a signature. This is a tradeoff: `mtl` is able to provide excellent type inference for effectful operations like `get`, since the functional dependencies can resolve the state type from the monad type. On the other hand, this behaviour can be recovered in `fused-effects` using `newtype` wrappers with phantom type parameters and helper functions, e.g.:  ```haskell-newtype Wrapper s m a = Wrapper { runWrapper :: Eff m a }+newtype Wrapper s m a = Wrapper { runWrapper :: m a }   deriving (Applicative, Functor, Monad)  instance Carrier sig m => Carrier sig (Wrapper s m) where …

@@ -1,28 +1,63 @@-{-# LANGUAGE FlexibleContexts, TypeApplications, TypeOperators #-}+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-} module Main where  import Control.Effect-import Control.Effect.Void+import Control.Effect.Carrier+import Control.Effect.Pure import Control.Effect.Writer-import Control.Monad (replicateM_)+import Control.Effect.State+import Control.Monad (ap, replicateM_) import Criterion.Main import Data.Monoid (Sum(..))  main :: IO () main = defaultMain-  [ bgroup "WriterC"-    [ bgroup "Eff"+  [+    bgroup "WriterC"+    [ bgroup "Cod"+      [ bench "100"       $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 100+      , bench "1000"    $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 1000+      , bench "10000" $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 10000+      ]+    , bgroup "standalone"       [ bench "100"       $ whnf (run . execWriter @(Sum Int) . tellLoop) 100-      , bench "100000"    $ whnf (run . execWriter @(Sum Int) . tellLoop) 100000-      , bench "100000000" $ whnf (run . execWriter @(Sum Int) . tellLoop) 100000000+      , bench "1000"    $ whnf (run . execWriter @(Sum Int) . tellLoop) 1000+      , bench "10000" $ whnf (run . execWriter @(Sum Int) . tellLoop) 10000       ]+    ]+  ,+    bgroup "Strict StateC"+    [ bgroup "Cod"+      [ bench "100"       $ whnf (run . runCod pure . execState @(Sum Int) 0 . runCod pure . modLoop) 100+      , bench "1000"    $ whnf (run . runCod pure . execState @(Sum Int) 0 . runCod pure . modLoop) 1000+      , bench "10000" $ whnf (run . runCod pure . execWriter @(Sum Int) . runCod pure . tellLoop) 10000+      ]     , bgroup "standalone"-      [ bench "100"       $ whnf (fst . runVoidC . flip runWriterC (Sum (0 :: Int)) . tellLoop) 100-      , bench "100000"    $ whnf (fst . runVoidC . flip runWriterC (Sum (0 :: Int)) . tellLoop) 100000-      , bench "100000000" $ whnf (fst . runVoidC . flip runWriterC (Sum (0 :: Int)) . tellLoop) 100000000+      [ bench "100"       $ whnf (run . execState @(Sum Int) 0 . modLoop) 100+      , bench "1000"    $ whnf (run . execState @(Sum Int) 0 . modLoop) 1000+      , bench "10000" $ whnf (run . execWriter @(Sum Int) . tellLoop) 10000       ]     ]   ]  tellLoop :: (Applicative m, Carrier sig m, Member (Writer (Sum Int)) sig) => Int -> m () tellLoop i = replicateM_ i (tell (Sum (1 :: Int)))++modLoop :: (Applicative m, Carrier sig m, Member (State (Sum Int)) sig) => Int -> m ()+modLoop i = replicateM_ i (modify (+ (Sum (1 :: Int))))++newtype Cod m a = Cod { unCod :: forall b . (a -> m b) -> m b }+  deriving (Functor)++runCod :: (a -> m b) -> Cod m a -> m b+runCod = flip unCod++instance Applicative (Cod m) where+  pure a = Cod (\ k -> k a)+  (<*>) = ap++instance Monad (Cod m) where+  Cod a >>= f = Cod (\ k -> a (runCod k . f))++instance Carrier sig m => Carrier sig (Cod m) where+  eff op = Cod (\ k -> eff (hmap (runCod pure) (fmap' (runCod k) op)))

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveTraversable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, KindSignatures, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveTraversable, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Parser ( spec ) where@@ -7,7 +7,8 @@ import Control.Effect.Carrier import Control.Effect.Cut import Control.Effect.NonDet-import Control.Effect.Sum hiding (L)+import Control.Effect.State+import Control.Effect.Sum import Control.Monad (replicateM) import Data.Char import Data.Coerce@@ -84,7 +85,7 @@   handle state handler = coerce . fmap (handler . (<$ state))  satisfy :: (Carrier sig m, Member Symbol sig) => (Char -> Bool) -> m Char-satisfy p = send (Satisfy p ret)+satisfy p = send (Satisfy p pure)  char :: (Carrier sig m, Member Symbol sig) => Char -> m Char char = satisfy . (==)@@ -92,43 +93,41 @@ digit :: (Carrier sig m, Member Symbol sig) => m Char digit = satisfy isDigit -parens :: (Applicative m, Carrier sig m, Member Symbol sig) => m a -> m a+parens :: (Carrier sig m, Member Symbol sig) => m a -> m a parens m = char '(' *> m <* char ')'  -parse :: (Alternative m, Carrier sig m, Effect sig, Monad m) => String -> Eff (ParseC m) a -> m a-parse input = (>>= exhaustive) . flip runParseC input . interpret+parse :: (Alternative m, Monad m) => String -> ParseC m a -> m a+parse input = (>>= exhaustive) . runState input . runParseC   where exhaustive ("", a) = pure a         exhaustive _       = empty -newtype ParseC m a = ParseC { runParseC :: String -> m (String, a) }+newtype ParseC m a = ParseC { runParseC :: StateC String m a }+  deriving (Alternative, Applicative, Functor, Monad)  instance (Alternative m, Carrier sig m, Effect sig) => Carrier (Symbol :+: sig) (ParseC m) where-  ret a = ParseC (\ input -> ret (input, a))-  {-# INLINE ret #-}--  eff op = ParseC (\ input -> handleSum-    (eff . handleState input runParseC)-    (\ (Satisfy p k) -> case input of-      c:cs | p c -> runParseC (k c) cs-      _          -> empty)-    op)+  eff (L (Satisfy p k)) = do+    input <- ParseC get+    case input of+      c:cs | p c -> ParseC (put cs) *> k c+      _          -> empty+  eff (R other)         = ParseC (eff (R (handleCoercible other)))   {-# INLINE eff #-}  -expr :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig, Monad m) => m Int+expr :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig) => m Int expr = do   i <- term   call ((i +) <$ char '+' <* cut <*> expr     <|> pure i) -term :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig, Monad m) => m Int+term :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig) => m Int term = do   i <- factor   call ((i *) <$ char '*' <* cut <*> term     <|> pure i) -factor :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig, Monad m) => m Int+factor :: (Alternative m, Carrier sig m, Member Cut sig, Member Symbol sig) => m Int factor   =   read <$> some digit   <|> parens expr

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}  module Teletype where @@ -6,7 +6,9 @@  import Control.Effect import Control.Effect.Carrier+import Control.Effect.State import Control.Effect.Sum+import Control.Effect.Writer import Control.Monad.IO.Class import Data.Coerce import Test.Hspec@@ -15,13 +17,13 @@ spec :: Spec spec = describe "teletype" $ do   prop "reads" $-    \ line -> run (runTeletypeRet [line] read) `shouldBe` (([], []), line)+    \ line -> run (runTeletypeRet [line] read) `shouldBe` ([], ([], line))    prop "writes" $-    \ input output -> run (runTeletypeRet input (write output)) `shouldBe` ((input, [output]), ())+    \ input output -> run (runTeletypeRet input (write output)) `shouldBe` ([output], (input, ()))    prop "writes multiple things" $-    \ input output1 output2 -> run (runTeletypeRet input (write output1 >> write output2)) `shouldBe` ((input, [output1, output2]), ())+    \ input output1 output2 -> run (runTeletypeRet input (write output1 >> write output2)) `shouldBe` ([output1, output2], (input, ()))  data Teletype (m :: * -> *) k   = Read (String -> k)@@ -37,39 +39,35 @@   handle state handler (Write s k) = Write s (handler (k <$ state))  read :: (Member Teletype sig, Carrier sig m) => m String-read = send (Read ret)+read = send (Read pure)  write :: (Member Teletype sig, Carrier sig m) => String -> m ()-write s = send (Write s (ret ()))+write s = send (Write s (pure ()))  -runTeletypeIO :: (MonadIO m, Carrier sig m) => Eff (TeletypeIOC m) a -> m a-runTeletypeIO = runTeletypeIOC . interpret+runTeletypeIO :: TeletypeIOC m a -> m a+runTeletypeIO = runTeletypeIOC  newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }   deriving (Applicative, Functor, Monad, MonadIO)  instance (MonadIO m, Carrier sig m) => Carrier (Teletype :+: sig) (TeletypeIOC m) where-  ret = pure-  eff = handleSum (TeletypeIOC . eff . handleCoercible) (\case-    Read    k -> liftIO getLine      >>= k-    Write s k -> liftIO (putStrLn s) >>  k)+  eff (L (Read    k)) = liftIO getLine      >>= k+  eff (L (Write s k)) = liftIO (putStrLn s) >>  k+  eff (R other)       = TeletypeIOC (eff (handleCoercible other))  -runTeletypeRet :: (Carrier sig m, Effect sig, Monad m) => [String] -> Eff (TeletypeRetC m) a -> m (([String], [String]), a)-runTeletypeRet s m = runTeletypeRetC (interpret m) s+runTeletypeRet :: [String] -> TeletypeRetC m a -> m ([String], ([String], a))+runTeletypeRet i = runWriter . runState i . runTeletypeRetC -newtype TeletypeRetC m a = TeletypeRetC { runTeletypeRetC :: [String] -> m (([String], [String]), a) }+newtype TeletypeRetC m a = TeletypeRetC { runTeletypeRetC :: StateC [String] (WriterC [String] m) a }+  deriving (Applicative, Functor, Monad) -instance (Monad m, Carrier sig m, Effect sig) => Carrier (Teletype :+: sig) (TeletypeRetC m) where-  ret a = TeletypeRetC (\ i -> ret ((i, []), a))-  eff op = TeletypeRetC (\ i -> handleSum (eff . handle ((i, []), ()) mergeResults) (\case-    Read k -> case i of-      []  -> runTeletypeRetC (k "") []-      h:t -> runTeletypeRetC (k h)  t-    Write s k -> do-      ((i, out), a) <- runTeletypeRetC k i-      pure ((i, s:out), a)) op)-    where mergeResults ((i, o), m) = do-            ((i', o'), a) <- runTeletypeRetC m i-            pure ((i', o ++ o'), a)+instance (Carrier sig m, Effect sig) => Carrier (Teletype :+: sig) (TeletypeRetC m) where+  eff (L (Read    k)) = do+    i <- TeletypeRetC get+    case i of+      []  -> k ""+      h:t -> TeletypeRetC (put t) *> k h+  eff (L (Write s k)) = TeletypeRetC (tell [s]) *> k+  eff (R other)       = TeletypeRetC (eff (R (R (handleCoercible other))))

@@ -1,8 +1,8 @@ name:                fused-effects-version:             0.2.0.2+version:             0.3.0.0 synopsis:            A fast, flexible, fused effect system. description:         A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers.-homepage:            https://github.com/robrix/fused-effects+homepage:            https://github.com/fused-effects/fused-effects license:             BSD3 license-file:        LICENSE author:              Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson@@ -26,27 +26,26 @@                      , Control.Effect.Cut                      , Control.Effect.Error                      , Control.Effect.Fail-                     , Control.Effect.Fail.Internal                      , Control.Effect.Fresh-                     , Control.Effect.Internal                      , Control.Effect.Lift-                     , Control.Effect.Lift.Internal                      , Control.Effect.NonDet-                     , Control.Effect.NonDet.Internal+                     , Control.Effect.Pure                      , Control.Effect.Random-                     , Control.Effect.Random.Internal                      , Control.Effect.Reader                      , Control.Effect.Resource                      , Control.Effect.Resumable                      , Control.Effect.State+                     , Control.Effect.State.Internal+                     , Control.Effect.State.Lazy+                     , Control.Effect.State.Strict                      , Control.Effect.Sum                      , Control.Effect.Trace-                     , Control.Effect.Void                      , Control.Effect.Writer   build-depends:       base >=4.9 && <4.13                      , deepseq >=1.4.3 && <1.5                      , MonadRandom >=0.5 && <0.6                      , random+                     , transformers   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -Weverything -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-name-shadowing -Wno-monomorphism-restriction -Wno-missed-specialisations -Wno-all-missed-specialisations@@ -84,6 +83,7 @@   main-is:             Doctest.hs   build-depends:       base >=4.9 && <4.13                      , doctest >=0.7 && <1.0+                     , fused-effects   hs-source-dirs:      test   default-language:    Haskell2010 @@ -101,4 +101,4 @@  source-repository head   type:     git-  location: https://github.com/robrix/fused-effects+  location: https://github.com/fused-effects/fused-effects

@@ -1,16 +1,17 @@ module Control.Effect ( module X+, Eff ) where  import Control.Effect.Carrier   as X (Carrier, Effect)-import Control.Effect.Cull      as X (Cull, CullC)+import Control.Effect.Cull      as X (Cull, CullC, OnceC) import Control.Effect.Cut       as X (Cut, CutC) import Control.Effect.Error     as X (Error, ErrorC) import Control.Effect.Fail      as X (Fail, FailC) import Control.Effect.Fresh     as X (Fresh, FreshC)-import Control.Effect.Internal  as X (Eff, interpret) import Control.Effect.Lift      as X (Lift, LiftC, runM)-import Control.Effect.NonDet    as X (NonDet, AltC, OnceC)+import Control.Effect.NonDet    as X (NonDet, NonDetC)+import Control.Effect.Pure      as X (Pure, PureC, run) import Control.Effect.Random    as X (Random, RandomC) import Control.Effect.Reader    as X (Reader, ReaderC) import Control.Effect.Resource  as X (Resource, ResourceC)@@ -18,5 +19,7 @@ import Control.Effect.State     as X (State, StateC) import Control.Effect.Sum       as X ((:+:), Member, send) import Control.Effect.Trace     as X (Trace, TraceByPrintingC, TraceByIgnoringC, TraceByReturningC)-import Control.Effect.Void      as X (Void, VoidC, run) import Control.Effect.Writer    as X (Writer, WriterC)++type Eff m = m+{-# DEPRECATED Eff "Carriers are now monads; use @m@ instead of @Eff m@." #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE DefaultSignatures, FunctionalDependencies, RankNTypes #-}+{-# LANGUAGE DefaultSignatures, DeriveFunctor, FlexibleInstances, FunctionalDependencies, RankNTypes, UndecidableInstances #-} module Control.Effect.Carrier ( HFunctor(..) , Effect(..)@@ -9,6 +9,7 @@ , handleState , handleEither , handleTraversable+, interpret ) where  import Control.Monad (join)@@ -40,14 +41,16 @@          -> sig n (n (f a))  --- | The class of carriers (results) for algebras (effect handlers) over signatures (effects), whose actions are given by the 'ret' and 'eff' methods.-class HFunctor sig => Carrier sig h | h -> sig where-  -- | Wrap a return value.-  ret :: a -> h a+-- | The class of carriers (results) for algebras (effect handlers) over signatures (effects), whose actions are given by the 'eff' method.+class (HFunctor sig, Monad m) => Carrier sig m | m -> sig where+  -- | Construct a value in the carrier for an effect signature (typically a sum of a handled effect and any remaining effects).+  eff :: sig m (m a) -> m a    -- | Construct a value in the carrier for an effect signature (typically a sum of a handled effect and any remaining effects).-  eff :: sig h (h a) -> h a+  ret :: a -> m a+  ret = pure +{-# DEPRECATED ret "Use 'pure' instead; 'ret' is a historical alias and will be removed in future versions" #-}  -- | Apply a handler specified as a natural transformation to both higher-order and continuation positions within an 'HFunctor'. handlePure :: HFunctor sig => (forall x . f x -> g x) -> sig f (f a) -> sig g (g a)@@ -61,6 +64,9 @@ handleCoercible = handlePure coerce {-# INLINE handleCoercible #-} +{-# DEPRECATED handleReader, handleState, handleEither, handleTraversable+  "Compose carrier types from other carriers and define 'eff' with handleCoercible instead" #-}+ -- | Thread a @Reader@-like carrier through an 'HFunctor'. handleReader :: HFunctor sig => r -> (forall x . f x -> r -> g x) -> sig f (f a) -> sig g (g a) handleReader r run = handlePure (flip run r)@@ -73,10 +79,15 @@  -- | Thread a carrier producing 'Either's through an 'Effect'. handleEither :: (Carrier sig g, Effect sig) => (forall x . f x -> g (Either e x)) -> sig f (f a) -> sig g (g (Either e a))-handleEither run = handle (Right ()) (either (ret . Left) run)+handleEither run = handle (Right ()) (either (pure . Left) run) {-# INLINE handleEither #-}  -- | Thread a carrier producing values in a 'Traversable' 'Monad' (e.g. '[]') through an 'Effect'. handleTraversable :: (Effect sig, Applicative g, Monad m, Traversable m) => (forall x . f x -> g (m x)) -> sig f (f a) -> sig g (g (m a)) handleTraversable run = handle (pure ()) (fmap join . traverse run) {-# INLINE handleTraversable #-}++-- | A backwards-compatibility shim, equivalent to 'id'.+interpret :: carrier a -> carrier a+interpret = id+{-# DEPRECATED interpret "Not necessary with monadic carriers; remove or replace with 'id'." #-}

@@ -1,16 +1,23 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Cull ( Cull(..) , cull , runCull , CullC(..)+, runNonDetOnce+, OnceC(..) ) where  import Control.Applicative (Alternative(..)) import Control.Effect.Carrier-import Control.Effect.Internal-import Control.Effect.NonDet.Internal+import Control.Effect.NonDet+import Control.Effect.Reader import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Prelude hiding (fail)  -- | 'Cull' effects are used with 'NonDet' to provide control over branching. data Cull m k@@ -32,36 +39,61 @@ --   prop> run (runNonDet (runCull (cull (pure a <|> pure b) <|> pure c))) == [a, c] --   prop> run (runNonDet (runCull (cull (asum (map pure (repeat a)))))) == [a] cull :: (Carrier sig m, Member Cull sig) => m a -> m a-cull m = send (Cull m ret)+cull m = send (Cull m pure)   -- | Run a 'Cull' effect. Branches outside of any 'cull' block will not be pruned. -- --   prop> run (runNonDet (runCull (pure a <|> pure b))) == [a, b]-runCull :: (Alternative m, Carrier sig m, Effect sig, Monad m) => Eff (CullC m) a -> m a-runCull = (>>= runBranch (const empty)) . flip runCullC False . interpret+runCull :: Alternative m => CullC m a -> m a+runCull (CullC m) = runNonDetC (runReader False m) ((<|>) . pure) empty -newtype CullC m a = CullC { runCullC :: Bool -> m (Branch m () a) }+newtype CullC m a = CullC { runCullC :: ReaderC Bool (NonDetC m) a }+  deriving (Applicative, Functor, Monad, MonadFail, MonadIO) -instance (Alternative m, Carrier sig m, Effect sig, Monad m) => Carrier (Cull :+: NonDet :+: sig) (CullC m) where-  ret = CullC . const . ret . Pure-  {-# INLINE ret #-}+instance Alternative (CullC m) where+  empty = CullC empty+  {-# INLINE empty #-}+  l <|> r = CullC $ ReaderC $ \ cull -> NonDetC $ \ cons nil -> do+    runNonDetC (runReader cull (runCullC l))+      (\ a as -> cons a (if cull then nil else as))+      (runNonDetC (runReader cull (runCullC r)) cons nil)+  {-# INLINE (<|>) #-} -  eff op = CullC (\ cull -> handleSum (handleSum-    (eff . handle (Pure ()) (bindBranch (flip runCullC cull)))-    (\case-      Empty       -> ret (None ())-      Choose k    -> runCullC (k True) cull >>= branch (const (runCullC (k False) cull)) (if cull then ret . Pure else \ a -> ret (Alt (ret a) (runCullC (k False) cull >>= runBranch (const empty)))) (fmap ret . Alt)))-    (\ (Cull m k) -> runCullC m True >>= bindBranch (flip runCullC cull . k))-    op)-    where bindBranch :: (Alternative m, Carrier sig m, Monad m) => (b -> m (Branch m () a)) -> Branch m () b -> m (Branch m () a)-          bindBranch bind = branch (const (ret (None ()))) bind (\ a b -> ret (Alt (a >>= bind >>= runBranch (const empty)) (b >>= bind >>= runBranch (const empty))))+instance MonadPlus (CullC m)++instance MonadTrans CullC where+  lift = CullC . lift . lift+  {-# INLINE lift #-}++instance (Carrier sig m, Effect sig) => Carrier (Cull :+: NonDet :+: sig) (CullC m) where+  eff (L (Cull m k))     = CullC (local (const True) (runCullC m)) >>= k+  eff (R (L Empty))      = empty+  eff (R (L (Choose k))) = k True <|> k False+  eff (R (R other))      = CullC (eff (R (R (handleCoercible other))))   {-# INLINE eff #-}  +-- | Run a 'NonDet' effect, returning the first successful result in an 'Alternative' functor.+--+--   Unlike 'runNonDet', this will terminate immediately upon finding a solution.+--+--   prop> run (runNonDetOnce (asum (map pure (repeat a)))) == [a]+--   prop> run (runNonDetOnce (asum (map pure (repeat a)))) == Just a+runNonDetOnce :: (Alternative f, Carrier sig m, Effect sig) => OnceC m a -> m (f a)+runNonDetOnce = runNonDet . runCull . cull . runOnceC++newtype OnceC m a = OnceC { runOnceC :: CullC (NonDetC m) a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)++instance (Carrier sig m, Effect sig) => Carrier (NonDet :+: sig) (OnceC m) where+  eff = OnceC . eff . R . R . handleCoercible+  {-# INLINE eff #-}++ -- $setup -- >>> :seti -XFlexibleContexts -- >>> import Test.QuickCheck -- >>> import Control.Effect.NonDet--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure -- >>> import Data.Foldable (asum)

@@ -1,18 +1,23 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Cut ( Cut(..) , cutfail , call , cut , runCut+, runCutAll , CutC(..) ) where  import Control.Applicative (Alternative(..)) import Control.Effect.Carrier-import Control.Effect.Internal import Control.Effect.NonDet import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Prelude hiding (fail)  -- | 'Cut' effects are used with 'NonDet' to provide control over backtracking. data Cut m k@@ -45,7 +50,7 @@ -- --   prop> run (runNonDet (runCut (call (cutfail <|> pure a) <|> pure b))) == [b] call :: (Carrier sig m, Member Cut sig) => m a -> m a-call m = send (Call m ret)+call m = send (Call m pure) {-# INLINE call #-}  -- | Commit to the current branch, preventing backtracking within the nearest enclosing 'call' (if any) on failure.@@ -58,32 +63,65 @@ {-# INLINE cut #-}  --- | Run a 'Cut' effect within an underlying 'Alternative' instance (typically 'Eff' carrying a 'NonDet' effect).+-- | Run a 'Cut' effect within an underlying 'Alternative' instance (typically another 'Carrier' for a 'NonDet' effect). -- --   prop> run (runNonDetOnce (runCut (pure a))) == Just a-runCut :: (Alternative m, Carrier sig m, Effect sig, Monad m) => Eff (CutC m) a -> m a-runCut = (>>= runBranch (const empty)) . runCutC . interpret+runCut :: Alternative m => CutC m a -> m a+runCut m = runCutC m ((<|>) . pure) empty empty -newtype CutC m a = CutC { runCutC :: m (Branch m Bool a) }+-- | Run a 'Cut' effect, returning all its results in an 'Alternative' collection.+runCutAll :: (Alternative f, Applicative m) => CutC m a -> m (f a)+runCutAll (CutC m) = m (fmap . (<|>) . pure) (pure empty) (pure empty) -instance (Alternative m, Carrier sig m, Effect sig, Monad m) => Carrier (Cut :+: NonDet :+: sig) (CutC m) where-  ret = CutC . ret . Pure-  {-# INLINE ret #-}+newtype CutC m a = CutC+  { -- | A higher-order function receiving three parameters: a function to combine each solution with the rest of the solutions, an action to run when no results are produced (e.g. on 'empty'), and an action to run when no results are produced and backtrcking should not be attempted (e.g. on 'cutfail').+    runCutC :: forall b . (a -> m b -> m b) -> m b -> m b -> m b+  }+  deriving (Functor) -  eff = CutC . handleSum (handleSum-    (eff . handle (Pure ()) (bindBranch (ret (None False)) runCutC))-    (\case-      Empty    -> ret (None True)-      Choose k -> runCutC (k True) >>= branch (\ e -> if e then runCutC (k False) else ret (None False)) (\ a -> ret (Alt (ret a) (runCutC (k False) >>= runBranch (const empty)))) (fmap ret . Alt)))-    (\case-      Cutfail  -> ret (None False)-      Call m k -> runCutC m >>= bindBranch (ret (None True)) (runCutC . k))-    where bindBranch :: (Alternative m, Carrier sig m, Monad m) => m (Branch m Bool a) -> (b -> m (Branch m Bool a)) -> Branch m Bool b -> m (Branch m Bool a)-          bindBranch cut bind = branch (\ e -> if e then ret (None True) else cut) bind (\ a b -> ret (Alt (a >>= bind >>= runBranch (const empty)) (b >>= bind >>= runBranch (const empty))))+instance Applicative (CutC m) where+  pure a = CutC (\ cons nil _ -> cons a nil)+  {-# INLINE pure #-}+  CutC f <*> CutC a = CutC $ \ cons nil fail ->+    f (\ f' fs -> a (cons . f') fs fail) nil fail+  {-# INLINE (<*>) #-}++instance Alternative (CutC m) where+  empty = CutC (\ _ nil _ -> nil)+  {-# INLINE empty #-}+  CutC l <|> CutC r = CutC (\ cons nil fail -> l cons (r cons nil fail) fail)+  {-# INLINE (<|>) #-}++instance Monad (CutC m) where+  CutC a >>= f = CutC $ \ cons nil fail ->+    a (\ a' as -> runCutC (f a') cons as fail) nil fail+  {-# INLINE (>>=) #-}++instance MonadFail m => MonadFail (CutC m) where+  fail s = CutC (\ _ _ _ -> fail s)+  {-# INLINE fail #-}++instance MonadIO m => MonadIO (CutC m) where+  liftIO io = CutC (\ cons nil _ -> liftIO io >>= flip cons nil)+  {-# INLINE liftIO #-}++instance MonadPlus (CutC m)++instance MonadTrans CutC where+  lift m = CutC (\ cons nil _ -> m >>= flip cons nil)+  {-# INLINE lift #-}++instance (Carrier sig m, Effect sig) => Carrier (Cut :+: NonDet :+: sig) (CutC m) where+  eff (L Cutfail)    = CutC $ \ _    _   fail -> fail+  eff (L (Call m k)) = CutC $ \ cons nil fail -> runCutC m (\ a as -> runCutC (k a) cons as fail) nil nil+  eff (R (L Empty))      = empty+  eff (R (L (Choose k))) = k True <|> k False+  eff (R (R other)) = CutC $ \ cons nil _ -> eff (handle [()] (fmap concat . traverse runCutAll) other) >>= foldr cons nil   {-# INLINE eff #-}   -- $setup -- >>> :seti -XFlexibleContexts -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Cull+-- >>> import Control.Effect.Pure

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Error ( Error(..) , throwError@@ -7,10 +7,14 @@ , ErrorC(..) ) where +import Control.Applicative (Alternative(..), liftA2) import Control.Effect.Carrier import Control.Effect.Sum-import Control.Effect.Internal-import Control.Monad ((<=<))+import Control.Monad (MonadPlus(..), (<=<))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Prelude hiding (fail)  data Error exc m k   = Throw exc@@ -44,26 +48,57 @@ --   prop> run (runError (throwError a `catchError` pure)) == Right @Int @Int a --   prop> run (runError (throwError a `catchError` (throwError @Int))) == Left @Int @Int a catchError :: (Member (Error exc) sig, Carrier sig m) => m a -> (exc -> m a) -> m a-catchError m h = send (Catch m h ret)+catchError m h = send (Catch m h pure)   -- | Run an 'Error' effect, returning uncaught errors in 'Left' and successful computations’ values in 'Right'. -- --   prop> run (runError (pure a)) == Right @Int @Int a-runError :: forall exc sig m a . (Carrier sig m, Effect sig, Monad m) => Eff (ErrorC exc m) a -> m (Either exc a)-runError = runErrorC . interpret+runError :: ErrorC exc m a -> m (Either exc a)+runError = runErrorC  newtype ErrorC e m a = ErrorC { runErrorC :: m (Either e a) }+  deriving (Functor) -instance (Carrier sig m, Effect sig, Monad m) => Carrier (Error e :+: sig) (ErrorC e m) where-  ret a = ErrorC (pure (Right a))-  eff = ErrorC . handleSum (eff . handleEither runErrorC) (\case-    Throw e     -> pure (Left e)-    Catch m h k -> runErrorC m >>= either (either (pure . Left) (runErrorC . k) <=< runErrorC . h) (runErrorC . k))+instance Applicative m => Applicative (ErrorC e m) where+  pure a = ErrorC (pure (Right a))+  {-# INLINE pure #-}+  ErrorC f <*> ErrorC a = ErrorC (liftA2 (<*>) f a)+  {-# INLINE (<*>) #-} +instance Alternative m => Alternative (ErrorC e m) where+  empty = ErrorC empty+  {-# INLINE empty #-}+  ErrorC l <|> ErrorC r = ErrorC (l <|> r)+  {-# INLINE (<|>) #-} +instance Monad m => Monad (ErrorC e m) where+  ErrorC a >>= f = ErrorC (a >>= either (pure . Left) (runError . f))+  {-# INLINE (>>=) #-}++instance MonadIO m => MonadIO (ErrorC e m) where+  liftIO io = ErrorC (Right <$> liftIO io)+  {-# INLINE liftIO #-}++instance MonadFail m => MonadFail (ErrorC e m) where+  fail s = ErrorC (fail s)+  {-# INLINE fail #-}++instance (Alternative m, Monad m) => MonadPlus (ErrorC e m)++instance MonadTrans (ErrorC e) where+  lift = ErrorC . fmap Right+  {-# INLINE lift #-}++instance (Carrier sig m, Effect sig) => Carrier (Error e :+: sig) (ErrorC e m) where+  eff (L (Throw e))     = ErrorC (pure (Left e))+  eff (L (Catch m h k)) = ErrorC (runError m >>= either (either (pure . Left) (runError . k) <=< runError . h) (runError . k))+  eff (R other)         = ErrorC (eff (handle (Right ()) (either (pure . Left) runError) other))+  {-# INLINE eff #-}++ -- $setup -- >>> :seti -XFlexibleContexts -- >>> :seti -XTypeApplications -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} module Control.Effect.Fail ( Fail(..) , MonadFail(..)@@ -6,26 +6,49 @@ , FailC(..) ) where +import Control.Applicative (Alternative(..)) import Control.Effect.Carrier-import Control.Effect.Fail.Internal-import Control.Effect.Internal+import Control.Effect.Error import Control.Effect.Sum+import Control.Monad (MonadPlus(..)) import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Coerce+import Prelude hiding (fail) +newtype Fail (m :: * -> *) k = Fail String+  deriving (Functor)++instance HFunctor Fail where+  hmap _ = coerce+  {-# INLINE hmap #-}++instance Effect Fail where+  handle _ _ = coerce+  {-# INLINE handle #-}++ -- | Run a 'Fail' effect, returning failure messages in 'Left' and successful computations’ results in 'Right'. -- --   prop> run (runFail (pure a)) == Right a-runFail :: (Carrier sig m, Effect sig) => Eff (FailC m) a -> m (Either String a)-runFail = runFailC . interpret+runFail :: FailC m a -> m (Either String a)+runFail = runError . runFailC -newtype FailC m a = FailC { runFailC :: m (Either String a) }+newtype FailC m a = FailC { runFailC :: ErrorC String m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadIO, MonadPlus, MonadTrans) +instance (Carrier sig m, Effect sig) => MonadFail (FailC m) where+  fail s = FailC (throwError s)+  {-# INLINE fail #-}+ instance (Carrier sig m, Effect sig) => Carrier (Fail :+: sig) (FailC m) where-  ret a = FailC (ret (Right a))-  eff = FailC . handleSum (eff . handleEither runFailC) (\ (Fail s) -> ret (Left s))+  eff (L (Fail s)) = fail s+  eff (R other)    = FailC (eff (R (handleCoercible other)))+  {-# INLINE eff #-}   -- $setup -- >>> :seti -XFlexibleContexts -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure

@@ -1,18 +0,0 @@-{-# LANGUAGE DeriveFunctor, KindSignatures #-}-module Control.Effect.Fail.Internal-( Fail(..)-) where--import Control.Effect.Carrier-import Data.Coerce--newtype Fail (m :: * -> *) k = Fail String-  deriving (Functor)--instance HFunctor Fail where-  hmap _ = coerce-  {-# INLINE hmap #-}--instance Effect Fail where-  handle _ _ = coerce-  {-# INLINE handle #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Fresh ( Fresh(..) , fresh@@ -7,9 +7,14 @@ , FreshC(..) ) where +import Control.Applicative (Alternative(..)) import Control.Effect.Carrier-import Control.Effect.Internal+import Control.Effect.State import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class  data Fresh m k   = Fresh (Int -> k)@@ -29,34 +34,42 @@ -- --   prop> run (runFresh (replicateM n fresh)) == nub (run (runFresh (replicateM n fresh))) fresh :: (Member Fresh sig, Carrier sig m) => m Int-fresh = send (Fresh ret)+fresh = send (Fresh pure)  -- | Reset the fresh counter after running a computation. -- --   prop> run (runFresh (resetFresh (replicateM m fresh) *> replicateM n fresh)) == run (runFresh (replicateM n fresh)) resetFresh :: (Member Fresh sig, Carrier sig m) => m a -> m a-resetFresh m = send (Reset m ret)+resetFresh m = send (Reset m pure)   -- | Run a 'Fresh' effect counting up from 0. -- --   prop> run (runFresh (replicateM n fresh)) == [0..pred n] --   prop> run (runFresh (replicateM n fresh *> pure b)) == b-runFresh :: (Carrier sig m, Effect sig, Monad m) => Eff (FreshC m) a -> m a-runFresh = fmap snd . flip runFreshC 0 . interpret+runFresh :: Functor m => FreshC m a -> m a+runFresh = evalState 0 . runFreshC -newtype FreshC m a = FreshC { runFreshC :: Int -> m (Int, a) }+newtype FreshC m a = FreshC { runFreshC :: StateC Int m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans) -instance (Carrier sig m, Effect sig, Monad m) => Carrier (Fresh :+: sig) (FreshC m) where-  ret a = FreshC (\ i -> ret (i, a))-  eff op = FreshC (\ i -> handleSum (eff . handleState i runFreshC) (\case-    Fresh   k -> runFreshC (k i) (succ i)-    Reset m k -> runFreshC m i >>= flip runFreshC i . k . snd) op)+instance (Carrier sig m, Effect sig) => Carrier (Fresh :+: sig) (FreshC m) where+  eff (L (Fresh   k)) = FreshC $ do+    i <- get+    put (succ i)+    runFreshC (k i)+  eff (L (Reset m k)) = FreshC $ do+    i <- get+    a <- runFreshC m+    put (i :: Int)+    runFreshC (k a)+  eff (R other)       = FreshC (eff (R (handleCoercible other)))+  {-# INLINE eff #-}   -- $setup -- >>> :seti -XFlexibleContexts -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure -- >>> import Control.Monad (replicateM) -- >>> import Data.List (nub)

@@ -1,115 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RankNTypes, UndecidableInstances #-}-module Control.Effect.Internal-( Eff(..)-, runEff-, interpret-) where--import Control.Applicative (Alternative(..))-import Control.Effect.Carrier-import Control.Effect.Fail.Internal-import Control.Effect.Lift.Internal-import Control.Effect.NonDet.Internal-import Control.Effect.Random.Internal-import Control.Effect.Sum-import Control.Monad (MonadPlus(..), liftM, ap)-import Control.Monad.Fail-import Control.Monad.IO.Class-import Control.Monad.Random.Class-import Prelude hiding (fail)--newtype Eff carrier a = Eff { unEff :: forall x . (a -> carrier x) -> carrier x }--runEff :: (a -> carrier b) -> Eff carrier a -> carrier b-runEff = flip unEff-{-# INLINE runEff #-}--interpret :: Carrier sig carrier => Eff carrier a -> carrier a-interpret = runEff ret-{-# INLINE interpret #-}--instance Functor (Eff carrier) where-  fmap = liftM-  {-# INLINE fmap #-}--instance Applicative (Eff carrier) where-  pure a = Eff ($ a)-  {-# INLINE pure #-}--  (<*>) = ap-  {-# INLINE (<*>) #-}---- | Run computations nondeterministically.------   prop> run (runNonDet empty) == []---   prop> run (runNonDet empty) == Nothing------   prop> run (runNonDet (pure a <|> pure b)) == [a, b]---   prop> run (runNonDet (pure a <|> pure b)) == Just a------   Associativity:------   prop> run (runNonDet ((pure a <|> pure b) <|> pure c)) == (run (runNonDet (pure a <|> (pure b <|> pure c))) :: [Integer])---   prop> run (runNonDet ((pure a <|> pure b) <|> pure c)) == (run (runNonDet (pure a <|> (pure b <|> pure c))) :: Maybe Integer)------   Left-identity:------   prop> run (runNonDet (empty <|> pure b)) == (run (runNonDet (pure b)) :: [Integer])---   prop> run (runNonDet (empty <|> pure b)) == (run (runNonDet (pure b)) :: Maybe Integer)------   Right-identity:------   prop> run (runNonDet (pure a <|> empty)) == (run (runNonDet (pure a)) :: [Integer])---   prop> run (runNonDet (pure a <|> empty)) == (run (runNonDet (pure a)) :: Maybe Integer)-instance (Member NonDet sig, Carrier sig carrier) => Alternative (Eff carrier) where-  empty = send Empty-  {-# INLINE empty #-}--  l <|> r = send (Choose (\ c -> if c then l else r))-  {-# INLINE (<|>) #-}--instance Monad (Eff carrier) where-  return = pure-  {-# INLINE return #-}--  Eff m >>= f = Eff (\ k -> m (runEff k . f))-  {-# INLINE (>>=) #-}--instance (Member Fail sig, Carrier sig carrier) => MonadFail (Eff carrier) where-  fail = send . Fail-  {-# INLINE fail #-}--instance (Member NonDet sig, Carrier sig carrier) => MonadPlus (Eff carrier)--instance (Member (Lift IO) sig, Carrier sig carrier) => MonadIO (Eff carrier) where-  liftIO = send . Lift . fmap pure-  {-# INLINE liftIO #-}--instance (Member Random sig, Carrier sig carrier) => MonadRandom (Eff carrier) where-  getRandom = send (Random ret)-  {-# INLINE getRandom #-}-  getRandomR r = send (RandomR r ret)-  {-# INLINE getRandomR #-}-  getRandomRs interval = (:) <$> getRandomR interval <*> getRandomRs interval-  {-# INLINE getRandomRs #-}-  getRandoms = (:) <$> getRandom <*> getRandoms-  {-# INLINE getRandoms #-}--instance (Member Random sig, Carrier sig carrier) => MonadInterleave (Eff carrier) where-  interleave m = send (Interleave m ret)-  {-# INLINE interleave #-}---instance Carrier sig carrier => Carrier sig (Eff carrier) where-  ret = pure-  {-# INLINE ret #-}--  eff op = Eff (\ k -> eff (hmap (runEff ret) (fmap' (runEff k) op)))-  {-# INLINE eff #-}----- $setup--- >>> :seti -XFlexibleContexts--- >>> import Test.QuickCheck--- >>> import Control.Effect.Void--- >>> import Control.Effect.NonDet

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses #-} module Control.Effect.Lift ( Lift(..) , sendM@@ -6,23 +6,41 @@ , LiftC(..) ) where +import Control.Applicative (Alternative(..)) import Control.Effect.Carrier import Control.Effect.Sum-import Control.Effect.Internal-import Control.Effect.Lift.Internal+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Coerce +newtype Lift sig (m :: * -> *) k = Lift { unLift :: sig k }+  deriving (Functor)++instance Functor sig => HFunctor (Lift sig) where+  hmap _ = coerce+  {-# INLINE hmap #-}++instance Functor sig => Effect (Lift sig) where+  handle state handler (Lift op) = Lift (fmap (handler . (<$ state)) op)++ -- | Extract a 'Lift'ed 'Monad'ic action from an effectful computation.-runM :: Monad m => Eff (LiftC m) a -> m a-runM = runLiftC . interpret+runM :: LiftC m a -> m a+runM = runLiftC  -- | Given a @Lift n@ constraint in a signature carried by @m@, 'sendM' -- promotes arbitrary actions of type @n a@ to @m a@. It is spiritually -- similar to @lift@ from the @MonadTrans@ typeclass.-sendM :: (Member (Lift n) sig, Carrier sig m, Functor n, Applicative m) => n a -> m a+sendM :: (Member (Lift n) sig, Carrier sig m, Functor n) => n a -> m a sendM = send . Lift . fmap pure  newtype LiftC m a = LiftC { runLiftC :: m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus) +instance MonadTrans LiftC where+  lift = LiftC+ instance Monad m => Carrier (Lift m) (LiftC m) where-  ret = LiftC . pure   eff = LiftC . (>>= runLiftC) . unLift

@@ -1,17 +0,0 @@-{-# LANGUAGE DeriveFunctor, KindSignatures #-}-module Control.Effect.Lift.Internal-( Lift(..)-) where--import Control.Effect.Carrier-import Data.Coerce--newtype Lift sig (m :: * -> *) k = Lift { unLift :: sig k }-  deriving (Functor)--instance Functor sig => HFunctor (Lift sig) where-  hmap _ = coerce-  {-# INLINE hmap #-}--instance Functor sig => Effect (Lift sig) where-  handle state handler (Lift op) = Lift (fmap (handler . (<$ state)) op)

@@ -1,61 +1,92 @@-{-# LANGUAGE DeriveFunctor, FlexibleInstances, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-} module Control.Effect.NonDet ( NonDet(..) , Alternative(..) , runNonDet-, AltC(..)-, runNonDetOnce-, OnceC(..)-, Branch(..)-, branch-, runBranch+, NonDetC(..) ) where -import Control.Applicative (Alternative(..), liftA2)+import Control.Applicative (Alternative(..)) import Control.Effect.Carrier-import Control.Effect.Cull-import Control.Effect.Internal-import Control.Effect.NonDet.Internal import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Coerce+import Prelude hiding (fail) +data NonDet (m :: * -> *) k+  = Empty+  | Choose (Bool -> k)+  deriving (Functor)++instance HFunctor NonDet where+  hmap _ = coerce+  {-# INLINE hmap #-}++instance Effect NonDet where+  handle _     _       Empty      = Empty+  handle state handler (Choose k) = Choose (handler . (<$ state) . k)++ -- | Run a 'NonDet' effect, collecting all branches’ results into an 'Alternative' functor. -- --   Using '[]' as the 'Alternative' functor will produce all results, while 'Maybe' will return only the first. However, unlike 'runNonDetOnce', this will still enumerate the entire search space before returning, meaning that it will diverge for infinite search spaces, even when using 'Maybe'. -- --   prop> run (runNonDet (pure a)) == [a] --   prop> run (runNonDet (pure a)) == Just a-runNonDet :: (Alternative f, Monad f, Traversable f, Carrier sig m, Effect sig, Applicative m) => Eff (AltC f m) a -> m (f a)-runNonDet = runAltC . interpret+runNonDet :: (Alternative f, Applicative m) => NonDetC m a -> m (f a)+runNonDet (NonDetC m) = m (fmap . (<|>) . pure) (pure empty) -newtype AltC f m a = AltC { runAltC :: m (f a) }+-- | A carrier for 'NonDet' effects based on Ralf Hinze’s design described in [Deriving Backtracking Monad Transformers](https://www.cs.ox.ac.uk/ralf.hinze/publications/#P12).+newtype NonDetC m a = NonDetC+  { -- | A higher-order function receiving two parameters: a function to combine each solution with the rest of the solutions, and an action to run when no results are produced.+    runNonDetC :: forall b . (a -> m b -> m b) -> m b -> m b+  }+  deriving (Functor) -instance (Alternative f, Monad f, Traversable f, Carrier sig m, Effect sig, Applicative m) => Carrier (NonDet :+: sig) (AltC f m) where-  ret a = AltC (ret (pure a))-  eff = AltC . handleSum (eff . handleTraversable runAltC) (\case-    Empty    -> ret empty-    Choose k -> liftA2 (<|>) (runAltC (k True)) (runAltC (k False)))+instance Applicative (NonDetC m) where+  pure a = NonDetC (\ cons -> cons a)+  {-# INLINE pure #-}+  NonDetC f <*> NonDetC a = NonDetC $ \ cons ->+    f (\ f' -> a (cons . f'))+  {-# INLINE (<*>) #-} +instance Alternative (NonDetC m) where+  empty = NonDetC (\ _ nil -> nil)+  {-# INLINE empty #-}+  NonDetC l <|> NonDetC r = NonDetC $ \ cons -> l cons . r cons+  {-# INLINE (<|>) #-} --- | Run a 'NonDet' effect, returning the first successful result in an 'Alternative' functor.------   Unlike 'runNonDet', this will terminate immediately upon finding a solution.------   prop> run (runNonDetOnce (asum (map pure (repeat a)))) == [a]---   prop> run (runNonDetOnce (asum (map pure (repeat a)))) == Just a-runNonDetOnce :: (Alternative f, Monad f, Traversable f, Carrier sig m, Effect sig, Monad m) => Eff (OnceC f m) a -> m (f a)-runNonDetOnce = runNonDet . runCull . cull . runOnceC . interpret+instance Monad (NonDetC m) where+  NonDetC a >>= f = NonDetC $ \ cons ->+    a (\ a' -> runNonDetC (f a') cons)+  {-# INLINE (>>=) #-} -newtype OnceC f m a = OnceC { runOnceC :: Eff (CullC (Eff (AltC f m))) a }+instance MonadFail m => MonadFail (NonDetC m) where+  fail s = NonDetC (\ _ _ -> fail s)+  {-# INLINE fail #-} -instance (Alternative f, Carrier sig m, Effect sig, Traversable f, Monad f, Monad m) => Carrier (NonDet :+: sig) (OnceC f m) where-  ret = OnceC . ret-  eff = OnceC . handleSum (eff . R . R . R . handleCoercible) (\case-    Empty    -> empty-    Choose k -> runOnceC (k True) <|> runOnceC (k False))+instance MonadIO m => MonadIO (NonDetC m) where+  liftIO io = NonDetC (\ cons nil -> liftIO io >>= flip cons nil)+  {-# INLINE liftIO #-} +instance MonadPlus (NonDetC m) +instance MonadTrans NonDetC where+  lift m = NonDetC (\ cons nil -> m >>= flip cons nil)+  {-# INLINE lift #-}++instance (Carrier sig m, Effect sig) => Carrier (NonDet :+: sig) (NonDetC m) where+  eff (L Empty)      = empty+  eff (L (Choose k)) = k True <|> k False+  eff (R other)      = NonDetC $ \ cons nil -> eff (handle [()] (fmap concat . traverse runNonDet) other) >>= foldr cons nil+  {-# INLINE eff #-}++ -- $setup -- >>> :seti -XFlexibleContexts -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure -- >>> import Data.Foldable (asum)

@@ -1,60 +0,0 @@-{-# LANGUAGE DeriveTraversable, KindSignatures #-}-module Control.Effect.NonDet.Internal-( NonDet(..)-, Branch(..)-, branch-, runBranch-) where--import Control.Applicative (Alternative(..))-import Control.Effect.Carrier-import Data.Coerce--data NonDet (m :: * -> *) k-  = Empty-  | Choose (Bool -> k)-  deriving (Functor)--instance HFunctor NonDet where-  hmap _ = coerce-  {-# INLINE hmap #-}--instance Effect NonDet where-  handle _     _       Empty      = Empty-  handle state handler (Choose k) = Choose (handler . (<$ state) . k)----- | The result of a nondeterministic branch of a computation.------   'Branch' can be used to define 'NonDet' carriers which control nondeterminism in some specific way, e.g. pruning branches according to some specific heuristic.-data Branch m e a-  = None e-  | Pure a-  | Alt (m a) (m a)-  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)---- | Case analysis for 'Branch', taking a value to use for 'Cut', a value to use for 'None', and a function to apply to the contents of 'Pure'.------   prop> branch None Pure Alt a == (a :: Branch e [] a)---   prop> branch (applyFun f) (applyFun g) (applyFun2 h) (None a :: Branch [] a) == applyFun f a---   prop> branch (applyFun f) (applyFun g) (applyFun2 h) (Pure a :: Branch [] a) == applyFun g a---   prop> branch (applyFun f) (applyFun g) (applyFun2 h) (Alt a b :: Branch [] a) == applyFun2 h a b-branch :: (e -> a) -> (b -> a) -> (m b -> m b -> a) -> Branch m e b -> a-branch f _ _ (None a)  = f a-branch _ f _ (Pure a)  = f a-branch _ _ f (Alt a b) = f a b-{-# INLINE branch #-}---- | Interpret a 'Branch' into an underlying 'Alternative' context.-runBranch :: Alternative m => (e -> m a) -> Branch m e a -> m a-runBranch f = branch f pure (<|>)-{-# INLINE runBranch #-}----- $setup--- >>> :seti -XFlexibleContexts--- >>> import Test.QuickCheck--- >>> import Control.Effect.Void--- >>> import Data.Foldable (asum)--- >>> instance (Arbitrary1 m, Arbitrary e) => Arbitrary1 (Branch m e) where liftArbitrary arb = frequency [(1, None <$> arbitrary), (3, Pure <$> arb), (3, Alt <$> liftArbitrary arb <*> liftArbitrary arb)]--- >>> instance (Arbitrary1 m, Arbitrary e, Arbitrary a) => Arbitrary (Branch m e a) where arbitrary = arbitrary1

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveFunctor, EmptyCase, KindSignatures, MultiParamTypeClasses #-}+module Control.Effect.Pure+( Pure+, run+, PureC(..)+) where++import Control.Effect.Carrier+import Data.Coerce++data Pure (m :: * -> *) k+  deriving (Functor)++instance HFunctor Pure where+  hmap _ v = case v of {}+  {-# INLINE hmap #-}++instance Effect Pure where+  handle _ _ v = case v of {}+  {-# INLINE handle #-}+++-- | Run an action exhausted of effects to produce its final result value.+run :: PureC a -> a+run = runPureC+{-# INLINE run #-}++newtype PureC a = PureC { runPureC :: a }++instance Functor PureC where+  fmap = coerce+  {-# INLINE fmap #-}++instance Applicative PureC where+  pure = PureC+  {-# INLINE pure #-}++  (<*>) = coerce+  {-# INLINE (<*>) #-}++instance Monad PureC where+  return = pure+  {-# INLINE return #-}++  PureC a >>= f = f a+  {-# INLINE (>>=) #-}++instance Carrier Pure PureC where+  eff v = case v of {}+  {-# INLINE eff #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Random ( Random(..) , runRandom@@ -10,51 +10,96 @@ , MonadInterleave(..) ) where +import Control.Applicative (Alternative(..)) import Control.Effect.Carrier-import Control.Effect.Internal-import Control.Effect.Random.Internal+import Control.Effect.State import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail import Control.Monad.Random.Class (MonadInterleave(..), MonadRandom(..)) import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class import qualified System.Random as R (Random(..), RandomGen(..), StdGen, newStdGen) +data Random m k+  = forall a . R.Random a => Random (a -> k)+  | forall a . R.Random a => RandomR (a, a) (a -> k)+  | forall a . Interleave (m a) (a -> k)++deriving instance Functor (Random m)++instance HFunctor Random where+  hmap _ (Random k) = Random k+  hmap _ (RandomR r k) = RandomR r k+  hmap f (Interleave m k) = Interleave (f m) k+  {-# INLINE hmap #-}++instance Effect Random where+  handle state handler (Random    k) = Random    (handler . (<$ state) . k)+  handle state handler (RandomR r k) = RandomR r (handler . (<$ state) . k)+  handle state handler (Interleave m k) = Interleave (handler (m <$ state)) (handler . fmap k)++ -- | Run a random computation starting from a given generator. -- --   prop> run (runRandom (PureGen a) (pure b)) == (PureGen a, b)-runRandom :: (Carrier sig m, Effect sig, Monad m, R.RandomGen g) => g -> Eff (RandomC g m) a -> m (g, a)-runRandom g = flip runRandomC g . interpret+runRandom :: g -> RandomC g m a -> m (g, a)+runRandom g = runState g . runRandomC  -- | Run a random computation starting from a given generator and discarding the final generator. -- --   prop> run (evalRandom (PureGen a) (pure b)) == b-evalRandom :: (Carrier sig m, Effect sig, Monad m, R.RandomGen g) => g -> Eff (RandomC g m) a -> m a+evalRandom :: Functor m => g -> RandomC g m a -> m a evalRandom g = fmap snd . runRandom g  -- | Run a random computation starting from a given generator and discarding the final result. -- --   prop> run (execRandom (PureGen a) (pure b)) == PureGen a-execRandom :: (Carrier sig m, Effect sig, Monad m, R.RandomGen g) => g -> Eff (RandomC g m) a -> m g+execRandom :: Functor m => g -> RandomC g m a -> m g execRandom g = fmap fst . runRandom g  -- | Run a random computation in 'IO', splitting the global standard generator to get a new one for the computation.-evalRandomIO :: (Carrier sig m, Effect sig, MonadIO m) => Eff (RandomC R.StdGen m) a -> m a+evalRandomIO :: MonadIO m => RandomC R.StdGen m a -> m a evalRandomIO m = liftIO R.newStdGen >>= flip evalRandom m -newtype RandomC g m a = RandomC { runRandomC :: g -> m (g, a) }+newtype RandomC g m a = RandomC { runRandomC :: StateC g m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans) -instance (Carrier sig m, Effect sig, R.RandomGen g, Monad m) => Carrier (Random :+: sig) (RandomC g m) where-  ret a = RandomC (\ g -> ret (g, a))-  eff op = RandomC (\ g -> handleSum (eff . handleState g runRandomC) (\case-    Random    k -> let (a, g') = R.random    g in runRandomC (k a) g'-    RandomR r k -> let (a, g') = R.randomR r g in runRandomC (k a) g'-    Interleave m k -> let (g1, g2) = R.split g in runRandomC m g1 >>= flip runRandomC g2 . k . snd) op)+instance (Carrier sig m, Effect sig, R.RandomGen g) => MonadRandom (RandomC g m) where+  getRandom = RandomC $ do+    (a, g') <- gets R.random+    a <$ put (g' :: g)+  {-# INLINE getRandom #-}+  getRandomR r = RandomC $ do+    (a, g') <- gets (R.randomR r)+    a <$ put (g' :: g)+  {-# INLINE getRandomR #-}+  getRandomRs interval = (:) <$> getRandomR interval <*> getRandomRs interval+  {-# INLINE getRandomRs #-}+  getRandoms = (:) <$> getRandom <*> getRandoms+  {-# INLINE getRandoms #-} +instance (Carrier sig m, Effect sig, R.RandomGen g) => MonadInterleave (RandomC g m) where+  interleave m = RandomC $ do+    (g1, g2) <- gets R.split+    put (g1 :: g)+    a <- runRandomC m+    a <$ put g2+  {-# INLINE interleave #-} +instance (Carrier sig m, Effect sig, R.RandomGen g) => Carrier (Random :+: sig) (RandomC g m) where+  eff (L (Random       k)) = getRandom >>= k+  eff (L (RandomR r    k)) = getRandomR r >>= k+  eff (L (Interleave m k)) = interleave m >>= k+  eff (R other)            = RandomC (eff (R (handleCoercible other)))+  {-# INLINE eff #-}++ -- $setup -- >>> :seti -XFlexibleContexts -- >>> import System.Random -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure -- >>> import Control.Effect.NonDet -- >>> newtype PureGen = PureGen Int deriving (Eq, Show) -- >>> instance RandomGen PureGen where next (PureGen i) = (i, PureGen i) ; split g = (g, g)

@@ -1,25 +0,0 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, StandaloneDeriving #-}-module Control.Effect.Random.Internal-( Random(..)-) where--import Control.Effect.Carrier-import qualified System.Random as R (Random(..))--data Random m k-  = forall a . R.Random a => Random (a -> k)-  | forall a . R.Random a => RandomR (a, a) (a -> k)-  | forall a . Interleave (m a) (a -> k)--deriving instance Functor (Random m)--instance HFunctor Random where-  hmap _ (Random k) = Random k-  hmap _ (RandomR r k) = RandomR r k-  hmap f (Interleave m k) = Interleave (f m) k-  {-# INLINE hmap #-}--instance Effect Random where-  handle state handler (Random    k) = Random    (handler . (<$ state) . k)-  handle state handler (RandomR r k) = RandomR r (handler . (<$ state) . k)-  handle state handler (Interleave m k) = Interleave (handler (m <$ state)) (handler . fmap k)

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Reader ( Reader(..) , ask@@ -8,9 +8,14 @@ , ReaderC(..) ) where +import Control.Applicative (Alternative(..), liftA2) import Control.Effect.Carrier import Control.Effect.Sum-import Control.Effect.Internal+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Prelude hiding (fail)  data Reader r m k   = Ask (r -> k)@@ -30,38 +35,70 @@ -- --   prop> run (runReader a ask) == a ask :: (Member (Reader r) sig, Carrier sig m) => m r-ask = send (Ask ret)+ask = send (Ask pure)  -- | Project a function out of the current environment value. -- --   prop> snd (run (runReader a (asks (applyFun f)))) == applyFun f a asks :: (Member (Reader r) sig, Carrier sig m) => (r -> a) -> m a-asks f = send (Ask (ret . f))+asks f = send (Ask (pure . f))  -- | Run a computation with an environment value locally modified by the passed function. -- --   prop> run (runReader a (local (applyFun f) ask)) == applyFun f a --   prop> run (runReader a ((,,) <$> ask <*> local (applyFun f) ask <*> ask)) == (a, applyFun f a, a) local :: (Member (Reader r) sig, Carrier sig m) => (r -> r) -> m a -> m a-local f m = send (Local f m ret)+local f m = send (Local f m pure)   -- | Run a 'Reader' effect with the passed environment value. -- --   prop> run (runReader a (pure b)) == b-runReader :: forall r sig m a . (Carrier sig m, Monad m) => r -> Eff (ReaderC r m) a -> m a-runReader r m = runReaderC (interpret m) r+runReader :: r -> ReaderC r m a -> m a+runReader r c = runReaderC c r+{-# INLINE runReader #-}  newtype ReaderC r m a = ReaderC { runReaderC :: r -> m a }+  deriving (Functor) -instance (Carrier sig m, Monad m) => Carrier (Reader r :+: sig) (ReaderC r m) where-  ret a = ReaderC (const (ret a))-  eff op = ReaderC (\ r -> handleSum (eff . handleReader r runReaderC) (\case-    Ask       k -> runReaderC (k r) r-    Local f m k -> runReaderC m (f r) >>= flip runReaderC r . k) op)+instance Applicative m => Applicative (ReaderC r m) where+  pure = ReaderC . const . pure+  {-# INLINE pure #-}+  ReaderC f <*> ReaderC a = ReaderC (liftA2 (<*>) f a)+  {-# INLINE (<*>) #-} +instance Alternative m => Alternative (ReaderC r m) where+  empty = ReaderC (const empty)+  {-# INLINE empty #-}+  ReaderC l <|> ReaderC r = ReaderC (liftA2 (<|>) l r)+  {-# INLINE (<|>) #-} +instance Monad m => Monad (ReaderC r m) where+  ReaderC a >>= f = ReaderC (\ r -> a r >>= runReader r . f)+  {-# INLINE (>>=) #-}++instance MonadFail m => MonadFail (ReaderC r m) where+  fail = ReaderC . const . fail+  {-# INLINE fail #-}++instance MonadIO m => MonadIO (ReaderC r m) where+  liftIO = ReaderC . const . liftIO+  {-# INLINE liftIO #-}++instance (Alternative m, Monad m) => MonadPlus (ReaderC r m)++instance MonadTrans (ReaderC r) where+  lift = ReaderC . const+  {-# INLINE lift #-}++instance Carrier sig m => Carrier (Reader r :+: sig) (ReaderC r m) where+  eff (L (Ask       k)) = ReaderC (\ r -> runReader r (k r))+  eff (L (Local f m k)) = ReaderC (\ r -> runReader (f r) m) >>= k+  eff (R other)         = ReaderC (\ r -> eff (handlePure (runReader r) other))+  {-# INLINE eff #-}++ -- $setup -- >>> :seti -XFlexibleContexts -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Resource ( Resource(..) , bracket@@ -9,11 +9,15 @@ , ResourceC(..) ) where +import           Control.Applicative (Alternative(..)) import           Control.Effect.Carrier-import           Control.Effect.Internal+import           Control.Effect.Reader import           Control.Effect.Sum import qualified Control.Exception as Exc+import           Control.Monad (MonadPlus(..))+import           Control.Monad.Fail import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  data Resource m k   = forall resource any output . Resource (m resource) (resource -> m any) (resource -> m output) (output -> k)@@ -44,7 +48,7 @@         -> (resource -> m any)  -- ^ computation to run last ("release resource")         -> (resource -> m a)    -- ^ computation to run in-between         -> m a-bracket acquire release use = send (Resource acquire release use ret)+bracket acquire release use = send (Resource acquire release use pure)  -- | Like 'bracket', but only performs the final action if there was an -- exception raised by the in-between computation.@@ -53,46 +57,51 @@                -> (resource -> m any)  -- ^ computation to run last ("release resource")                -> (resource -> m a)    -- ^ computation to run in-between                -> m a-bracketOnError acquire release use = send (OnError acquire release use ret)+bracketOnError acquire release use = send (OnError acquire release use pure)  -- | Like 'bracket', but for the simple case of one computation to run afterward.-finally :: (Member Resource sig, Carrier sig m, Applicative m)+finally :: (Member Resource sig, Carrier sig m)         => m a -- ^ computation to run first         -> m b -- ^ computation to run afterward (even if an exception was raised)         -> m a finally act end = bracket (pure ()) (const end) (const act)  -- | Like 'bracketOnError', but for the simple case of one computation to run afterward.-onException :: (Member Resource sig, Carrier sig m, Applicative m)+onException :: (Member Resource sig, Carrier sig m)         => m a -- ^ computation to run first         -> m b -- ^ computation to run afterward if an exception was raised         -> m a onException act end = bracketOnError (pure ()) (const end) (const act) -runResource :: (Carrier sig m, MonadIO m)-            => (forall x . m x -> IO x)-            -> Eff (ResourceC m) a+runResource :: (forall x . m x -> IO x)+            -> ResourceC m a             -> m a-runResource handler = runResourceC handler . interpret+runResource handler = runReader (Handler handler) . runResourceC -newtype ResourceC m a = ResourceC ((forall x . m x -> IO x) -> m a)+newtype ResourceC m a = ResourceC { runResourceC :: ReaderC (Handler m) m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus) -runResourceC :: (forall x . m x -> IO x) -> ResourceC m a -> m a-runResourceC handler (ResourceC m) = m handler+instance MonadTrans ResourceC where+  lift = ResourceC . lift +newtype Handler m = Handler (forall x . m x -> IO x)++runHandler :: Handler m -> ResourceC m a -> IO a+runHandler h@(Handler handler) = handler . runReader h . runResourceC+ instance (Carrier sig m, MonadIO m) => Carrier (Resource :+: sig) (ResourceC m) where-  ret a = ResourceC (const (ret a))-  eff op = ResourceC (\ handler -> handleSum-    (eff . handlePure (runResourceC handler))-    (\case-        Resource acquire release use k -> liftIO (Exc.bracket-                                                    (handler (runResourceC handler acquire))-                                                    (handler . runResourceC handler . release)-                                                    (handler . runResourceC handler . use))-                                            >>= runResourceC handler . k-        OnError acquire release use k -> liftIO (Exc.bracketOnError-                                                    (handler (runResourceC handler acquire))-                                                    (handler . runResourceC handler . release)-                                                    (handler . runResourceC handler . use))-                                            >>= runResourceC handler . k-    ) op)+  eff (L (Resource acquire release use k)) = do+    handler <- ResourceC ask+    a <- liftIO (Exc.bracket+      (runHandler handler acquire)+      (runHandler handler . release)+      (runHandler handler . use))+    k a+  eff (L (OnError  acquire release use k)) = do+    handler <- ResourceC ask+    a <- liftIO (Exc.bracketOnError+      (runHandler handler acquire)+      (runHandler handler . release)+      (runHandler handler . use))+    k a+  eff (R other)                            = ResourceC (eff (R (handleCoercible other)))

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Resumable ( Resumable(..) , throwResumable@@ -9,10 +9,16 @@ , ResumableWithC(..) ) where +import Control.Applicative (Alternative(..)) import Control.DeepSeq import Control.Effect.Carrier-import Control.Effect.Internal+import Control.Effect.Error+import Control.Effect.Reader import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class import Data.Coerce import Data.Functor.Classes @@ -33,7 +39,7 @@ -- --   prop> run (runResumable (throwResumable (Identity a))) == Left (SomeError (Identity a)) throwResumable :: (Member (Resumable err) sig, Carrier sig m) => err a -> m a-throwResumable err = send (Resumable err ret)+throwResumable err = send (Resumable err pure)   -- | An error at some existentially-quantified type index.@@ -64,7 +70,7 @@ -- --   prop> show (SomeError (Identity a)) == "SomeError (Identity )" --   prop> show (SomeError (Const a)) == ("SomeError (Const " ++ showsPrec 11 a ")")-instance (Show1 err) => Show (SomeError err) where+instance Show1 err => Show (SomeError err) where   showsPrec d (SomeError err) = showsUnaryWith (liftShowsPrec (const (const id)) (const id)) "SomeError" d err  @@ -78,16 +84,16 @@ -- | Run a 'Resumable' effect, returning uncaught errors in 'Left' and successful computations’ values in 'Right'. -- --   prop> run (runResumable (pure a)) == Right @(SomeError Identity) @Int a-runResumable :: (Carrier sig m, Effect sig) => Eff (ResumableC err m) a -> m (Either (SomeError err) a)-runResumable = runResumableC . interpret+runResumable :: ResumableC err m a -> m (Either (SomeError err) a)+runResumable = runError . runResumableC -newtype ResumableC err m a = ResumableC { runResumableC :: m (Either (SomeError err) a) }+newtype ResumableC err m a = ResumableC { runResumableC :: ErrorC (SomeError err) m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans)  instance (Carrier sig m, Effect sig) => Carrier (Resumable err :+: sig) (ResumableC err m) where-  ret a = ResumableC (ret (Right a))-  eff = ResumableC . handleSum-    (eff . handleEither runResumableC)-    (\ (Resumable err _) -> ret (Left (SomeError err)))+  eff (L (Resumable err _)) = ResumableC (throwError (SomeError err))+  eff (R other)             = ResumableC (eff (R (handleCoercible other)))+  {-# INLINE eff #-}   -- | Run a 'Resumable' effect, resuming uncaught errors with a given handler.@@ -98,29 +104,31 @@ -- --   prop> run (runResumableWith (\ (Err b) -> pure (1 + b)) (pure a)) == a --   prop> run (runResumableWith (\ (Err b) -> pure (1 + b)) (throwResumable (Err a))) == 1 + a-runResumableWith :: (Carrier sig m, Monad m)-                 => (forall x . err x -> m x)-                 -> Eff (ResumableWithC err m) a+runResumableWith :: (forall x . err x -> m x)+                 -> ResumableWithC err m a                  -> m a-runResumableWith with = runResumableWithC with . interpret+runResumableWith with = runReader (Handler with) . runResumableWithC -newtype ResumableWithC err m a = ResumableWithC ((forall x . err x -> m x) -> m a)+newtype ResumableWithC err m a = ResumableWithC { runResumableWithC :: ReaderC (Handler err m) m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus) -runResumableWithC :: (forall x . err x -> m x) -> ResumableWithC err m a -> m a-runResumableWithC f (ResumableWithC m) = m f+instance MonadTrans (ResumableWithC err) where+  lift = ResumableWithC . lift+  {-# INLINE lift #-} -instance (Carrier sig m, Monad m) => Carrier (Resumable err :+: sig) (ResumableWithC err m) where-  ret a = ResumableWithC (const (ret a))-  eff op = ResumableWithC (\ handler -> handleSum-    (eff . handlePure (runResumableWithC handler))-    (\ (Resumable err k) -> handler err >>= runResumableWithC handler . k) op)+newtype Handler err m = Handler { runHandler :: forall x . err x -> m x } +instance Carrier sig m => Carrier (Resumable err :+: sig) (ResumableWithC err m) where+  eff (L (Resumable err k)) = ResumableWithC (ReaderC (\ handler -> runHandler handler err)) >>= k+  eff (R other)             = ResumableWithC (eff (R (handleCoercible other)))+  {-# INLINE eff #-} + -- $setup -- >>> :seti -XFlexibleContexts -- >>> :seti -XGADTs -- >>> :seti -XTypeApplications -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure -- >>> import Data.Functor.Const -- >>> import Data.Functor.Identity

@@ -1,92 +1,5 @@-{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, KindSignatures, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} module Control.Effect.State-( State(..)-, get-, gets-, put-, modify-, runState-, evalState-, execState-, StateC(..)+( module Control.Effect.State.Strict ) where -import Control.Effect.Carrier-import Control.Effect.Sum-import Control.Effect.Internal-import Data.Coerce--data State s (m :: * -> *) k-  = Get (s -> k)-  | Put s k-  deriving (Functor)--instance HFunctor (State s) where-  hmap _ = coerce-  {-# INLINE hmap #-}--instance Effect (State s) where-  handle state handler (Get k)   = Get   (handler . (<$ state) . k)-  handle state handler (Put s k) = Put s (handler . (<$ state) $ k)---- | Get the current state value.------   prop> snd (run (runState a get)) == a-get :: (Member (State s) sig, Carrier sig m) => m s-get = send (Get ret)---- | Project a function out of the current state value.------   prop> snd (run (runState a (gets (applyFun f)))) == applyFun f a-gets :: (Member (State s) sig, Carrier sig m) => (s -> a) -> m a-gets f = send (Get (ret . f))---- | Replace the state value with a new value.------   prop> fst (run (runState a (put b))) == b---   prop> snd (run (runState a (get <* put b))) == a---   prop> snd (run (runState a (put b *> get))) == b-put :: (Member (State s) sig, Carrier sig m) => s -> m ()-put s = send (Put s (ret ()))---- | Replace the state value with the result of applying a function to the current state value.---   This is strict in the new state; if you need laziness, use @get >>= put . f@.------   prop> fst (run (runState a (modify (+1)))) == (1 + a :: Integer)-modify :: (Member (State s) sig, Carrier sig m, Monad m) => (s -> s) -> m ()-modify f = do-   a <- get-   put $! f a---- | Run a 'State' effect starting from the passed value.------   prop> run (runState a (pure b)) == (a, b)-runState :: forall s sig m a . (Carrier sig m, Effect sig) => s -> Eff (StateC s m) a -> m (s, a)-runState s m = runStateC (interpret m) s---- | Run a 'State' effect, yielding the result value and discarding the final state.------   prop> run (evalState a (pure b)) == b-evalState :: forall s sig m a . (Carrier sig m, Effect sig, Functor m) => s -> Eff (StateC s m) a -> m a-evalState s m = fmap snd (runStateC (interpret m) s)---- | Run a 'State' effect, yielding the final state and discarding the return value.------   prop> run (execState a (pure b)) == a-execState :: forall s sig m a . (Carrier sig m, Effect sig, Functor m) => s -> Eff (StateC s m) a -> m s-execState s m = fmap fst (runStateC (interpret m) s)---newtype StateC s m a = StateC { runStateC :: s -> m (s, a) }--instance (Carrier sig m, Effect sig) => Carrier (State s :+: sig) (StateC s m) where-  ret a = StateC (\ s -> ret (s, a))-  eff op = StateC (\ s -> handleSum (eff . handleState s runStateC) (\case-    Get   k -> runStateC (k s) s-    Put s k -> runStateC  k    s) op)----- $setup--- >>> :seti -XFlexibleContexts--- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+import Control.Effect.State.Strict

@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.State.Internal+( State(..)+, get+, gets+, put+, modify+, modifyLazy+) where++import Control.Effect.Carrier+import Control.Effect.Sum+import Data.Coerce+import Prelude hiding (fail)++data State s (m :: * -> *) k+  = Get (s -> k)+  | Put s k+  deriving (Functor)++instance HFunctor (State s) where+  hmap _ = coerce+  {-# INLINE hmap #-}++instance Effect (State s) where+  handle state handler (Get k)   = Get   (handler . (<$ state) . k)+  handle state handler (Put s k) = Put s (handler . (<$ state) $ k)++-- | Get the current state value.+--+--   prop> snd (run (runState a get)) == a+get :: (Member (State s) sig, Carrier sig m) => m s+get = send (Get pure)++-- | Project a function out of the current state value.+--+--   prop> snd (run (runState a (gets (applyFun f)))) == applyFun f a+gets :: (Member (State s) sig, Carrier sig m) => (s -> a) -> m a+gets f = send (Get (pure . f))++-- | Replace the state value with a new value.+--+--   prop> fst (run (runState a (put b))) == b+--   prop> snd (run (runState a (get <* put b))) == a+--   prop> snd (run (runState a (put b *> get))) == b+put :: (Member (State s) sig, Carrier sig m) => s -> m ()+put s = send (Put s (pure ()))++-- | Replace the state value with the result of applying a function to the current state value.+--   This is strict in the new state.+--+--   prop> fst (run (runState a (modify (+1)))) == (1 + a :: Integer)+modify :: (Member (State s) sig, Carrier sig m) => (s -> s) -> m ()+modify f = do+  a <- get+  put $! f a++-- | Replace the state value with the result of applying a function to the current state value.+--   This is lazy in the new state; injudicious use of this function may lead to space leaks.+modifyLazy :: (Member (State s) sig, Carrier sig m) => (s -> s) -> m ()+modifyLazy f = get >>= put . f++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Pure+-- >>> import Control.Effect.State.Strict

@@ -0,0 +1,95 @@+{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.State.Lazy+( State (..)+, get+, gets+, put+, modify+, modifyLazy+, StateC(..)+, runState+, evalState+, execState+) where++import Control.Applicative (Alternative(..))+import Control.Effect.Carrier+import Control.Effect.Sum+import Control.Effect.State.Internal+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Prelude hiding (fail)++newtype StateC s m a = StateC { runStateC :: s -> m (s, a) }++instance Functor m => Functor (StateC s m) where+  fmap f m = StateC $ \ s -> fmap (\ ~(s', a) -> (s', f a)) $ runStateC m s+  {-# INLINE fmap #-}++instance (Functor m, Monad m) => Applicative (StateC s m) where+  pure a = StateC $ \ s -> pure (s, a)+  StateC mf <*> StateC mx = StateC $ \ s -> do+    ~(s', f) <- mf s+    ~(s'', x) <- mx s'+    return (s'', f x)+  {-# INLINE (<*>) #-}++instance Monad m => Monad (StateC s m) where+  m >>= k  = StateC $ \ s -> do+    ~(s', a) <- runStateC m s+    runStateC (k a) s'+  {-# INLINE (>>=) #-}++instance (Alternative m, Monad m) => Alternative (StateC s m) where+  empty = StateC (const empty)+  {-# INLINE empty #-}+  StateC l <|> StateC r = StateC (\ s -> l s <|> r s)+  {-# INLINE (<|>) #-}++instance MonadFail m => MonadFail (StateC s m) where+  fail s = StateC (const (fail s))+  {-# INLINE fail #-}++instance MonadIO m => MonadIO (StateC s m) where+  liftIO io = StateC (\ s -> (,) s <$> liftIO io)+  {-# INLINE liftIO #-}++instance (Alternative m, Monad m) => MonadPlus (StateC s m)++instance MonadTrans (StateC s) where+  lift m = StateC (\ s -> (,) s <$> m)+  {-# INLINE lift #-}++instance (Carrier sig m, Effect sig) => Carrier (State s :+: sig) (StateC s m) where+  eff (L (Get   k)) = StateC (\ s -> runState s (k s))+  eff (L (Put s k)) = StateC (\ _ -> runState s k)+  eff (R other)     = StateC (\ s -> eff (handle (s, ()) (uncurry runState) other))+  {-# INLINE eff #-}++-- | Run a lazy 'State' effect, yielding the result value and the final state.+--   More programs terminate with lazy state than strict state, but injudicious+--   use of lazy state may lead to thunk buildup.+--+--   prop> run (runState a (pure b)) == (a, b)+--   prop> take 5 . snd . run $ runState () (traverse pure [1..]) == [1,2,3,4,5]+runState :: s -> StateC s m a -> m (s, a)+runState s c = runStateC c s++-- | Run a lazy 'State' effect, yielding the result value and discarding the final state.+--+--   prop> run (evalState a (pure b)) == b+evalState :: forall s m a . Functor m => s -> StateC s m a -> m a+evalState s = fmap snd . runState s++-- | Run a lazy 'State' effect, yielding the final state and discarding the return value.+--+--   prop> run (execState a (pure b)) == a+execState :: forall s m a . Functor m => s -> StateC s m a -> m s+execState s = fmap fst . runState s++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Pure

@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.State.Strict+( State (..)+, get+, gets+, put+, modify+, modifyLazy+, StateC(..)+, runState+, evalState+, execState+) where++import Control.Applicative (Alternative(..))+import Control.Effect.Carrier+import Control.Effect.State.Internal+import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Prelude hiding (fail)++-- | Run a 'State' effect starting from the passed value.+--+--   prop> run (runState a (pure b)) == (a, b)+runState :: s -> StateC s m a -> m (s, a)+runState = flip runStateC++-- | Run a 'State' effect, yielding the result value and discarding the final state.+--+--   prop> run (evalState a (pure b)) == b+evalState :: forall s m a . Functor m => s -> StateC s m a -> m a+evalState s = fmap snd . runState s++-- | Run a 'State' effect, yielding the final state and discarding the return value.+--+--   prop> run (execState a (pure b)) == a+execState :: forall s m a . Functor m => s -> StateC s m a -> m s+execState s = fmap fst . runState s+++newtype StateC s m a = StateC { runStateC :: s -> m (s, a) }+  deriving (Functor)++instance Monad m => Applicative (StateC s m) where+  pure a = StateC (\ s -> pure (s, a))+  StateC f <*> StateC a = StateC $ \ s -> do+    (s', f') <- f s+    (s'', a') <- a s'+    let fa = f' a'+    fa `seq` pure (s'', fa)++instance (Alternative m, Monad m) => Alternative (StateC s m) where+  empty = StateC (const empty)+  StateC l <|> StateC r = StateC (\ s -> l s <|> r s)++instance Monad m => Monad (StateC s m) where+  StateC m >>= f = StateC $ \ s -> do+    (s', a) <- m s+    let fa = f a+    fa `seq` runState s' fa++instance MonadFail m => MonadFail (StateC s m) where+  fail s = StateC (const (fail s))++instance MonadIO m => MonadIO (StateC s m) where+  liftIO io = StateC (\ s -> (,) s <$> liftIO io)++instance (Alternative m, Monad m) => MonadPlus (StateC s m)++instance MonadTrans (StateC s) where+  lift m = StateC (\ s -> (,) s <$> m)++instance (Carrier sig m, Effect sig) => Carrier (State s :+: sig) (StateC s m) where+  eff (L (Get   k)) = StateC (\ s -> runState s (k s))+  eff (L (Put s k)) = StateC (\ _ -> runState s k)+  eff (R other)     = StateC (\ s -> eff (handle (s, ()) (uncurry runState) other))++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Pure

@@ -26,17 +26,16 @@   handle state handler (L l) = L (handle state handler l)   handle state handler (R r) = R (handle state handler r) - -- | Lift algebras for either side of a sum into a single algebra on sums. -- --   Note that the order of the functions is the opposite of members of the sum. This is more convenient for defining effect handlers as lambdas (especially using @-XLambdaCase@) on the right, enabling better error messaging when using typed holes than would be the case with a binding in a where clause.+{-# DEPRECATED handleSum "Carriers are now monads, so handleSum is obsolete: define handlers with do-notation and pattern-matching on L and R" #-} handleSum :: (          sig2  m a -> b)           -> ( sig1           m a -> b)           -> ((sig1 :+: sig2) m a -> b) handleSum alg1 _    (R op) = alg1 op handleSum _    alg2 (L op) = alg2 op {-# INLINE handleSum #-}-  class Member (sub :: (* -> *) -> (* -> *)) sup where   inj :: sub m a -> sup m a

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} module Control.Effect.Trace ( Trace(..) , trace@@ -10,10 +10,14 @@ , TraceByReturningC(..) ) where +import Control.Applicative (Alternative(..)) import Control.Effect.Carrier-import Control.Effect.Internal+import Control.Effect.State import Control.Effect.Sum+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail import Control.Monad.IO.Class+import Control.Monad.Trans.Class import Data.Bifunctor (first) import Data.Coerce import System.IO@@ -33,51 +37,60 @@  -- | Append a message to the trace log. trace :: (Member Trace sig, Carrier sig m) => String -> m ()-trace message = send (Trace message (ret ()))+trace message = send (Trace message (pure ()))   -- | Run a 'Trace' effect, printing traces to 'stderr'.-runTraceByPrinting :: (MonadIO m, Carrier sig m) => Eff (TraceByPrintingC m) a -> m a-runTraceByPrinting = runTraceByPrintingC . interpret+runTraceByPrinting :: TraceByPrintingC m a -> m a+runTraceByPrinting = runTraceByPrintingC  newtype TraceByPrintingC m a = TraceByPrintingC { runTraceByPrintingC :: m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus) +instance MonadTrans TraceByPrintingC where+  lift = TraceByPrintingC+  {-# INLINE lift #-}+ instance (MonadIO m, Carrier sig m) => Carrier (Trace :+: sig) (TraceByPrintingC m) where-  ret = TraceByPrintingC . ret-  eff = TraceByPrintingC . handleSum-    (eff . handlePure runTraceByPrintingC)-    (\ (Trace s k) -> liftIO (hPutStrLn stderr s) *> runTraceByPrintingC k)+  eff (L (Trace s k)) = liftIO (hPutStrLn stderr s) *> k+  eff (R other)       = TraceByPrintingC (eff (handleCoercible other))+  {-# INLINE eff #-}   -- | Run a 'Trace' effect, ignoring all traces. -- --   prop> run (runTraceByIgnoring (trace a *> pure b)) == b-runTraceByIgnoring :: Carrier sig m => Eff (TraceByIgnoringC m) a -> m a-runTraceByIgnoring = runTraceByIgnoringC . interpret+runTraceByIgnoring :: TraceByIgnoringC m a -> m a+runTraceByIgnoring = runTraceByIgnoringC  newtype TraceByIgnoringC m a = TraceByIgnoringC { runTraceByIgnoringC :: m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus) +instance MonadTrans TraceByIgnoringC where+  lift = TraceByIgnoringC+  {-# INLINE lift #-}+ instance Carrier sig m => Carrier (Trace :+: sig) (TraceByIgnoringC m) where-  ret = TraceByIgnoringC . ret-  eff = handleSum (TraceByIgnoringC . eff . handlePure runTraceByIgnoringC) traceCont+  eff (L trace) = traceCont trace+  eff (R other) = TraceByIgnoringC (eff (handleCoercible other))+  {-# INLINE eff #-}   -- | Run a 'Trace' effect, returning all traces as a list. -- --   prop> run (runTraceByReturning (trace a *> trace b *> pure c)) == ([a, b], c)-runTraceByReturning :: (Carrier sig m, Effect sig, Functor m) => Eff (TraceByReturningC m) a -> m ([String], a)-runTraceByReturning = fmap (first reverse) . flip runTraceByReturningC [] . interpret+runTraceByReturning :: Functor m => TraceByReturningC m a -> m ([String], a)+runTraceByReturning = fmap (first reverse) . runState [] . runTraceByReturningC -newtype TraceByReturningC m a = TraceByReturningC { runTraceByReturningC :: [String] -> m ([String], a) }+newtype TraceByReturningC m a = TraceByReturningC { runTraceByReturningC :: StateC [String] m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans)  instance (Carrier sig m, Effect sig) => Carrier (Trace :+: sig) (TraceByReturningC m) where-  ret a = TraceByReturningC (\ s -> ret (s, a))-  eff op = TraceByReturningC (\ s -> handleSum-    (eff . handleState s runTraceByReturningC)-    (\ (Trace m k) -> runTraceByReturningC k (m : s)) op)+  eff (L (Trace m k)) = TraceByReturningC (modify (m :)) *> k+  eff (R other)       = TraceByReturningC (eff (R (handleCoercible other)))   -- $setup -- >>> :seti -XFlexibleContexts -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure

@@ -1,53 +0,0 @@-{-# LANGUAGE DeriveFunctor, EmptyCase, KindSignatures, MultiParamTypeClasses #-}-module Control.Effect.Void-( Void-, run-, VoidC(..)-) where--import Control.Effect.Carrier-import Control.Effect.Internal--data Void (m :: * -> *) k-  deriving (Functor)--instance HFunctor Void where-  hmap _ v = case v of {}-  {-# INLINE hmap #-}--instance Effect Void where-  handle _ _ v = case v of {}-  {-# INLINE handle #-}----- | Run an 'Eff' exhausted of effects to produce its final result value.-run :: Eff VoidC a -> a-run = runVoidC . interpret-{-# INLINE run #-}--newtype VoidC a = VoidC { runVoidC :: a }--instance Functor VoidC where-  fmap f (VoidC a) = VoidC (f a)-  {-# INLINE fmap #-}--instance Applicative VoidC where-  pure = VoidC-  {-# INLINE pure #-}--  VoidC f <*> VoidC a = VoidC (f a)-  {-# INLINE (<*>) #-}--instance Monad VoidC where-  return = pure-  {-# INLINE return #-}--  VoidC a >>= f = f a-  {-# INLINE (>>=) #-}--instance Carrier Void VoidC where-  ret = VoidC-  {-# INLINE ret #-}--  eff v = case v of {}-  {-# INLINE eff #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, ExplicitForAll, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Writer ( Writer(..) , tell@@ -10,9 +10,14 @@ , WriterC(..) ) where +import Control.Applicative (Alternative(..)) import Control.Effect.Carrier+import Control.Effect.State import Control.Effect.Sum-import Control.Effect.Internal+import Control.Monad (MonadPlus(..))+import Control.Monad.Fail+import Control.Monad.IO.Class+import Control.Monad.Trans.Class  data Writer w m k   = Tell w k@@ -37,21 +42,21 @@ -- --   prop> fst (run (runWriter (mapM_ (tell . Sum) (0 : ws)))) == foldMap Sum ws tell :: (Member (Writer w) sig, Carrier sig m) => w -> m ()-tell w = send (Tell w (ret ()))+tell w = send (Tell w (pure ())) {-# INLINE tell #-}  -- | Run a computation, returning the pair of its output and its result. -- --   prop> run (runWriter (fst <$ tell (Sum a) <*> listen @(Sum Integer) (tell (Sum b)))) == (Sum a <> Sum b, Sum b) listen :: (Member (Writer w) sig, Carrier sig m) => m a -> m (w, a)-listen m = send (Listen m (curry ret))+listen m = send (Listen m (curry pure)) {-# INLINE listen #-}  -- | Run a computation, applying a function to its output and returning the pair of the modified output and its result. -- --   prop> run (runWriter (fst <$ tell (Sum a) <*> listens @(Sum Integer) (applyFun f) (tell (Sum b)))) == (Sum a <> Sum b, applyFun f (Sum b)) listens :: (Member (Writer w) sig, Carrier sig m) => (w -> b) -> m a -> m (b, a)-listens f m = send (Listen m (curry ret . f))+listens f m = send (Listen m (curry pure . f)) {-# INLINE listens #-}  -- | Run a computation, modifying its output with the passed function.@@ -59,21 +64,21 @@ --   prop> run (execWriter (censor (applyFun f) (tell (Sum a)))) == applyFun f (Sum a) --   prop> run (execWriter (tell (Sum a) *> censor (applyFun f) (tell (Sum b)) *> tell (Sum c))) == (Sum a <> applyFun f (Sum b) <> Sum c) censor :: (Member (Writer w) sig, Carrier sig m) => (w -> w) -> m a -> m a-censor f m = send (Censor f m ret)+censor f m = send (Censor f m pure) {-# INLINE censor #-}   -- | Run a 'Writer' effect with a 'Monoid'al log, producing the final log alongside the result value. -- --   prop> run (runWriter (tell (Sum a) *> pure b)) == (Sum a, b)-runWriter :: forall w sig m a . (Carrier sig m, Effect sig, Monad m, Monoid w) => Eff (WriterC w m) a -> m (w, a)-runWriter m = runWriterC (interpret m) mempty+runWriter :: Monoid w => WriterC w m a -> m (w, a)+runWriter = runState mempty . runWriterC {-# INLINE runWriter #-}  -- | Run a 'Writer' effect with a 'Monoid'al log, producing the final log and discarding the result value. -- --   prop> run (execWriter (tell (Sum a) *> pure b)) == Sum a-execWriter :: forall w sig m a . (Carrier sig m, Effect sig, Monad m, Monoid w) => Eff (WriterC w m) a -> m w+execWriter :: (Monoid w, Functor m) => WriterC w m a -> m w execWriter = fmap fst . runWriter {-# INLINE execWriter #-} @@ -81,49 +86,27 @@ -- | A space-efficient carrier for 'Writer' effects. -- --   This is based on a post Gabriel Gonzalez made to the Haskell mailing list: https://mail.haskell.org/pipermail/libraries/2013-March/019528.html------   Note that currently, the constant-space behaviour observed there only occurs when using 'WriterC' and 'VoidC' without 'Eff' wrapping them. See the @benchmark@ component for details.-newtype WriterC w m a = WriterC { runWriterC :: w -> m (w, a) }--instance Functor m => Functor (WriterC w m) where-  fmap f (WriterC run) = WriterC (\ w -> fmap (fmap f) (run w))-  {-# INLINE fmap #-}--instance (Monad m, Monoid w) => Applicative (WriterC w m) where-  pure a = WriterC $ \w -> pure (w, a)-  {-# INLINE pure #-}--  WriterC f <*> WriterC a = WriterC $ \ w -> do-    (w', f') <- f w-    (w'', a') <- a w'-    let fa = f' a'-    fa `seq` pure (w'', fa)-  {-# INLINE (<*>) #-}--instance (Monad m, Monoid w) => Monad (WriterC w m) where-  return = pure-  {-# INLINE return #-}--  m >>= f  = WriterC $ \w -> do-    (w', a) <- runWriterC m w-    runWriterC (f a) w'-  {-# INLINE (>>=) #-}--instance (Monoid w, Carrier sig m, Effect sig, Monad m) => Carrier (Writer w :+: sig) (WriterC w m) where-  ret a = WriterC (\ w -> ret (w, a))-  {-# INLINE ret #-}+newtype WriterC w m a = WriterC { runWriterC :: StateC w m a }+  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans) -  eff op = WriterC (\ w -> handleSum (eff . handleState w runWriterC) (\case-    Tell w'    k -> let w'' = mappend w w' in w'' `seq` runWriterC k w''-    Listen   m k -> do-      (w', a) <- runWriterC m mempty-      let w'' = mappend w w'-      w'' `seq` runWriterC (k w' a) w''-    Censor f m k -> do-      (w', a) <- runWriterC m mempty-      let w'' = mappend w (f w')-      w'' `seq` runWriterC (k a) w'')-    op)+instance (Monoid w, Carrier sig m, Effect sig) => Carrier (Writer w :+: sig) (WriterC w m) where+  eff (L (Tell w     k)) = WriterC $ do+    modify (`mappend` w)+    runWriterC k+  eff (L (Listen   m k)) = WriterC $ do+    w <- get+    put (mempty :: w)+    a <- runWriterC m+    w' <- get+    modify (mappend (w :: w))+    runWriterC (k w' a)+  eff (L (Censor f m k)) = WriterC $ do+    w <- get+    put (mempty :: w)+    a <- runWriterC m+    modify (mappend w . f)+    runWriterC (k a)+  eff (R other)          = WriterC (eff (R (handleCoercible other)))   {-# INLINE eff #-}  @@ -131,5 +114,5 @@ -- >>> :seti -XFlexibleContexts -- >>> :seti -XTypeApplications -- >>> import Test.QuickCheck--- >>> import Control.Effect.Void+-- >>> import Control.Effect.Pure -- >>> import Data.Semigroup (Semigroup(..), Sum(..))

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} module Control.Effect.Spec where  import Control.Effect@@ -25,16 +25,15 @@ askEnv :: (Member (Reader env) sig, Carrier sig m) => HasEnv env m env askEnv = ask -runEnv :: Carrier sig m => env -> HasEnv env (ReaderC env (Eff m)) a -> HasEnv env m a+runEnv :: Carrier sig m => env -> HasEnv env (ReaderC env m) a -> HasEnv env m a runEnv r = HasEnv . runReader r . runHasEnv  -newtype HasEnv env carrier a = HasEnv { runHasEnv :: Eff carrier a }+newtype HasEnv env m a = HasEnv { runHasEnv :: m a }   deriving (Applicative, Functor, Monad) -instance Carrier sig carrier => Carrier sig (HasEnv env carrier) where-  ret = pure-  eff op = HasEnv (eff (handleCoercible op))+instance Carrier sig m => Carrier sig (HasEnv env m) where+  eff = HasEnv . eff . handleCoercible   reinterpretation :: Spec@@ -42,21 +41,21 @@   it "can reinterpret effects into other effects" $     run (runState "a" ((++) <$> reinterpretReader (local ('b':) ask) <*> get)) `shouldBe` ("a", "baa") -reinterpretReader :: (Carrier sig m, Effect sig) => Eff (ReinterpretReaderC r m) a -> Eff (StateC r m) a-reinterpretReader = runReinterpretReaderC . interpret+reinterpretReader :: ReinterpretReaderC r m a -> StateC r m a+reinterpretReader = runReinterpretReaderC -newtype ReinterpretReaderC r m a = ReinterpretReaderC { runReinterpretReaderC :: Eff (StateC r m) a }+newtype ReinterpretReaderC r m a = ReinterpretReaderC { runReinterpretReaderC :: StateC r m a }+  deriving (Applicative, Functor, Monad, MonadFail)  instance (Carrier sig m, Effect sig) => Carrier (Reader r :+: sig) (ReinterpretReaderC r m) where-  ret = ReinterpretReaderC . ret-  eff = ReinterpretReaderC . handleSum (eff . R . handleCoercible) (\case-    Ask       k -> get >>= runReinterpretReaderC . k-    Local f m k -> do-      a <- get-      put (f a)-      v <- runReinterpretReaderC m-      put a-      runReinterpretReaderC (k v))+  eff (L (Ask       k)) = ReinterpretReaderC get >>= k+  eff (L (Local f m k)) = do+    a <- ReinterpretReaderC get+    ReinterpretReaderC (put (f a))+    v <- m+    ReinterpretReaderC (put a)+    k v+  eff (R other)         = ReinterpretReaderC (eff (R (handleCoercible other)))   interposition :: Spec@@ -68,13 +67,16 @@     run (runFail (fail "world" *> interposeFail (pure (0 :: Int)))) `shouldBe` Left "world"     run (runFail (interposeFail (pure (0 :: Int)) <* fail "world")) `shouldBe` Left "world" -interposeFail :: (Member Fail sig, Carrier sig m) => Eff (InterposeC m) a -> m a-interposeFail = runInterposeC . interpret+interposeFail :: InterposeC m a -> m a+interposeFail = runInterposeC  newtype InterposeC m a = InterposeC { runInterposeC :: m a }+  deriving (Applicative, Functor, Monad) -instance (Member Fail sig, Carrier sig m) => Carrier sig (InterposeC m) where-  ret = InterposeC . ret+instance (Carrier sig m, Member Fail sig) => MonadFail (InterposeC m) where+  fail s = send (Fail s)++instance (Carrier sig m, Member Fail sig) => Carrier sig (InterposeC m) where   eff op     | Just (Fail s) <- prj op = InterposeC (send (Fail ("hello, " ++ s)))     | otherwise               = InterposeC (eff (handleCoercible op))