fused-effects 1.0.2.1 → 1.0.2.2

raw patch · 76 files changed

+1105/−1810 lines, 76 filesdep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +1/−41
• README.lhs +5/−4
• README.md +5/−4
• benchmark/Bench.hs +54/−11
• benchmark/Bench/Error.hs +0/−31
• benchmark/Bench/Interpret.hs +0/−47
• benchmark/Bench/NonDet.hs +1/−1
• benchmark/Bench/NonDet/NQueens.hs +1/−1
• benchmark/Bench/Reader.hs +17/−32
• benchmark/Bench/State.hs +0/−36
• benchmark/Bench/Writer.hs +0/−45
• examples/Inference.hs +8/−13
• examples/Labelled.hs +13/−12
• examples/Parser.hs +38/−44
• examples/ReinterpretLog.hs +124/−50
• examples/Teletype.hs +35/−35
• fused-effects.cabal +9/−17
• src/Control/Algebra.hs +73/−192
• src/Control/Algebra/Handler.hs +0/−47
• src/Control/Carrier/Choose/Church.hs +16/−26
• src/Control/Carrier/Cull/Church.hs +17/−30
• src/Control/Carrier/Cut/Church.hs +17/−35
• src/Control/Carrier/Empty/Church.hs +0/−138
• src/Control/Carrier/Empty/Maybe.hs +14/−45
• src/Control/Carrier/Error/Church.hs +0/−113
• src/Control/Carrier/Error/Either.hs +15/−13
• src/Control/Carrier/Fail/Either.hs +15/−12
• src/Control/Carrier/Fresh/Church.hs +0/−66
• src/Control/Carrier/Fresh/Strict.hs +14/−18
• src/Control/Carrier/Interpret.hs +27/−32
• src/Control/Carrier/Lift.hs +10/−12
• src/Control/Carrier/NonDet/Church.hs +15/−28
• src/Control/Carrier/Reader.hs +11/−21
• src/Control/Carrier/State/Church.hs +0/−129
• src/Control/Carrier/State/Lazy.hs +13/−18
• src/Control/Carrier/State/Strict.hs +12/−17
• src/Control/Carrier/Throw/Either.hs +14/−17
• src/Control/Carrier/Trace/Ignoring.hs +10/−14
• src/Control/Carrier/Trace/Printing.hs +11/−14
• src/Control/Carrier/Trace/Returning.hs +16/−20
• src/Control/Carrier/Writer/Church.hs +0/−82
• src/Control/Carrier/Writer/Strict.hs +24/−28
• src/Control/Effect/Catch.hs +2/−2
• src/Control/Effect/Catch/Internal.hs +15/−3
• src/Control/Effect/Choose.hs +2/−10
• src/Control/Effect/Choose/Internal.hs +10/−5
• src/Control/Effect/Class.hs +182/−0
• src/Control/Effect/Cull.hs +16/−5
• src/Control/Effect/Cut.hs +20/−5
• src/Control/Effect/Empty.hs +2/−5
• src/Control/Effect/Empty/Internal.hs +9/−4
• src/Control/Effect/Error.hs +0/−1
• src/Control/Effect/Fail.hs +4/−3
• src/Control/Effect/Fresh.hs +13/−9
• src/Control/Effect/Labelled.hs +10/−13
• src/Control/Effect/Lift.hs +6/−8
• src/Control/Effect/Lift/Internal.hs +18/−4
• src/Control/Effect/NonDet.hs +1/−2
• src/Control/Effect/Reader.hs +4/−3
• src/Control/Effect/Reader/Internal.hs +18/−4
• src/Control/Effect/Reader/Labelled.hs +2/−2
• src/Control/Effect/State.hs +5/−6
• src/Control/Effect/State/Internal.hs +11/−6
• src/Control/Effect/State/Labelled.hs +1/−1
• src/Control/Effect/Sum.hs +10/−4
• src/Control/Effect/Throw.hs +1/−1
• src/Control/Effect/Throw/Internal.hs +9/−4
• src/Control/Effect/Trace.hs +14/−7
• src/Control/Effect/Writer.hs +6/−9
• src/Control/Effect/Writer/Internal.hs +23/−5
• test/Empty.hs +3/−11
• test/Error.hs +5/−11
• test/Fresh.hs +3/−9
• test/Lift.hs +1/−1
• test/State.hs +13/−26
• test/Writer.hs +11/−30

