packages feed

fused-effects (empty) → 0.1.0.0

raw patch · 32 files changed

+1753/−0 lines, 32 filesdep +MonadRandomdep +basedep +deepseqsetup-changed

Dependencies added: MonadRandom, base, deepseq, doctest, fused-effects, hspec, random

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Rob Rix and Patrick Thomson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Rob Rix nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,297 @@+# 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)++- [Overview](#overview)+  - [Algebraic effects](#algebraic-effects)+  - [Higher-order effects](#fused-effects)+  - [Fusion](#fusion)+- [Usage](#usage)+  - [Using built-in effects](#using-built-in-effects)+  - [Running effects](#running-effects)+  - [Defining new effects](#defining-new-effects)+  - [Defining effect handlers](#defining-effect-handlers)+- [Benchmarks](#benchmarks)+- [Related work](#related-work)+  - [Comparison to `mtl`](#comparison-to--mtl-)+  - [Comparison to `freer-simple`](#comparison-to--freer-simple-)+++## Overview++`fused-effects` is an effect system for Haskell emphasizing expressivity and efficiency. The former is achieved by encoding [algebraic](#algebraic-effects), [higher-order](#fused-effects) effects, while the latter is the result of [fusing](#fusion) effect handlers all the way through computations.++Readers already familiar with effect systems may wish to start with the [usage](#usage) instead.+++### Algebraic effects++In `fused-effects` and other systems with _algebraic_ (or, sometimes, _extensible_) effects, effectful programs are split into two parts: the specification (or _syntax_) of the actions to be performed, and the interpretation (or _semantics_) given to them. Thus, a program written using the syntax of an effect can be given different meanings by using different effect handlers.++These roles are performed by the effect and carrier types, respectively. Effects are datatypes with one constructor for each action. Carriers are generally `newtype`s, with a `Carrier` instance specifying how an effect’s constructors should be interpreted. Each carrier handles one effect, but multiple carriers can be defined for the same effect, corresponding to different interpreters for the effect’s syntax.+++### Higher-order effects++Unlike most other effect systems, `fused-effects` offers _higher-order_ (or _scoped_) effects in addition to first-order algebraic effects. In a strictly first-order algebraic effect system, operations (like `local` or `catchError`) which specify some action limited to a given scope must be implemented as interpreters, hard-coding their meaning in precisely the manner algebraic effects were designed to avoid. By specifying effects as higher-order functors, these operations are likewise able to be given a variety of interpretations. This means, for example, that you can introspect and redefine both the `local` and `ask` operations provided by the `Reader` effect, rather than solely `ask` (as is the case with certain formulations of algebraic effects).++As Nicolas Wu et al showed in _[Effect Handlers in Scope][]_, this has implications for the expressiveness of effect systems. It also has the benefit of making effect handling more consistent, since scoped operations are just syntax which can be interpreted like any other, and are thus simpler to reason about.+++### Fusion++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.++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`.++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.+++## Usage++### Using built-in effects++Like other effect systems, effects are performed in a `Monad` extended with operations relating to the effect. In `fused-effects`, this is done by means of a `Member` constraint to require the effect’s presence in a _signature_, and a `Carrier` constraint to relate the signature to the `Monad`. For example, to use a `State` effect managing a `String`, one would write:++```haskell+action :: (Member (State String) sig, Carrier sig m) => m ()+```++(Additional constraints may be necessary depending on the precise operations required, e.g. to make the `Monad` methods available.)++Multiple effects can be required simply by adding their corresponding `Member` constraints to the context. For example, to add a `Reader` effect managing an `Int`, we would write:++```haskell+action :: (Member (State String) sig, Member (Reader Int) sig, Carrier sig m) => m ()+```++Different effects make different operations available; see the documentation for individual effects for more information about their operations. Note that we generally don't program against an explicit list of effect components: we take the typeclass-oriented approach, adding new constraints to `sig` as new capabilities become necessary. If you want to name and share some predefined list of effects, it's best to use the `-XConstraintKinds` extension to GHC, capturing the elements of `sig` as a type synonym of kind `Constraint`:++```haskell+type Shared sig = ( Member (State String) sig+                  , Member (Reader Int)   sig+                  , Member (Writer Graph) sig+                  )++myFunction :: (Shared sig, Carrier sig m) => Int -> m ()+```++### Running effects++Effects are run with _effect handlers_, specified as functions (generally starting with `run…`) invoking some specific `Carrier` instance. For example, we can run a `State` computation using `runState`:++```haskell+example1 :: (Carrier sig m, Effect sig) => [a] -> m (Int, ())+example1 list = runState 0 $ do+  i <- get+  put (i + length list)+```++`runState` returns a tuple of both the computed value (the `()`) and the final state (the `Int`), visible in the result of the returned computation.++Since this function returns a value in some carrier `m`, effect handlers can be chained to run multiple effects. Here, we get the list to compute the length of from a `Reader` effect:++```haskell+example2 :: (Carrier sig m, Effect sig, Monad m) => m (Int, ())+example2 = runReader "hello" . runState 0 $ do+  list <- ask+  put (length (list :: String))+```++(Note that the type annotation on `list` is necessary to disambiguate the requested value, since otherwise all the typechecker knows is that it’s an arbitrary `Foldable`. For more information, see the [comparison to `mtl`](#comparison-to--mtl-).)++When all effects have been handled, a computation’s final value can be extracted with `run`:++```haskell+example3 :: (Int, ())+example3 = run . runReader "hello" . runState 0 $ do+  list <- ask+  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.++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:++```haskell+example4 :: IO (Int, ())+example4 = runM . runReader "hello" . runState 0 $ do+  list <- ask+  liftIO (putStrLn list)+  put (length list)+```++(Note that we no longer need to give a type annotation for `list`, since `putStrLn` constrains the type for us.)+++### Defining new effects++Effects are a powerful mechanism for abstraction, and so defining new effects is a valuable tool for system architecture. Effects are modelled as (higher-order) functors, with an explicit continuation denoting the remainder of the computation after the effect.++It’s often helpful to start by specifying the types of the desired operations. For our example, we’re going to define a `Teletype` effect, with `read` and `write` operations, which read a string from some input and write a string to some output, respectively:++```haskell+data Teletype (m :: * -> *) k+read :: (Member Teletype sig, Carrier sig m) => m String+write :: (Member Teletype sig, Carrier sig m) => String -> m ()+```++Effect types must have two type parameters: `m`, denoting any computations which the effect embeds, and `k`, denoting the remainder of the computation after the effect. Note that since `Teletype` doesn’t use `m`, the compiler will infer it as being of kind `*` by default. The explicit kind annotation on `m` corrects that.++Next, we can flesh out the definition of the `Teletype` effect by providing constructors for each primitive operation:++```haskell+data Teletype (m :: * -> *) k+  = Read (String -> k)+  | Write String k+  deriving (Functor)+```++The `Read` operation returns a `String`, and hence its continuation is represented as a function _taking_ a `String`. Thus, to continue the computation, a handler will have to provide a `String`. But since the effect type doesn’t say anything about where that `String` should come from, handlers are free to read from `stdin`, use a constant value, etc.++On the other hand, the `Write` operation returns `()`. Since a function `() -> k` is equivalent to a (non-strict) `k`, we can omit the function parameter.++In addition to a `Functor` instance (derived here using `-XDeriveFunctor`), we need two other instances: `HFunctor` and `Effect`. `HFunctor`, named for “higher-order functor,” has one non-default operation, `hmap`, which applies a function to any embedded computations inside an effect. Since `Teletype` is first-order (i.e. it doesn’t have any embedded computations), the definition of `hmap` can be given using `coerce`:++```haskell+instance HFunctor Teletype where+  hmap _ = coerce+```++`Effect` plays a similar role to the combination of `Functor` (which operates on continuations) and `HFunctor` (which operates on embedded computations). It’s used by `Carrier` instances to service any requests for their effect occurring inside other computations—whether embedded or in the continuations. Since these may require some state to be maintained, `handle` takes an initial state parameter (encoded as some arbitrary functor filled with `()`), and its function is phrased as a _distributive law_, mapping state functors containing unhandled computations to handled computations producing the state functor alongside any results.++Since `Teletype`’s operations don’t have any embedded computations, the `Effect` instance only has to operate on the continuations, by wrapping the computations in the state and applying the handler:++```haskell+instance Effect Teletype where+  handle state handler (Read    k) = Read (handler . (<$ state) . k)+  handle state handler (Write s k) = Write s (handler (k <$ state))+```++Now that we have our effect datatype, we can give definitions for `read` and `write`:++```haskell+read :: (Member Teletype sig, Carrier sig m) => m String+read = send (Read ret)++write :: (Member Teletype sig, Carrier sig m) => String -> m ()+write s = send (Write s (ret ()))+```++This gives us enough to write computations using the `Teletype` effect. The next section discusses how to run `Teletype` computations.+++### Defining effect handlers++Effects only specify actions, they don’t actually perform them. That task is left up to effect handlers, typically defined as functions calling `interpret` to apply a given `Carrier` instance.++Following from the above section, we can define a carrier for the `Teletype` effect which runs the calls in an underlying `MonadIO` instance:++```haskell+newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }++instance (Carrier sig m, MonadIO m) => Carrier (Teletype :+: sig) (TeletypeIOC m) where+  ret = TeletypeIOC . ret++  eff = TeletypeIOC . handleSum (eff . handleCoercible) (\ t -> case t of+    Read    k -> liftIO getLine      >>= runTeletypeIOC . k+    Write s k -> liftIO (putStrLn s) >>  runTeletypeIOC   k)+```++Here, `ret` is responsible for wrapping pure values in the carrier, and `eff` is responsible for handling an effectful computations. Since the `Carrier` instance handles a sum (`:+:`) of `Teletype` and the remaining signature, `eff` has two parts: a handler for `Teletype` (`alg`), and a handler for teletype effects that might be embedded in other effects in the signature.++In this case, since the `Teletype` carrier is just a thin wrapper around the underlying computation, we can use `handleCoercible` to handle any embedded `TeletypeIOC` carriers by simply mapping `coerce` over them.++That leaves `alg`, which handles `Teletype` effects with one case per constructor. Since we’re assuming the existence of a `MonadIO` instance for the underlying computation, we can use `liftIO` to inject the `getLine` and `putStrLn` actions into it, and then proceed with the continuations, unwrapping them in the process.++Users could use `interpret` directly to run the effect, but it’s more convenient to provide effect handler functions applying `interpret` and then unwrapping the carrier:++```haskell+runTeletypeIO :: (MonadIO m, Carrier sig m) => Eff (TeletypeIOC m) a -> m a+runTeletypeIO = runTeletypeIOC . interpret+```++In general, carriers don’t have to be `Functor`s, let alone `Monad`s. However, sometimes—especially in cases where the carrier is a thin wrapper like this—they can be more convenient to write using (derived) `Monad` instances. In this case, by using `-XGeneralizedNewtypeDeriving`, we can derive `Functor`, `Applicative`, `Monad`, and `MonadIO` instances for `TeletypeIOC`:++```haskell+newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }+  deriving (Applicative, Functor, Monad, MonadIO)+```++This allows us to use `liftIO` directly on the carrier itself, instead of only in the underlying `m`; likewise with `>>=`, `>>`, and `pure`:++```haskell+instance (MonadIO m, Carrier sig m) => Carrier (Teletype :+: sig) (TeletypeIOC m) where+  ret = pure+  eff = handleSum (TeletypeIOC . eff . handleCoercible) (\ t -> case t of+    Read    k -> liftIO getLine      >>= k+    Write s k -> liftIO (putStrLn s) >>  k)+```+++## Benchmarks++`fused-effects` has been [benchmarked against a number of other effect systems](https://github.com/joshvera/freemonad-benchmark). See also [@patrickt’s benchmarks](https://github.com/patrickt/effects-benchmarks).+++## Related work++`fused-effects` is an encoding of higher-order algebraic effects following the recipes in _[Effect Handlers in Scope][]_ (Nicolas Wu, Tom Schrijvers, Ralf Hinze), _[Monad Transformers and Modular Algebraic Effects: What Binds Them Together][]_ (Tom Schrijvers, Maciej Piróg, Nicolas Wu, Mauro Jaskelioff), and _[Fusion for Free—Efficient Algebraic Effect Handlers][]_ (Nicolas Wu, Tom Schrijvers).++[Effect Handlers in Scope]: http://www.cs.ox.ac.uk/people/nicolas.wu/papers/Scope.pdf+[Monad Transformers and Modular Algebraic Effects: What Binds Them Together]: http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW699.pdf+[Fusion for Free—Efficient Algebraic Effect Handlers]: https://people.cs.kuleuven.be/~tom.schrijvers/Research/papers/mpc2015.pdf+++### Comparison to `mtl`++Like [`mtl`][], `fused-effects` provides a library of monadic effects which can be given different interpretations. In `mtl` this is done by defining new instances of the typeclasses encoding the actions of the effect, e.g. `MonadState`. In `fused-effects`, this is done by defining new instances of the `Carrier` typeclass for the effect.++Also like `mtl`, `fused-effects` allows scoped operations like `local` and `catchError` to be given different interpretations. As with first-order operations, `mtl` achieves this with a final tagless encoding via methods, whereas `fused-effects` achieves this with an initial algebra encoding via `Carrier` instances.++Unlike `mtl`, effects are automatically available regardless of where they occur in the signature; in `mtl` this requires instances for all valid orderings of the transformers (O(n²) of them, in general).++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 }+  deriving (Applicative, Functor, Monad)++instance Carrier sig m => Carrier sig (Wrapper s m) where …++getState :: (Carrier sig m, Member (State s) m) => Wrapper m s+getState = get+```++Indeed, `Wrapper` can now be made an instance of `MonadState`:++```haskell+instance (Carrier sig m, Member (State s) m) => MTL.MonadState s (Wrapper s m) where+  get = get+  put = put+```++Thus, the approaches aren’t mutually exclusive; consumers are free to decide which approach makes the most sense for their situation.++Unlike `fused-effects`, `mtl` provides a `ContT` monad transformer; however, it’s worth noting that many behaviours possible with delimited continuations (e.g. resumable exceptions) are directly encodable as effects. Further, `fused-effects` provides a relatively large palette of these, including resumable exceptions, tracing, resource management, and others, as well as tools to define your own.++Finally, thanks to the fusion and inlining of carriers, `fused-effects` is approximately as fast as `mtl` (see [benchmarks](#benchmarks)).++[`mtl`]: http://hackage.haskell.org/package/mtl+++### Comparison to `freer-simple`++Like [`freer-simple`][], `fused-effects` uses an initial encoding of library- and user-defined effects as syntax which can then be given different interpretations. In `freer-simple`, this is done with a family of interpreter functions (which cover a variety of needs, and which can be extended for more bespoke needs), whereas in `fused-effects` this is done with `Carrier` instances for `newtype`s.++(Technically, it is possible to define handlers like `freer-simple`’s `interpret` using `fused-effects`, but passing handlers in as higher-order functions defeats the fusion and inlining of `Carrier` instances which makes `fused-effects` so efficient.)++Unlike `fused-effects`, in `freer-simple`, scoped operations like `catchError` and `local` are implemented as interpreters, and can therefore not be given new interpretations.++Unlike `freer-simple`, `fused-effects` has relatively little attention paid to compiler error messaging, which can make common (compile-time) errors somewhat more confusing to diagnose. Similarly, `freer-simple`’s family of interpreter functions can make the job of defining new effect handlers somewhat easier than in `fused-effects`. Further, `freer-simple` provides many of the same effects as `fused-effects`, plus a coroutine effect, but minus resource management and random generation.++Finally, `fused-effects` has been [benchmarked](#benchmarks) as faster than `freer-simple`.++[`freer-simple`]: http://hackage.haskell.org/package/freer-simple
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import qualified Teletype+import Test.Hspec++main :: IO ()+main = hspec Teletype.spec
+ examples/Teletype.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}++module Teletype where++import Prelude hiding (read)++import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Sum+import Control.Monad.IO.Class+import Data.Coerce+import Test.Hspec+import Test.Hspec.QuickCheck++spec :: Spec+spec = describe "teletype" $ do+  prop "reads" $+    \ line -> run (runTeletypeRet [line] read) `shouldBe` (([], []), line)++  prop "writes" $+    \ input output -> run (runTeletypeRet input (write output)) `shouldBe` ((input, [output]), ())++  prop "writes multiple things" $+    \ input output1 output2 -> run (runTeletypeRet input (write output1 >> write output2)) `shouldBe` ((input, [output1, output2]), ())++data Teletype (m :: * -> *) k+  = Read (String -> k)+  | Write String k+  deriving (Functor)++instance HFunctor Teletype where+  hmap _ = coerce+  {-# INLINE hmap #-}++instance Effect Teletype where+  handle state handler (Read    k) = Read (handler . (<$ state) . k)+  handle state handler (Write s k) = Write s (handler (k <$ state))++read :: (Member Teletype sig, Carrier sig m) => m String+read = send (Read ret)++write :: (Member Teletype sig, Carrier sig m) => String -> m ()+write s = send (Write s (ret ()))+++runTeletypeIO :: (MonadIO m, Carrier sig m) => Eff (TeletypeIOC m) a -> m a+runTeletypeIO = runTeletypeIOC . interpret++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)+++runTeletypeRet :: (Carrier sig m, Effect sig, Monad m) => [String] -> Eff (TeletypeRetC m) a -> m (([String], [String]), a)+runTeletypeRet s m = runTeletypeRetC (interpret m) s++newtype TeletypeRetC m a = TeletypeRetC { runTeletypeRetC :: [String] -> m (([String], [String]), a) }++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)
+ fused-effects.cabal view
@@ -0,0 +1,82 @@+name:                fused-effects+version:             0.1.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+license:             BSD3+license-file:        LICENSE+author:              Rob Rix, Patrick Thomson+maintainer:          robrix@github.com+copyright:           2018 Rob Rix, Patrick Thomson+category:            Control+build-type:          Simple+extra-source-files:+  README.md+  ChangeLog.md+cabal-version:       >=1.10++tested-with:         GHC == 8.2.2+                   , GHC == 8.4.4++library+  exposed-modules:     Control.Effect+                     , Control.Effect.Carrier+                     , 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.Random+                     , Control.Effect.Random.Internal+                     , Control.Effect.Reader+                     , Control.Effect.Resource+                     , Control.Effect.Resumable+                     , Control.Effect.State+                     , Control.Effect.Sum+                     , Control.Effect.Trace+                     , Control.Effect.Void+                     , Control.Effect.Writer+  build-depends:       base >=4.9 && <4.12+                     , deepseq >=1.4.3 && <1.5+                     , MonadRandom >=0.5 && <0.6+                     , random+  hs-source-dirs:      src+  default-language:    Haskell2010+++test-suite examples+  type:                exitcode-stdio-1.0+  main-is:             Main.hs+  other-modules:       Teletype+  build-depends:       base >=4.9 && <4.12+                     , fused-effects+                     , hspec >=2.4.1+  hs-source-dirs:      examples+  default-language:    Haskell2010++test-suite test+  type:                exitcode-stdio-1.0+  main-is:             Spec.hs+  other-modules:       Control.Effect.Spec+                     , Control.Effect.NonDet.Spec+  build-depends:       base >=4.9 && <4.12+                     , fused-effects+                     , hspec >=2.4.1+  hs-source-dirs:      test+  default-language:    Haskell2010++test-suite doctest+  type:                exitcode-stdio-1.0+  main-is:             Doctest.hs+  build-depends:       base >=4.9 && <4.12+                     , doctest >=0.7 && <1.0+  hs-source-dirs:      test+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/robrix/fused-effects
+ src/Control/Effect.hs view
@@ -0,0 +1,20 @@+module Control.Effect+( module X+) where++import Control.Effect.Carrier   as X (Carrier, Effect)+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)+import Control.Effect.Random    as X (Random, RandomC)+import Control.Effect.Reader    as X (Reader, ReaderC)+import Control.Effect.Resource  as X (Resource, ResourceC)+import Control.Effect.Resumable as X (Resumable, ResumableC, ResumableWithC)+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)
+ src/Control/Effect/Carrier.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DefaultSignatures, FunctionalDependencies, RankNTypes #-}+module Control.Effect.Carrier+( HFunctor(..)+, Effect(..)+, Carrier(..)+, handlePure+, handleCoercible+, handleReader+, handleState+, handleEither+, handleTraversable+) where++import Control.Monad (join)+import Data.Coerce++class HFunctor h where+  -- | Functor map. This is required to be 'fmap'.+  --+  --   This can go away once we have quantified constraints.+  fmap' :: (a -> b) -> (h m a -> h m b)+  default fmap' :: Functor (h m) => (a -> b) -> (h m a -> h m b)+  fmap' = fmap++  -- | Higher-order functor map of a natural transformation over higher-order positions within the effect.+  hmap :: (forall x . m x -> n x) -> (h m a -> h n a)+++-- | The class of effect types, which must:+--+--   1. Be functorial in their last two arguments, and+--   2. Support threading effects in higher-order positions through using the carrier’s suspended state.+class HFunctor sig => Effect sig where+  -- | Handle any effects in a signature by threading the carrier’s state all the way through to the continuation.+  handle :: Functor f+         => f ()+         -> (forall x . f (m x) -> n (f x))+         -> sig m (m a)+         -> 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++  -- | 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+++-- | 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)+handlePure handler = hmap handler . fmap' handler+{-# INLINE handlePure #-}++-- | Thread a 'Coercible' carrier through an 'HFunctor'.+--+--   This is applicable whenever @f@ is 'Coercible' to @g@, e.g. simple @newtype@s.+handleCoercible :: (HFunctor sig, Coercible f g) => sig f (f a) -> sig g (g a)+handleCoercible = handlePure coerce+{-# INLINE handleCoercible #-}++-- | 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)+{-# INLINE handleReader #-}++-- | Thread a @State@-like carrier through an 'Effect'.+handleState :: Effect sig => s -> (forall x . f x -> s -> g (s, x)) -> sig f (f a) -> sig g (g (s, a))+handleState s run = handle (s, ()) (uncurry (flip run))+{-# INLINE handleState #-}++-- | 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)+{-# 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 #-}
+ src/Control/Effect/Error.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+module Control.Effect.Error+( Error(..)+, throwError+, catchError+, runError+, ErrorC(..)+) where++import Control.Effect.Carrier+import Control.Effect.Sum+import Control.Effect.Internal+import Control.Monad ((<=<))++data Error exc m k+  = Throw exc+  | forall b . Catch (m b) (exc -> m b) (b -> k)++deriving instance Functor (Error exc m)++instance HFunctor (Error exc) where+  hmap _ (Throw exc)   = Throw exc+  hmap f (Catch m h k) = Catch (f m) (f . h) k++instance Effect (Error exc) where+  handle _     _       (Throw exc)   = Throw exc+  handle state handler (Catch m h k) = Catch (handler (m <$ state)) (handler . (<$ state) . h) (handler . fmap k)++-- | Throw an error, escaping the current computation up to the nearest 'catchError' (if any).+--+--   prop> run (runError (throwError a)) == Left @Int @Int a+throwError :: (Member (Error exc) sig, Carrier sig m) => exc -> m a+throwError = send . Throw++-- | Run a computation which can throw errors with a handler to run on error.+--+--   Errors thrown by the handler will escape up to the nearest enclosing 'catchError' (if any).+--+--   prop> run (runError (pure a `catchError` pure)) == Right a+--   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)+++-- | 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 :: (Carrier sig m, Effect sig, Monad m) => Eff (ErrorC exc m) a -> m (Either exc a)+runError = runErrorC . interpret++newtype ErrorC e m a = ErrorC { runErrorC :: m (Either e a) }++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))+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XTypeApplications+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void
+ src/Control/Effect/Fail.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.Fail+( Fail(..)+, MonadFail(..)+, runFail+, FailC(..)+) where++import Control.Effect.Carrier+import Control.Effect.Fail.Internal+import Control.Effect.Internal+import Control.Effect.Sum+import Control.Monad.Fail++-- | 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++newtype FailC m a = FailC { runFailC :: m (Either String a) }++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))+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void
+ src/Control/Effect/Fail/Internal.hs view
@@ -0,0 +1,18 @@+{-# 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 #-}
+ src/Control/Effect/Fresh.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+module Control.Effect.Fresh+( Fresh(..)+, fresh+, resetFresh+, runFresh+, FreshC(..)+) where++import Control.Effect.Carrier+import Control.Effect.Internal+import Control.Effect.Sum++data Fresh m k+  = Fresh (Int -> k)+  | forall b . Reset (m b) (b -> k)++deriving instance Functor (Fresh m)++instance HFunctor Fresh where+  hmap _ (Fresh   k) = Fresh k+  hmap f (Reset m k) = Reset (f m) k++instance Effect Fresh where+  handle state handler (Fresh   k) = Fresh (handler . (<$ state) . k)+  handle state handler (Reset m k) = Reset (handler (m <$ state)) (handler . fmap k)++-- | Produce a fresh (i.e. unique) 'Int'.+--+--   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)++-- | 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)+++-- | 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++newtype FreshC m a = FreshC { runFreshC :: Int -> m (Int, a) }++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)+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void+-- >>> import Control.Monad (replicateM)+-- >>> import Data.List (nub)
+ src/Control/Effect/Internal.hs view
@@ -0,0 +1,98 @@+{-# 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++instance Applicative (Eff carrier) where+  pure a = Eff ($ a)++  (<*>) = ap++-- | 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++  l <|> r = send (Choose (\ c -> if c then l else r))++instance Monad (Eff carrier) where+  return = pure++  Eff m >>= f = Eff (\ k -> m (runEff k . f))++instance (Member Fail sig, Carrier sig carrier) => MonadFail (Eff carrier) where+  fail = send . 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++instance (Member Random sig, Carrier sig carrier) => MonadRandom (Eff carrier) where+  getRandom = send (Random ret)+  getRandomR r = send (RandomR r ret)+  getRandomRs interval = (:) <$> getRandomR interval <*> getRandomRs interval+  getRandoms = (:) <$> getRandom <*> getRandoms++instance (Member Random sig, Carrier sig carrier) => MonadInterleave (Eff carrier) where+  interleave m = send (Interleave m ret)+++instance Carrier sig carrier => Carrier sig (Eff carrier) where+  ret = pure+  eff op = Eff (\ k -> eff (hmap (runEff ret) (fmap' (runEff k) op)))+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void+-- >>> import Control.Effect.NonDet
+ src/Control/Effect/Lift.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Control.Effect.Lift+( Lift(..)+, runM+, LiftC(..)+) where++import Control.Effect.Carrier+import Control.Effect.Internal+import Control.Effect.Lift.Internal++-- | Extract a 'Lift'ed 'Monad'ic action from an effectful computation.+runM :: Monad m => Eff (LiftC m) a -> m a+runM = runLiftC . interpret++newtype LiftC m a = LiftC { runLiftC :: m a }++instance Monad m => Carrier (Lift m) (LiftC m) where+  ret = LiftC . pure+  eff = LiftC . (>>= runLiftC) . unLift
+ src/Control/Effect/Lift/Internal.hs view
@@ -0,0 +1,17 @@+{-# 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)
+ src/Control/Effect/NonDet.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleInstances, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.NonDet+( NonDet(..)+, Alternative(..)+, runNonDet+, AltC(..)+) where++import Control.Applicative (Alternative(..), liftA2)+import Control.Effect.Carrier+import Control.Effect.Internal+import Control.Effect.NonDet.Internal+import Control.Effect.Sum++-- | 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.+--+--   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++newtype AltC f m a = AltC { runAltC :: m (f a) }++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)))+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void
+ src/Control/Effect/NonDet/Internal.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveFunctor, KindSignatures #-}+module Control.Effect.NonDet.Internal+( NonDet(..)+) where++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)
+ src/Control/Effect/Random.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleInstances, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.Random+( Random(..)+, runRandom+, evalRandom+, execRandom+, evalRandomIO+, RandomC(..)+, MonadRandom(..)+, MonadInterleave(..)+) where++import Control.Effect.Carrier+import Control.Effect.Internal+import Control.Effect.Random.Internal+import Control.Effect.Sum+import Control.Monad.Random.Class (MonadInterleave(..), MonadRandom(..))+import Control.Monad.IO.Class (MonadIO(..))+import qualified System.Random as R (Random(..), RandomGen(..), StdGen, newStdGen)++-- | 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++-- | 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 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 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 m = liftIO R.newStdGen >>= flip evalRandom m++newtype RandomC g m a = RandomC { runRandomC :: g -> m (g, a) }++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)+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import System.Random+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void+-- >>> 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)
+ src/Control/Effect/Random/Internal.hs view
@@ -0,0 +1,25 @@+{-# 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)
+ src/Control/Effect/Reader.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+module Control.Effect.Reader+( Reader(..)+, ask+, asks+, local+, runReader+, ReaderC(..)+) where++import Control.Effect.Carrier+import Control.Effect.Sum+import Control.Effect.Internal++data Reader r m k+  = Ask (r -> k)+  | forall b . Local (r -> r) (m b) (b -> k)++deriving instance Functor (Reader r m)++instance HFunctor (Reader r) where+  hmap _ (Ask k)       = Ask k+  hmap f (Local g m k) = Local g (f m) k++instance Effect (Reader r) where+  handle state handler (Ask k)       = Ask (handler . (<$ state) . k)+  handle state handler (Local f m k) = Local f (handler (m <$ state)) (handler . fmap k)++-- | Retrieve the environment value.+--+--   prop> run (runReader a ask) == a+ask :: (Member (Reader r) sig, Carrier sig m) => m r+ask = send (Ask ret)++-- | 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, Functor m) => (r -> a) -> m a+asks f = fmap f ask++-- | 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)+++-- | Run a 'Reader' effect with the passed environment value.+--+--   prop> run (runReader a (pure b)) == b+runReader :: (Carrier sig m, Monad m) => r -> Eff (ReaderC r m) a -> m a+runReader r m = runReaderC (interpret m) r++newtype ReaderC r m a = ReaderC { runReaderC :: r -> m a }++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)+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void
+ src/Control/Effect/Resource.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+module Control.Effect.Resource+( Resource(..)+, bracket+, runResource+, ResourceC(..)+) where++import           Control.Effect.Carrier+import           Control.Effect.Internal+import           Control.Effect.Sum+import qualified Control.Exception as Exc+import           Control.Monad.IO.Class++data Resource m k+  = forall resource any output . Resource (m resource) (resource -> m any) (resource -> m output) (output -> k)++deriving instance Functor (Resource m)++instance HFunctor Resource where+  hmap f (Resource acquire release use k) = Resource (f acquire) (f . release) (f . use) k++instance Effect Resource where+  handle state handler (Resource acquire release use k) = Resource (handler (acquire <$ state)) (handler . fmap release) (handler . fmap use) (handler . fmap k)++-- | Provides a safe idiom to acquire and release resources safely.+--+-- When acquiring and operating on a resource (such as opening and+-- reading file handle with 'openFile' or writing to a blob of memory+-- with 'malloc'), any exception thrown during the operation may mean+-- that the resource is not properly released. @bracket acquire release op@+-- ensures that @release@ is run on the value returned from @acquire@ even+-- if @op@ throws an exception.+--+-- 'bracket' is safe in the presence of asynchronous exceptions.+bracket :: (Member Resource sig, Carrier sig m)+        => m resource           -- ^ computation to run first ("acquire resource")+        -> (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)+++runResource :: (Carrier sig m, MonadIO m)+            => (forall x . m x -> IO x)+            -> Eff (ResourceC m) a+            -> m a+runResource handler = runResourceC handler . interpret++newtype ResourceC m a = ResourceC ((forall x . m x -> IO x) -> m a)++runResourceC :: (forall x . m x -> IO x) -> ResourceC m a -> m a+runResourceC handler (ResourceC m) = m handler++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))+    (\ (Resource acquire release use k) -> liftIO (Exc.bracket+      (handler (runResourceC handler acquire))+      (handler . runResourceC handler . release)+      (handler . runResourceC handler . use))+      >>= runResourceC handler . k) op)
+ src/Control/Effect/Resumable.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+module Control.Effect.Resumable+( Resumable(..)+, throwResumable+, SomeError(..)+, runResumable+, ResumableC(..)+, runResumableWith+, ResumableWithC(..)+) where++import Control.DeepSeq+import Control.Effect.Carrier+import Control.Effect.Internal+import Control.Effect.Sum+import Data.Coerce+import Data.Functor.Classes++-- | Errors which can be resumed with values of some existentially-quantified type.+data Resumable err (m :: * -> *) k+  = forall a . Resumable (err a) (a -> k)++deriving instance Functor (Resumable err m)++instance HFunctor (Resumable err) where+  hmap _ = coerce+  {-# INLINE hmap #-}++instance Effect (Resumable err) where+  handle state handler (Resumable err k) = Resumable err (handler . (<$ state) . k)++-- | Throw an error which can be resumed with a value of its result type.+--+--   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)+++-- | An error at some existentially-quantified type index.+data SomeError (err :: * -> *)+  = forall a . SomeError (err a)++-- | Equality for 'SomeError' is determined by an 'Eq1' instance for the error type.+--+--   Note that since we can’t tell whether the type indices are equal, let alone what 'Eq' instance to use for them, the comparator passed to 'liftEq' always returns 'True'. Thus, 'SomeError' is best used with type-indexed GADTs for the error type.+--+--   prop> SomeError (Identity a) == SomeError (Identity b)+--   prop> (SomeError (Const a) == SomeError (Const b)) == (a == b)+instance Eq1 err => Eq (SomeError err) where+  SomeError exc1 == SomeError exc2 = liftEq (const (const True)) exc1 exc2++-- | Ordering for 'SomeError' is determined by an 'Ord1' instance for the error type.+--+--   Note that since we can’t tell whether the type indices are equal, let alone what 'Ord' instance to use for them, the comparator passed to 'liftCompare' always returns 'EQ'. Thus, 'SomeError' is best used with type-indexed GADTs for the error type.+--+--   prop> (SomeError (Identity a) `compare` SomeError (Identity b)) == EQ+--   prop> (SomeError (Const a) `compare` SomeError (Const b)) == (a `compare` b)+instance Ord1 err => Ord (SomeError err) where+  SomeError exc1 `compare` SomeError exc2 = liftCompare (const (const EQ)) exc1 exc2++-- | Showing for 'SomeError' is determined by a 'Show1' instance for the error type.+--+--   Note that since we can’t tell what 'Show' instance to use for the type index, the functions passed to 'liftShowsPrec' always return the empty 'ShowS'. Thus, 'SomeError' is best used with type-indexed GADTs for the error type.+--+--   prop> show (SomeError (Identity a)) == "SomeError (Identity )"+--   prop> show (SomeError (Const a)) == ("SomeError (Const " ++ showsPrec 11 a ")")+instance (Show1 err) => Show (SomeError err) where+  showsPrec d (SomeError err) = showsUnaryWith (liftShowsPrec (const (const id)) (const id)) "SomeError" d err+++-- | Evaluation of 'SomeError' to normal forms is determined by a 'NFData1' instance for the error type.+--+--   prop> pure (rnf (SomeError (Identity (error "error"))) :: SomeError Identity) `shouldThrow` errorCall "error"+instance NFData1 err => NFData (SomeError err) where+  rnf (SomeError err) = liftRnf (\a -> seq a ()) err+++-- | 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++newtype ResumableC err m a = ResumableC { runResumableC :: m (Either (SomeError err) a) }++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)))+++-- | Run a 'Resumable' effect, resuming uncaught errors with a given handler.+--+--   Note that this may be less efficient than defining a specialized carrier type and instance specifying the handler’s behaviour directly. Performance-critical code may wish to do that to maximize the opportunities for fusion and inlining.+--+--   >>> data Err a where Err :: Int -> Err Int+--+--   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+                 -> m a+runResumableWith with = runResumableWithC with . interpret++newtype ResumableWithC err m a = ResumableWithC ((forall x . err x -> m x) -> m a)++runResumableWithC :: (forall x . err x -> m x) -> ResumableWithC err m a -> m a+runResumableWithC f (ResumableWithC m) = m f++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)+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XGADTs+-- >>> :seti -XTypeApplications+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void+-- >>> import Data.Functor.Const+-- >>> import Data.Functor.Identity
+ src/Control/Effect/State.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, KindSignatures, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.State+( State(..)+, get+, gets+, put+, modify+, runState+, evalState+, execState+, StateC(..)+) 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, Functor m) => (s -> a) -> m a+gets f = fmap f get++-- | 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 :: (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 :: (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 :: (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
+ src/Control/Effect/Sum.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveFunctor, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators #-}+module Control.Effect.Sum+( (:+:)(..)+, handleSum+, Member(..)+, send+) where++import Control.Effect.Carrier++data (f :+: g) (m :: * -> *) k+  = L (f m k)+  | R (g m k)+  deriving (Eq, Functor, Ord, Show)++infixr 4 :+:++instance (HFunctor l, HFunctor r) => HFunctor (l :+: r) where+  hmap f (L l) = L (hmap f l)+  hmap f (R r) = R (hmap f r)++  fmap' f (L l) = L (fmap' f l)+  fmap' f (R r) = R (fmap' f r)++instance (Effect l, Effect r) => Effect (l :+: r) where+  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.+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+++class Member (sub :: (* -> *) -> (* -> *)) sup where+  inj :: sub m a -> sup m a+  prj :: sup m a -> Maybe (sub m a)++instance Member sub sub where+  inj = id+  prj = Just++instance {-# OVERLAPPABLE #-} Member sub (sub :+: sup) where+  inj = L . inj+  prj (L f) = Just f+  prj _     = Nothing++instance {-# OVERLAPPABLE #-} Member sub sup => Member sub (sub' :+: sup) where+  inj = R . inj+  prj (R g) = prj g+  prj _     = Nothing+++-- | Construct a request for an effect to be interpreted by some handler later on.+send :: (Member effect sig, Carrier sig m) => effect m (m a) -> m a+send = eff . inj
+ src/Control/Effect/Trace.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.Trace+( Trace(..)+, trace+, runTraceByPrinting+, TraceByPrintingC(..)+, runTraceByIgnoring+, TraceByIgnoringC(..)+, runTraceByReturning+, TraceByReturningC(..)+) where++import Control.Effect.Carrier+import Control.Effect.Internal+import Control.Effect.Sum+import Control.Monad.IO.Class+import Data.Bifunctor (first)+import Data.Coerce+import System.IO++data Trace (m :: * -> *) k = Trace+  { traceMessage :: String+  , traceCont    :: k+  }+  deriving (Functor)++instance HFunctor Trace where+  hmap _ = coerce+  {-# INLINE hmap #-}++instance Effect Trace where+  handle state handler (Trace s k) = Trace s (handler (k <$ state))++-- | Append a message to the trace log.+trace :: (Member Trace sig, Carrier sig m) => String -> m ()+trace message = send (Trace message (ret ()))+++-- | Run a 'Trace' effect, printing traces to 'stderr'.+runTraceByPrinting :: (MonadIO m, Carrier sig m) => Eff (TraceByPrintingC m) a -> m a+runTraceByPrinting = runTraceByPrintingC . interpret++newtype TraceByPrintingC m a = TraceByPrintingC { runTraceByPrintingC :: m a }++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)+++-- | 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++newtype TraceByIgnoringC m a = TraceByIgnoringC { runTraceByIgnoringC :: m a }++instance Carrier sig m => Carrier (Trace :+: sig) (TraceByIgnoringC m) where+  ret = TraceByIgnoringC . ret+  eff = handleSum (TraceByIgnoringC . eff . handlePure runTraceByIgnoringC) traceCont+++-- | 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++newtype TraceByReturningC m a = TraceByReturningC { runTraceByReturningC :: [String] -> m ([String], a) }++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)+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void
+ src/Control/Effect/Void.hs view
@@ -0,0 +1,29 @@+{-# 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 {}++instance Effect Void where+  handle _ _ v = case v of {}+++-- | Run an 'Eff' exhausted of effects to produce its final result value.+run :: Eff VoidC a -> a+run = runVoidC . interpret++newtype VoidC a = VoidC { runVoidC :: a }++instance Carrier Void VoidC where+  ret = VoidC+  eff v = case v of {}
+ src/Control/Effect/Writer.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.Writer+( Writer(..)+, tell+, runWriter+, execWriter+, WriterC(..)+) where++import Control.Effect.Carrier+import Control.Effect.Sum+import Control.Effect.Internal+import Data.Bifunctor (first)+import Data.Coerce++data Writer w (m :: * -> *) k = Tell w k+  deriving (Functor)++instance HFunctor (Writer w) where+  hmap _ = coerce+  {-# INLINE hmap #-}++instance Effect (Writer w) where+  handle state handler (Tell w k) = Tell w (handler (k <$ state))++-- | Write a value to the log.+--+--   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 ()))+++-- | 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 :: (Carrier sig m, Effect sig, Functor m, Monoid w) => Eff (WriterC w m) a -> m (w, a)+runWriter m = runWriterC (interpret m)++-- | 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 :: (Carrier sig m, Effect sig, Functor m, Monoid w) => Eff (WriterC w m) a -> m w+execWriter m = fmap fst (runWriterC (interpret m))+++newtype WriterC w m a = WriterC { runWriterC :: m (w, a) }++instance (Monoid w, Carrier sig m, Effect sig, Functor m) => Carrier (Writer w :+: sig) (WriterC w m) where+  ret a = WriterC (ret (mempty, a))+  eff = WriterC . handleSum+    (eff . handle (mempty, ()) (uncurry runWriter'))+    (\ (Tell w k) -> first (mappend w) <$> runWriterC k)+    where runWriter' w = fmap (first (mappend w)) . runWriterC+++-- $setup+-- >>> :seti -XFlexibleContexts+-- >>> import Test.QuickCheck+-- >>> import Control.Effect.Void+-- >>> import Data.Monoid (Sum(..))
+ test/Control/Effect/NonDet/Spec.hs view
@@ -0,0 +1,22 @@+module Control.Effect.NonDet.Spec where++import Control.Effect+import Control.Effect.Error+import Control.Effect.NonDet+import Control.Effect.State+import Test.Hspec++spec :: Spec+spec = do+  describe "interactions" $ do+    it "collects results of effects run before it" $+      run (runNonDet (runState 'a' (pure 'z' <|> put 'b' *> get <|> get))) `shouldBe` [('a', 'z'), ('b', 'b'), ('a', 'a')]++    it "collapses results of effects run after it" $+      run (runState 'a' (runNonDet (pure 'z' <|> put 'b' *> get <|> get))) `shouldBe` ('b', "zbb")++    it "collects results from higher-order effects run before it" $+      run (runNonDet (runError ((pure 'z' <|> throwError 'a') `catchError` pure))) `shouldBe` [Right 'z', Right 'a' :: Either Char Char]++    it "collapses results of higher-order effects run after it" $+      run (runError (runNonDet ((pure 'z' <|> throwError 'a') `catchError` pure))) `shouldBe` (Right "a" :: Either Char String)
+ test/Control/Effect/Spec.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+module Control.Effect.Spec where++import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Fail+import Control.Effect.Reader+import Control.Effect.State+import Control.Effect.Sum+import Prelude hiding (fail)+import Test.Hspec++spec :: Spec+spec = do+  inference+  reinterpretation+  interposition+++inference :: Spec+inference = describe "inference" $ do+  it "can be wrapped for better type inference" $+    run (runHasEnv (runEnv "i" ((++) <$> askEnv <*> askEnv))) `shouldBe` "ii"++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 r = HasEnv . runReader r . runHasEnv+++newtype HasEnv env carrier a = HasEnv { runHasEnv :: Eff carrier a }+  deriving (Applicative, Functor, Monad)++instance Carrier sig carrier => Carrier sig (HasEnv env carrier) where+  ret = pure+  eff op = HasEnv (eff (handleCoercible op))+++reinterpretation :: Spec+reinterpretation = describe "reinterpretation" $ do+  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++newtype ReinterpretReaderC r m a = ReinterpretReaderC { runReinterpretReaderC :: Eff (StateC r m) a }++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))+++interposition :: Spec+interposition = describe "interposition" $ do+  it "can interpose handlers without changing the available effects" $+    run (runFail (interposeFail (fail "world"))) `shouldBe` (Left "hello, world" :: Either String Int)++  it "interposition only intercepts effects in its scope" $ do+    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++newtype InterposeC m a = InterposeC { runInterposeC :: m a }++instance (Member Fail sig, Carrier sig m) => Carrier sig (InterposeC m) where+  ret = InterposeC . ret+  eff op+    | Just (Fail s) <- prj op = InterposeC (send (Fail ("hello, " ++ s)))+    | otherwise               = InterposeC (eff (handleCoercible op))
+ test/Doctest.hs view
@@ -0,0 +1,11 @@+module Main+( main+) where++import System.Environment+import Test.DocTest++main :: IO ()+main = do+  args <- getArgs+  doctest ("-isrc" : "--fast" : if null args then ["src"] else args)
+ test/Spec.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified Control.Effect.Spec+import qualified Control.Effect.NonDet.Spec+import Test.Hspec++main :: IO ()+main = hspec . parallel $ do+  describe "Control.Effect.Spec" Control.Effect.Spec.spec+  describe "Control.Effect.NonDet.Spec" Control.Effect.NonDet.Spec.spec