@@ -1,44 +1,4 @@-- Adds a church-encoded `State` carrier in `Control.Carrier.State.Church`. ([#363](https://github.com/fused-effects/fused-effects/pull/363))--- Adds a church-encoded `Error` carrier in `Control.Carrier.Error.Church`. ([#203](https://github.com/fused-effects/fused-effects/pull/203))--- Adds a church-encoded `Empty` carrier in `Control.Carrier.Empty.Church`. ([#203](https://github.com/fused-effects/fused-effects/pull/203))--- Adds a church-encoded `Writer` carrier in `Control.Carrier.Writer.Church`. ([#369](https://github.com/fused-effects/fused-effects/pull/369))--- Adds a church-encoded `Fresh` carrier in `Control.Carrier.Fresh.Church`. ([#373](https://github.com/fused-effects/fused-effects/pull/373))--- Defines `Algebra` instances for `Control.Monad.Trans.Maybe.MaybeT`, `Control.Monad.Trans.RWS.CPS`, and `Control.Monad.Trans.Writer.CPS`. ([#366](https://github.com/fused-effects/fused-effects/pull/366))--- Adds `evalEmpty` and `execEmpty` handlers for the `Empty` carriers as conveniences for using `empty` to signal early returns. ([#371](https://github.com/fused-effects/fused-effects/pull/371))---## Backwards-incompatible changes--- Changes `alg`’s signature, giving it an initial state, and a distributive law which must be applied to each computation in the signature. This change allows `Algebra` instances to be derived using `GeneralizedNewtypeDeriving` and `DerivingVia`, while also obviating the need for `hmap`, `handleCoercible`, or the `thread` method of `Effect`. This furthermore increases the expressiveness of effects, allowing effects with higher-order positions yielding concrete types, e.g. `m ()`, to be run anywhere in the stack, not just above any `Effect`-requiring algebras. ([#359](https://github.com/fused-effects/fused-effects/pull/359), [#361](https://github.com/fused-effects/fused-effects/pull/361))--- Changes the signatures of `runInterpret` and `runInterpretState` analogously; also reorders the parameters to `runInterpretState` to take the signature before the state parameter. ([#359](https://github.com/fused-effects/fused-effects/pull/359))--- Removes `Algebra`’s superclass constraint requiring a `HFunctor` instance for the signature. ([#359](https://github.com/fused-effects/fused-effects/pull/359))--- Removes `handleCoercible`. Algebras which formerly used it when handling the tail of the signature may now compose `coerce` onto the homomorphism passed to `alg`. ([#359](https://github.com/fused-effects/fused-effects/pull/359))--- Removes `HFunctor`. Effects are no longer required to have `HFunctor` instances, and so the class is redundant. ([#359](https://github.com/fused-effects/fused-effects/pull/359))--- Removes `Effect`. The new signature for `alg` (see above) obviates the need for threading handlers through _effects_, replacing that by threading them through _algebras_ instead. ([#361](https://github.com/fused-effects/fused-effects/pull/361))--- Redefines `thread` as a wrapper around `alg`, composing context functors and distributive laws together. (Note that its type has also changed to take the context last and to decompose the handler for the two carriers.) ([#361](https://github.com/fused-effects/fused-effects/pull/361))--- Renames `Control.Effect.Interpret.Handler` to `Interpreter`. ([#361](https://github.com/fused-effects/fused-effects/pull/361))--- Reorders the parameters to the higher-order function passed to `Control.Effect.Lift.liftWith` for consistency with `alg` and to reflect its purpose of lifting Kleisli arrows in some underlying monad into the context modulo the context’s state. ([#361](https://github.com/fused-effects/fused-effects/pull/361))--- Redefines all effects as GADTs. Since we no longer require `Functor`, `HFunctor`, or `Effect` instances, we no longer need to use continuations to allow distinct result types per constructor. `Algebra` instances for these effects can be ported forwards by removing the continuations. User-defined effects are not impacted, but we recommend migrating to GADT definitions of them for convenience and ease of comprehension going forwards. ([#365](https://github.com/fused-effects/fused-effects/pull/365))--- Removes `Control.Carrier.State.Lazy.runStateC`, which was supposed to have been removed in 1.0.---# v1.0.2.1+# v1.0.2.2  - Adds support for `ghc` 8.10 & `base` 4.14. ([#376](https://github.com/fused-effects/fused-effects/pull/376)) 

@@ -143,7 +143,7 @@ Effects are run with _effect handlers_, specified as functions (generally starting with `run…`) unpacking some specific monad with a `Carrier` instance. For example, we can run a `State` computation using `runState`, imported from the `Control.Carrier.State.Strict` carrier module:  ```haskell-example1 :: Algebra sig m => [a] -> m (Int, ())+example1 :: (Algebra sig m, Effect sig) => [a] -> m (Int, ()) example1 list = runState 0 $ do   i <- get   put (i + length list)@@ -154,7 +154,7 @@ 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 :: Algebra sig m => m (Int, ())+example2 :: (Algebra sig m, Effect sig) => m (Int, ()) example2 = runReader "hello" . runState 0 $ do   list <- ask   put (length (list :: String))@@ -188,7 +188,7 @@  ### Required compiler extensions -When defining your own effects, you may need `-XKindSignatures` if GHC cannot correctly infer the type of your constructor; see the [documentation on common errors][common] for more information about this case.+When defining your own effects, 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. `-XDeriveGeneric` can be used with many first-order effects to derive default implementations of `HFunctor` and `Effect`.  When defining carriers, you’ll need `-XTypeOperators` to declare a `Carrier` instance over (`:+:`), `-XFlexibleInstances` to loosen the conditions on the instance, `-XMultiParamTypeClasses` since `Carrier` takes two parameters, and `-XUndecidableInstances` to satisfy the coverage condition for this instance. @@ -197,7 +197,7 @@ The following invocation, taken from the teletype example, should suffice for most use or construction of effects and carriers:  ```haskell-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} ```  @@ -289,6 +289,7 @@ ### Projects using `fused-effects`  * [`semantic`](http://github.com/github/semantic), a program analysis toolkit+* [`aurapm`](https://github.com/aurapm/aura), a package manager for Arch Linux * [`now-haskell`](http://hackage.haskell.org/package/now-haskell), a client library for AWS Lambda  

@@ -143,7 +143,7 @@ Effects are run with _effect handlers_, specified as functions (generally starting with `run…`) unpacking some specific monad with a `Carrier` instance. For example, we can run a `State` computation using `runState`, imported from the `Control.Carrier.State.Strict` carrier module:  ```haskell-example1 :: Algebra sig m => [a] -> m (Int, ())+example1 :: (Algebra sig m, Effect sig) => [a] -> m (Int, ()) example1 list = runState 0 $ do   i <- get   put (i + length list)@@ -154,7 +154,7 @@ 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 :: Algebra sig m => m (Int, ())+example2 :: (Algebra sig m, Effect sig) => m (Int, ()) example2 = runReader "hello" . runState 0 $ do   list <- ask   put (length (list :: String))@@ -188,7 +188,7 @@  ### Required compiler extensions -When defining your own effects, you may need `-XKindSignatures` if GHC cannot correctly infer the type of your constructor; see the [documentation on common errors][common] for more information about this case.+When defining your own effects, 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. `-XDeriveGeneric` can be used with many first-order effects to derive default implementations of `HFunctor` and `Effect`.  When defining carriers, you’ll need `-XTypeOperators` to declare a `Carrier` instance over (`:+:`), `-XFlexibleInstances` to loosen the conditions on the instance, `-XMultiParamTypeClasses` since `Carrier` takes two parameters, and `-XUndecidableInstances` to satisfy the coverage condition for this instance. @@ -197,7 +197,7 @@ The following invocation, taken from the teletype example, should suffice for most use or construction of effects and carriers:  ```haskell-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} ```  @@ -289,6 +289,7 @@ ### Projects using `fused-effects`  * [`semantic`](http://github.com/github/semantic), a program analysis toolkit+* [`aurapm`](https://github.com/aurapm/aura), a package manager for Arch Linux * [`now-haskell`](http://hackage.haskell.org/package/now-haskell), a client library for AWS Lambda  

@@ -1,21 +1,64 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid lambda" #-} module Main ( main ) where -import qualified Bench.Error as Error-import qualified Bench.Interpret as Interpret-import qualified Bench.NonDet as NonDet-import qualified Bench.Reader as Reader-import qualified Bench.State as State-import qualified Bench.Writer as Writer+import           Control.Algebra+import           Control.Carrier.Interpret+import           Control.Carrier.State.Strict+import           Control.Carrier.Writer.Strict+import           Control.Monad (replicateM_)+import           Data.Monoid (Sum(..)) import           Gauge +import qualified Bench.Reader as Reader+import qualified Bench.NonDet as NonDet+ main :: IO () main = defaultMain-  [ Error.benchmark-  , Interpret.benchmark+  [ Reader.benchmark   , NonDet.benchmark-  , Reader.benchmark-  , State.benchmark-  , Writer.benchmark+  , bgroup "WriterC"+    [ bench "100"   $ whnf (run . execWriter @(Sum Int) . tellLoop) 100+    , bench "1000"  $ whnf (run . execWriter @(Sum Int) . tellLoop) 1000+    , bench "10000" $ whnf (run . execWriter @(Sum Int) . tellLoop) 10000+    ]+  ,+    bgroup "Strict StateC"+    [ bench "100"   $ whnf (run . execState @(Sum Int) 0 . modLoop) 100+    , bench "1000"  $ whnf (run . execState @(Sum Int) 0 . modLoop) 1000+    , bench "10000" $ whnf (run . execState @(Sum Int) 0 . modLoop) 10000+    ]+  ,+    bgroup "InterpretC vs InterpretStateC vs StateC"+    [ bgroup "InterpretC"+      [ bench "100"   $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) $ modLoop n) 100+      , bench "1000"  $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) $ modLoop n) 1000+      , bench "10000" $ whnf (\n -> run $ evalState @(Sum Int) 0 $ runInterpret (\case { Get k -> get @(Sum Int) >>= k ; Put s k -> put s >> k }) $ modLoop n) 10000+      ]+    , bgroup "InterpretStateC"+      [ bench "100"   $ whnf (\n -> run $ runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 $ modLoop n) 100+      , bench "1000"  $ whnf (\n -> run $ runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 $ modLoop n) 1000+      , bench "10000" $ whnf (\n -> run $ runInterpretState (\ s -> \case { Get k -> runState @(Sum Int) s (k s) ; Put s k -> runState s k }) 0 $ modLoop n) 10000+      ]+    , bgroup "StateC"+      [ bench "100"   $ whnf (run . evalState @(Sum Int) 0 . modLoop) 100+      , bench "1000"  $ whnf (run . evalState @(Sum Int) 0 . modLoop) 1000+      , bench "10000" $ whnf (run . evalState @(Sum Int) 0 . modLoop) 10000+      ]+    ]   ]++tellLoop :: Has (Writer (Sum Int)) sig m => Int -> m ()+tellLoop i = replicateM_ i (tell (Sum (1 :: Int)))++modLoop :: Has (State (Sum Int)) sig m => Int -> m ()+modLoop i = replicateM_ i (modify (+ Sum (1 :: Int)))

@@ -1,31 +0,0 @@-{-# LANGUAGE TypeApplications #-}-module Bench.Error-( benchmark-) where--import Control.Carrier.Error.Church as Church-import Control.Carrier.Error.Either as Either-import Data.Foldable (for_)-import Control.Monad.Trans.Except as Except-import Gauge hiding (benchmark)--benchmark :: Benchmark-benchmark = bgroup "Error"-  [ bench "Either" $ whnf (errorLoop :: Int -> Either Int ()) n-  , bgroup "Identity"-    [ bench "Church.ErrorC" $ whnf (run . Church.runError @Int (pure . Left) (pure . Right) . errorLoop) n-    , bench "Either.ErrorC" $ whnf (run . Either.runError @Int . errorLoop) n-    , bench "ExceptT"       $ whnf (run . Except.runExceptT @Int . errorLoop) n-    ]-  , bgroup "IO"-    [ bench "Church.ErrorC" $ whnfAppIO (Church.runError @Int (pure . Left) (pure . Right) . errorLoop) n-    , bench "Either.ErrorC" $ whnfAppIO (Either.runError @Int . errorLoop) n-    , bench "ExceptT"       $ whnfAppIO (Except.runExceptT @Int . errorLoop) n-    ]-  ]-  where-  n = 100000--errorLoop :: Has (Error Int) sig m => Int -> m ()-errorLoop i = for_ [1..i] (\ i -> throwError i `catchError` pure @_ @Int)-{-# INLINE errorLoop #-}

@@ -1,47 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}-{-# HLINT ignore "Avoid lambda" #-}-module Bench.Interpret-( benchmark-) where--import Control.Carrier.Interpret-import Control.Carrier.State.Strict-import Data.Foldable (for_)-import Gauge hiding (benchmark)--benchmark :: Benchmark-benchmark = bgroup "Interpret"-  [ bgroup "Identity"-    [ bench "InterpretC" $-      whnf (\ n -> run $ execState @Int 0 $ runInterpret (\ _ (sig :: State Int m k) ctx -> case sig of-        Get   -> gets @Int (<$ ctx)-        Put s -> ctx <$ put s) $ modLoop n) n-    , bench "InterpretStateC" $-      whnf (\ n -> fst . run $ runInterpretState (\ _ (sig :: State Int m k) (s :: Int) ctx -> case sig of-        Get   -> pure (s, s <$ ctx)-        Put s -> pure (s, ctx)) 0 $ modLoop n) n-    , bench "StateC" $-      whnf (run . execState @Int 0 . modLoop) n-    ]-  , bgroup "IO"-    [ bench "InterpretC" $-      whnfAppIO (\ n -> execState @Int 0 $ runInterpret (\ _ (sig :: State Int m k) ctx -> case sig of-        Get   -> gets @Int (<$ ctx)-        Put s -> ctx <$ put s) $ modLoop n) n-    , bench "InterpretStateC" $-      whnfAppIO (\ n -> fmap fst $ runInterpretState (\ _ (sig :: State Int m k) (s :: Int) ctx -> case sig of-        Get   -> pure (s, s <$ ctx)-        Put s -> pure (s, ctx)) 0 $ modLoop n) n-    , bench "StateC" $-      whnfAppIO (execState @Int 0 . modLoop) n-    ]-  ]-  where-  n = 100000--modLoop :: Has (State Int) sig m => Int -> m ()-modLoop i = for_ [1..i] (modify . (+))-{-# INLINE modLoop #-}

@@ -8,7 +8,7 @@ import qualified Control.Carrier.NonDet.Church as NonDet.Church import           Gauge hiding (benchmark) -benchmark :: Benchmark+benchmark :: Gauge.Benchmark benchmark = bgroup "NonDet"   [ bgroup "N-queens problem"     [ NQueens.benchmark "NonDet.Church" (run . NonDet.Church.runNonDetA)

@@ -48,7 +48,7 @@ queens :: (Alternative m, Monad m) => Int -> m Board queens n = foldl' (>>=) (pure empty) (replicate n (addOne n)) -benchmark :: (Alternative m, Monad m) => String -> (m Board -> [Board]) -> Benchmark+benchmark :: (Alternative m, Monad m) => String -> (m Board -> [Board]) -> Gauge.Benchmark benchmark title runQueens = bgroup title   [ bench "4"  $ whnf (runQueens . queens) 4   , bench "8"  $ whnf (runQueens . queens) 8

@@ -1,45 +1,30 @@ {-# LANGUAGE TypeApplications #-}+ module Bench.Reader ( benchmark ) where  import Control.Carrier.Reader-import Control.Monad (replicateM_)-import Control.Monad.Trans.Reader (runReaderT)-import Gauge hiding (benchmark)+import Control.Monad -benchmark :: Benchmark-benchmark = bgroup "Reader"-  [ bgroup "ask"-    [ bench "(->)"    $ whnf (`asking` 'c') n-    , bgroup "Identity"-      [ bench "ReaderC" $ whnf (run . runReader 'c' . asking) n-      , bench "ReaderT" $ whnf (run . (`runReaderT` 'c') . asking) n-      ]-    , bgroup "IO"-      [ bench "ReaderC" $ whnfAppIO (runReader 'c' . asking) n-      , bench "ReaderT" $ whnfAppIO ((`runReaderT` 'c') . asking) n-      ]-    ]-  , bgroup "local"-    [ bench "(->)"    $ whnf (`locally` 'c') n-    , bgroup "Identity"-      [ bench "ReaderC" $ whnf (run . runReader 'c' . locally) n-      , bench "ReaderT" $ whnf (run . (`runReaderT` 'c') . locally) n-      ]-    , bgroup "IO"-      [ bench "ReaderC" $ whnfAppIO (runReader 'c' . locally) n-      , bench "ReaderT" $ whnfAppIO ((`runReaderT` 'c') . locally) n-      ]-    ]-  ]-  where-  n = 100000+import Gauge hiding (benchmark)  asking :: Has (Reader Char) sig m => Int -> m () asking i = replicateM_ i (ask @Char)-{-# INLINE asking #-}  locally :: Has (Reader Char) sig m => Int -> m () locally i = replicateM_ i (local @Char succ (ask @Char))-{-# INLINE locally #-}++benchmark :: Gauge.Benchmark+benchmark = bgroup "Control.Carrier.Reader"+  [ bgroup "ask"+    [ bench "10" $ whnf (run . runReader 'a' . asking) 10+    , bench "100" $ whnf (run . runReader 'b' . asking) 100+    , bench "1000" $ whnf (run . runReader 'c' . asking) 1000+    ]+  , bgroup "local"+    [ bench "10" $ whnf (run . runReader 'a' . locally) 10+    , bench "100" $ whnf (run . runReader 'b' . locally) 100+    , bench "1000" $ whnf (run . runReader 'c' . locally) 1000+    ]+  ]

@@ -1,36 +0,0 @@-module Bench.State-( benchmark-) where--import Control.Carrier.State.Church as C.Church-import Control.Carrier.State.Lazy as C.Lazy-import Control.Carrier.State.Strict as C.Strict-import Control.Monad.Trans.State.Lazy as T.Lazy (execStateT)-import Control.Monad.Trans.State.Strict as T.Strict (execStateT)-import Data.Foldable (for_)-import Gauge hiding (benchmark)--benchmark :: Benchmark-benchmark = bgroup "State"-  [ bgroup "Identity"-    [ bench "Church.StateC" $ whnf (run . C.Church.execState from . modLoop) n-    , bench "Lazy.StateC"   $ whnf (run . C.Lazy.execState from . modLoop) n-    , bench "Strict.StateC" $ whnf (run . C.Strict.execState from . modLoop) n-    , bench "Lazy.StateT"   $ whnf (run . flip T.Lazy.execStateT from . modLoop) n-    , bench "Strict.StateT" $ whnf (run . flip T.Strict.execStateT from . modLoop) n-    ]-  , bgroup "IO"-    [ bench "Church.StateC" $ whnfAppIO (C.Church.execState from . modLoop) n-    , bench "Lazy.StateC"   $ whnfAppIO (C.Lazy.execState from . modLoop) n-    , bench "Strict.StateC" $ whnfAppIO (C.Strict.execState from . modLoop) n-    , bench "Lazy.StateT"   $ whnfAppIO (flip T.Lazy.execStateT from . modLoop) n-    , bench "Strict.StateT" $ whnfAppIO (flip T.Strict.execStateT from . modLoop) n-    ]-  ]-  where-  from = 0 :: Int-  n = 100000--modLoop :: Has (State Int) sig m => Int -> m ()-modLoop i = for_ [1..i] (modify . (+))-{-# INLINE modLoop #-}

@@ -1,45 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeApplications #-}-module Bench.Writer-( benchmark-) where--import Control.Carrier.Writer.Church as C.Church-import Control.Carrier.Writer.Strict as C.Strict-import Control.Monad (replicateM_)-#if MIN_VERSION_transformers(0,5,6)-import Control.Monad.Trans.Writer.CPS as T.CPS (execWriterT)-#endif-import Control.Monad.Trans.Writer.Lazy as T.Lazy (execWriterT)-import Control.Monad.Trans.Writer.Strict as T.Strict (execWriterT)-import Data.Monoid (Sum(..))-import Gauge hiding (benchmark)--benchmark :: Benchmark-benchmark = bgroup "Writer"-  [ bench "(,) w" $ whnf (fst . (tellLoop :: Int -> (Sum Int, ()))) n-  , bgroup "Identity"-    [ bench "Church.WriterC" $ whnf (run . C.Church.execWriter @(Sum Int) . tellLoop) n-    , bench "Strict.WriterC" $ whnf (run . C.Strict.execWriter @(Sum Int) . tellLoop) n-#if MIN_VERSION_transformers(0,5,6)-    , bench "CPS.WriterT"    $ whnf (run . T.CPS.execWriterT @_ @(Sum Int) . tellLoop) n-#endif-    , bench "Lazy.WriterT"   $ whnf (run . T.Lazy.execWriterT @_ @(Sum Int) . tellLoop) n-    , bench "Strict.WriterT" $ whnf (run . T.Strict.execWriterT @_ @(Sum Int) . tellLoop) n-    ]-  , bgroup "IO"-    [ bench "Church.WriterC" $ whnfAppIO (C.Church.execWriter @(Sum Int) . tellLoop) n-    , bench "Strict.WriterC" $ whnfAppIO (C.Strict.execWriter @(Sum Int) . tellLoop) n-#if MIN_VERSION_transformers(0,5,6)-    , bench "CPS.WriterT"    $ whnfAppIO (T.CPS.execWriterT @_ @(Sum Int) . tellLoop) n-#endif-    , bench "Lazy.WriterT"   $ whnfAppIO (T.Lazy.execWriterT @_ @(Sum Int) . tellLoop) n-    , bench "Strict.WriterT" $ whnfAppIO (T.Strict.execWriterT @_ @(Sum Int) . tellLoop) n-    ]-  ]-  where-  n = 1000000--tellLoop :: Has (Writer (Sum Int)) sig m => Int -> m ()-tellLoop i = replicateM_ i (tell (Sum (1 :: Int)))-{-# INLINE tellLoop #-}

@@ -1,21 +1,15 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeApplications, TypeOperators, UndecidableInstances #-} module Inference ( example ) where -import           Control.Algebra-import           Control.Carrier.Reader-import           Hedgehog+import Control.Algebra+import Control.Carrier.Reader+import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-import           Test.Tasty-import           Test.Tasty.Hedgehog+import Test.Tasty+import Test.Tasty.Hedgehog  example :: TestTree example = testGroup "inference"@@ -52,4 +46,5 @@   deriving (Applicative, Functor, Monad)  -- | The 'Carrier' instance for 'HasEnv' simply delegates all effects to the underlying carrier.-deriving instance Algebra sig m => Algebra sig (HasEnv env m)+instance Algebra sig m => Algebra sig (HasEnv env m) where+  alg = HasEnv . alg . handleCoercible

@@ -5,14 +5,14 @@ ( example ) where -import           Control.Applicative-import           Control.Carrier.Reader-import           Control.Carrier.State.Strict-import           Control.Effect.Labelled+import Test.Tasty+import Test.Tasty.HUnit+import Control.Applicative+import Control.Effect.Labelled+import Control.Carrier.Reader+import Control.Carrier.State.Strict import qualified Control.Effect.Reader.Labelled as L import qualified Control.Effect.State.Labelled as L-import           Test.Tasty-import           Test.Tasty.HUnit  sample :: ( HasLabelled "fore" (Reader Int) sig m           , HasLabelled "aft" (Reader Int) sig m@@ -34,9 +34,9 @@  readerExamples :: TestTree readerExamples = testGroup "Reader"-  [ testCase "runUnderLabel"           (run (runReader (5 :: Int) (runLabelled @"fore" (runReader (10 :: Int) (runLabelled @"aft" sample)))) @=? 15)-  , testCase "Reader.Labelled helpers" (run (runReader (5 :: Int) (runLabelled @"fore" (runReader (10 :: Int) (runLabelled @"aft" withHelpers)))) @=? 15)-  , testCase "Nat labels"              (run (runReader (5 :: Int) (runLabelled @1 (runReader (10 :: Int) (runLabelled @2 numerically)))) @=? 15)+  [ testCase "runUnderLabel"           ((run (runReader (5 :: Int) (runLabelled @"fore" (runReader (10 :: Int) (runLabelled @"aft" sample))))) @=? 15)+  , testCase "Reader.Labelled helpers" ((run (runReader (5 :: Int) (runLabelled @"fore" (runReader (10 :: Int) (runLabelled @"aft" withHelpers))))) @=? 15)+  , testCase "Nat labels"              ((run (runReader (5 :: Int) (runLabelled @1 (runReader (10 :: Int) (runLabelled @2 numerically))))) @=? 15)   ]  sampleS :: ( HasLabelled "fore" (State Int) sig m@@ -59,9 +59,9 @@  stateExamples :: TestTree stateExamples = testGroup "State"-  [ testCase "runUnderLabel"          (run (evalState (5 :: Int) (runLabelled @"fore" (evalState (10 :: Int) (runLabelled @"aft" sampleS)))) @=? 15)-  , testCase "State.Labelled helpers" (run (evalState (5 :: Int) (runLabelled @"fore" (evalState (10 :: Int) (runLabelled @"aft" helpersS)))) @=? 15)-  , testCase "Boolean labels"         (run (evalState (5 :: Int) (runLabelled @'True (evalState (10 :: Int) (runLabelled @'False boolean)))) @=? 15)+  [ testCase "runUnderLabel"          ((run (evalState (5 :: Int) (runLabelled @"fore" (evalState (10 :: Int) (runLabelled @"aft" sampleS))))) @=? 15)+  , testCase "State.Labelled helpers" ((run (evalState (5 :: Int) (runLabelled @"fore" (evalState (10 :: Int) (runLabelled @"aft" helpersS))))) @=? 15)+  , testCase "Boolean labels"         ((run (evalState (5 :: Int) (runLabelled @'True (evalState (10 :: Int) (runLabelled @'False boolean))))) @=? 15)   ]  @@ -70,3 +70,4 @@   [ readerExamples   , stateExamples   ]+

@@ -1,30 +1,22 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveGeneric, DeriveTraversable, ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Parser ( example ) where -import           Control.Algebra-import           Control.Carrier.Cut.Church-import           Control.Carrier.NonDet.Church-import           Control.Carrier.State.Strict-import           Control.Monad (replicateM)-import           Data.Char-import           Data.Kind (Type)-import           Data.List (intercalate)-import           Hedgehog+import Control.Algebra+import Control.Carrier.Cut.Church+import Control.Carrier.NonDet.Church+import Control.Carrier.State.Strict+import Control.Monad (replicateM)+import Data.Char+import Data.List (intercalate)+import GHC.Generics (Generic1)+import Hedgehog import qualified Hedgehog.Function as Fn import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-import           Test.Tasty-import           Test.Tasty.Hedgehog+import Test.Tasty+import Test.Tasty.Hedgehog  example :: TestTree example = testGroup "parser"@@ -44,14 +36,15 @@     [ testProperty "matches with a predicate" . property $ do       c <- forAll Gen.alphaNum       f <- (. ord) <$> Fn.forAllFn predicate-      run (runNonDetA (parse [c] (satisfy f))) === [c | f c]+      run (runNonDetA (parse [c] (satisfy f))) === if f c then [c] else []      , testProperty "fails at end of input" . property $ do       f <- (. ord) <$> Fn.forAllFn predicate       run (runNonDetA (parse "" (satisfy f))) === []      , testProperty "fails if input remains" . property $ do-      (c1, c2) <- forAll ((,) <$> Gen.alphaNum <*> Gen.alphaNum)+      c1 <- forAll Gen.alphaNum+      c2 <- forAll Gen.alphaNum       f <- (. ord) <$> Fn.forAllFn predicate       run (runNonDetA (parse [c1, c2] (satisfy f))) === [] @@ -59,7 +52,7 @@       c1 <- forAll Gen.alphaNum       c2 <- forAll Gen.alphaNum       f <- (. ord) <$> Fn.forAllFn predicate-      run (runNonDetA (parse [c1, c2] ((,) <$> satisfy f <*> satisfy f))) === [(c1, c2) | f c1, f c2]+      run (runNonDetA (parse [c1, c2] ((,) <$> satisfy f <*> satisfy f))) === if f c1 && f c2 then [(c1, c2)] else []     ]    , testGroup "factor"@@ -100,25 +93,27 @@       run (runCutA (parse (intercalate "+" (intercalate "*" . map (show . abs) . (1:) <$> [0]:as)) expr)) === [sum (map (product . map abs) as)]     ]   ]-  where-  arbNested :: Gen a -> Range.Size -> Gen [[a]]-  arbNested _ 0 = pure []-  arbNested g n = do-    m <- Gen.integral (Range.linear 0 10)-    let n' = n `div` (m + 1)-    replicateM (Range.unSize m) (Gen.list (Range.singleton (Range.unSize n')) g) -  predicate = Fn.fn Gen.bool-  genFactor = Gen.integral (Range.linear 0 100)-  genFactors = Gen.list (Range.linear 0 10) genFactor+    where arbNested :: Gen a -> Range.Size -> Gen [[a]]+          arbNested _ 0 = pure []+          arbNested g n = do+            m <- Gen.integral (Range.linear 0 10)+            let n' = n `div` (m + 1)+            replicateM (Range.unSize m) (Gen.list (Range.singleton (Range.unSize n')) g) +          predicate = Fn.fn Gen.bool+          genFactor = Gen.integral (Range.linear 0 100)+          genFactors = Gen.list (Range.linear 0 10) genFactor -data Symbol (m :: Type -> Type) k where-  Satisfy :: (Char -> Bool) -> Symbol m Char +data Symbol m k = Satisfy (Char -> Bool) (Char -> m k)+  deriving (Functor, Generic1) +instance HFunctor Symbol+instance Effect   Symbol+ satisfy :: Has Symbol sig m => (Char -> Bool) -> m Char-satisfy p = send (Satisfy p)+satisfy p = send (Satisfy p pure)  char :: Has Symbol sig m => Char -> m Char char = satisfy . (==)@@ -138,14 +133,13 @@ newtype ParseC m a = ParseC { runParseC :: StateC String m a }   deriving (Alternative, Applicative, Functor, Monad) -instance (Alternative m, Algebra sig m) => Algebra (Symbol :+: sig) (ParseC m) where-  alg hdl sig ctx = case sig of-    L (Satisfy p) -> do-      input <- ParseC get-      case input of-        c:cs | p c -> c <$ ctx <$ ParseC (put cs)-        _          -> empty-    R other       -> ParseC (alg (runParseC . hdl) (R other) ctx)+instance (Alternative m, Algebra sig m, Effect sig) => Algebra (Symbol :+: sig) (ParseC m) where+  alg (L (Satisfy p k)) = do+    input <- ParseC get+    case input of+      c:cs | p c -> ParseC (put cs) *> k c+      _          -> empty+  alg (R other)         = ParseC (alg (R (handleCoercible other)))   {-# INLINE alg #-}  

@@ -9,34 +9,40 @@ -- * Finally, we will bridge the two with an effect carrier that reinterprets --   structured log messages as strings. -{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}++{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}  module ReinterpretLog-( example-, application-, runApplication-) where+  ( example+  , application+  , runApplication+  ) where  import Control.Algebra+import Control.Carrier.Lift import Control.Carrier.Reader import Control.Carrier.Writer.Strict import Control.Monad.IO.Class (MonadIO(..))-import Data.Kind (Type)-import Prelude hiding (log)+import Data.Function          ((&))+import Data.Kind              (Type)+import GHC.Generics           (Generic1)+import Prelude                hiding (log) import Test.Tasty import Test.Tasty.HUnit + -------------------------------------------------------------------------------- -- The application --------------------------------------------------------------------------------@@ -48,13 +54,16 @@   | Info String  -- Render a structured log message as a string.-renderLogMessage :: Message -> String+renderLogMessage ::+     Message+  -> String renderLogMessage = \case   Debug message -> "[debug] " ++ message   Info  message -> "[info] "  ++ message  -- The application: it logs two messages, then quits.-application :: Has (Log Message) sig m => m ()+application :: Has (Log Message) sig m+  => m () application = do   log (Debug "debug message")   log (Info "info message")@@ -64,24 +73,48 @@ -- * Reinterpreting 'Log Message' effects as 'Log String' effects. -- * Interpreting 'Log String' effects by printing to stdout. runApplication :: IO ()-runApplication-  = runLogStdout                    -- IO ()-  . reinterpretLog renderLogMessage -- LogStdoutC IO ()-  $ application                     -- ReinterpretLogC Message String (LogStdoutC IO) ()+runApplication =+  application+    -- Type inference is picking our concrete monad stack.+    --+    -- Here its type is:+    --+    --   ReinterpretLogC Message String (LogStdoutC (LiftC IO)) () +    & reinterpretLog renderLogMessage+    -- Now its type is:+    --+    --   LogStdoutC (LiftC IO) () +    & runLogStdout+    -- Now its type is:+    --+    --   LiftC IO ()++    & runM+    -- Now its type is:+    --+    --   IO ()++ -------------------------------------------------------------------------------- -- The logging effect --------------------------------------------------------------------------------  -- Log an 'a', then continue with 'k'.-data Log (a :: Type) (m :: Type -> Type) (k :: Type) where-  Log :: a -> Log a m ()+data Log (a :: Type) (m :: Type -> Type) (k :: Type)+  = Log a (m k)+  deriving (Functor, Generic1) +instance HFunctor (Log a)+instance Effect   (Log a)  -- Log an 'a'.-log :: Has (Log a) sig m => a -> m ()-log x = send (Log x)+log :: Has (Log a) sig m+  => a+  -> m ()+log x =+  send (Log x (pure ()))   --------------------------------------------------------------------------------@@ -89,7 +122,8 @@ --------------------------------------------------------------------------------  -- Carrier one: log strings to stdout.-newtype LogStdoutC m a = LogStdoutC { runLogStdout :: m a }+newtype LogStdoutC m a+  = LogStdoutC (m a)   deriving (Applicative, Functor, Monad, MonadIO)  instance@@ -101,15 +135,28 @@      -- ... the 'LogStdoutC m' monad can interpret 'Log String :+: sig' effects   => Algebra (Log String :+: sig) (LogStdoutC m) where -  alg hdl sig ctx = case sig of-    L (Log message) -> ctx <$ liftIO (putStrLn message)+  alg :: (Log String :+: sig) (LogStdoutC m) a -> LogStdoutC m a+  alg = \case+    L (Log message k) ->+      LogStdoutC $ do+        liftIO (putStrLn message)+        runLogStdout k -    R other         -> LogStdoutC (alg (runLogStdout . hdl) other ctx)+    R other ->+      LogStdoutC (alg (hmap runLogStdout other)) +-- The 'LogStdoutC' runner.+runLogStdout ::+     LogStdoutC m a+  -> m a+runLogStdout (LogStdoutC m) =+  m + -- Carrier two: reinterpret a program that logs 's's into one that logs 't's -- using a function (provided at runtime) from 's' to 't'.-newtype ReinterpretLogC s t m a = ReinterpretLogC { runReinterpretLogC :: ReaderC (s -> t) m a }+newtype ReinterpretLogC s t m a+  = ReinterpretLogC { unReinterpretLogC :: ReaderC (s -> t) m a }   deriving (Applicative, Functor, Monad, MonadIO)  instance@@ -120,46 +167,73 @@      -- effects   => Algebra (Log s :+: sig) (ReinterpretLogC s t m) where -  alg hdl sig ctx = ReinterpretLogC $ case sig of-    L (Log s) -> do-      f <- ask @(s -> t)-      ctx <$ log (f s)+  alg ::+       (Log s :+: sig) (ReinterpretLogC s t m) a+    -> ReinterpretLogC s t m a+  alg = \case+    L (Log s k) ->+      ReinterpretLogC $ do+        f <- ask @(s -> t)+        log (f s)+        unReinterpretLogC k -    R other   -> alg (runReinterpretLogC . hdl) (R other) ctx+    R other ->+      ReinterpretLogC (alg (R (handleCoercible other)))  -- The 'ReinterpretLogC' runner.-reinterpretLog :: (s -> t) -> ReinterpretLogC s t m a -> m a-reinterpretLog f = runReader f . runReinterpretLogC+reinterpretLog ::+     (s -> t)+  -> ReinterpretLogC s t m a+  -> m a+reinterpretLog f =+  runReader f . unReinterpretLogC  + -- Carrier three: collect log messages in a list. This is used for writing this -- example's test spec.-newtype CollectLogMessagesC s m a = CollectLogMessagesC { runCollectLogMessagesC :: WriterC [s] m a }+newtype CollectLogMessagesC s m a+  = CollectLogMessagesC { unCollectLogMessagesC :: WriterC [s] m a }   deriving (Applicative, Functor, Monad)  instance      -- So long as the 'm' monad can interpret the 'sig' effects...-     Algebra sig m+     ( Algebra sig m+     , Effect sig+     )      -- ...the 'CollectLogMessagesC s m' monad can interpret 'Log s :+: sig'      -- effects   => Algebra (Log s :+: sig) (CollectLogMessagesC s m) where -  alg hdl sig ctx = CollectLogMessagesC $ case sig of-    L (Log s) -> ctx <$ tell [s]+  alg ::+       (Log s :+: sig) (CollectLogMessagesC s m) a+    -> CollectLogMessagesC s m a+  alg = \case+    L (Log s k) ->+      CollectLogMessagesC $ do+        tell [s]+        unCollectLogMessagesC k -    R other   -> alg (runCollectLogMessagesC . hdl) (R other) ctx+    R other ->+      CollectLogMessagesC (alg (R (handleCoercible other)))  -- The 'CollectLogMessagesC' runner.-collectLogMessages :: Functor m => CollectLogMessagesC s m a -> m [s]-collectLogMessages = execWriter . runCollectLogMessagesC+collectLogMessages ::+     CollectLogMessagesC s m a+  -> m ([s], a)+collectLogMessages =+  runWriter . unCollectLogMessagesC   -- Test spec. example :: TestTree example = testGroup "reinterpret log"-  [ testCase "reinterprets logs" $ do-      a <- collectLogMessages . reinterpretLog renderLogMessage $ do+  [ testCase "reinterprets logs" $+    ((do         log (Debug "foo")-        log (Info "bar")-      a @?= ["[debug] foo", "[info] bar"]+        log (Info "bar"))+      & reinterpretLog renderLogMessage+      & collectLogMessages+      & run)+    @?= (["[debug] foo", "[info] bar"], ())   ]

@@ -1,26 +1,22 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}  module Teletype ( example+, runTeletypeIO ) where -import           Control.Algebra-import           Control.Carrier.State.Strict-import           Control.Carrier.Writer.Strict-import           Control.Monad.IO.Class-import           Data.Kind (Type)-import           Hedgehog+import Prelude hiding (read)++import Control.Algebra+import Control.Carrier.State.Strict+import Control.Carrier.Writer.Strict+import Control.Monad.IO.Class+import GHC.Generics (Generic1)+import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-import           Prelude hiding (read)-import           Test.Tasty-import           Test.Tasty.Hedgehog+import Test.Tasty+import Test.Tasty.Hedgehog  example :: TestTree example = testGroup "teletype"@@ -41,26 +37,31 @@   ] where   genLine = Gen.string (Range.linear 0 20) Gen.unicode -data Teletype (m :: Type -> Type) k where-  Read  ::           Teletype m String-  Write :: String -> Teletype m ()+data Teletype m k+  = Read (String -> m k)+  | Write String (m k)+  deriving (Functor, Generic1) +instance HFunctor Teletype+instance Effect   Teletype  read :: Has Teletype sig m => m String-read = send Read+read = send (Read pure)  write :: Has Teletype sig m => String -> m ()-write s = send (Write s)+write s = send (Write s (pure ()))  -newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIO :: m a }+runTeletypeIO :: TeletypeIOC m a -> m a+runTeletypeIO = runTeletypeIOC++newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }   deriving (Applicative, Functor, Monad, MonadIO)  instance (MonadIO m, Algebra sig m) => Algebra (Teletype :+: sig) (TeletypeIOC m) where-  alg hdl sig ctx = case sig of-    L Read      -> (<$ ctx) <$> liftIO getLine-    L (Write s) -> ctx <$ liftIO (putStrLn s)-    R other     -> TeletypeIOC (alg (runTeletypeIO . hdl) other ctx)+  alg (L (Read    k)) = liftIO getLine      >>= k+  alg (L (Write s k)) = liftIO (putStrLn s) >>  k+  alg (R other)       = TeletypeIOC (alg (handleCoercible other))   runTeletypeRet :: [String] -> TeletypeRetC m a -> m ([String], ([String], a))@@ -69,12 +70,11 @@ newtype TeletypeRetC m a = TeletypeRetC { runTeletypeRetC :: StateC [String] (WriterC [String] m) a }   deriving (Applicative, Functor, Monad) -instance Algebra sig m => Algebra (Teletype :+: sig) (TeletypeRetC m) where-  alg hdl sig ctx = TeletypeRetC $ case sig of-    L Read      -> do-      i <- get-      case i of-        []  -> pure ("" <$ ctx)-        h:t -> h <$ ctx <$ put t-    L (Write s) -> ctx <$ tell [s]-    R other     -> alg (runTeletypeRetC . hdl) (R (R other)) ctx+instance (Algebra sig m, Effect sig) => Algebra (Teletype :+: sig) (TeletypeRetC m) where+  alg (L (Read    k)) = do+    i <- TeletypeRetC get+    case i of+      []  -> k ""+      h:t -> TeletypeRetC (put t) *> k h+  alg (L (Write s k)) = TeletypeRetC (tell [s]) *> k+  alg (R other)       = TeletypeRetC (alg (R (R (handleCoercible other))))

@@ -1,7 +1,7 @@ cabal-version:       2.2  name:                fused-effects-version:             1.0.2.1+version:             1.0.2.2 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/fused-effects/fused-effects@@ -36,6 +36,8 @@     -Wno-name-shadowing     -Wno-safe     -Wno-unsafe+  if (impl(ghc >= 8.6))+    ghc-options: -Wno-star-is-type   if (impl(ghc >= 8.8))     ghc-options: -Wno-missing-deriving-strategies   if (impl(ghc >= 8.10))@@ -48,34 +50,29 @@   hs-source-dirs: src   exposed-modules:     Control.Algebra-    Control.Algebra.Handler     -- Carriers     Control.Carrier.Choose.Church     Control.Carrier.Cull.Church     Control.Carrier.Cut.Church-    Control.Carrier.Empty.Church     Control.Carrier.Empty.Maybe-    Control.Carrier.Error.Church     Control.Carrier.Error.Either     Control.Carrier.Fail.Either-    Control.Carrier.Fresh.Church     Control.Carrier.Fresh.Strict     Control.Carrier.Interpret     Control.Carrier.Lift     Control.Carrier.NonDet.Church     Control.Carrier.Reader-    Control.Carrier.State.Church     Control.Carrier.State.Lazy     Control.Carrier.State.Strict     Control.Carrier.Throw.Either     Control.Carrier.Trace.Ignoring     Control.Carrier.Trace.Printing     Control.Carrier.Trace.Returning-    Control.Carrier.Writer.Church     Control.Carrier.Writer.Strict     -- Effects     Control.Effect.Catch     Control.Effect.Choose+    Control.Effect.Class     Control.Effect.Cull     Control.Effect.Cut     Control.Effect.Empty@@ -121,7 +118,7 @@     ReinterpretLog     Teletype   build-depends:-    , base+      base     , fused-effects     , hedgehog           ^>= 1     , hedgehog-fn        ^>= 1@@ -157,7 +154,7 @@     Throw     Writer   build-depends:-    , base+      base     , containers          >= 0.5 && < 0.7     , fused-effects     , hedgehog           ^>= 1@@ -175,7 +172,7 @@   main-is:     README.lhs   ghc-options: -pgmL markdown-unlit   build-depends:-    , base+      base     , fused-effects   build-tool-depends:       markdown-unlit:markdown-unlit ^>= 0.5@@ -187,18 +184,13 @@   hs-source-dirs: benchmark   main-is:        Bench.hs   other-modules:-    Bench.Error-    Bench.Interpret+    Bench.Reader     Bench.NonDet     Bench.NonDet.NQueens-    Bench.Reader-    Bench.State-    Bench.Writer   build-depends:-    , base+      base     , fused-effects     , gauge-    , transformers   ghc-options:     -threaded     -rtsopts "-with-rtsopts=-N -A4m -n2m"

@@ -1,13 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -19,19 +15,17 @@ -} module Control.Algebra ( Algebra(..)-, thread , run , Has , send   -- * Re-exports-, Handler-, (~<~) , (:+:) (..)+, module Control.Effect.Class ) where -import           Control.Algebra.Handler import           Control.Effect.Catch.Internal import           Control.Effect.Choose.Internal+import           Control.Effect.Class import           Control.Effect.Empty.Internal import           Control.Effect.Error.Internal import           Control.Effect.Lift.Internal@@ -41,70 +35,29 @@ import           Control.Effect.Sum ((:+:)(..), Member(..), Members) import           Control.Effect.Throw.Internal import           Control.Effect.Writer.Internal+import           Control.Monad ((<=<)) import qualified Control.Monad.Trans.Except as Except import qualified Control.Monad.Trans.Identity as Identity-import qualified Control.Monad.Trans.Maybe as Maybe import qualified Control.Monad.Trans.Reader as Reader-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.RWS.CPS as RWS.CPS-#endif import qualified Control.Monad.Trans.RWS.Lazy as RWS.Lazy import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict import qualified Control.Monad.Trans.State.Lazy as State.Lazy import qualified Control.Monad.Trans.State.Strict as State.Strict-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.Writer.CPS as Writer.CPS-#endif import qualified Control.Monad.Trans.Writer.Lazy as Writer.Lazy import qualified Control.Monad.Trans.Writer.Strict as Writer.Strict-import           Data.Functor.Compose+import           Data.Coerce import           Data.Functor.Identity-import           Data.List.NonEmpty (NonEmpty(..))+import           Data.List.NonEmpty (NonEmpty) import           Data.Monoid+import qualified Data.Semigroup as S+import           Data.Tuple (swap)  -- | The class of carriers (results) for algebras (effect handlers) over signatures (effects), whose actions are given by the 'alg' method. -- -- @since 1.0.0.0-class Monad m => Algebra sig m | m -> sig where-  -- | Interpret an effect, running any nested actions using a 'Handler' starting from an initial state in @ctx@.-  ---  -- Instances receive a signature of effects containing actions in @n@ which can be lowered to @m@ using the passed 'Handler' and initial context. Continuations in @n@ can be handled after mapping into contexts returned from previous actions.-  ---  -- For example, considering the 'Algebra' instance for @'Either' e@:-  ---  -- > instance Algebra (Error e) (Either e) where-  -- >   alg hdl sig ctx = case sig of-  -- >     L (Throw e)   -> Left e-  -- >     R (Catch m h) -> either (hdl . (<$ ctx) . h) pure (hdl (m <$ ctx))-  ---  -- The 'Catch' case holds actions @m :: n x@ and @h :: e -> n x@ (for some existentially-quantified type @x@), and a continuation @k :: x -> n a@. The algebra must return @m (ctx a)@, so we have to ultimately use and lower the continuation in order to produce that type. The continuation takes an @x@, which we can get from either of the actions, after lowering them to values in @'Either' e@.-  ---  -- To that end, the algebra lifts both the action @m@ and the result of the error handler @h@ into the initial context @ctx@ before lowering them with @hdl@. The continuation @k@ is 'fmap'ed into the resulting context and then itself lowered with @hdl@.-  ---  -- By contrast, the 'Throw' case can simply return a value in 'Left', since there is no continuation to call—it represents an exceptional return—and @'Left' e :: forall a . Either e a@ (i.e. 'Left' is polymorphic in @a@).-  ---  -- Instances for monad transformers will most likely handle a signature containing multiple effects, with the tail of the signature handled by whatever monad the transformer wraps. In these cases, the tail of the signature can be delegated most conveniently using 'thread'; see the 'Algebra' instances for @transformers@ types such as 'Reader.ReaderT' and 'Except.ExceptT' for details.-  alg-    :: Functor ctx-    => Handler ctx n m -- ^ A 'Handler' lowering computations inside the effect into the carrier type @m@.-    -> sig n a         -- ^ The effect signature to be interpreted.-    -> ctx ()          -- ^ The initial state.-    -> m (ctx a)       -- ^ The interpretation of the effect in @m@.---- | Thread a composed handler and input state through the algebra for some underlying signature.------ @since 1.1.0.0-thread-  :: ( Functor ctx1-     , Functor ctx2-     , Algebra sig m-     )-  => Handler (Compose ctx1 ctx2) n m-  -> sig n a-  -> ctx1 (ctx2 ())-  -> m (ctx1 (ctx2 a))-thread hdl sig = fmap getCompose . alg hdl sig . Compose-{-# INLINE thread #-}+class (HFunctor sig, Monad m) => Algebra 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).+  alg :: sig m a -> m a   -- | Run an action exhausted of effects to produce its final result value.@@ -122,73 +75,55 @@ -- 1. Due to [a problem with recursive type families](https://gitlab.haskell.org/ghc/ghc/issues/8095), this can lead to significantly slower compiles. -- -- 2. It defeats @ghc@’s warnings for redundant constraints, and thus can lead to a proliferation of redundant constraints as code is changed.------ @since 1.0.0.0 type Has eff sig m = (Members eff sig, Algebra sig m)  -- | Construct a request for an effect to be interpreted by some handler later on.------ @since 0.1.0.0 send :: (Member eff sig, Algebra sig m) => eff m a -> m a-send sig = runIdentity <$> alg (fmap Identity . runIdentity) (inj sig) (Identity ())+send = alg . inj {-# INLINE send #-}   -- base  instance Algebra (Lift IO) IO where-  alg hdl (LiftWith with) = with hdl-  {-# INLINE alg #-}+  alg (LiftWith with k) = with (Identity ()) coerce >>= k . runIdentity  instance Algebra (Lift Identity) Identity where-  alg hdl (LiftWith with) = with hdl-  {-# INLINE alg #-}+  alg (LiftWith with k) = with (Identity ()) coerce >>= k . runIdentity  instance Algebra Choose NonEmpty where-  alg _ Choose ctx = (True <$ ctx) :| [ False <$ ctx ]-  {-# INLINE alg #-}+  alg (Choose m) = m True S.<> m False  instance Algebra Empty Maybe where-  alg _ Empty _ = Nothing-  {-# INLINE alg #-}+  alg Empty = Nothing  instance Algebra (Error e) (Either e) where-  alg hdl sig ctx = case sig of-    L (Throw e)   -> Left e-    R (Catch m h) -> either (hdl . (<$ ctx) . h) pure (hdl (m <$ ctx))-  {-# INLINE alg #-}+  alg (L (Throw e))     = Left e+  alg (R (Catch m h k)) = either (k <=< h) k m  instance Algebra (Reader r) ((->) r) where-  alg hdl sig ctx = case sig of-    Ask       -> (<$ ctx)-    Local f m -> hdl (m <$ ctx) . f-  {-# INLINE alg #-}+  alg (Ask       k) r = k r r+  alg (Local f m k) r = k (m (f r)) r  instance Algebra NonDet [] where-  alg _ sig ctx = case sig of-    L Empty  -> []-    R Choose -> [ True <$ ctx, False <$ ctx ]-  {-# INLINE alg #-}+  alg (L Empty)      = []+  alg (R (Choose k)) = k True ++ k False  instance Monoid w => Algebra (Writer w) ((,) w) where-  alg hdl sig ctx = case sig of-    Tell w     -> (w, ctx)-    Listen m   -> let (w, a) = hdl (m <$ ctx) in (w, (,) w <$> a)-    Censor f m -> let (w, a) = hdl (m <$ ctx) in (f w, a)-  {-# INLINE alg #-}+  alg (Tell w (w', k))    = (mappend w w', k)+  alg (Listen (w, a) k)   = let (w', a') = k w a in (mappend w w', a')+  alg (Censor f (w, a) k) = let (w', a') = k a in (mappend (f w) w', a')   -- transformers -instance Algebra sig m => Algebra (Error e :+: sig) (Except.ExceptT e m) where-  alg hdl sig ctx = case sig of-    L (L (Throw e))   -> Except.throwE e-    L (R (Catch m h)) -> Except.catchE (hdl (m <$ ctx)) (hdl . (<$ ctx) . h)-    R other           -> Except.ExceptT $ thread (either (pure . Left) Except.runExceptT ~<~ hdl) other (Right ctx)-  {-# INLINE alg #-}-+instance (Algebra sig m, Effect sig) => Algebra (Error e :+: sig) (Except.ExceptT e m) where+  alg (L (L (Throw e)))     = Except.throwE e+  alg (L (R (Catch m h k))) = Except.catchE m h >>= k+  alg (R other)             = Except.ExceptT $ alg (thread (Right ()) (either (pure . Left) Except.runExceptT) other) -deriving instance Algebra sig m => Algebra sig (Identity.IdentityT m)+instance Algebra sig m => Algebra sig (Identity.IdentityT m) where+  alg = Identity.IdentityT . alg . handleCoercible  #if MIN_VERSION_base(4,12,0) -- | This instance permits effectful actions to be lifted into the 'Ap' monad@@ -202,7 +137,8 @@ -- > getAp (act1 <> act2 <> act3) -- -- @since 1.0.1.0-deriving instance Algebra sig m => Algebra sig (Ap m)+instance Algebra sig m => Algebra sig (Ap m) where+  alg = Ap . alg . handleCoercible #endif  -- | This instance permits effectful actions to be lifted into the 'Alt' monad,@@ -215,23 +151,13 @@ -- > getAlt (mconcat [a, b, c, d]) -- -- @since 1.0.1.0-deriving instance Algebra sig m => Algebra sig (Alt m)---instance Algebra sig m => Algebra (Empty :+: sig) (Maybe.MaybeT m) where-  alg hdl sig ctx = case sig of-    L Empty -> Maybe.MaybeT (pure Nothing)-    R other -> Maybe.MaybeT $ thread (maybe (pure Nothing) Maybe.runMaybeT ~<~ hdl) other (Just ctx)-  {-# INLINE alg #-}-+instance Algebra sig m => Algebra sig (Alt m) where+  alg = Alt . alg . handleCoercible  instance Algebra sig m => Algebra (Reader r :+: sig) (Reader.ReaderT r m) where-  alg hdl sig ctx = case sig of-    L Ask         -> Reader.asks (<$ ctx)-    L (Local f m) -> Reader.local f (hdl (m <$ ctx))-    R other       -> Reader.ReaderT $ \ r -> alg ((`Reader.runReaderT` r) . hdl) other ctx-  {-# INLINE alg #-}-+  alg (L (Ask       k)) = Reader.ask >>= k+  alg (L (Local f m k)) = Reader.local f m >>= k+  alg (R other)         = Reader.ReaderT $ \ r -> alg (hmap (`Reader.runReaderT` r) other)  newtype RWSTF w s a = RWSTF { unRWSTF :: (a, s, w) }   deriving (Functor)@@ -240,89 +166,44 @@ toRWSTF w (a, s, w') = RWSTF (a, s, mappend w w') {-# INLINE toRWSTF #-} -newtype Swap s a = Swap { getSwap :: (a, s) }-  deriving (Functor)--swapAndLift :: Functor ctx => (ctx a, w) -> ctx (w, a)-swapAndLift p = (,) (snd p) <$> fst p-{-# INLINE swapAndLift #-}--#if MIN_VERSION_transformers(0,5,6)-instance (Algebra sig m, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.CPS.RWST r w s m) where-  alg hdl sig ctx = case sig of-    L Ask              -> RWS.CPS.asks (<$ ctx)-    L (Local f m)      -> RWS.CPS.local f (hdl (m <$ ctx))-    R (L (Tell w))     -> ctx <$ RWS.CPS.tell w-    R (L (Listen m))   -> swapAndLift <$> RWS.CPS.listen (hdl (m <$ ctx))-    R (L (Censor f m)) -> RWS.CPS.censor f (hdl (m <$ ctx))-    R (R (L Get))      -> RWS.CPS.gets (<$ ctx)-    R (R (L (Put s)))  -> ctx <$ RWS.CPS.put s-    R (R (R other))    -> RWS.CPS.rwsT $ \ r s -> unRWSTF <$> thread ((\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.CPS.runRWST x r s) ~<~ hdl) other (RWSTF (ctx, s, mempty))-  {-# INLINE alg #-}-#endif--instance (Algebra sig m, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Lazy.RWST r w s m) where-  alg hdl sig ctx = case sig of-    L Ask              -> RWS.Lazy.asks (<$ ctx)-    L (Local f m)      -> RWS.Lazy.local f (hdl (m <$ ctx))-    R (L (Tell w))     -> ctx <$ RWS.Lazy.tell w-    R (L (Listen m))   -> swapAndLift <$> RWS.Lazy.listen (hdl (m <$ ctx))-    R (L (Censor f m)) -> RWS.Lazy.censor f (hdl (m <$ ctx))-    R (R (L Get))      -> RWS.Lazy.gets (<$ ctx)-    R (R (L (Put s)))  -> ctx <$ RWS.Lazy.put s-    R (R (R other))    -> RWS.Lazy.RWST $ \ r s -> unRWSTF <$> thread ((\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.Lazy.runRWST x r s) ~<~ hdl) other (RWSTF (ctx, s, mempty))-  {-# INLINE alg #-}--instance (Algebra sig m, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Strict.RWST r w s m) where-  alg hdl sig ctx = case sig of-    L Ask              -> RWS.Strict.asks (<$ ctx)-    L (Local f m)      -> RWS.Strict.local f (hdl (m <$ ctx))-    R (L (Tell w))     -> ctx <$ RWS.Strict.tell w-    R (L (Listen m))   -> swapAndLift <$> RWS.Strict.listen (hdl (m <$ ctx))-    R (L (Censor f m)) -> RWS.Strict.censor f (hdl (m <$ ctx))-    R (R (L Get))      -> RWS.Strict.gets (<$ ctx)-    R (R (L (Put s)))  -> ctx <$ RWS.Strict.put s-    R (R (R other))    -> RWS.Strict.RWST $ \ r s -> unRWSTF <$> thread ((\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.Strict.runRWST x r s) ~<~ hdl) other (RWSTF (ctx, s, mempty))-  {-# INLINE alg #-}---instance Algebra sig m => Algebra (State s :+: sig) (State.Lazy.StateT s m) where-  alg hdl sig ctx = case sig of-    L Get     -> State.Lazy.gets (<$ ctx)-    L (Put s) -> ctx <$ State.Lazy.put s-    R other   -> State.Lazy.StateT $ \ s -> getSwap <$> thread (fmap Swap . uncurry State.Lazy.runStateT . getSwap ~<~ hdl) other (Swap (ctx, s))-  {-# INLINE alg #-}+instance (Algebra sig m, Effect sig, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Lazy.RWST r w s m) where+  alg (L (Ask       k))      = RWS.Lazy.ask >>= k+  alg (L (Local f m k))      = RWS.Lazy.local f m >>= k+  alg (R (L (Tell w k)))     = RWS.Lazy.tell w *> k+  alg (R (L (Listen m k)))   = RWS.Lazy.listen m >>= uncurry (flip k)+  alg (R (L (Censor f m k))) = RWS.Lazy.censor f m >>= k+  alg (R (R (L (Get   k))))  = RWS.Lazy.get >>= k+  alg (R (R (L (Put s k))))  = RWS.Lazy.put s *> k+  alg (R (R (R other)))      = RWS.Lazy.RWST $ \ r s -> unRWSTF <$> alg (thread (RWSTF ((), s, mempty)) (\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.Lazy.runRWST x r s) other) -instance Algebra sig m => Algebra (State s :+: sig) (State.Strict.StateT s m) where-  alg hdl sig ctx = case sig of-    L Get     -> State.Strict.gets (<$ ctx)-    L (Put s) -> ctx <$ State.Strict.put s-    R other   -> State.Strict.StateT $ \ s -> getSwap <$> thread (fmap Swap . uncurry State.Strict.runStateT . getSwap ~<~ hdl) other (Swap (ctx, s))-  {-# INLINE alg #-}+instance (Algebra sig m, Effect sig, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Strict.RWST r w s m) where+  alg (L (Ask       k))      = RWS.Strict.ask >>= k+  alg (L (Local f m k))      = RWS.Strict.local f m >>= k+  alg (R (L (Tell w k)))     = RWS.Strict.tell w *> k+  alg (R (L (Listen m k)))   = RWS.Strict.listen m >>= uncurry (flip k)+  alg (R (L (Censor f m k))) = RWS.Strict.censor f m >>= k+  alg (R (R (L (Get   k))))  = RWS.Strict.get >>= k+  alg (R (R (L (Put s k))))  = RWS.Strict.put s *> k+  alg (R (R (R other)))      = RWS.Strict.RWST $ \ r s -> unRWSTF <$> alg (thread (RWSTF ((), s, mempty)) (\ (RWSTF (x, s, w)) -> toRWSTF w <$> RWS.Strict.runRWST x r s) other) +instance (Algebra sig m, Effect sig) => Algebra (State s :+: sig) (State.Lazy.StateT s m) where+  alg (L (Get   k)) = State.Lazy.get >>= k+  alg (L (Put s k)) = State.Lazy.put s *> k+  alg (R other)     = State.Lazy.StateT $ \ s -> swap <$> alg (thread (s, ()) (\ (s, x) -> swap <$> State.Lazy.runStateT x s) other) -#if MIN_VERSION_transformers(0,5,6)-instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.CPS.WriterT w m) where-  alg hdl sig ctx = case sig of-    L (Tell w)     -> ctx <$ Writer.CPS.tell w-    L (Listen m)   -> swapAndLift <$> Writer.CPS.listen (hdl (m <$ ctx))-    L (Censor f m) -> Writer.CPS.censor f (hdl (m <$ ctx))-    R other        -> Writer.CPS.writerT $ getSwap <$> thread ((\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.CPS.runWriterT x) ~<~ hdl) other (Swap (ctx, mempty))-  {-# INLINE alg #-}-#endif+instance (Algebra sig m, Effect sig) => Algebra (State s :+: sig) (State.Strict.StateT s m) where+  alg (L (Get   k)) = State.Strict.get >>= k+  alg (L (Put s k)) = State.Strict.put s *> k+  alg (R other)     = State.Strict.StateT $ \ s -> swap <$> alg (thread (s, ()) (\ (s, x) -> swap <$> State.Strict.runStateT x s) other) -instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.Lazy.WriterT w m) where-  alg hdl sig ctx = case sig of-    L (Tell w)     -> ctx <$ Writer.Lazy.tell w-    L (Listen m)   -> swapAndLift <$> Writer.Lazy.listen (hdl (m <$ ctx))-    L (Censor f m) -> Writer.Lazy.censor f (hdl (m <$ ctx))-    R other        -> Writer.Lazy.WriterT $ getSwap <$> thread ((\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.Lazy.runWriterT x) ~<~ hdl) other (Swap (ctx, mempty))-  {-# INLINE alg #-}+instance (Algebra sig m, Effect sig, Monoid w) => Algebra (Writer w :+: sig) (Writer.Lazy.WriterT w m) where+  alg (L (Tell w k))     = Writer.Lazy.tell w *> k+  alg (L (Listen m k))   = Writer.Lazy.listen m >>= uncurry (flip k)+  alg (L (Censor f m k)) = Writer.Lazy.censor f m >>= k+  alg (R other)          = Writer.Lazy.WriterT $ swap <$> alg (thread (mempty, ()) (\ (s, x) -> swap . fmap (mappend s) <$> Writer.Lazy.runWriterT x) other) -instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (Writer.Strict.WriterT w m) where-  alg hdl sig ctx = case sig of-    L (Tell w)     -> ctx <$ Writer.Strict.tell w-    L (Listen m)   -> swapAndLift <$> Writer.Strict.listen (hdl (m <$ ctx))-    L (Censor f m) -> Writer.Strict.censor f (hdl (m <$ ctx))-    R other        -> Writer.Strict.WriterT $ getSwap <$> thread ((\ (Swap (x, s)) -> Swap . fmap (mappend s) <$> Writer.Strict.runWriterT x) ~<~ hdl) other (Swap (ctx, mempty))-  {-# INLINE alg #-}+instance (Algebra sig m, Effect sig, Monoid w) => Algebra (Writer w :+: sig) (Writer.Strict.WriterT w m) where+  alg (L (Tell w k))     = Writer.Strict.tell w *> k+  alg (L (Listen m k))   = Writer.Strict.listen m >>= uncurry (flip k)+  alg (L (Censor f m k)) = Writer.Strict.censor f m >>= k+  alg (R other)          = Writer.Strict.WriterT $ swap <$> alg (thread (mempty, ()) (\ (s, x) -> swap . fmap (mappend s) <$> Writer.Strict.runWriterT x) other)

@@ -1,47 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Control.Algebra.Handler-( Handler-, (~<~)-) where--import Data.Functor.Compose---- | Handlers take an action in @m@ bundled up with some state in some context functor @ctx@, and return an action in @n@ producing a derived state in @ctx@.------ These are expected to be well-behaved /distributive laws/, and are required to adhere to the following laws:------ @--- handler '.' 'fmap' 'pure' = 'pure'--- @--- @--- handler '.' 'fmap' (k '=<<') = handler '.' 'fmap' k 'Control.Monad.<=<' handler--- @------ respectively expressing that the handler does not alter the context of pure computations, and that the handler distributes over monadic composition.------ Handlers compose with handlers, using e.g. @"Data.Functor.Compose".'Data.Functor.Compose.Compose'@ to ensure that the result is itself well-typed as a 'Handler':------ @--- 'fmap' 'Data.Functor.Compose.Compose' '.' handler1 '.' 'fmap' handler2 '.' 'Data.Functor.Compose.getCompose'--- @------ and with monad homomorphisms on the left and right:------ @--- hom '.' handler--- @--- @--- handler '.' 'fmap' hom--- @------ @since 1.1.0.0-type Handler ctx m n = forall x . ctx (m x) -> n (ctx x)---- | Composition of handlers.------ @since 1.1.0.0-(~<~) :: (Functor n, Functor ctx1) => Handler ctx1 m n -> Handler ctx2 l m -> Handler (Compose ctx1 ctx2) l n-hdl1 ~<~ hdl2 = fmap Compose . hdl1 . fmap hdl2 . getCompose-{-# INLINE (~<~) #-}--infixr 1 ~<~

@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}@@ -23,36 +22,30 @@ , module Control.Effect.Choose ) where -import Control.Algebra-import Control.Applicative (liftA2)-import Control.Effect.Choose-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Data.Coerce (coerce)-import Data.Functor.Identity-import Data.List.NonEmpty (NonEmpty(..), head, tail)-import Data.Semigroup as S-import Prelude hiding (head, tail)+import           Control.Algebra+import           Control.Applicative (liftA2)+import           Control.Effect.Choose+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Data.Coerce (coerce)+import           Data.Functor.Identity+import           Data.List.NonEmpty (NonEmpty(..), head, tail)+import qualified Data.Semigroup as S+import           Prelude hiding (head, tail)  -- | Run a 'Choose' effect with continuations respectively interpreting '<|>' and 'pure'. ----- @--- runChoose fork leaf ('pure' a '<|>' b) = leaf a \`fork\` 'runChoose' fork leaf b--- @--- -- @since 1.0.0.0 runChoose :: (m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b runChoose fork leaf (ChooseC runChooseC) = runChooseC fork leaf-{-# INLINE runChoose #-}  -- | Run a 'Choose' effect, mapping results into a 'S.Semigroup'. -- -- @since 1.0.0.0 runChooseS :: (S.Semigroup b, Applicative m) => (a -> m b) -> ChooseC m a -> m b runChooseS = runChoose (liftA2 (S.<>))-{-# INLINE runChooseS #-}  -- | A carrier for 'Choose' effects based on Ralf Hinze’s design described in [Deriving Backtracking Monad Transformers](https://www.cs.ox.ac.uk/ralf.hinze/publications/#P12). --@@ -63,7 +56,6 @@ instance Applicative (ChooseC m) where   pure a = ChooseC (\ _ leaf -> leaf a)   {-# INLINE pure #-}-   ChooseC f <*> ChooseC a = ChooseC $ \ fork leaf ->     f fork (\ f' -> a fork (leaf . f'))   {-# INLINE (<*>) #-}@@ -96,11 +88,9 @@   lift m = ChooseC (\ _ leaf -> m >>= leaf)   {-# INLINE lift #-} -instance Algebra sig m => Algebra (Choose :+: sig) (ChooseC m) where-  alg hdl sig ctx = ChooseC $ \ fork leaf -> case sig of-    L Choose -> leaf (True <$ ctx) `fork` leaf (False <$ ctx)-    R other  -> thread (dst ~<~ hdl) other (pure ctx) >>= run . runChoose (coerce fork) (coerce leaf)-    where+instance (Algebra sig m, Effect sig) => Algebra (Choose :+: sig) (ChooseC m) where+  alg (L (Choose k)) = ChooseC $ \ fork leaf -> fork (runChoose fork leaf (k True)) (runChoose fork leaf (k False))+  alg (R other)      = ChooseC $ \ fork leaf -> alg (thread (pure ()) dst other) >>= runIdentity . runChoose (coerce fork) (coerce leaf) where     dst :: Applicative m => ChooseC Identity (ChooseC m a) -> m (ChooseC Identity a)-    dst = run . runChoose (liftA2 (liftA2 (<|>))) (pure . runChoose (liftA2 (<|>)) (pure . pure))+    dst = runIdentity . runChoose (liftA2 (liftA2 (<|>))) (pure . runChoose (liftA2 (<|>)) (pure . pure))   {-# INLINE alg #-}

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-}@@ -14,60 +13,49 @@   runCull , runCullA , runCullM-, CullC(CullC)+, CullC(..)   -- * Cull effect , module Control.Effect.Cull   -- * NonDet effects , module Control.Effect.NonDet ) where -import Control.Algebra-import Control.Applicative (liftA2)-import Control.Carrier.NonDet.Church-import Control.Carrier.Reader-import Control.Effect.Cull-import Control.Effect.NonDet-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (liftA2)+import           Control.Carrier.NonDet.Church+import           Control.Carrier.Reader+import           Control.Effect.Cull+import           Control.Effect.NonDet+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | Run a 'Cull' effect with continuations respectively interpreting '<|>', 'pure', and 'empty'. Branches outside of any 'cull' block will not be pruned. ----- @--- runCull fork leaf nil ('pure' a '<|>' 'empty') = leaf a \`fork\` nil--- @--- @--- runCull fork leaf nil ('cull' ('pure' a '<|>' b)) = leaf a--- @--- -- @since 1.0.0.0 runCull :: (m b -> m b -> m b) -> (a -> m b) -> m b -> CullC m a -> m b runCull fork leaf nil (CullC m) = runNonDet fork leaf nil (runReader False m)-{-# INLINE runCull #-}  -- | Run a 'Cull' effect, interpreting the result into an 'Alternative' functor. Choice is handled with '<|>', embedding with 'pure', and failure with 'empty'. -- -- @since 1.0.0.0 runCullA :: (Alternative f, Applicative m) => CullC m a -> m (f a) runCullA = runCull (liftA2 (<|>)) (pure . pure) (pure empty)-{-# INLINE runCullA #-}  -- | Run a 'Cull' effect, mapping results into a 'Monoid'. -- -- @since 1.0.0.0 runCullM :: (Applicative m, Monoid b) => (a -> b) -> CullC m a -> m b runCullM leaf = runCull (liftA2 mappend) (pure . leaf) (pure mempty)-{-# INLINE runCullM #-}  -- | @since 1.0.0.0-newtype CullC m a = CullC { runCullC :: ReaderC Bool (NonDetC m) a }+newtype CullC m a = CullC (ReaderC Bool (NonDetC m) a)   deriving (Applicative, Functor, Monad, Fail.MonadFail, MonadIO)  instance Alternative (CullC m) where   empty = CullC empty   {-# INLINE empty #-}-   CullC l <|> CullC r = CullC $ ReaderC $ \ cull ->     if cull then       NonDetC $ \ fork leaf nil ->@@ -85,10 +73,9 @@   lift = CullC . lift . lift   {-# INLINE lift #-} -instance Algebra sig m => Algebra (Cull :+: NonDet :+: sig) (CullC m) where-  alg hdl sig ctx = case sig of-    L (Cull m)       -> CullC (local (const True) (runCullC (hdl (m <$ ctx))))-    R (L (L Empty))  -> empty-    R (L (R Choose)) -> pure (True <$ ctx) <|> pure (False <$ ctx)-    R (R other)      -> CullC (alg (runCullC . hdl) (R (R other)) ctx)+instance (Algebra sig m, Effect sig) => Algebra (Cull :+: NonDet :+: sig) (CullC m) where+  alg (L (Cull (CullC m) k)) = CullC (local (const True) m) >>= k+  alg (R (L (L Empty)))      = empty+  alg (R (L (R (Choose k)))) = k True <|> k False+  alg (R (R other))          = CullC (alg (R (R (handleCoercible other))))   {-# INLINE alg #-}

@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-}@@ -21,47 +20,34 @@ , module Control.Effect.NonDet ) where -import Control.Algebra-import Control.Applicative (liftA2)-import Control.Effect.Cut-import Control.Effect.NonDet-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Data.Coerce (coerce)-import Data.Functor.Identity+import           Control.Algebra+import           Control.Applicative (liftA2)+import           Control.Effect.Cut+import           Control.Effect.NonDet+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Data.Coerce (coerce)+import           Data.Functor.Identity  -- | Run a 'Cut' effect with continuations respectively interpreting 'pure' / '<|>', 'empty', and 'cutfail'. ----- @--- runCut cons nil fail ('pure' a '<|>' 'empty') = cons a nil--- @--- @--- runCut cons nil fail 'cutfail' = fail--- @--- @--- runCut cons nil fail ('call' 'cutfail') = nil--- @--- -- @since 1.0.0.0 runCut :: (a -> m b -> m b) -> m b -> m b -> CutC m a -> m b runCut cons nil fail (CutC runCutC) = runCutC cons nil fail-{-# INLINE runCut #-}  -- | Run a 'Cut' effect, returning all its results in an 'Alternative' collection. -- -- @since 1.0.0.0 runCutA :: (Alternative f, Applicative m) => CutC m a -> m (f a) runCutA = runCut (fmap . (<|>) . pure) (pure empty) (pure empty)-{-# INLINE runCutA #-}  -- | Run a 'Cut' effect, mapping results into a 'Monoid'. -- -- @since 1.0.0.0 runCutM :: (Applicative m, Monoid b) => (a -> b) -> CutC m a -> m b runCutM leaf = runCut (fmap . mappend . leaf) (pure mempty) (pure mempty)-{-# INLINE runCutM #-}  -- | @since 1.0.0.0 newtype CutC m a = CutC (forall b . (a -> m b -> m b) -> m b -> m b -> m b)@@ -70,7 +56,6 @@ 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 (<*>) #-}@@ -78,7 +63,6 @@ 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 (<|>) #-} @@ -110,14 +94,12 @@   lift m = CutC (\ cons nil _ -> m >>= flip cons nil)   {-# INLINE lift #-} -instance Algebra sig m => Algebra (Cut :+: NonDet :+: sig) (CutC m) where-  alg hdl sig ctx = CutC $ \ cons nil fail -> case sig of-    L Cutfail        -> fail-    L (Call m)       -> runCut cons nil nil (hdl (m <$ ctx))-    R (L (L Empty))  -> nil-    R (L (R Choose)) -> cons (True <$ ctx) (cons (False <$ ctx) nil)-    R (R other)      -> thread (dst ~<~ hdl) other (pure ctx) >>= run . runCut (coerce cons) (coerce nil) (coerce fail)-    where+instance (Algebra sig m, Effect sig) => Algebra (Cut :+: NonDet :+: sig) (CutC m) where+  alg (L Cutfail)    = CutC $ \ _    _   fail -> fail+  alg (L (Call m k)) = CutC $ \ cons nil fail -> runCut (\ a as -> runCut cons as fail (k a)) nil nil m+  alg (R (L (L Empty)))      = empty+  alg (R (L (R (Choose k)))) = k True <|> k False+  alg (R (R other))          = CutC $ \ cons nil fail -> alg (thread (pure ()) dst other) >>= runIdentity . runCut (coerce cons) (coerce nil) (coerce fail) where     dst :: Applicative m => CutC Identity (CutC m a) -> m (CutC Identity a)-    dst = run . runCut (fmap . liftA2 (<|>) . runCut (fmap . (<|>) . pure) (pure empty) (pure cutfail)) (pure (pure empty)) (pure (pure cutfail))+    dst = runIdentity . runCut (fmap . liftA2 (<|>) . runCut (fmap . (<|>) . pure) (pure empty) (pure cutfail)) (pure (pure empty)) (pure (pure cutfail))   {-# INLINE alg #-}

@@ -1,138 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{- | A church-encoded carrier for 'Empty'.--@since 1.1.0.0--}-module Control.Carrier.Empty.Church-( -- * Empty carrier-  runEmpty-, evalEmpty-, execEmpty-, EmptyC(..)-  -- * Empty effect-, module Control.Effect.Empty-) where--import Control.Algebra-import Control.Applicative (liftA2)-import Control.Effect.Empty-import Control.Monad.Fix-import Control.Monad.Fail as Fail-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Data.Coerce (coerce)-import Data.Functor.Identity---- | Run an 'Empty' effect, returning the first continuation for 'empty' programs and applying the second to successful results.------ @--- 'runEmpty' j k 'empty' = j--- @--- @--- 'runEmpty' j k ('pure' a) = k a--- @------ @since 1.1.0.0-runEmpty :: m b -> (a -> m b) -> EmptyC m a -> m b-runEmpty nil leaf (EmptyC m) = m nil leaf-{-# INLINE runEmpty #-}---- | Run an 'Empty' effect, discarding its result.------ This is convenient for using 'empty' to signal early returns without needing to know whether control exited normally or not.------ @--- 'evalEmpty' = 'runEmpty' ('pure' ()) ('const' ('pure' ()))--- @------ @since 1.1.0.0-evalEmpty :: Applicative m => EmptyC m a -> m ()-evalEmpty = runEmpty (pure ()) (const (pure ()))-{-# INLINE evalEmpty #-}---- | Run an 'Empty' effect, replacing its result with a 'Bool' indicating whether control exited normally.------ This is convenient for using 'empty' to signal early returns when all you need to know is whether control exited normally or not, and not what value it exited with.------ @--- 'execEmpty' = 'runEmpty' ('pure' 'False') ('const' ('pure' 'True'))--- @--- @--- 'execEmpty' ('pure' a) = 'pure' 'True'--- @--- @--- 'execEmpty' 'empty' = 'pure' 'False'--- @------ @since 1.1.0.0-execEmpty :: Applicative m => EmptyC m a -> m Bool-execEmpty = runEmpty (pure False) (const (pure True))-{-# INLINE execEmpty #-}---- | @since 1.1.0.0-newtype EmptyC m a = EmptyC (forall b . m b -> (a -> m b) -> m b)-  deriving (Functor)--instance Applicative (EmptyC m) where-  pure a = EmptyC $ \ _ leaf -> leaf a-  {-# INLINE pure #-}--  EmptyC f <*> EmptyC a = EmptyC $ \ nil leaf ->-    f nil (\ f' -> a nil (leaf . f'))-  {-# INLINE (<*>) #-}--  liftA2 f (EmptyC a) (EmptyC b) = EmptyC $ \ nil leaf ->-    a nil (\ a' -> b nil (leaf . f a'))-  {-# INLINE liftA2 #-}--  EmptyC a *> EmptyC b = EmptyC $ \ nil ->-    a nil . const . b nil-  {-# INLINE (*>) #-}--  EmptyC a <* EmptyC b = EmptyC $ \ nil leaf ->-    a nil (b nil . const . leaf)-  {-# INLINE (<*) #-}--instance Monad (EmptyC m) where-  EmptyC a >>= f = EmptyC $ \ nil leaf ->-    a nil (runEmpty nil leaf . f)-  {-# INLINE (>>=) #-}--  (>>) = (*>)-  {-# INLINE (>>) #-}--instance Fail.MonadFail m => Fail.MonadFail (EmptyC m) where-  fail = lift . Fail.fail-  {-# INLINE fail #-}--instance MonadFix m => MonadFix (EmptyC m) where-  mfix f = EmptyC $ \ nil leaf ->-    mfix (toEmpty . f . run . fromEmpty)-    >>= run . runEmpty (coerce nil) (coerce leaf)-    where-    toEmpty   = runEmpty (pure empty) (pure . pure)-    fromEmpty = runEmpty (error "mfix (EmptyC): empty") pure-  {-# INLINE mfix #-}--instance MonadIO m => MonadIO (EmptyC m) where-  liftIO = lift . liftIO-  {-# INLINE liftIO #-}--instance MonadTrans EmptyC where-  lift m = EmptyC $ \ _ leaf -> m >>= leaf-  {-# INLINE lift #-}--instance Algebra sig m => Algebra (Empty :+: sig) (EmptyC m) where-  alg hdl sig ctx = EmptyC $ \ nil leaf -> case sig of-    L Empty -> nil-    R other -> thread (dst ~<~ hdl) other (pure ctx) >>= run . runEmpty (coerce nil) (coerce leaf)-    where-    dst :: Applicative m => EmptyC Identity (EmptyC m a) -> m (EmptyC Identity a)-    dst = run . runEmpty (pure (pure empty)) (pure . runEmpty (pure empty) (pure . pure))-  {-# INLINE alg #-}

@@ -14,22 +14,18 @@ module Control.Carrier.Empty.Maybe ( -- * Empty carrier   runEmpty-, evalEmpty-, execEmpty , EmptyC(..)   -- * Empty effect , module Control.Effect.Empty ) where -import Control.Algebra-import Control.Effect.Empty-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Maybe-import Data.Functor (void)-import Data.Maybe (isJust)+import           Control.Algebra+import           Control.Effect.Empty+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Maybe  -- | Run an 'Empty' effect, returning 'Nothing' for empty computations, or 'Just' the result otherwise. --@@ -37,7 +33,7 @@ -- 'runEmpty' 'empty' = 'pure' 'Nothing' -- @ -- @--- 'runEmpty' ('pure' a) = 'pure' ('Just' a)+-- 'runEmpty' ('pure' a) = 'Just' a -- @ -- -- @since 1.0.0.0@@ -45,43 +41,16 @@ runEmpty (EmptyC m) = runMaybeT m {-# INLINE runEmpty #-} --- | Run an 'Empty' effect, discarding its result.------ This is convenient for using 'empty' to signal early returns without needing to know whether control exited normally or not.------ @--- 'evalEmpty' = 'void' '.' 'runEmpty'--- @------ @since 1.1.0.0-evalEmpty :: Functor m => EmptyC m a -> m ()-evalEmpty = void . runEmpty-{-# INLINE evalEmpty #-}---- | Run an 'Empty' effect, replacing its result with a 'Bool' indicating whether control exited normally.------ This is convenient for using 'empty' to signal early returns when all you need to know is whether control exited normally or not, and not what value it exited with.------ @--- 'execEmpty' = 'fmap' 'isJust' '.' 'runEmpty'--- @--- @--- 'execEmpty' ('pure' a) = 'pure' 'True'--- @--- @--- 'execEmpty' 'empty' = 'pure' 'False'--- @------ @since 1.1.0.0-execEmpty :: Functor m => EmptyC m a -> m Bool-execEmpty = fmap isJust . runEmpty-{-# INLINE execEmpty #-}- -- | @since 1.0.0.0 newtype EmptyC m a = EmptyC (MaybeT m a)-  deriving (Algebra (Empty :+: sig), Applicative, Functor, Monad, MonadFix, MonadIO, MonadTrans)+  deriving (Applicative, Functor, Monad, MonadFix, MonadIO, MonadTrans)  -- | 'EmptyC' passes 'Fail.MonadFail' operations along to the underlying monad @m@, rather than interpreting it as a synonym for 'empty' à la 'MaybeT'. instance Fail.MonadFail m => Fail.MonadFail (EmptyC m) where   fail = lift . Fail.fail   {-# INLINE fail #-}++instance (Algebra sig m, Effect sig) => Algebra (Empty :+: sig) (EmptyC m) where+  alg (L Empty) = EmptyC (MaybeT (pure Nothing))+  alg (R other) = EmptyC (MaybeT (alg (thread (Just ()) (maybe (pure Nothing) runEmpty) other)))+  {-# INLINE alg #-}

@@ -1,113 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{- | A church-encoded carrier for 'Error'.--@since 1.1.0.0--}-module Control.Carrier.Error.Church-( -- * Error carrier-  runError-, ErrorC(..)-  -- * Error effect-, module Control.Effect.Error-) where--import Control.Algebra-import Control.Applicative (Alternative(..), liftA2)-import Control.Effect.Error-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Data.Coerce (coerce)-import Data.Functor.Identity-import Prelude hiding (fail)---- | Run an 'Error' effect, applying the first continuation to uncaught errors and the second continuation to successful computations’ results.------ @--- 'runError' j k ('pure' a) = k a--- @--- @--- 'runError' j k ('throwError' e) = j e--- @--- @--- 'runError' j k ('throwError' e \`'catchError'\` 'pure') = k e--- @------ @since 1.1.0.0-runError :: (e -> m b) -> (a -> m b) -> ErrorC e m a -> m b-runError fail leaf m = runErrorC m fail leaf-{-# INLINE runError #-}---- | @since 1.1.0.0-newtype ErrorC e m a = ErrorC { runErrorC :: forall b . (e -> m b) -> (a -> m b) -> m b }-  deriving (Functor)--instance Applicative (ErrorC e m) where-  pure a = ErrorC $ \ _ leaf -> leaf a-  {-# INLINE pure #-}--  ErrorC f <*> ErrorC a = ErrorC $ \ fail leaf -> f fail (\ f' -> a fail (leaf . f'))-  {-# INLINE (<*>) #-}--  liftA2 f (ErrorC a) (ErrorC b) = ErrorC $ \ fail leaf ->-    a fail (\ a' -> b fail (leaf . f a'))-  {-# INLINE liftA2 #-}--  ErrorC a1 *> ErrorC a2 = ErrorC $ \ fail -> a1 fail . const . a2 fail-  {-# INLINE (*>) #-}--  ErrorC a1 <* ErrorC a2 = ErrorC $ \ fail leaf -> a1 fail (a2 fail . const . leaf)-  {-# INLINE (<*) #-}--instance Alternative m => Alternative (ErrorC e m) where-  empty = ErrorC $ \ _ _ -> empty-  {-# INLINE empty #-}--  ErrorC a <|> ErrorC b = ErrorC $ \ fail leaf -> a fail leaf <|> b fail leaf-  {-# INLINE (<|>) #-}--instance Monad (ErrorC e m) where-  ErrorC a >>= f = ErrorC $ \ fail leaf -> a fail (runError fail leaf . f)-  {-# INLINE (>>=) #-}--instance Fail.MonadFail m => Fail.MonadFail (ErrorC e m) where-  fail = lift . Fail.fail-  {-# INLINE fail #-}--instance MonadFix m => MonadFix (ErrorC e m) where-  mfix f = ErrorC $ \ fail leaf ->-    mfix (toError . f . run . fromError)-    >>= run . runError (pure . fail) (pure . leaf)-    where-    toError   = runError (pure . throwError) (pure . pure)-    fromError = runError (const (error "mfix (ErrorC): throwError")) pure-  {-# INLINE mfix #-}--instance MonadIO m => MonadIO (ErrorC e m) where-  liftIO = lift . liftIO-  {-# INLINE liftIO #-}--instance (Alternative m, Monad m) => MonadPlus (ErrorC e m)--instance MonadTrans (ErrorC e) where-  lift m = ErrorC $ \ _ leaf -> m >>= leaf-  {-# INLINE lift #-}--instance Algebra sig m => Algebra (Error e :+: sig) (ErrorC e m) where-  alg hdl sig ctx = ErrorC $ \ fail leaf -> case sig of-    L (L (Throw e))   -> fail e-    L (R (Catch m h)) -> runError (runError fail leaf . lower . h) leaf (lower m)-    R other           -> thread (dst ~<~ hdl) other (pure ctx) >>= run . runError (coerce fail) (coerce leaf)-    where-    lower = hdl . (<$ ctx)-    dst :: Applicative m => ErrorC e Identity (ErrorC e m a) -> m (ErrorC e Identity a)-    dst = run . runError (pure . pure . throwError) (pure . runError (pure . throwError) (pure . pure))-  {-# INLINE alg #-}

@@ -15,15 +15,15 @@ , module Control.Effect.Error ) where -import Control.Algebra-import Control.Applicative (Alternative(..))-import Control.Effect.Error-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Effect.Error+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except  -- | Run an 'Error' effect, returning uncaught errors in 'Left' and successful computations’ values in 'Right'. --@@ -34,25 +34,27 @@ -- 'runError' ('throwError' e) = 'pure' ('Left' e) -- @ -- @--- 'runError' ('throwError' e \`'catchError'\` 'pure') = 'pure' ('Right' e)+-- 'runError' ('throwError' e `catchError` 'pure') = 'pure' ('Right' e) -- @ -- -- @since 0.1.0.0 runError :: ErrorC exc m a -> m (Either exc a) runError (ErrorC m) = runExceptT m-{-# INLINE runError #-}  -- | @since 0.1.0.0 newtype ErrorC e m a = ErrorC (ExceptT e m a)-  deriving (Algebra (Error e :+: sig), Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadTrans)+  deriving (Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadTrans)  -- | 'ErrorC' passes 'Alternative' operations along to the underlying monad @m@, rather than combining errors à la 'ExceptT'. instance (Alternative m, Monad m) => Alternative (ErrorC e m) where   empty = ErrorC (ExceptT empty)   {-# INLINE empty #-}-   ErrorC (ExceptT l) <|> ErrorC (ExceptT r) = ErrorC (ExceptT (l <|> r))   {-# INLINE (<|>) #-}  -- | 'ErrorC' passes 'MonadPlus' operations along to the underlying monad @m@, rather than combining errors à la 'ExceptT'. instance (Alternative m, Monad m) => MonadPlus (ErrorC e m)++instance (Algebra sig m, Effect sig) => Algebra (Error e :+: sig) (ErrorC e m) where+  alg = ErrorC . alg . handleCoercible+  {-# INLINE alg #-}

@@ -15,15 +15,15 @@ , module Control.Effect.Fail ) where -import Control.Algebra-import Control.Applicative (Alternative(..))-import Control.Carrier.Throw.Either-import Control.Effect.Fail-import Control.Monad (MonadPlus(..))-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Carrier.Throw.Either+import           Control.Effect.Fail+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | Run a 'Control.Effect.Fail.Fail' effect, returning failure messages in 'Left' and successful computations’ results in 'Right'. --@@ -37,12 +37,15 @@ -- @since 1.0.0.0 runFail :: FailC m a -> m (Either String a) runFail (FailC m) = runThrow m-{-# INLINE runFail #-}  -- | @since 1.0.0.0 newtype FailC m a = FailC (ThrowC String m a)-  deriving (Algebra (Fail :+: sig), Alternative, Applicative, Functor, Monad, MonadFix, MonadIO, MonadPlus, MonadTrans)+  deriving (Alternative, Applicative, Functor, Monad, MonadFix, MonadIO, MonadPlus, MonadTrans) -instance Algebra sig m => Fail.MonadFail (FailC m) where+instance (Algebra sig m, Effect sig) => Fail.MonadFail (FailC m) where   fail = send . Fail   {-# INLINE fail #-}++instance (Algebra sig m, Effect sig) => Algebra (Fail :+: sig) (FailC m) where+  alg = FailC . alg . handleCoercible+  {-# INLINE alg #-}

@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}---- | A church-encoded carrier for a 'Fresh' effect, providing access to a monotonically increasing stream of 'Int' values.------ @since 1.1.0.0-module Control.Carrier.Fresh.Church-( -- * Fresh carrier-  runFresh-, evalFresh-, FreshC(FreshC)-  -- * Fresh effect-, module Control.Effect.Fresh-) where--import Control.Algebra-import Control.Applicative (Alternative)-import Control.Carrier.State.Church-import Control.Effect.Fresh-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class---- | Run a 'Fresh' effect counting up from 0.------ @--- 'runFresh' k n ('pure' a) = k n a--- @--- @--- 'runFresh' k n 'fresh' = k (n '+' 1) n--- @------ @since 1.1.0.0-runFresh :: (Int -> a -> m b) -> Int -> FreshC m a -> m b-runFresh k n = runState k n . runFreshC-{-# INLINE runFresh #-}---- | Run a 'Fresh' effect counting up from an initial value, and forgetting the final value.------ @--- 'evalFresh' n ('pure' a) = 'pure' a--- @--- @--- 'evalFresh' n 'fresh' = 'pure' n--- @------ @since 1.1.0.0-evalFresh :: Applicative m => Int -> FreshC m a -> m a-evalFresh n = evalState n . runFreshC-{-# INLINE evalFresh #-}---- | @since 1.1.0.0-newtype FreshC m a = FreshC { runFreshC :: StateC Int m a }-  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans)--instance Algebra sig m => Algebra (Fresh :+: sig) (FreshC m) where-  alg hdl sig ctx = FreshC $ case sig of-    L Fresh -> state $ \ i -> (i + 1, i <$ ctx)-    R other -> alg (runFreshC . hdl) (R other) ctx-  {-# INLINE alg #-}

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-}@@ -12,20 +11,20 @@ ( -- * Fresh carrier   runFresh , evalFresh-, FreshC(FreshC)+, FreshC(..)   -- * Fresh effect , module Control.Effect.Fresh ) where -import Control.Algebra-import Control.Applicative (Alternative)-import Control.Carrier.State.Strict-import Control.Effect.Fresh-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Carrier.State.Strict+import           Control.Effect.Fresh+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | Run a 'Fresh' effect counting up from 0. --@@ -39,7 +38,6 @@ -- @since 0.1.0.0 runFresh :: Int -> FreshC m a -> m (Int, a) runFresh n (FreshC m) = runState n m-{-# INLINE runFresh #-}  -- | Run a 'Fresh' effect counting up from an initial value, and forgetting the final value. --@@ -53,14 +51,12 @@ -- @since 1.0.0.0 evalFresh :: Functor m => Int -> FreshC m a -> m a evalFresh n (FreshC m) = evalState n m-{-# INLINE evalFresh #-}  -- | @since 1.0.0.0-newtype FreshC m a = FreshC { runFreshC :: StateC Int m a }+newtype FreshC m a = FreshC (StateC Int m a)   deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans) -instance Algebra sig m => Algebra (Fresh :+: sig) (FreshC m) where-  alg hdl sig ctx = FreshC $ case sig of-    L Fresh -> state $ \ i -> (i + 1, i <$ ctx)-    R other -> alg (runFreshC . hdl) (R other) ctx+instance (Algebra sig m, Effect sig) => Algebra (Fresh :+: sig) (FreshC m) where+  alg (L (Fresh k)) = FreshC (get <* modify (+ (1 :: Int))) >>= k+  alg (R other)     = FreshC (alg (R (handleCoercible other)))   {-# INLINE alg #-}

@@ -3,7 +3,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -16,30 +15,29 @@ ( -- * Interpret carrier   runInterpret , runInterpretState-, InterpretC(InterpretC)+, InterpretC(..) , Reifies-, Interpreter+, Handler   -- * Re-exports , Algebra , Has , run ) where -import Control.Algebra-import Control.Applicative (Alternative)-import Control.Carrier.State.Strict-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Data.Functor.Const (Const(..))-import Data.Kind (Type)-import Unsafe.Coerce (unsafeCoerce)+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Carrier.State.Strict+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Data.Functor.Const (Const(..))+import           Unsafe.Coerce (unsafeCoerce) --- | An @Interpreter@ is a function that interprets effects described by @sig@ into the carrier monad @m@.-newtype Interpreter sig m = Interpreter-  { runInterpreter :: forall ctx n s x . Functor ctx => Handler ctx n (InterpretC s sig m) -> sig n x -> ctx () -> InterpretC s sig m (ctx x) }+-- | A @Handler@ is a function that interprets effects described by @sig@ into the carrier monad @m@.+newtype Handler sig m = Handler+  { runHandler :: forall s x . sig (InterpretC s sig m) x -> InterpretC s sig m x }   class Reifies s a | s -> a where@@ -64,37 +62,34 @@ -- -- @since 1.0.0.0 runInterpret-  :: (forall ctx n x . Functor ctx => Handler ctx n m -> eff n x -> ctx () -> m (ctx x))-  -> (forall s . Reifies s (Interpreter eff m) => InterpretC s eff m a)+  :: (HFunctor eff, Monad m)+  => (forall x . eff m x -> m x)+  -> (forall s . Reifies s (Handler eff m) => InterpretC s eff m a)   -> m a-runInterpret f m = reify (Interpreter (\ hdl sig -> InterpretC . f (runInterpretC . hdl) sig)) (go m) where+runInterpret f m = reify (Handler (InterpretC . f . handleCoercible)) (go m) where   go :: InterpretC s eff m x -> Const (m x) s   go (InterpretC m) = Const m-{-# INLINE runInterpret #-}  -- | Interpret an effect using a higher-order function with some state variable. -- -- @since 1.0.0.0 runInterpretState-  :: (forall ctx n x . Functor ctx => Handler ctx n (StateC s m) -> eff n x -> s -> ctx () -> m (s, ctx x))+  :: (HFunctor eff, Monad m)+  => (forall x . s -> eff (StateC s m) x -> m (s, x))   -> s-  -> (forall t . Reifies t (Interpreter eff (StateC s m)) => InterpretC t eff (StateC s m) a)+  -> (forall t . Reifies t (Handler eff (StateC s m)) => InterpretC t eff (StateC s m) a)   -> m (s, a) runInterpretState handler state m   = runState state-  $ runInterpret (\ hdl sig ctx -> StateC (flip (handler hdl sig) ctx)) m-{-# INLINE runInterpretState #-}+  $ runInterpret (\e -> StateC (`handler` e)) m  -- | @since 1.0.0.0-newtype InterpretC s (sig :: (Type -> Type) -> (Type -> Type)) m a = InterpretC { runInterpretC :: m a }+newtype InterpretC s (sig :: (* -> *) -> * -> *) m a = InterpretC (m a)   deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus)  instance MonadTrans (InterpretC s sig) where   lift = InterpretC-  {-# INLINE lift #-} -instance (Reifies s (Interpreter eff m), Algebra sig m) => Algebra (eff :+: sig) (InterpretC s eff m) where-  alg hdl = \case-    L eff   -> runInterpreter (getConst (reflect @s)) hdl eff-    R other -> InterpretC . alg (runInterpretC . hdl) other-  {-# INLINE alg #-}+instance (HFunctor eff, HFunctor sig, Reifies s (Handler eff m), Monad m, Algebra sig m) => Algebra (eff :+: sig) (InterpretC s eff m) where+  alg (L eff)   = runHandler (getConst (reflect @s)) eff+  alg (R other) = InterpretC (alg (handleCoercible other))

@@ -12,21 +12,21 @@ , module Control.Effect.Lift ) where -import Control.Algebra-import Control.Applicative (Alternative)-import Control.Effect.Lift-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative)+import           Control.Effect.Lift+import           Control.Monad (MonadPlus)+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Data.Functor.Identity  -- | Extract a 'Lift'ed 'Monad'ic action from an effectful computation. -- -- @since 1.0.0.0 runM :: LiftC m a -> m a runM (LiftC m) = m-{-# INLINE runM #-}  -- | @since 1.0.0.0 newtype LiftC m a = LiftC (m a)@@ -34,8 +34,6 @@  instance MonadTrans LiftC where   lift = LiftC-  {-# INLINE lift #-}  instance Monad m => Algebra (Lift m) (LiftC m) where-  alg hdl (LiftWith with) = LiftC . with (runM . hdl)-  {-# INLINE alg #-}+  alg (LiftWith with k) = LiftC (with (Identity ()) (fmap Identity . runM . runIdentity)) >>= k . runIdentity

@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-}@@ -23,22 +22,18 @@ , module Control.Effect.NonDet ) where -import Control.Algebra-import Control.Applicative (liftA2)-import Control.Effect.NonDet-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Data.Coerce (coerce)-import Data.Functor.Identity+import           Control.Algebra+import           Control.Applicative (liftA2)+import           Control.Effect.NonDet+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Data.Coerce (coerce)+import           Data.Functor.Identity  -- | Run a 'NonDet' effect, using the provided functions to interpret choice, leaf results, and failure. ----- @--- runNonDet fork leaf nil ('pure' a '<|>' 'empty') = leaf a \`fork\` nil--- @--- -- @since 1.0.0.0 runNonDet   :: (m b -> m b -> m b) -- ^ Handles choice ('<|>')@@ -47,7 +42,6 @@   -> NonDetC m a         -- ^ A nondeterministic computation to execute   -> m b runNonDet fork leaf nil (NonDetC m) = m fork leaf nil-{-# INLINE runNonDet #-}  -- | Run a 'NonDet' effect, collecting all branches’ results into an 'Alternative' functor. --@@ -63,14 +57,12 @@ -- @since 1.0.0.0 runNonDetA :: (Alternative f, Applicative m) => NonDetC m a -> m (f a) runNonDetA = runNonDet (liftA2 (<|>)) (pure . pure) (pure empty)-{-# INLINE runNonDetA #-}  -- | Run a 'NonDet' effect, mapping results into a 'Monoid'. -- -- @since 1.0.0.0 runNonDetM :: (Applicative m, Monoid b) => (a -> b) -> NonDetC m a -> m b runNonDetM leaf = runNonDet (liftA2 mappend) (pure . leaf) (pure mempty)-{-# INLINE runNonDetM #-}  -- | 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). --@@ -81,7 +73,6 @@ instance Applicative (NonDetC m) where   pure a = NonDetC (\ _ leaf _ -> leaf a)   {-# INLINE pure #-}-   NonDetC f <*> NonDetC a = NonDetC $ \ fork leaf nil ->     f fork (\ f' -> a fork (leaf . f') nil) nil   {-# INLINE (<*>) #-}@@ -89,9 +80,7 @@ instance Alternative (NonDetC m) where   empty = NonDetC (\ _ _ nil -> nil)   {-# INLINE empty #-}--  NonDetC l <|> NonDetC r = NonDetC $ \ fork leaf nil ->-    l fork leaf nil `fork` r fork leaf nil+  NonDetC l <|> NonDetC r = NonDetC $ \ fork leaf nil -> fork (l fork leaf nil) (r fork leaf nil)   {-# INLINE (<|>) #-}  instance Monad (NonDetC m) where@@ -123,12 +112,10 @@   lift m = NonDetC (\ _ leaf _ -> m >>= leaf)   {-# INLINE lift #-} -instance Algebra sig m => Algebra (NonDet :+: sig) (NonDetC m) where-  alg hdl sig ctx = NonDetC $ \ fork leaf nil -> case sig of-    L (L Empty)  -> nil-    L (R Choose) -> leaf (True <$ ctx) `fork` leaf (False <$ ctx)-    R other      -> thread (dst ~<~ hdl) other (pure ctx) >>= run . runNonDet (coerce fork) (coerce leaf) (coerce nil)-    where+instance (Algebra sig m, Effect sig) => Algebra (NonDet :+: sig) (NonDetC m) where+  alg (L (L Empty))      = empty+  alg (L (R (Choose k))) = k True <|> k False+  alg (R other)          = NonDetC $ \ fork leaf nil -> alg (thread (pure ()) dst other) >>= runIdentity . runNonDet (coerce fork) (coerce leaf) (coerce nil) where     dst :: Applicative m => NonDetC Identity (NonDetC m a) -> m (NonDetC Identity a)-    dst = run . runNonDet (liftA2 (liftA2 (<|>))) (pure . runNonDetA) (pure (pure empty))+    dst = runIdentity . runNonDet (liftA2 (liftA2 (<|>))) (Identity . runNonDetA) (pure (pure empty))   {-# INLINE alg #-}

@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -16,14 +15,14 @@ , module Control.Effect.Reader ) where -import Control.Algebra-import Control.Applicative (Alternative(..), liftA2)-import Control.Effect.Reader-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative(..), liftA2)+import           Control.Effect.Reader+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | Run a 'Reader' effect with the passed environment value. --@@ -49,24 +48,16 @@ instance Applicative m => Applicative (ReaderC r m) where   pure = ReaderC . const . pure   {-# INLINE pure #-}-   ReaderC f <*> ReaderC a = ReaderC (liftA2 (<*>) f a)   {-# INLINE (<*>) #-}--  liftA2 f (ReaderC a) (ReaderC b) = ReaderC $ \ r ->-    liftA2 f (a r) (b r)-  {-# INLINE liftA2 #-}-   ReaderC u *> ReaderC v = ReaderC $ \ r -> u r *> v r   {-# INLINE (*>) #-}-   ReaderC u <* ReaderC v = ReaderC $ \ r -> u r <* v r   {-# INLINE (<*) #-}  instance Alternative m => Alternative (ReaderC r m) where   empty = ReaderC (const empty)   {-# INLINE empty #-}-   ReaderC l <|> ReaderC r = ReaderC (liftA2 (<|>) l r)   {-# INLINE (<|>) #-} @@ -93,8 +84,7 @@   {-# INLINE lift #-}  instance Algebra sig m => Algebra (Reader r :+: sig) (ReaderC r m) where-  alg hdl sig ctx = ReaderC $ \ r -> case sig of-    L Ask         -> pure (r <$ ctx)-    L (Local f m) -> runReader (f r) (hdl (m <$ ctx))-    R other       -> alg (runReader r . hdl) other ctx+  alg (L (Ask       k)) = ReaderC (\ r -> runReader r (k r))+  alg (L (Local f m k)) = ReaderC (\ r -> runReader (f r) m) >>= k+  alg (R other)         = ReaderC (\ r -> alg (hmap (runReader r) other))   {-# INLINE alg #-}

@@ -1,129 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{- | A church-encoded carrier for the 'State' effect.--Note that the parameter order in 'runState', 'evalState', and 'execState' is reversed compared the equivalent functions provided by @transformers@. This is an intentional decision made to enable the composition of effect handlers with '.' without invoking 'flip'.--@since 1.1.0.0--}-module Control.Carrier.State.Church-( -- * State carrier-  runState-, evalState-, execState-, StateC(StateC)-  -- * State effect-, module Control.Effect.State-) where--import Control.Algebra-import Control.Applicative (Alternative(..), liftA2)-import Control.Effect.State-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class---- | Run a 'State' effect starting from the passed value, applying a continuation to the final state and result.------ @--- 'runState' k s ('pure' a) = k s a--- @--- @--- 'runState' k s 'get' = k s s--- @--- @--- 'runState' k s ('put' t) = k t ()--- @------ @since 1.1.0.0-runState :: forall s m a b . (s -> a -> m b) -> s -> StateC s m a -> m b-runState f s (StateC m) = m f s-{-# INLINE runState #-}---- | Run a 'State' effect, yielding the result value and discarding the final state.------ @--- 'evalState' = 'runState' ('const' 'pure')--- @------ @since 1.1.0.0-evalState :: forall s m a . Applicative m => s -> StateC s m a -> m a-evalState = runState (const pure)-{-# INLINE evalState #-}---- | Run a 'State' effect, yielding the final state and discarding the return value.------ @--- 'execState' = 'runState' ('const' '.' 'pure')--- @------ @since 1.1.0.0-execState :: forall s m a . Applicative m => s -> StateC s m a -> m s-execState = runState (const . pure)-{-# INLINE execState #-}---- | @since 1.1.0.0-newtype StateC s m a = StateC (forall r . (s -> a -> m r) -> s -> m r)-  deriving (Functor)--instance Applicative (StateC s m) where-  pure a = StateC $ \ k s -> k s a-  {-# INLINE pure #-}--  StateC f <*> StateC a = StateC $ \ k -> f (\ s f' -> a (\ s' -> k s' . f') s)-  {-# INLINE (<*>) #-}--  liftA2 f (StateC a) (StateC b) = StateC $ \ k ->-    a (\ s' a' -> b (\ s'' -> k s'' . f a') s')-  {-# INLINE liftA2 #-}--  StateC a *> StateC b = StateC $ \ k -> a (const . b k)-  {-# INLINE (*>) #-}--  StateC a <* StateC b = StateC $ \ k ->-    a (\ s' a' -> b (\ s'' _ -> k s'' a') s')-  {-# INLINE (<*) #-}--instance Alternative m => Alternative (StateC s m) where-  empty = StateC $ \ _ _ -> empty-  {-# INLINE empty #-}--  StateC l <|> StateC r = StateC $ \ k s -> l k s <|> r k s-  {-# INLINE (<|>) #-}--instance Monad (StateC s m) where-  StateC a >>= f = StateC $ \ k -> a (\ s -> runState k s . f)-  {-# INLINE (>>=) #-}--instance Fail.MonadFail m => Fail.MonadFail (StateC s m) where-  fail = lift . Fail.fail-  {-# INLINE fail #-}--instance MonadFix m => MonadFix (StateC s m) where-  mfix f = StateC $ \ k s -> mfix (runState (curry pure) s . f . snd) >>= uncurry k-  {-# INLINE mfix #-}--instance MonadIO m => MonadIO (StateC s m) where-  liftIO = lift . liftIO-  {-# INLINE liftIO #-}--instance (Alternative m, Monad m) => MonadPlus (StateC s m)--instance MonadTrans (StateC s) where-  lift m = StateC $ \ k s -> m >>= k s-  {-# INLINE lift #-}--instance Algebra sig m => Algebra (State s :+: sig) (StateC s m) where-  alg hdl sig ctx = StateC $ \ k s -> case sig of-    L Get     -> k s (s <$ ctx)-    L (Put s) -> k s       ctx-    R other   -> thread (uncurry (runState (curry pure)) ~<~ hdl) other (s, ctx) >>= uncurry k-  {-# INLINE alg #-}

@@ -1,6 +1,5 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -22,14 +21,14 @@ , module Control.Effect.State ) where -import Control.Algebra-import Control.Applicative (Alternative(..))-import Control.Effect.State-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Effect.State+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | 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. --@@ -71,7 +70,7 @@ {-# INLINE[3] execState #-}  -- | @since 1.0.0.0-newtype StateC s m a = StateC (s -> m (s, a))+newtype StateC s m a = StateC { runStateC :: s -> m (s, a) }  instance Functor m => Functor (StateC s m) where   fmap f m = StateC $ \ s -> (\ ~(s', a) -> (s', f a)) <$> runState s m@@ -80,13 +79,11 @@ instance Monad m => Applicative (StateC s m) where   pure a = StateC $ \ s -> pure (s, a)   {-# INLINE pure #-}-   StateC mf <*> StateC mx = StateC $ \ s -> do     ~(s',  f) <- mf s     ~(s'', x) <- mx s'     pure (s'', f x)   {-# INLINE (<*>) #-}-   m *> k = m >>= const k   {-# INLINE (*>) #-} @@ -99,7 +96,6 @@ 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 (<|>) #-} @@ -121,9 +117,8 @@   lift m = StateC (\ s -> (,) s <$> m)   {-# INLINE lift #-} -instance Algebra sig m => Algebra (State s :+: sig) (StateC s m) where-  alg hdl sig ctx = StateC $ \ s -> case sig of-    L Get     -> pure (s, s <$ ctx)-    L (Put s) -> pure (s, ctx)-    R other   -> thread (uncurry runState ~<~ hdl) other (s, ctx)+instance (Algebra sig m, Effect sig) => Algebra (State s :+: sig) (StateC s m) where+  alg (L (Get   k)) = StateC (\ s -> runState s (k s))+  alg (L (Put s k)) = StateC (\ _ -> runState s k)+  alg (R other)     = StateC (\ s -> alg (thread (s, ()) (uncurry runState) other))   {-# INLINE alg #-}

@@ -1,7 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -22,14 +21,14 @@ , module Control.Effect.State ) where -import Control.Algebra-import Control.Applicative (Alternative(..))-import Control.Effect.State-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Effect.State+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | Run a 'State' effect starting from the passed value. --@@ -78,20 +77,17 @@ instance Monad m => Applicative (StateC s m) where   pure a = StateC (\ s -> pure (s, a))   {-# INLINE pure #-}-   StateC f <*> StateC a = StateC $ \ s -> do     (s', f') <- f s     (s'', a') <- a s'     pure (s'', f' a')   {-# INLINE (<*>) #-}-   m *> k = m >>= const k   {-# 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 (<|>) #-} @@ -119,9 +115,8 @@   lift m = StateC (\ s -> (,) s <$> m)   {-# INLINE lift #-} -instance Algebra sig m => Algebra (State s :+: sig) (StateC s m) where-  alg hdl sig ctx = StateC $ \ s -> case sig of-    L Get     -> pure (s, s <$ ctx)-    L (Put s) -> pure (s, ctx)-    R other   -> thread (uncurry runState ~<~ hdl) other (s, ctx)+instance (Algebra sig m, Effect sig) => Algebra (State s :+: sig) (StateC s m) where+  alg (L (Get   k)) = StateC (\ s -> runState s (k s))+  alg (L (Put s k)) = StateC (\ _ -> runState s k)+  alg (R other)     = StateC (\ s -> alg (thread (s, ()) (uncurry runState) other))   {-# INLINE alg #-}

@@ -10,32 +10,29 @@ module Control.Carrier.Throw.Either ( -- * Throw carrier   runThrow-, ThrowC(ThrowC)+, ThrowC(..)   -- * Throw effect , module Control.Effect.Throw ) where -import Control.Algebra-import Control.Applicative (Alternative)-import Control.Carrier.Error.Either-import Control.Effect.Throw-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative)+import           Control.Carrier.Error.Either+import           Control.Effect.Throw+import           Control.Monad (MonadPlus)+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | Run a 'Throw' effect, returning failures in 'Left' and successful computations’ results in 'Right'. runThrow :: ThrowC e m a -> m (Either e a) runThrow (ThrowC m) = runError m-{-# INLINE runThrow #-}  -- | @since 1.0.0.0-newtype ThrowC e m a = ThrowC { runThrowC :: ErrorC e m a }+newtype ThrowC e m a = ThrowC (ErrorC e m a)   deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans) -instance Algebra sig m => Algebra (Throw e :+: sig) (ThrowC e m) where-  alg hdl sig ctx = case sig of-    L (Throw e) -> ThrowC (throwError e)-    R other     -> ThrowC (alg (runThrowC . hdl) (R other) ctx)-  {-# INLINE alg #-}+instance (Algebra sig m, Effect sig) => Algebra (Throw e :+: sig) (ThrowC e m) where+  alg (L (Throw e)) = ThrowC (throwError e)+  alg (R other)     = ThrowC (alg (R (handleCoercible other)))

@@ -1,7 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -17,14 +15,14 @@ , module Control.Effect.Trace ) where -import Control.Algebra-import Control.Applicative (Alternative)-import Control.Effect.Trace-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Effect.Trace+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | Run a 'Trace' effect, ignoring all traces. --@@ -38,7 +36,6 @@ -- @since 1.0.0.0 runTrace :: TraceC m a -> m a runTrace (TraceC m) = m-{-# INLINE runTrace #-}  -- | @since 1.0.0.0 newtype TraceC m a = TraceC (m a)@@ -49,7 +46,6 @@   {-# INLINE lift #-}  instance Algebra sig m => Algebra (Trace :+: sig) (TraceC m) where-  alg hdl = \case-    L (Trace _) -> pure-    R other     -> TraceC . alg (runTrace . hdl) other+  alg (L trace) = traceCont trace+  alg (R other) = TraceC (alg (handleCoercible other))   {-# INLINE alg #-}

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-}@@ -16,15 +15,15 @@ , module Control.Effect.Trace ) where -import Control.Algebra-import Control.Applicative (Alternative)-import Control.Effect.Trace-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import System.IO+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Effect.Trace+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           System.IO  -- | Run a 'Trace' effect, printing traces to 'stderr'. --@@ -38,7 +37,6 @@ -- @since 1.0.0.0 runTrace :: TraceC m a -> m a runTrace (TraceC m) = m-{-# INLINE runTrace #-}  -- | @since 1.0.0.0 newtype TraceC m a = TraceC (m a)@@ -49,7 +47,6 @@   {-# INLINE lift #-}  instance (MonadIO m, Algebra sig m) => Algebra (Trace :+: sig) (TraceC m) where-  alg hdl sig ctx = case sig of-    L (Trace s) -> ctx <$ liftIO (hPutStrLn stderr s)-    R other     -> TraceC (alg (runTrace . hdl) other ctx)+  alg (L (Trace s k)) = liftIO (hPutStrLn stderr s) *> k+  alg (R other)       = TraceC (alg (handleCoercible other))   {-# INLINE alg #-}

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-}@@ -11,22 +10,22 @@ module Control.Carrier.Trace.Returning ( -- * Trace carrier   runTrace-, TraceC(TraceC)+, TraceC(..)   -- * Trace effect , module Control.Effect.Trace ) where -import Control.Algebra-import Control.Applicative (Alternative)-import Control.Carrier.Writer.Strict-import Control.Effect.Trace-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Data.Bifunctor (first)-import Data.Monoid (Endo(..))+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Carrier.Writer.Strict+import           Control.Effect.Trace+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Data.Bifunctor (first)+import           Data.Monoid (Endo(..))  -- | Run a 'Trace' effect, returning all traces as a list. --@@ -40,14 +39,11 @@ -- @since 1.0.0.0 runTrace :: Functor m => TraceC m a -> m ([String], a) runTrace (TraceC m) = first (($[]) . appEndo) <$> runWriter m-{-# INLINE runTrace #-}  -- | @since 1.0.0.0-newtype TraceC m a = TraceC { runTraceC :: WriterC (Endo [String]) m a }+newtype TraceC m a = TraceC (WriterC (Endo [String]) m a)   deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans) -instance Algebra sig m => Algebra (Trace :+: sig) (TraceC m) where-  alg hdl sig ctx = case sig of-    L (Trace m) -> ctx <$ TraceC (tell (Endo (m :)))-    R other     -> TraceC (alg (runTraceC . hdl) (R other) ctx)-  {-# INLINE alg #-}+instance (Algebra sig m, Effect sig) => Algebra (Trace :+: sig) (TraceC m) where+  alg (L (Trace m k)) = TraceC (tell (Endo (m :))) *> k+  alg (R other)       = TraceC (alg (R (handleCoercible other)))

@@ -1,82 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{- | A high-performance, strict, church-encoded carrier for 'Writer'.--This carrier issues left-associated 'mappend's, meaning that 'Monoid's such as @[]@ with poor performance for left-associated 'mappend's are ill-suited for use with this carrier. Alternatives such as 'Data.Monoid.Endo', @Seq@, or @DList@ may be preferred.--@since 1.1.0.0--}-module Control.Carrier.Writer.Church-( -- * Writer carrier-  runWriter-, execWriter-, WriterC(WriterC)-  -- * Writer effect-, module Control.Effect.Writer-) where--import Control.Algebra-import Control.Applicative (Alternative)-import Control.Carrier.State.Church-import Control.Effect.Writer-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class---- | Run a 'Writer' effect with a 'Monoid'al log, applying a continuation to the final log and result.------ @--- 'runWriter' k ('pure' a) = k 'mempty' a--- @--- @--- 'runWriter' k ('tell' w) = k w ()--- @--- @--- 'runWriter' k ('listen' ('tell' w)) = k w (w, ())--- @--- @--- 'runWriter' k ('censor' f ('tell' w)) = k (f w) ()--- @------ @since 1.1.0.0-runWriter :: Monoid w => (w -> a -> m b) -> WriterC w m a -> m b-runWriter k = runState k mempty . runWriterC-{-# INLINE runWriter #-}---- | Run a 'Writer' effect with a 'Monoid'al log, producing the final log and discarding the result value.------ @--- 'execWriter' = 'runWriter' ('const' '.' 'pure')--- @------ @since 1.1.0.0-execWriter :: (Monoid w, Applicative m) => WriterC w m a -> m w-execWriter = runWriter (const . pure)-{-# INLINE execWriter #-}---- | @since 1.1.0.0-newtype WriterC w m a = WriterC { runWriterC :: StateC w m a }-  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans)--instance (Algebra sig m, Monoid w) => Algebra (Writer w :+: sig) (WriterC w m) where-  alg hdl sig ctx = WriterC $ case sig of-    L writer -> StateC $ \ k w -> case writer of-      Tell w'    -> do-        let !w'' = mappend w w'-        k w'' ctx-      Listen   m -> runWriter (\ w' a -> do-        let !w'' = mappend w w'-        k w'' ((,) w' <$> a)) (hdl (m <$ ctx))-      Censor f m -> runWriter (\ w' a -> do-        let !w'' = mappend w (f w')-        k w'' a) (hdl (m <$ ctx))-    R other  -> alg (runWriterC . hdl) (R other) ctx-  {-# INLINE alg #-}

@@ -1,6 +1,4 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-}@@ -17,20 +15,20 @@ ( -- * Writer carrier   runWriter , execWriter-, WriterC(WriterC)+, WriterC(..)   -- * Writer effect , module Control.Effect.Writer ) where -import Control.Algebra-import Control.Applicative (Alternative)-import Control.Carrier.State.Strict-import Control.Effect.Writer-import Control.Monad (MonadPlus)-import Control.Monad.Fail as Fail-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import           Control.Algebra+import           Control.Applicative (Alternative(..))+import           Control.Carrier.State.Strict+import           Control.Effect.Writer+import           Control.Monad (MonadPlus(..))+import qualified Control.Monad.Fail as Fail+import           Control.Monad.Fix+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class  -- | Run a 'Writer' effect with a 'Monoid'al log, producing the final log alongside the result value. --@@ -57,22 +55,20 @@ -- | A space-efficient carrier for 'Writer' effects, implemented atop "Control.Carrier.State.Strict". -- -- @since 1.0.0.0-newtype WriterC w m a = WriterC { runWriterC :: StateC w m a }+newtype WriterC w m a = WriterC (StateC w m a)   deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans) -instance (Monoid w, Algebra sig m) => Algebra (Writer w :+: sig) (WriterC w m) where-  alg hdl sig ctx = WriterC $ case sig of-    L writer -> StateC $ \ w -> case writer of-      Tell w'    -> do-        let !w'' = mappend w w'-        pure (w'', ctx)-      Listen   m -> do-        (w', a) <- runWriter (hdl (m <$ ctx))-        let !w'' = mappend w w'-        pure (w'', (,) w' <$> a)-      Censor f m -> do-        (w', a) <- runWriter (hdl (m <$ ctx))-        let !w'' = mappend w (f w')-        pure (w'', a)-    R other  -> alg (runWriterC . hdl) (R other) ctx+instance (Monoid w, Algebra sig m, Effect sig) => Algebra (Writer w :+: sig) (WriterC w m) where+  alg (L (Tell w     k)) = WriterC (modify (`mappend` w)) >> k+  alg (L (Listen   m k)) = WriterC (StateC (\ w -> do+    (w', a) <- runWriter m+    let w'' = mappend w w'+    w'' `seq` pure (w'', (w', a))))+    >>= uncurry k+  alg (L (Censor f m k)) = WriterC (StateC (\ w -> do+    (w', a) <- runWriter m+    let w'' = mappend w (f w')+    w'' `seq` pure (w'', a)))+    >>= k+  alg (R other)          = WriterC (alg (R (handleCoercible other)))   {-# INLINE alg #-}

@@ -12,6 +12,7 @@ , catchError   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -29,5 +30,4 @@ -- -- @since 0.1.0.0 catchError :: Has (Catch e) sig m => m a -> (e -> m a) -> m a-catchError m h = send (Catch m h)-{-# INLINE catchError #-}+catchError m h = send (Catch m h pure)

@@ -1,10 +1,22 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-} module Control.Effect.Catch.Internal ( Catch(..) ) where +import Control.Effect.Class+ -- | 'Catch' effects can be used alongside 'Control.Effect.Throw.Throw' to provide recoverable exceptions. -- -- @since 1.0.0.0-data Catch e m k where-  Catch :: m a -> (e -> m a) -> Catch e m a+data Catch e m k+  = forall b . Catch (m b) (e -> m b) (b -> m k)++deriving instance Functor m => Functor (Catch e m)++instance HFunctor (Catch e) where+  hmap f (Catch m h k) = Catch (f m) (f . h) (f . k)++instance Effect (Catch e) where+  thread ctx handler (Catch m h k) = Catch (handler (m <$ ctx)) (handler . (<$ ctx) . h) (handler . fmap k)

@@ -24,6 +24,7 @@ , Choosing(..)   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -52,8 +53,7 @@ -- -- @since 1.0.0.0 (<|>) :: Has Choose sig m => m a -> m a -> m a-a <|> b = send Choose >>= bool b a-{-# INLINE (<|>) #-}+(<|>) a b = send (Choose (bool b a))  infixl 3 <|> @@ -69,7 +69,6 @@ -- @since 1.0.0.0 optional :: Has Choose sig m => m a -> m (Maybe a) optional a = Just <$> a <|> pure Nothing-{-# INLINE optional #-}  -- | Zero or more. --@@ -80,7 +79,6 @@ -- @since 1.0.0.0 many :: Has Choose sig m => m a -> m [a] many a = go where go = (:) <$> a <*> go <|> pure []-{-# INLINE many #-}  -- | One or more. --@@ -91,7 +89,6 @@ -- @since 1.0.0.0 some :: Has Choose sig m => m a -> m [a] some a = (:) <$> a <*> many a-{-# INLINE some #-}  -- | One or more, returning a 'NonEmpty' list of the results. --@@ -102,7 +99,6 @@ -- @since 1.0.0.0 some1 :: Has Choose sig m => m a -> m (NonEmpty a) some1 a = (:|) <$> a <*> many a-{-# INLINE some1 #-}   -- | @since 1.0.0.0@@ -110,11 +106,7 @@  instance Has Choose sig m => S.Semigroup (Choosing m a) where   Choosing m1 <> Choosing m2 = Choosing (m1 <|> m2)-  {-# INLINE (<>) #-}  instance (Has Choose sig m, Has Empty sig m) => Monoid (Choosing m a) where   mempty = Choosing empty-  {-# INLINE mempty #-}-   mappend = (S.<>)-  {-# INLINE mappend #-}

@@ -1,11 +1,16 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} module Control.Effect.Choose.Internal ( Choose(..) ) where -import Data.Kind (Type)+import Control.Effect.Class+import GHC.Generics (Generic1)  -- | @since 1.0.0.0-data Choose (m :: Type -> Type) k where-  Choose :: Choose m Bool+newtype Choose m k+  = Choose (Bool -> m k)+  deriving (Functor, Generic1)++instance HFunctor Choose+instance Effect   Choose

@@ -0,0 +1,182 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++-- | Provides the 'HFunctor' and 'Effect' classes that effect types implement.+--+-- @since 1.0.0.0+module Control.Effect.Class+( HFunctor(..)+, handleCoercible+, Effect(..)+-- * Generic deriving of 'HFunctor' & 'Effect' instances.+, GHFunctor(..)+, GEffect(..)+) where++import Data.Coerce+import GHC.Generics++-- | Higher-order functors of kind @(* -> *) -> (* -> *)@ map functors to functors.+--+--   All effects must be 'HFunctor's.+--+-- @since 1.0.0.0+class HFunctor h where+  -- | Higher-order functor map of a natural transformation over higher-order positions within the effect.+  --+  -- A definition for 'hmap' over first-order effects can be derived automatically provided a 'Generic1' instance is available.+  hmap :: Functor m => (forall x . m x -> n x) -> (h m a -> h n a)+  default hmap :: (Functor m, Generic1 (h m), Generic1 (h n), GHFunctor m n (Rep1 (h m)) (Rep1 (h n))) => (forall x . m x -> n x) -> (h m a -> h n a)+  hmap f = to1 . ghmap f . from1+  {-# INLINE hmap #-}+++-- | Thread a 'Coercible' carrier through an 'HFunctor'.+--+--   This is applicable whenever @f@ is 'Coercible' to @g@, e.g. simple @newtype@s.+--+-- @since 1.0.0.0+handleCoercible :: (HFunctor sig, Functor f, Coercible f g) => sig f a -> sig g a+handleCoercible = hmap coerce+{-# INLINE handleCoercible #-}+++-- | 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 context.+--+-- All first-order effects (those without existential occurrences of @m@) admit a default definition of 'thread' provided a 'Generic1' instance is available for the effect.+--+-- @since 1.0.0.0+class HFunctor sig => Effect sig where+  -- | Handle any effects in a signature by threading the algebra’s handler all the way through to the continuation, starting from some initial context.+  --+  -- The handler is expressed as a /distributive law/, and required to adhere to the following laws:+  --+  -- @+  -- handler . 'fmap' 'pure' = 'pure'+  -- @+  -- @+  -- handler . 'fmap' (k '=<<') = handler . 'fmap' k 'Control.Monad.<=<' handler+  -- @+  --+  -- respectively expressing that the handler does not alter the context of pure computations, and that the handler distributes over monadic composition.+  thread+    :: (Functor ctx, Monad m)+    => ctx ()                              -- ^ The initial context.+    -> (forall x . ctx (m x) -> n (ctx x)) -- ^ A handler for actions in a context, producing actions with a derived context.+    -> sig m a                             -- ^ The effect to thread the handler through.+    -> sig n (ctx a)+  default thread+    :: (Functor ctx, Monad m, Generic1 (sig m), Generic1 (sig n), GEffect m n (Rep1 (sig m)) (Rep1 (sig n)))+    => ctx ()+    -> (forall x . ctx (m x) -> n (ctx x))+    -> sig m a+    -> sig n (ctx a)+  thread ctx handler = to1 . gthread ctx handler . from1+  {-# INLINE thread #-}+++-- | Generic implementation of 'HFunctor'.+class GHFunctor m m' rep rep' where+  -- | Generic implementation of 'hmap'.+  ghmap :: Functor m => (forall x . m x -> m' x) -> (rep a -> rep' a)++instance GHFunctor m m' rep rep' => GHFunctor m m' (M1 i c rep) (M1 i c rep') where+  ghmap f = M1 . ghmap f . unM1+  {-# INLINE ghmap #-}++instance (GHFunctor m m' l l', GHFunctor m m' r r') => GHFunctor m m' (l :+: r) (l' :+: r') where+  ghmap f (L1 l) = L1 (ghmap f l)+  ghmap f (R1 r) = R1 (ghmap f r)+  {-# INLINE ghmap #-}++instance (GHFunctor m m' l l', GHFunctor m m' r r') => GHFunctor m m' (l :*: r) (l' :*: r') where+  ghmap f (l :*: r) = ghmap f l :*: ghmap f r+  {-# INLINE ghmap #-}++instance GHFunctor m m' V1 V1 where+  ghmap _ v = case v of {}+  {-# INLINE ghmap #-}++instance GHFunctor m m' U1 U1 where+  ghmap _ = id+  {-# INLINE ghmap #-}++instance GHFunctor m m' (K1 R c) (K1 R c) where+  ghmap _ = coerce+  {-# INLINE ghmap #-}++instance GHFunctor m m' Par1 Par1 where+  ghmap _ = coerce+  {-# INLINE ghmap #-}++instance (Functor f, GHFunctor m m' g g') => GHFunctor m m' (f :.: g) (f :.: g') where+  ghmap f = Comp1 . fmap (ghmap f) . unComp1+  {-# INLINE ghmap #-}++instance GHFunctor m m' (Rec1 m) (Rec1 m') where+  ghmap f = Rec1 . f . unRec1+  {-# INLINE ghmap #-}++instance HFunctor f => GHFunctor m m' (Rec1 (f m)) (Rec1 (f m')) where+  ghmap f = Rec1 . hmap f . unRec1+  {-# INLINE ghmap #-}+++-- | Generic implementation of 'Effect'.+class GEffect m m' rep rep' where+  -- | Generic implementation of 'thread'.+  gthread+    :: (Functor ctx, Monad m)+    => ctx ()+    -> (forall x . ctx (m x) -> m' (ctx x))+    -> rep a+    -> rep' (ctx a)++instance GEffect m m' rep rep' => GEffect m m' (M1 i c rep) (M1 i c rep') where+  gthread ctx handler = M1 . gthread ctx handler . unM1+  {-# INLINE gthread #-}++instance (GEffect m m' l l', GEffect m m' r r') => GEffect m m' (l :+: r) (l' :+: r') where+  gthread ctx handler (L1 l) = L1 (gthread ctx handler l)+  gthread ctx handler (R1 r) = R1 (gthread ctx handler r)+  {-# INLINE gthread #-}++instance (GEffect m m' l l', GEffect m m' r r') => GEffect m m' (l :*: r) (l' :*: r') where+  gthread ctx handler (l :*: r) = gthread ctx handler l :*: gthread ctx handler r+  {-# INLINE gthread #-}++instance GEffect m m' V1 V1 where+  gthread _ _ v = case v of {}+  {-# INLINE gthread #-}++instance GEffect m m' U1 U1 where+  gthread _ _ = coerce+  {-# INLINE gthread #-}++instance GEffect m m' (K1 R c) (K1 R c) where+  gthread _ _ = coerce+  {-# INLINE gthread #-}++instance GEffect m m' Par1 Par1 where+  gthread ctx _ = Par1 . (<$ ctx) . unPar1+  {-# INLINE gthread #-}++instance (Functor f, GEffect m m' g g') => GEffect m m' (f :.: g) (f :.: g') where+  gthread ctx handler = Comp1 . fmap (gthread ctx handler) . unComp1+  {-# INLINE gthread #-}++instance GEffect m m' (Rec1 m) (Rec1 m') where+  gthread ctx handler = Rec1 . handler . (<$ ctx) . unRec1+  {-# INLINE gthread #-}++instance Effect sig => GEffect m m' (Rec1 (sig m)) (Rec1 (sig m')) where+  gthread ctx handler = Rec1 . thread ctx handler . unRec1+  {-# INLINE gthread #-}

@@ -1,4 +1,6 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-} {- | Provides an effect to cull choices in a given nondeterministic context. This effect is used in concert with 'Control.Effect.NonDet.NonDet'.  Computations run inside a call to 'cull' will return at most one result.@@ -15,6 +17,7 @@ , cull   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -24,10 +27,19 @@ -- | 'Cull' effects are used with 'Control.Effect.Choose' to provide control over branching. -- -- @since 0.1.2.0-data Cull m k where-  Cull :: m a -> Cull m a+data Cull m k+  = forall a . Cull (m a) (a -> m k) +deriving instance Functor m => Functor (Cull m) +instance HFunctor Cull where+  hmap f (Cull m k) = Cull (f m) (f . k)+  {-# INLINE hmap #-}++instance Effect Cull where+  thread ctx handler (Cull m k) = Cull (handler (m <$ ctx)) (handler . fmap k)+  {-# INLINE thread #-}+ -- | Cull nondeterminism in the argument, returning at most one result. -- -- @@@ -36,5 +48,4 @@ -- -- @since 0.1.2.0 cull :: Has Cull sig m => m a -> m a-cull m = send (Cull m)-{-# INLINE cull #-}+cull m = send (Cull m pure)

@@ -1,4 +1,7 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}  {- | Provides an effect to delimit backtracking in a given nondeterministic context. This effect is used in concert with 'Control.Effect.NonDet.NonDet'. @@ -19,6 +22,7 @@ , cut   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -29,11 +33,22 @@ -- | 'Cut' effects are used with 'Control.Effect.Choose' to provide control over backtracking. -- -- @since 0.1.2.0-data Cut m k where-  Cutfail ::        Cut m a-  Call    :: m a -> Cut m a+data Cut m k+  = Cutfail+  | forall a . Call (m a) (a -> m k) +deriving instance Functor m => Functor (Cut m) +instance HFunctor Cut where+  hmap _ Cutfail    = Cutfail+  hmap f (Call m k) = Call (f m) (f . k)+  {-# INLINE hmap #-}++instance Effect Cut where+  thread _   _       Cutfail    = Cutfail+  thread ctx handler (Call m k) = Call (handler (m <$ ctx)) (handler . fmap k)+  {-# INLINE thread #-}+ -- | Fail the current branch, and prevent backtracking within the nearest enclosing 'call' (if any). -- --   Contrast with 'empty', which fails the current branch but allows backtracking.@@ -58,7 +73,7 @@ -- -- @since 0.1.2.0 call :: Has Cut sig m => m a -> m a-call m = send (Call m)+call m = send (Call m pure) {-# INLINE call #-}  -- | Commit to the current branch, preventing backtracking within the nearest enclosing 'call' (if any) on failure.

@@ -4,9 +4,7 @@  Predefined carriers: -* @"Control.Carrier.Empty.Church".'Control.Carrier.Empty.Church.EmptyC'@-* @"Control.Carrier.Empty.Maybe".'Control.Carrier.Empty.Maybe.EmptyC'@-* @"Control.Monad.Trans.Maybe".'Control.Monad.Trans.Maybe.MaybeT'@+* "Control.Carrier.Empty.Maybe". * If 'Empty' is the last effect in a stack, it can be interpreted directly to a 'Maybe'.  @since 1.0.0.0@@ -19,6 +17,7 @@ , guard   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -37,7 +36,6 @@ -- @since 1.0.0.0 empty :: Has Empty sig m => m a empty = send Empty-{-# INLINE empty #-}  -- | Conditional failure, returning only if the condition is 'True'. --@@ -45,4 +43,3 @@ guard :: Has Empty sig m => Bool -> m () guard True  = pure () guard False = empty-{-# INLINE guard #-}

@@ -1,11 +1,16 @@-{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE KindSignatures #-} module Control.Effect.Empty.Internal ( Empty(..) ) where -import Data.Kind (Type)+import Control.Effect.Class+import GHC.Generics (Generic1)  -- | @since 1.0.0.0-data Empty (m :: Type -> Type) k where-  Empty :: Empty m a+data Empty (m :: * -> *) k = Empty+  deriving (Functor, Generic1)++instance HFunctor Empty+instance Effect   Empty

@@ -4,7 +4,6 @@  Predefined carriers: -* "Control.Carrier.Error.Church". * "Control.Carrier.Error.Either". * "Control.Monad.Trans.Except". * If 'Error' @e@ is the last effect in a stack, it can be interpreted directly to an 'Either' @e@.

@@ -3,7 +3,7 @@  {- | An effect providing failure with an error message. -This effect is invoked through the 'Fail.fail' method from 'Fail.MonadFail'.+This effect is invoked through the 'Control.Monad.Fail.fail' method from 'Control.Monad.Fail.MonadFail'.  Predefined carriers: @@ -19,12 +19,13 @@ , Fail.MonadFail(..)   -- * Re-exports , Algebra+, Effect , Has , run ) where -import Control.Effect.Throw-import Control.Monad.Fail as Fail+import           Control.Effect.Throw+import qualified Control.Monad.Fail as Fail  -- | @since 0.1.0.0 type Fail = Throw String

@@ -1,11 +1,12 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+ {- | This effect provides source to an infinite source of 'Int' values, suitable for generating "fresh" values to uniquely identify data without needing to invoke random numbers or impure IO.  Predefined carriers: -* "Control.Carrier.Fresh.Church"-* "Control.Carrier.Fresh.Strict"+* "Control.Carrier.Fresh.Strict".+ -} module Control.Effect.Fresh ( -- * Fresh effect@@ -13,18 +14,22 @@ , fresh   -- * Re-exports , Algebra+, Effect , Has , run ) where  import Control.Algebra-import Data.Kind (Type)+import GHC.Generics (Generic1)  -- | @since 0.1.0.0-data Fresh (m :: Type -> Type) k where-  Fresh :: Fresh m Int+newtype Fresh m k = Fresh (Int -> m k)+  deriving (Functor, Generic1) +instance HFunctor Fresh+instance Effect   Fresh + -- | Produce a fresh (i.e. unique) 'Int'. -- -- @@@ -33,5 +38,4 @@ -- -- @since 0.1.0.0 fresh :: Has Fresh sig m => m Int-fresh = send Fresh-{-# INLINE fresh #-}+fresh = send (Fresh pure)

@@ -39,24 +39,22 @@ import Control.Monad.Fail as Fail import Control.Monad.IO.Class import Control.Monad.Trans.Class-import Data.Functor.Identity import Data.Kind (Type)  -- | An effect transformer turning effects into labelled effects, and a carrier transformer turning carriers into labelled carriers for the same (labelled) effects. -- -- @since 1.0.2.0 newtype Labelled (label :: k) (sub :: (Type -> Type) -> (Type -> Type)) m a = Labelled (sub m a)-  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadIO, MonadPlus, MonadTrans)+  deriving (Alternative, Applicative, Effect, Functor, HFunctor, Monad, Fail.MonadFail, MonadIO, MonadPlus, MonadTrans)  -- | @since 1.0.2.0 runLabelled :: forall label sub m a . Labelled label sub m a -> sub m a runLabelled (Labelled l) = l-{-# INLINE runLabelled #-} -instance Algebra (eff :+: sig) (sub m) => Algebra (Labelled label eff :+: sig) (Labelled label sub m) where-  alg hdl = \case-    L eff -> Labelled . alg (runLabelled . hdl) (L (runLabelled eff))-    R sig -> Labelled . alg (runLabelled . hdl) (R sig)+instance (Algebra (eff :+: sig) (sub m), HFunctor eff, HFunctor sig) => Algebra (Labelled label eff :+: sig) (Labelled label sub m) where+  alg = \case+    L eff -> Labelled (send (handleCoercible (runLabelled eff)))+    R sig -> Labelled (send (handleCoercible sig))   {-# INLINE alg #-}  @@ -106,7 +104,7 @@ -- -- @since 1.0.2.0 sendLabelled :: forall label eff sig m a . HasLabelled label eff sig m => eff m a -> m a-sendLabelled op = runIdentity <$> alg (fmap Identity . runIdentity) (injLabelled @label (Labelled op)) (Identity ())+sendLabelled = alg . injLabelled @label . Labelled {-# INLINABLE sendLabelled #-}  @@ -119,14 +117,13 @@ -- | @since 1.0.2.0 runUnderLabel :: forall label sub m a . UnderLabel label sub m a -> m a runUnderLabel (UnderLabel l) = l-{-# INLINE runUnderLabel #-}  instance MonadTrans (UnderLabel sub label) where   lift = UnderLabel   {-# INLINE lift #-} -instance (LabelledMember label sub sig, Algebra sig m) => Algebra (sub :+: sig) (UnderLabel label sub m) where-  alg hdl = \case-    L sub -> UnderLabel . alg (runUnderLabel . hdl) (injLabelled @label (Labelled sub))-    R sig -> UnderLabel . alg (runUnderLabel . hdl) sig+instance (LabelledMember label sub sig, HFunctor sub, Algebra sig m) => Algebra (sub :+: sig) (UnderLabel label sub m) where+  alg = \case+    L sub -> UnderLabel (sendLabelled @label (handleCoercible sub))+    R sig -> UnderLabel (send (handleCoercible sig))   {-# INLINE alg #-}

@@ -21,6 +21,7 @@ , liftWith   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -34,8 +35,7 @@ -- -- @since 1.0.0.0 sendM :: (Has (Lift n) sig m, Functor n) => n a -> m a-sendM m = liftWith (\ _ ctx -> (<$ ctx) <$> m)-{-# INLINE sendM #-}+sendM m = send (LiftWith (\ ctx _ -> (<$ ctx) <$> m) pure)  -- | A type-restricted variant of 'sendM' for 'IO' actions. --@@ -44,7 +44,6 @@ -- @since 1.0.2.0 sendIO :: Has (Lift IO) sig m => IO a -> m a sendIO = sendM-{-# INLINE sendIO #-}   -- | Run actions in an outer context.@@ -52,17 +51,16 @@ -- This can be used to provide interoperation with @base@ functionality like @"Control.Exception".'Control.Exception.catch'@: -- -- @--- 'liftWith' $ \\ hdl ctx -> 'Control.Exception.catch' (hdl (m <$ ctx)) (hdl . (<$ ctx) . h)+-- 'liftWith' $ \\ ctx hdl -> 'Control.Exception.catch' (hdl (m <$ ctx)) (hdl . (<$ ctx) . h) -- @ ----- The higher-order function takes both an initial context, and a handler phrased as a distributive law (as described in the documentation for 'Handler'). This handler takes actions lifted into a context functor, which can be either the initial context, or the derived context produced by handling a previous action.+-- The higher-order function takes both an initial context, and a handler phrased as the same sort of distributive law as described in the documentation for 'thread'. This handler takes actions lifted into a context functor, which can be either the initial context, or the derived context produced by handling a previous action. -- -- As with @MonadBaseControl@, care must be taken when lifting functions like @"Control.Exception".'Control.Exception.finally'@ which don’t use the return value of one of their actions, as this can lead to dropped effects. -- -- @since 1.0.0.0 liftWith   :: Has (Lift n) sig m-  => (forall ctx . Functor ctx => Handler ctx m n -> ctx () -> n (ctx a))+  => (forall ctx . Functor ctx => ctx () -> (forall a . ctx (m a) -> n (ctx a)) -> n (ctx a))   -> m a-liftWith with = send (LiftWith with)-{-# INLINE liftWith #-}+liftWith with = send (LiftWith with pure)

@@ -1,11 +1,25 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} module Control.Effect.Lift.Internal ( Lift(..) ) where -import Control.Algebra.Handler (Handler)+import Control.Effect.Class+import Data.Functor.Compose  -- | @since 1.0.0.0-data Lift sig m k where-  LiftWith :: (forall ctx . Functor ctx => Handler ctx m sig -> ctx () -> sig (ctx a)) -> Lift sig m a+data Lift sig m k+  = forall a . LiftWith+    (forall ctx . Functor ctx => ctx () -> (forall a . ctx (m a) -> sig (ctx a)) -> sig (ctx a))+    (a -> m k)++instance Functor m => Functor (Lift sig m) where+  fmap f (LiftWith with k) = LiftWith with (fmap f . k)++instance HFunctor (Lift sig) where+  hmap f (LiftWith go k) = LiftWith (\c lift -> go c (lift . fmap f)) (f . k)++instance Functor sig => Effect (Lift sig) where+  thread ctx dst (LiftWith with k) = LiftWith+    (\ ctx' dst' -> getCompose <$> with (Compose (ctx <$ ctx')) (fmap Compose . dst' . fmap dst . getCompose))+    (dst . fmap k)

@@ -20,6 +20,7 @@   -- * Re-exports , Alternative(..) , Algebra+, Effect , Has , MonadPlus(..) , guard@@ -52,14 +53,12 @@ -- @since 1.0.0.0 oneOf :: (Foldable t, Alternative m) => t a -> m a oneOf = foldMapA pure-{-# INLINE oneOf #-}  -- | Map a 'Foldable' collection of values into a nondeterministic computation using the supplied action. -- -- @since 1.0.0.0 foldMapA :: (Foldable t, Alternative m) => (a -> m b) -> t a -> m b foldMapA f = getAlt #. foldMap (Alt #. f)-{-# INLINE foldMapA #-}   -- | Compose a function operationally equivalent to 'id' on the left.

@@ -21,6 +21,7 @@ , local   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -36,7 +37,7 @@ -- -- @since 0.1.0.0 ask :: Has (Reader r) sig m => m r-ask = send Ask+ask = send (Ask pure) {-# INLINE ask #-}  -- | Project a function out of the current environment value.@@ -47,7 +48,7 @@ -- -- @since 0.1.0.0 asks :: Has (Reader r) sig m => (r -> a) -> m a-asks = (`fmap` ask)+asks f = send (Ask (pure . f)) {-# INLINE asks #-}  -- | Run a computation with an environment value locally modified by the passed function.@@ -58,5 +59,5 @@ -- -- @since 0.1.0.0 local :: Has (Reader r) sig m => (r -> r) -> m a -> m a-local f m = send (Local f m)+local f m = send (Local f m pure) {-# INLINE local #-}

@@ -1,9 +1,23 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-} module Control.Effect.Reader.Internal ( Reader(..) ) where +import Control.Effect.Class+ -- | @since 0.1.0.0-data Reader r m k where-  Ask   ::                    Reader r m r-  Local :: (r -> r) -> m a -> Reader r m a+data Reader r m k+  = Ask (r -> m k)+  | forall b . Local (r -> r) (m b) (b -> m k)++deriving instance Functor m => Functor (Reader r m)++instance HFunctor (Reader r) where+  hmap f (Ask k)       = Ask           (f . k)+  hmap f (Local g m k) = Local g (f m) (f . k)++instance Effect (Reader r) where+  thread ctx handler (Ask k)       = Ask                          (handler . (<$ ctx) . k)+  thread ctx handler (Local f m k) = Local f (handler (m <$ ctx)) (handler . fmap k)

@@ -1,7 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} -- | Labelled 'Reader' operations. --@@ -14,8 +14,8 @@ , local   -- * Re-exports , Algebra+, Effect , Has-, HasLabelled , run ) where 

@@ -4,10 +4,8 @@  Predefined carriers: -* "Control.Carrier.State.Church"-* "Control.Carrier.State.Strict", which is strict in its updates; a good default choice.+* "Control.Carrier.State.Strict", which is strict in its updates. * "Control.Carrier.State.Lazy", which is lazy in its updates. This enables more programs to terminate, such as cyclic computations expressed with @MonadFix@ or @-XRecursiveDo@, at the cost of efficiency.-* "Control.Monad.Trans.RWS.CPS" * "Control.Monad.Trans.RWS.Lazy" * "Control.Monad.Trans.RWS.Strict" * "Control.Monad.Trans.State.Lazy"@@ -27,6 +25,7 @@ , state   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -42,7 +41,7 @@ -- -- @since 0.1.0.0 get :: Has (State s) sig m => m s-get = send Get+get = send (Get pure) {-# INLINEABLE get #-}  -- | Project a function out of the current state value.@@ -53,7 +52,7 @@ -- -- @since 0.1.0.0 gets :: Has (State s) sig m => (s -> a) -> m a-gets = (`fmap` get)+gets f = send (Get (pure . f)) {-# INLINEABLE gets #-}  -- | Replace the state value with a new value.@@ -64,7 +63,7 @@ -- -- @since 0.1.0.0 put :: Has (State s) sig m => s -> m ()-put s = send (Put s)+put s = send (Put s (pure ())) {-# INLINEABLE put #-}  -- | Replace the state value with the result of applying a function to the current state value.

@@ -1,12 +1,17 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} module Control.Effect.State.Internal ( State(..) ) where -import Data.Kind (Type)+import Control.Effect.Class+import GHC.Generics (Generic1)  -- | @since 0.1.0.0-data State s (m :: Type -> Type) k where-  Get ::      State s m s-  Put :: s -> State s m ()+data State s m k+  = Get (s -> m k)+  | Put s (m k)+  deriving (Functor, Generic1)++instance HFunctor (State s)+instance Effect   (State s)

@@ -17,8 +17,8 @@ , state   -- * Re-exports , Algebra+, Effect , Has-, HasLabelled , run ) where 

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}@@ -18,17 +19,22 @@ , reassociateSumL ) where -import Data.Kind (Constraint, Type)+import Control.Effect.Class+import Data.Kind (Constraint)+import GHC.Generics (Generic1)  -- | Higher-order sums are used to combine multiple effects into a signature, typically by chaining on the right.-data (f :+: g) (m :: Type -> Type) k+data (f :+: g) (m :: * -> *) k   = L (f m k)   | R (g m k)-  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)+  deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)  infixr 4 :+: +instance (HFunctor f, HFunctor g) => HFunctor (f :+: g)+instance (Effect f, Effect g)     => Effect   (f :+: g) + -- | The class of types present in a signature. -- --   This is based on Wouter Swierstra’s design described in [Data types à la carte](http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf). As described therein, overlapping instances are required in order to distinguish e.g. left-occurrence from right-recursion.@@ -36,7 +42,7 @@ --   It should not generally be necessary for you to define new 'Member' instances, but these are not specifically prohibited if you wish to get creative. -- -- @since 0.1.0.0-class Member (sub :: (Type -> Type) -> (Type -> Type)) sup where+class Member (sub :: (* -> *) -> (* -> *)) sup where   -- | Inject a member of a signature into the signature.   inj :: sub m a -> sup m a 

@@ -13,6 +13,7 @@ , throwError   -- * Re-exports , Algebra+, Effect , Has , run ) where@@ -25,4 +26,3 @@ -- @since 0.1.0.0 throwError :: Has (Throw e) sig m => e -> m a throwError = send . Throw-{-# INLINE throwError #-}

@@ -1,11 +1,16 @@-{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE KindSignatures #-} module Control.Effect.Throw.Internal ( Throw(..) ) where -import Data.Kind (Type)+import Control.Effect.Class+import GHC.Generics (Generic1)  -- | @since 1.0.0.0-newtype Throw e (m :: Type -> Type) k where-  Throw :: e -> Throw e m a+newtype Throw e (m :: * -> *) k = Throw e+  deriving (Functor, Generic1)++instance HFunctor (Throw e)+instance Effect   (Throw e)

@@ -1,5 +1,6 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+ {- | An effect that provides a record of 'String' values ("traces") aggregate during the execution of a given computation.  Predefined carriers:@@ -17,20 +18,26 @@ , trace   -- * Re-exports , Algebra+, Effect , Has , run ) where  import Control.Algebra-import Data.Kind (Type)+import GHC.Generics (Generic1)  -- | @since 0.1.0.0-data Trace (m :: Type -> Type) k where-  Trace :: { traceMessage :: String } -> Trace m ()+data Trace m k = Trace+  { traceMessage :: String+  , traceCont    :: m k+  }+  deriving (Functor, Generic1) +instance HFunctor Trace+instance Effect   Trace+ -- | Append a message to the trace log. -- -- @since 0.1.0.0 trace :: Has Trace sig m => String -> m ()-trace message = send (Trace message)-{-# INLINE trace #-}+trace message = send (Trace message (pure ()))

@@ -5,12 +5,9 @@  Predefined carriers: -* "Control.Carrier.Writer.Church" * "Control.Carrier.Writer.Strict". (A lazy carrier is not provided due to the inherent space leaks associated with lazy writer monads.)-* "Control.Monad.Trans.RWS.CPS" * "Control.Monad.Trans.RWS.Lazy" * "Control.Monad.Trans.RWS.Strict"-* "Control.Monad.Trans.Writer.CPS" * "Control.Monad.Trans.Writer.Lazy" * "Control.Monad.Trans.Writer.Strict" * If 'Writer' @w@ is the last effect in a stack, it can be interpreted to a tuple @(w, a)@ given some result type @a@ and the presence of a 'Monoid' instance for @w@.@@ -27,13 +24,13 @@ , censor   -- * Re-exports , Algebra+, Effect , Has , run ) where  import Control.Algebra import Control.Effect.Writer.Internal (Writer(..))-import Data.Bifunctor (first)  -- | Write a value to the log. --@@ -43,7 +40,7 @@ -- -- @since 0.1.0.0 tell :: Has (Writer w) sig m => w -> m ()-tell w = send (Tell w)+tell w = send (Tell w (pure ())) {-# INLINE tell #-}  -- | Run a computation, returning the pair of its output and its result.@@ -54,18 +51,18 @@ -- -- @since 0.2.0.0 listen :: Has (Writer w) sig m => m a -> m (w, a)-listen m = send (Listen m)+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. -- -- @--- 'listens' f m = 'fmap' ('first' f) ('listen' m)+-- 'listens' f m = 'fmap' ('Data.Bifunctor.first' f) ('listen' m) -- @ -- -- @since 0.2.0.0 listens :: Has (Writer w) sig m => (w -> b) -> m a -> m (b, a)-listens f = fmap (first f) . listen+listens f m = send (Listen m (curry pure . f)) {-# INLINE listens #-}  -- | Run a computation, modifying its output with the passed function.@@ -76,5 +73,5 @@ -- -- @since 0.2.0.0 censor :: Has (Writer w) sig m => (w -> w) -> m a -> m a-censor f m = send (Censor f m)+censor f m = send (Censor f m pure) {-# INLINE censor #-}

@@ -1,10 +1,28 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-} module Control.Effect.Writer.Internal ( Writer(..) ) where +import Control.Effect.Class+ -- | @since 0.1.0.0-data Writer w m k where-  Tell   :: w               -> Writer w m ()-  Listen :: m a             -> Writer w m (w, a)-  Censor :: (w -> w) -> m a -> Writer w m a+data Writer w m k+  = Tell w (m k)+  | forall a . Listen (m a) (w -> a -> m k)+  | forall a . Censor (w -> w) (m a) (a -> m k)++deriving instance Functor m => Functor (Writer w m)++instance HFunctor (Writer w) where+  hmap f (Tell w     k) = Tell w         (f       k)+  hmap f (Listen   m k) = Listen   (f m) ((f .) . k)+  hmap f (Censor g m k) = Censor g (f m) (f     . k)+  {-# INLINE hmap #-}++instance Effect (Writer w) where+  thread ctx handler (Tell w     k) = Tell w                        (handler (k <$ ctx))+  thread ctx handler (Listen   m k) = Listen   (handler (m <$ ctx)) (fmap handler . fmap . k)+  thread ctx handler (Censor f m k) = Censor f (handler (m <$ ctx)) (handler . fmap k)+  {-# INLINE thread #-}

@@ -10,9 +10,7 @@ , test ) where -import qualified Control.Carrier.Empty.Church as C.Church-import qualified Control.Carrier.Empty.Maybe as C.Maybe-import qualified Control.Monad.Trans.Maybe as T.Maybe+import qualified Control.Carrier.Empty.Maybe as EmptyC import           Control.Effect.Empty import           Data.Maybe (maybeToList) import           Gen@@ -23,17 +21,11 @@  tests :: TestTree tests = testGroup "Empty"-  [ testGroup "EmptyC (Church)" $-    [ testMonad-    , testMonadFix-    , testEmpty-    ] >>= ($ runL (fmap maybeToList . C.Church.runEmpty (pure Nothing) (pure . Just)))-  , testGroup "EmptyC (Maybe)" $+  [ testGroup "EmptyC" $     [ testMonad     , testMonadFix     , testEmpty-    ] >>= ($ runL (fmap maybeToList . C.Maybe.runEmpty))-  , testGroup "MaybeT" $ testEmpty (runL (fmap maybeToList . T.Maybe.runMaybeT))+    ] >>= ($ runL (fmap maybeToList . EmptyC.runEmpty))   , testGroup "Maybe"  $ testEmpty (runL (pure . maybeToList))   ] where   testMonad    run = Monad.test    (m gen0 (\ _ _ -> [])) a b c initial run

@@ -10,10 +10,9 @@ ) where  import qualified Catch-import qualified Control.Carrier.Error.Church as C.Church-import qualified Control.Carrier.Error.Either as C.Either+import qualified Control.Carrier.Error.Either as ErrorC import           Control.Effect.Error-import qualified Control.Monad.Trans.Except as T.Except+import qualified Control.Monad.Trans.Except as ExceptT import           Data.Semigroup as S ((<>)) import           Gen import qualified Monad@@ -23,18 +22,13 @@  tests :: TestTree tests = testGroup "Error"-  [ testGroup "ErrorC (Church)" $-    [ testMonad-    , testMonadFix-    , testError-    ] >>= ($ runL (C.Church.runError (pure . Left) (pure . Right)))-  , testGroup "ErrorC (Either)" $+  [ testGroup "ErrorC"  $     [ testMonad     , testMonadFix     , testError-    ] >>= ($ runL C.Either.runError)+    ] >>= ($ runL ErrorC.runError)   , testGroup "Either"  $ testError (runL pure)-  , testGroup "ExceptT" $ testError (runL T.Except.runExceptT)+  , testGroup "ExceptT" $ testError (runL ExceptT.runExceptT)   ] where   testMonad    run = Monad.test    (m (gen0 e) (genN e)) a b c initial run   testMonadFix run = MonadFix.test (m (gen0 e) (genN e)) a b   initial run

@@ -8,8 +8,7 @@ , test ) where -import qualified Control.Carrier.Fresh.Church as C.Church-import qualified Control.Carrier.Fresh.Strict as C.Strict+import qualified Control.Carrier.Fresh.Strict as FreshC import           Control.Effect.Fresh import           Gen import qualified Hedgehog.Range as R@@ -20,16 +19,11 @@  tests :: TestTree tests = testGroup "Fresh"-  [ testGroup "FreshC (Church)" $-    [ testMonad-    , testMonadFix-    , testFresh-    ] >>= ($ runC (C.Church.runFresh (curry pure)))-  , testGroup "FreshC (Strict)" $+  [ testGroup "FreshC" $     [ testMonad     , testMonadFix     , testFresh-    ] >>= ($ runC C.Strict.runFresh)+    ] >>= ($ runC FreshC.runFresh)   ] where   testMonad    run = Monad.test    (m gen (\ _ _ -> [])) a b c initial run   testMonadFix run = MonadFix.test (m gen (\ _ _ -> [])) a b   initial run

@@ -20,4 +20,4 @@   getMsg (E.AssertionFailed msg) = msg  handle :: (E.Exception e, Has (Lift IO) sig m) => (e -> m a) -> m a -> m a-handle h m = liftWith $ \ run ctx -> E.handle (run . (<$ ctx) . h) (run (m <$ ctx))+handle h m = liftWith $ \ ctx run -> E.handle (run . (<$ ctx) . h) (run (m <$ ctx))

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -11,17 +10,13 @@ , test ) where -import qualified Control.Carrier.State.Church as C.Church-import qualified Control.Carrier.State.Lazy as C.Lazy-import qualified Control.Carrier.State.Strict as C.Strict+import qualified Control.Carrier.State.Lazy as LazyStateC+import qualified Control.Carrier.State.Strict as StrictStateC import           Control.Effect.State-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.RWS.CPS as RWST.CPS-#endif-import qualified Control.Monad.Trans.RWS.Lazy as RWST.Lazy-import qualified Control.Monad.Trans.RWS.Strict as RWST.Strict-import qualified Control.Monad.Trans.State.Lazy as T.Lazy-import qualified Control.Monad.Trans.State.Strict as T.Strict+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWST+import qualified Control.Monad.Trans.RWS.Strict as StrictRWST+import qualified Control.Monad.Trans.State.Lazy as LazyStateT+import qualified Control.Monad.Trans.State.Strict as StrictStateT import           Data.Tuple (swap) import           Gen import qualified Monad@@ -31,28 +26,20 @@  tests :: TestTree tests = testGroup "State"-  [ testGroup "StateC (Church)"   $-    [ testMonad-    , testMonadFix-    , testState-    ] >>= ($ runC (C.Church.runState (curry pure)))-  , testGroup "StateC (Lazy)"   $+  [ testGroup "StateC (Lazy)"   $     [ testMonad     , testMonadFix     , testState-    ] >>= ($ runC C.Lazy.runState)+    ] >>= ($ runC LazyStateC.runState)   , testGroup "StateC (Strict)" $     [ testMonad     , testMonadFix     , testState-    ] >>= ($ runC C.Strict.runState)-  , testGroup "StateT (Lazy)"   $ testState (runC (fmap (fmap swap) . flip T.Lazy.runStateT))-  , testGroup "StateT (Strict)" $ testState (runC (fmap (fmap swap) . flip T.Strict.runStateT))-#if MIN_VERSION_transformers(0,5,6)-  , testGroup "RWST (CPS)"      $ testState (runC (runRWST RWST.CPS.runRWST))-#endif-  , testGroup "RWST (Lazy)"     $ testState (runC (runRWST RWST.Lazy.runRWST))-  , testGroup "RWST (Strict)"   $ testState (runC (runRWST RWST.Strict.runRWST))+    ] >>= ($ runC StrictStateC.runState)+  , testGroup "StateT (Lazy)"   $ testState (runC (fmap (fmap swap) . flip LazyStateT.runStateT))+  , testGroup "StateT (Strict)" $ testState (runC (fmap (fmap swap) . flip StrictStateT.runStateT))+  , testGroup "RWST (Lazy)"     $ testState (runC (runRWST LazyRWST.runRWST))+  , testGroup "RWST (Strict)"   $ testState (runC (runRWST StrictRWST.runRWST))   ] where   testMonad    run = Monad.test    (m (gen0 s) (\ _ _ -> [])) a b c (pair <*> s <*> unit) run   testMonadFix run = MonadFix.test (m (gen0 s) (\ _ _ -> [])) a b   (pair <*> s <*> unit) run

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -13,19 +12,12 @@ ) where  import           Control.Arrow ((&&&))-import qualified Control.Carrier.Writer.Church as C.Writer.Church-import qualified Control.Carrier.Writer.Strict as C.Writer.Strict+import qualified Control.Carrier.Writer.Strict as WriterC import           Control.Effect.Writer-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.RWS.CPS as T.RWS.CPS-#endif-import qualified Control.Monad.Trans.RWS.Lazy as T.RWS.Lazy-import qualified Control.Monad.Trans.RWS.Strict as T.RWS.Strict-#if MIN_VERSION_transformers(0,5,6)-import qualified Control.Monad.Trans.Writer.CPS as T.Writer.CPS-#endif-import qualified Control.Monad.Trans.Writer.Lazy as T.Writer.Lazy-import qualified Control.Monad.Trans.Writer.Strict as T.Writer.Strict+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWST+import qualified Control.Monad.Trans.RWS.Strict as StrictRWST+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriterT+import qualified Control.Monad.Trans.Writer.Strict as StrictWriterT import           Data.Bifunctor (first) import           Data.Tuple (swap) import           Gen@@ -36,27 +28,16 @@  tests :: TestTree tests = testGroup "Writer"-  [ testGroup "WriterC (Church)" $-    [ testMonad-    , testMonadFix-    , testWriter-    ] >>= ($ runL (C.Writer.Church.runWriter (curry pure)))-  , testGroup "WriterC (Strict)" $+  [ testGroup "WriterC" $     [ testMonad     , testMonadFix     , testWriter-    ] >>= ($ runL C.Writer.Strict.runWriter)+    ] >>= ($ runL WriterC.runWriter)   , testGroup "(,)"              $ testWriter (runL pure)-#if MIN_VERSION_transformers(0,5,6)-  , testGroup "WriterT (CPS)"    $ testWriter (runL (fmap swap . T.Writer.CPS.runWriterT))-#endif-  , testGroup "WriterT (Lazy)"   $ testWriter (runL (fmap swap . T.Writer.Lazy.runWriterT))-  , testGroup "WriterT (Strict)" $ testWriter (runL (fmap swap . T.Writer.Strict.runWriterT))-#if MIN_VERSION_transformers(0,5,6)-  , testGroup "RWST (CPS)"       $ testWriter (runL (runRWST T.RWS.CPS.runRWST))-#endif-  , testGroup "RWST (Lazy)"      $ testWriter (runL (runRWST T.RWS.Lazy.runRWST))-  , testGroup "RWST (Strict)"    $ testWriter (runL (runRWST T.RWS.Strict.runRWST))+  , testGroup "WriterT (Lazy)"   $ testWriter (runL (fmap swap . LazyWriterT.runWriterT))+  , testGroup "WriterT (Strict)" $ testWriter (runL (fmap swap . StrictWriterT.runWriterT))+  , testGroup "RWST (Lazy)"      $ testWriter (runL (runRWST LazyRWST.runRWST))+  , testGroup "RWST (Strict)"    $ testWriter (runL (runRWST StrictRWST.runRWST))   ] where   testMonad    run = Monad.test    (m (gen0 w) (genN w b)) a b c initial run   testMonadFix run = MonadFix.test (m (gen0 w) (genN w b)) a b   initial run