fused-effects 1.0.2.2 → 1.1.2.7
raw patch · 101 files changed
Files
- ChangeLog.md +108/−0
- LICENSE +1/−1
- README.lhs +12/−7
- README.md +12/−7
- benchmark/Bench.hs +11/−54
- benchmark/Bench/Error.hs +31/−0
- benchmark/Bench/Interpret.hs +47/−0
- benchmark/Bench/NonDet.hs +2/−2
- benchmark/Bench/NonDet/NQueens.hs +5/−4
- benchmark/Bench/Reader.hs +32/−17
- benchmark/Bench/State.hs +36/−0
- benchmark/Bench/Writer.hs +45/−0
- examples/Inference.hs +12/−8
- examples/Labelled.hs +21/−13
- examples/Main.hs +3/−2
- examples/Parser.hs +43/−38
- examples/ReinterpretLog.hs +52/−126
- examples/Teletype.hs +34/−35
- examples/Utils.hs +20/−0
- fused-effects.cabal +116/−73
- src/Control/Algebra.hs +207/−73
- src/Control/Algebra/Handler.hs +47/−0
- src/Control/Carrier/Accum/Church.hs +133/−0
- src/Control/Carrier/Accum/IORef.hs +99/−0
- src/Control/Carrier/Accum/Strict.hs +138/−0
- src/Control/Carrier/Choose/Church.hs +31/−18
- src/Control/Carrier/Cull/Church.hs +30/−17
- src/Control/Carrier/Cut/Church.hs +35/−17
- src/Control/Carrier/Empty/Church.hs +141/−0
- src/Control/Carrier/Empty/Maybe.hs +45/−14
- src/Control/Carrier/Error/Church.hs +113/−0
- src/Control/Carrier/Error/Either.hs +13/−15
- src/Control/Carrier/Fail/Either.hs +12/−15
- src/Control/Carrier/Fresh/Church.hs +66/−0
- src/Control/Carrier/Fresh/Strict.hs +18/−14
- src/Control/Carrier/Interpret.hs +35/−29
- src/Control/Carrier/Lift.hs +14/−11
- src/Control/Carrier/NonDet/Church.hs +28/−15
- src/Control/Carrier/Reader.hs +26/−11
- src/Control/Carrier/State/Church.hs +129/−0
- src/Control/Carrier/State/IORef.hs +107/−0
- src/Control/Carrier/State/Lazy.hs +18/−13
- src/Control/Carrier/State/Strict.hs +17/−12
- src/Control/Carrier/Throw/Either.hs +17/−14
- src/Control/Carrier/Trace/Ignoring.hs +15/−11
- src/Control/Carrier/Trace/Printing.hs +15/−12
- src/Control/Carrier/Trace/Returning.hs +22/−18
- src/Control/Carrier/Writer/Church.hs +82/−0
- src/Control/Carrier/Writer/Strict.hs +28/−24
- src/Control/Effect/Accum.hs +66/−0
- src/Control/Effect/Accum/Internal.hs +12/−0
- src/Control/Effect/Catch.hs +2/−2
- src/Control/Effect/Catch/Internal.hs +3/−15
- src/Control/Effect/Choose.hs +46/−2
- src/Control/Effect/Choose/Internal.hs +5/−10
- src/Control/Effect/Class.hs +0/−182
- src/Control/Effect/Cull.hs +5/−16
- src/Control/Effect/Cut.hs +5/−20
- src/Control/Effect/Empty.hs +5/−2
- src/Control/Effect/Empty/Internal.hs +4/−9
- src/Control/Effect/Error.hs +1/−0
- src/Control/Effect/Fail.hs +3/−4
- src/Control/Effect/Fresh.hs +9/−13
- src/Control/Effect/Labelled.hs +35/−12
- src/Control/Effect/Lift.hs +8/−6
- src/Control/Effect/Lift/Internal.hs +4/−18
- src/Control/Effect/NonDet.hs +2/−1
- src/Control/Effect/Reader.hs +3/−4
- src/Control/Effect/Reader/Internal.hs +4/−18
- src/Control/Effect/Reader/Labelled.hs +2/−2
- src/Control/Effect/State.hs +7/−5
- src/Control/Effect/State/Internal.hs +6/−11
- src/Control/Effect/State/Labelled.hs +1/−1
- src/Control/Effect/Sum.hs +5/−10
- src/Control/Effect/Throw.hs +12/−1
- src/Control/Effect/Throw/Internal.hs +4/−9
- src/Control/Effect/Trace.hs +7/−14
- src/Control/Effect/Writer.hs +9/−6
- src/Control/Effect/Writer/Internal.hs +5/−23
- test/Accum.hs +73/−0
- test/Catch.hs +1/−3
- test/Choose.hs +2/−4
- test/Cull.hs +1/−3
- test/Cut.hs +3/−5
- test/Cut/Church.hs +4/−4
- test/Empty.hs +12/−6
- test/Error.hs +11/−6
- test/Fail.hs +1/−3
- test/Fresh.hs +10/−6
- test/Fusion.hs +11/−11
- test/Gen.hs +26/−4
- test/Lift.hs +5/−5
- test/Monad.hs +5/−7
- test/MonadFix.hs +4/−6
- test/NonDet.hs +2/−4
- test/NonDet/Church.hs +10/−10
- test/Reader.hs +2/−4
- test/State.hs +28/−17
- test/Test.hs +6/−3
- test/Throw.hs +1/−3
- test/Writer.hs +33/−16
ChangeLog.md view
@@ -1,3 +1,111 @@+# v1.1.2.7++- Supports `base` 4.22.++# v1.1.2.6++- Make strict Accum carrier's `<*>` and `>>=` strict in the accumulated value ([#468](https://github.com/fused-effects/fused-effects/pull/468)) (by @byorgey)+- Allow inspection-testing 0.7 ([#466](https://github.com/fused-effects/fused-effects/pull/466)) (by @MangoIV)++# v1.1.2.5++- Fixes Accum carriers (Strict and Church) to not duplicate state ([#449](https://github.com/fused-effects/fused-effects/issues/449)) (by @byorgey)++# v1.1.2.4++- Adds support for `ghc` 9.12 and `base` 4.21.++# v1.1.2.3++- Adds support for `ghc` 9.8 and 9.10, `base` 4.19 and 4.20, and `containers` 0.7.++# v1.1.2.2++- Adds support for `ghc` 9.6, `base` 4.18, and `transformers` 0.6.++# v1.1.2.1++- Adds support for `ghc` 9.4 and `base` 4.17.++# v1.1.2.0++- Adds `MonadUnliftIO` instances for `ReaderC`, `LiftC`, and `InterpretC`. ([#420](https://github.com/fused-effects/fused-effects/pull/420))++- Adds `Accum` ([#391](https://github.com/fused-effects/fused-effects/pull/391)) (by @turion)+ - Adds an `Accum` effect+ - Adds a church-encoded `Control.Carrier.Accum.Church` carrier+ - Adds a strict `Control.Carrier.Accum.Strict` carrier+ - Adds an impure `Control.Carrier.Accum.IORef` carrier ([#430](https://github.com/fused-effects/fused-effects/pull/430))+ - Defines `Algebra` instances for the three mentioned carriers,+ and for `Control.Monad.Trans.Accum` from `transformers`++- Defines `Algebra`, `Alternative`, `Applicative`, `Foldable`, `Functor`, `Monad`, `MonadFail`, `MonadFix`, `MonadIO`, `MonadPlus`, `MonadTrans`, `MonadUnliftIO`, `MonadZip`, and `Traversable` instances for `Control.Effect.Choose.Choosing`. ([#419](https://github.com/fused-effects/fused-effects/pull/419))++- Adds an `IORef`-based carrier in `Control.Carrier.State.IORef`. ([#422](https://github.com/fused-effects/fused-effects/pull/422))+++# v1.1.1.3++- Adds support for `inspection-testing` 0.5.+++# v1.1.1.2++- Adds support for `ghc` 9.2.1 and `base` 4.16.+++# v1.1.1.1++- Adds support for `ghc` 9.0 & `base` 4.15.+++# v1.1.1++- Defines `MonadFix` instances for `Labelled` and `UnderLabel`. ([#402](https://github.com/fused-effects/fused-effects/pull/402))+++# v1.1++- 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.2 - Adds support for `ghc` 8.10 & `base` 4.14. ([#376](https://github.com/fused-effects/fused-effects/pull/376))
LICENSE view
@@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2018-2019, Nicolas Wu, Tom Schrijvers, Rob Rix, and Patrick Thomson+Copyright (c) 2018-2026, Nicolas Wu, Tom Schrijvers, Rob Rix, and Patrick Thomson All rights reserved. Redistribution and use in source and binary forms, with or without
README.lhs view
@@ -1,6 +1,6 @@ # A fast, flexible, fused effect system for Haskell -[](https://github.com/fused-effects/fused-effects/actions) [](http://hackage.haskell.org/package/fused-effects)+[](https://github.com/fused-effects/fused-effects/actions) [](http://hackage.haskell.org/package/fused-effects) - [Overview][] - [Algebraic effects][]@@ -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, Effect sig) => [a] -> m (Int, ())+example1 :: Algebra sig m => [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, Effect sig) => m (Int, ())+example2 :: Algebra sig m => m (Int, ()) example2 = runReader "hello" . runState 0 $ do list <- ask put (length (list :: String))@@ -188,16 +188,18 @@ ### Required compiler extensions -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 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 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. [common]: https://github.com/fused-effects/fused-effects/blob/master/docs/common_errors.md -The following invocation, taken from the teletype example, should suffice for most use or construction of effects and carriers:+The following invocation, taken from the [teletype example][], should suffice for most use or construction of effects and carriers: +[teletype example]: https://github.com/fused-effects/fused-effects/blob/master/examples/Teletype.hs+ ```haskell-{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} ``` @@ -274,6 +276,7 @@ * [`fused-effects-mwc-random`][] provides a performant, high-quality source of random data, as well as values from common numerical distributions. * [`fused-effects-readline`][] provides a REPL effect that interfaces with [`haskeline`][] for its UI. * [`fused-effects-parser`][] provides parser-combinator style effects similar to parsing libraries such as [`trifecta`][].+* [`fused-effects-optics`][] provides combinators for the [`optics`][optics] ecosystem. [exc]: https://github.com/fused-effects/fused-effects-exceptions [felens]: http://hackage.haskell.org/package/fused-effects-lens@@ -284,13 +287,15 @@ [`fused-effects-parser`]: https://github.com/fused-effects/fused-effects-parser [`trifecta`]: https://hackage.haskell.org/package/trifecta [lens]: http://hackage.haskell.org/package/lens+[`fused-effects-optics`]: https://github.com/fused-effects/fused-effects-optics+[optics]: https://github.com/well-typed/optics ### 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+* [`FOSSA`](https://serokell.io/blog/haskell-in-production-fossa), a tool for open-source risk management. ### Comparison to other effect libraries
README.md view
@@ -1,6 +1,6 @@ # A fast, flexible, fused effect system for Haskell -[](https://github.com/fused-effects/fused-effects/actions) [](http://hackage.haskell.org/package/fused-effects)+[](https://github.com/fused-effects/fused-effects/actions) [](http://hackage.haskell.org/package/fused-effects) - [Overview][] - [Algebraic effects][]@@ -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, Effect sig) => [a] -> m (Int, ())+example1 :: Algebra sig m => [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, Effect sig) => m (Int, ())+example2 :: Algebra sig m => m (Int, ()) example2 = runReader "hello" . runState 0 $ do list <- ask put (length (list :: String))@@ -188,16 +188,18 @@ ### Required compiler extensions -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 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 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. [common]: https://github.com/fused-effects/fused-effects/blob/master/docs/common_errors.md -The following invocation, taken from the teletype example, should suffice for most use or construction of effects and carriers:+The following invocation, taken from the [teletype example][], should suffice for most use or construction of effects and carriers: +[teletype example]: https://github.com/fused-effects/fused-effects/blob/master/examples/Teletype.hs+ ```haskell-{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} ``` @@ -274,6 +276,7 @@ * [`fused-effects-mwc-random`][] provides a performant, high-quality source of random data, as well as values from common numerical distributions. * [`fused-effects-readline`][] provides a REPL effect that interfaces with [`haskeline`][] for its UI. * [`fused-effects-parser`][] provides parser-combinator style effects similar to parsing libraries such as [`trifecta`][].+* [`fused-effects-optics`][] provides combinators for the [`optics`][optics] ecosystem. [exc]: https://github.com/fused-effects/fused-effects-exceptions [felens]: http://hackage.haskell.org/package/fused-effects-lens@@ -284,13 +287,15 @@ [`fused-effects-parser`]: https://github.com/fused-effects/fused-effects-parser [`trifecta`]: https://hackage.haskell.org/package/trifecta [lens]: http://hackage.haskell.org/package/lens+[`fused-effects-optics`]: https://github.com/fused-effects/fused-effects-optics+[optics]: https://github.com/well-typed/optics ### 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+* [`FOSSA`](https://serokell.io/blog/haskell-in-production-fossa), a tool for open-source risk management. ### Comparison to other effect libraries
benchmark/Bench.hs view
@@ -1,64 +1,21 @@-{-# 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 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.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 Test.Tasty.Bench main :: IO () main = defaultMain- [ Reader.benchmark+ [ Error.benchmark+ , Interpret.benchmark , NonDet.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- ]- ]+ , Reader.benchmark+ , State.benchmark+ , Writer.benchmark ]--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)))
+ benchmark/Bench/Error.hs view
@@ -0,0 +1,31 @@+{-# 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 Test.Tasty.Bench++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 #-}
+ benchmark/Bench/Interpret.hs view
@@ -0,0 +1,47 @@+{-# 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 Test.Tasty.Bench++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 #-}
benchmark/Bench/NonDet.hs view
@@ -6,9 +6,9 @@ import qualified Bench.NonDet.NQueens as NQueens import Control.Algebra import qualified Control.Carrier.NonDet.Church as NonDet.Church-import Gauge hiding (benchmark)+import Test.Tasty.Bench -benchmark :: Gauge.Benchmark+benchmark :: Benchmark benchmark = bgroup "NonDet" [ bgroup "N-queens problem" [ NQueens.benchmark "NonDet.Church" (run . NonDet.Church.runNonDetA)
benchmark/Bench/NonDet/NQueens.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-unused-imports #-} -- Based largely on the implementation by Sreekar Shastry, -- available at https://github.com/sshastry/queenslogic@@ -14,7 +15,7 @@ import Control.Monad (guard) import Data.Foldable import qualified Data.List as List-import Gauge hiding (benchmark)+import Test.Tasty.Bench type Square = (Int,Int) type Board = [Int]@@ -28,8 +29,8 @@ diags :: Square -> [Diagonal] diags (i,j) = [ Row i , Col j- , Backslash (j-i)- , Forwardslash (i+j) ]+ , Backslash (j - i)+ , Forwardslash (i + j) ] isSafeIn :: Square -> Board -> Bool isSafeIn (i, j) qs = null (diags (i, j) `List.intersect` underThreat)@@ -48,7 +49,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]) -> Gauge.Benchmark+benchmark :: (Alternative m, Monad m) => String -> (m Board -> [Board]) -> Benchmark benchmark title runQueens = bgroup title [ bench "4" $ whnf (runQueens . queens) 4 , bench "8" $ whnf (runQueens . queens) 8
benchmark/Bench/Reader.hs view
@@ -1,30 +1,45 @@ {-# LANGUAGE TypeApplications #-}- module Bench.Reader ( benchmark ) where import Control.Carrier.Reader-import Control.Monad+import Control.Monad (replicateM_)+import Control.Monad.Trans.Reader (runReaderT)+import Test.Tasty.Bench -import Gauge hiding (benchmark)+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 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))--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- ]- ]+{-# INLINE locally #-}
+ benchmark/Bench/State.hs view
@@ -0,0 +1,36 @@+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 Test.Tasty.Bench++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 #-}
+ benchmark/Bench/Writer.hs view
@@ -0,0 +1,45 @@+{-# 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 Test.Tasty.Bench++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 #-}
examples/Inference.hs view
@@ -1,15 +1,20 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeApplications, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE 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 Utils example :: TestTree example = testGroup "inference"@@ -46,5 +51,4 @@ deriving (Applicative, Functor, Monad) -- | The 'Carrier' instance for 'HasEnv' simply delegates all effects to the underlying carrier.-instance Algebra sig m => Algebra sig (HasEnv env m) where- alg = HasEnv . alg . handleCoercible+deriving instance Algebra sig m => Algebra sig (HasEnv env m)
examples/Labelled.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-}@@ -5,14 +6,16 @@ ( example ) where -import Test.Tasty-import Test.Tasty.HUnit-import Control.Applicative-import Control.Effect.Labelled-import Control.Carrier.Reader-import Control.Carrier.State.Strict+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative+#endif+import Control.Carrier.Reader+import Control.Carrier.State.Strict+import Control.Effect.Labelled import qualified Control.Effect.Reader.Labelled as L import qualified Control.Effect.State.Labelled as L+import Hedgehog+import Utils sample :: ( HasLabelled "fore" (Reader Int) sig m , HasLabelled "aft" (Reader Int) sig m@@ -34,9 +37,12 @@ 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)+ [ testProperty "runUnderLabel" . property $+ run (runReader (5 :: Int) (runLabelled @"fore" (runReader (10 :: Int) (runLabelled @"aft" sample)))) === 15+ , testProperty "Reader.Labelled helpers" . property $+ run (runReader (5 :: Int) (runLabelled @"fore" (runReader (10 :: Int) (runLabelled @"aft" withHelpers)))) === 15+ , testProperty "Nat labels" . property $+ run (runReader (5 :: Int) (runLabelled @1 (runReader (10 :: Int) (runLabelled @2 numerically)))) === 15 ] sampleS :: ( HasLabelled "fore" (State Int) sig m@@ -59,9 +65,12 @@ 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)+ [ testProperty "runUnderLabel" . property $+ run (evalState (5 :: Int) (runLabelled @"fore" (evalState (10 :: Int) (runLabelled @"aft" sampleS)))) === 15+ , testProperty "State.Labelled helpers" . property $+ run (evalState (5 :: Int) (runLabelled @"fore" (evalState (10 :: Int) (runLabelled @"aft" helpersS)))) === 15+ , testProperty "Boolean labels" . property $+ run (evalState (5 :: Int) (runLabelled @'True (evalState (10 :: Int) (runLabelled @'False boolean)))) === 15 ] @@ -70,4 +79,3 @@ [ readerExamples , stateExamples ]-
examples/Main.hs view
@@ -2,15 +2,16 @@ ( main ) where +import Hedgehog.Main import qualified Inference import qualified Labelled import qualified Parser import qualified ReinterpretLog import qualified Teletype-import Test.Tasty+import Utils main :: IO ()-main = defaultMain $ testGroup "examples"+main = defaultMain $ map checkTestTree [ Inference.example , Parser.example , ReinterpretLog.example
examples/Parser.hs view
@@ -1,22 +1,29 @@-{-# LANGUAGE DeriveGeneric, DeriveTraversable, ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE 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.List (intercalate)-import GHC.Generics (Generic1)-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.Kind (Type)+import Data.List (intercalate)+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 Utils example :: TestTree example = testGroup "parser"@@ -36,15 +43,14 @@ [ testProperty "matches with a predicate" . property $ do c <- forAll Gen.alphaNum f <- (. ord) <$> Fn.forAllFn predicate- run (runNonDetA (parse [c] (satisfy f))) === if f c then [c] else []+ run (runNonDetA (parse [c] (satisfy f))) === [c | f c] , 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 <- forAll Gen.alphaNum- c2 <- forAll Gen.alphaNum+ (c1, c2) <- forAll ((,) <$> Gen.alphaNum <*> Gen.alphaNum) f <- (. ord) <$> Fn.forAllFn predicate run (runNonDetA (parse [c1, c2] (satisfy f))) === [] @@ -52,7 +58,7 @@ c1 <- forAll Gen.alphaNum c2 <- forAll Gen.alphaNum f <- (. ord) <$> Fn.forAllFn predicate- run (runNonDetA (parse [c1, c2] ((,) <$> satisfy f <*> satisfy f))) === if f c1 && f c2 then [(c1, c2)] else []+ run (runNonDetA (parse [c1, c2] ((,) <$> satisfy f <*> satisfy f))) === [(c1, c2) | f c1, f c2] ] , testGroup "factor"@@ -93,27 +99,25 @@ 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) - 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 - 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 pure)+satisfy p = send (Satisfy p) char :: Has Symbol sig m => Char -> m Char char = satisfy . (==)@@ -133,13 +137,14 @@ newtype ParseC m a = ParseC { runParseC :: StateC String m a } deriving (Alternative, Applicative, Functor, Monad) -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)))+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) {-# INLINE alg #-}
examples/ReinterpretLog.hs view
@@ -9,39 +9,33 @@ -- * Finally, we will bridge the two with an effect carrier that reinterprets -- structured log messages as strings. --{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# 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.Function ((&))-import Data.Kind (Type)-import GHC.Generics (Generic1)-import Prelude hiding (log)-import Test.Tasty-import Test.Tasty.HUnit-+import Data.Kind (Type)+import Hedgehog+import Prelude hiding (log)+import Utils -------------------------------------------------------------------------------- -- The application@@ -54,16 +48,13 @@ | 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")@@ -73,28 +64,10 @@ -- * Reinterpreting 'Log Message' effects as 'Log String' effects. -- * Interpreting 'Log String' effects by printing to stdout. runApplication :: 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 ()+runApplication+ = runLogStdout -- IO ()+ . reinterpretLog renderLogMessage -- LogStdoutC IO ()+ $ application -- ReinterpretLogC Message String (LogStdoutC IO) () --------------------------------------------------------------------------------@@ -102,19 +75,13 @@ -------------------------------------------------------------------------------- -- Log an 'a', then continue with 'k'.-data Log (a :: Type) (m :: Type -> Type) (k :: Type)- = Log a (m k)- deriving (Functor, Generic1)+data Log (a :: Type) (m :: Type -> Type) (k :: Type) where+ Log :: a -> Log a m () -instance HFunctor (Log a)-instance Effect (Log a) -- Log an 'a'.-log :: Has (Log a) sig m- => a- -> m ()-log x =- send (Log x (pure ()))+log :: Has (Log a) sig m => a -> m ()+log x = send (Log x) --------------------------------------------------------------------------------@@ -122,8 +89,7 @@ -------------------------------------------------------------------------------- -- Carrier one: log strings to stdout.-newtype LogStdoutC m a- = LogStdoutC (m a)+newtype LogStdoutC m a = LogStdoutC { runLogStdout :: m a } deriving (Applicative, Functor, Monad, MonadIO) instance@@ -135,28 +101,15 @@ -- ... the 'LogStdoutC m' monad can interpret 'Log String :+: sig' effects => Algebra (Log String :+: sig) (LogStdoutC m) where - 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 (hmap runLogStdout other))+ alg hdl sig ctx = case sig of+ L (Log message) -> ctx <$ liftIO (putStrLn message) --- The 'LogStdoutC' runner.-runLogStdout ::- LogStdoutC m a- -> m a-runLogStdout (LogStdoutC m) =- m+ R other -> LogStdoutC (alg (runLogStdout . hdl) other ctx) -- 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 { unReinterpretLogC :: ReaderC (s -> t) m a }+newtype ReinterpretLogC s t m a = ReinterpretLogC { runReinterpretLogC :: ReaderC (s -> t) m a } deriving (Applicative, Functor, Monad, MonadIO) instance@@ -167,73 +120,46 @@ -- effects => Algebra (Log s :+: sig) (ReinterpretLogC s t m) where - 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+ alg hdl sig ctx = ReinterpretLogC $ case sig of+ L (Log s) -> do+ f <- ask @(s -> t)+ ctx <$ log (f s) - R other ->- ReinterpretLogC (alg (R (handleCoercible other)))+ R other -> alg (runReinterpretLogC . hdl) (R other) ctx -- The 'ReinterpretLogC' runner.-reinterpretLog ::- (s -> t)- -> ReinterpretLogC s t m a- -> m a-reinterpretLog f =- runReader f . unReinterpretLogC-+reinterpretLog :: (s -> t) -> ReinterpretLogC s t m a -> m a+reinterpretLog f = runReader f . runReinterpretLogC -- Carrier three: collect log messages in a list. This is used for writing this -- example's test spec.-newtype CollectLogMessagesC s m a- = CollectLogMessagesC { unCollectLogMessagesC :: WriterC [s] m a }+newtype CollectLogMessagesC s m a = CollectLogMessagesC { runCollectLogMessagesC :: WriterC [s] m a } deriving (Applicative, Functor, Monad) instance -- So long as the 'm' monad can interpret the 'sig' effects...- ( Algebra sig m- , Effect sig- )+ Algebra sig m -- ...the 'CollectLogMessagesC s m' monad can interpret 'Log s :+: sig' -- effects => Algebra (Log s :+: sig) (CollectLogMessagesC s m) where - alg ::- (Log s :+: sig) (CollectLogMessagesC s m) a- -> CollectLogMessagesC s m a- alg = \case- L (Log s k) ->- CollectLogMessagesC $ do- tell [s]- unCollectLogMessagesC k+ alg hdl sig ctx = CollectLogMessagesC $ case sig of+ L (Log s) -> ctx <$ tell [s] - R other ->- CollectLogMessagesC (alg (R (handleCoercible other)))+ R other -> alg (runCollectLogMessagesC . hdl) (R other) ctx -- The 'CollectLogMessagesC' runner.-collectLogMessages ::- CollectLogMessagesC s m a- -> m ([s], a)-collectLogMessages =- runWriter . unCollectLogMessagesC+collectLogMessages :: Functor m => CollectLogMessagesC s m a -> m [s]+collectLogMessages = execWriter . runCollectLogMessagesC -- Test spec. example :: TestTree example = testGroup "reinterpret log"- [ testCase "reinterprets logs" $- ((do+ [ testProperty "reinterprets logs" . property $ do+ a <- liftIO . collectLogMessages . reinterpretLog renderLogMessage $ do log (Debug "foo")- log (Info "bar"))- & reinterpretLog renderLogMessage- & collectLogMessages- & run)- @?= (["[debug] foo", "[info] bar"], ())+ log (Info "bar")+ a === ["[debug] foo", "[info] bar"] ]
examples/Teletype.hs view
@@ -1,22 +1,25 @@-{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Teletype ( example-, runTeletypeIO ) where -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 Control.Algebra+import Control.Carrier.State.Strict+import Control.Carrier.Writer.Strict+import Control.Monad.IO.Class+import Data.Kind (Type)+import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-import Test.Tasty-import Test.Tasty.Hedgehog+import Prelude hiding (read)+import Utils example :: TestTree example = testGroup "teletype"@@ -37,31 +40,26 @@ ] where genLine = Gen.string (Range.linear 0 20) Gen.unicode -data Teletype m k- = Read (String -> m k)- | Write String (m k)- deriving (Functor, Generic1)+data Teletype (m :: Type -> Type) k where+ Read :: Teletype m String+ Write :: String -> Teletype m () -instance HFunctor Teletype-instance Effect Teletype read :: Has Teletype sig m => m String-read = send (Read pure)+read = send Read write :: Has Teletype sig m => String -> m ()-write s = send (Write s (pure ()))+write s = send (Write s) -runTeletypeIO :: TeletypeIOC m a -> m a-runTeletypeIO = runTeletypeIOC--newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }+newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIO :: m a } deriving (Applicative, Functor, Monad, MonadIO) instance (MonadIO m, Algebra sig m) => Algebra (Teletype :+: sig) (TeletypeIOC m) where- alg (L (Read k)) = liftIO getLine >>= k- alg (L (Write s k)) = liftIO (putStrLn s) >> k- alg (R other) = TeletypeIOC (alg (handleCoercible other))+ 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) runTeletypeRet :: [String] -> TeletypeRetC m a -> m ([String], ([String], a))@@ -70,11 +68,12 @@ newtype TeletypeRetC m a = TeletypeRetC { runTeletypeRetC :: StateC [String] (WriterC [String] m) a } deriving (Applicative, Functor, Monad) -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))))+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
+ examples/Utils.hs view
@@ -0,0 +1,20 @@+module Utils+( module Utils+) where++import Hedgehog++data TestTree+ = Leaf String Property+ | Branch String [TestTree]++checkTestTree :: TestTree -> IO Bool+checkTestTree t = case t of+ Leaf n p -> putStrLn n *> check p <* putStrLn ""+ Branch n ts -> and <$ putStrLn n <*> traverse checkTestTree ts <* putStrLn ""++testGroup :: String -> [TestTree] -> TestTree+testGroup = Branch++testProperty :: String -> Property -> TestTree+testProperty = Leaf
fused-effects.cabal view
@@ -1,27 +1,35 @@-cabal-version: 2.2--name: fused-effects-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-license: BSD-3-Clause-license-file: LICENSE-author: Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson-maintainer: robrix@github.com-copyright: 2018-2019 Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson-category: Control-build-type: Simple+cabal-version: 2.2+name: fused-effects+version: 1.1.2.7+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+license: BSD-3-Clause+license-file: LICENSE+author: Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson+maintainer: rob.rix@me.com+copyright: 2018-2026 Nicolas Wu, Tom Schrijvers, Rob Rix, Patrick Thomson+category: Control+build-type: Simple extra-source-files: README.md++extra-doc-files: ChangeLog.md tested-with:- GHC == 8.2.2- GHC == 8.4.4- GHC == 8.6.5- GHC == 8.8.3- GHC == 8.10.1+ ghc ==8.2.2+ ghc ==8.4.4+ ghc ==8.6.5+ ghc ==8.8.4+ ghc ==8.10.4+ ghc ==9.0.1+ ghc ==9.2.1+ ghc ==9.4.2+ ghc ==9.6.2+ ghc ==9.8.2+ ghc ==9.10.1+ ghc ==9.12.1 common common default-language: Haskell2010@@ -36,43 +44,71 @@ -Wno-name-shadowing -Wno-safe -Wno-unsafe- if (impl(ghc >= 8.6))- ghc-options: -Wno-star-is-type- if (impl(ghc >= 8.8))++ if (impl(ghc >=8.8)) ghc-options: -Wno-missing-deriving-strategies- if (impl(ghc >= 8.10))++ if (impl(ghc >=8.10)) ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + if (impl(ghc >=9.2))+ ghc-options:+ -Wno-missing-kind-signatures++ -- Temporary hack to deal with a bug in GHC 9.6 where+ -- derivations of MonadTrans cause spurious redundant-constraint warnings.+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/23143+ if (impl(ghc >=9.6))+ ghc-options:+ -Wno-redundant-constraints++ if (impl(ghc >=9.8))+ ghc-options:+ -Wno-missing-role-annotations+ -Wno-term-variable-capture+ -Wno-x-partial+ -Wno-missing-poly-kind-signatures+ library- import: common+ import: common hs-source-dirs: src exposed-modules:- Control.Algebra -- Carriers+ -- Effects+ Control.Algebra+ Control.Algebra.Handler+ Control.Carrier.Accum.Church+ Control.Carrier.Accum.IORef+ Control.Carrier.Accum.Strict 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.IORef 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.Accum Control.Effect.Catch Control.Effect.Choose- Control.Effect.Class Control.Effect.Cull Control.Effect.Cut Control.Effect.Empty@@ -90,7 +126,9 @@ Control.Effect.Throw Control.Effect.Trace Control.Effect.Writer+ other-modules:+ Control.Effect.Accum.Internal Control.Effect.Catch.Internal Control.Effect.Choose.Internal Control.Effect.Empty.Internal@@ -101,38 +139,38 @@ Control.Effect.State.Internal Control.Effect.Throw.Internal Control.Effect.Writer.Internal- build-depends:- base >= 4.9 && < 4.15- , transformers >= 0.4 && < 0.6 + build-depends:+ base >=4.9 && <4.23,+ transformers >=0.4 && <0.7,+ unliftio-core >=0.2 && <0.3, test-suite examples- import: common- type: exitcode-stdio-1.0+ import: common+ type: exitcode-stdio-1.0 hs-source-dirs: examples- main-is: Main.hs+ main-is: Main.hs other-modules: Inference Labelled Parser ReinterpretLog Teletype- build-depends:- base- , fused-effects- , hedgehog ^>= 1- , hedgehog-fn ^>= 1- , tasty ^>= 1.2- , tasty-hedgehog ^>= 1- , tasty-hunit ^>= 0.10+ Utils + build-depends:+ base,+ fused-effects,+ hedgehog >=1 && <1.6,+ hedgehog-fn ^>=1, test-suite test- import: common- type: exitcode-stdio-1.0+ import: common+ type: exitcode-stdio-1.0 hs-source-dirs: test- main-is: Test.hs+ main-is: Test.hs other-modules:+ Accum Catch Choose Cull@@ -153,49 +191,54 @@ State Throw Writer- build-depends:- base- , containers >= 0.5 && < 0.7- , fused-effects- , hedgehog ^>= 1- , hedgehog-fn ^>= 1- , inspection-testing ^>= 0.4- , tasty ^>= 1.2- , tasty-hedgehog ^>= 1- , tasty-hunit ^>= 0.10- , transformers + build-depends:+ base,+ containers >=0.5 && <0.8,+ fused-effects,+ hedgehog,+ hedgehog-fn,+ inspection-testing >=0.4 && <0.7,+ transformers, test-suite docs- import: common- type: exitcode-stdio-1.0- main-is: README.lhs- ghc-options: -pgmL markdown-unlit+ import: common+ type: exitcode-stdio-1.0+ main-is: README.lhs+ ghc-options:+ -pgmL+ markdown-unlit+ build-depends:- base- , fused-effects- build-tool-depends:- markdown-unlit:markdown-unlit ^>= 0.5+ base,+ fused-effects, + build-tool-depends:+ markdown-unlit:markdown-unlit ^>=0.5 benchmark benchmark- import: common- type: exitcode-stdio-1.0+ import: common+ type: exitcode-stdio-1.0 hs-source-dirs: benchmark- main-is: Bench.hs+ main-is: Bench.hs other-modules:- Bench.Reader+ Bench.Error+ Bench.Interpret Bench.NonDet Bench.NonDet.NQueens+ Bench.Reader+ Bench.State+ Bench.Writer+ build-depends:- base- , fused-effects- , gauge+ base,+ fused-effects,+ tasty-bench ==0.3.*,+ transformers,+ ghc-options: -threaded- -rtsopts "-with-rtsopts=-N -A4m -n2m" - source-repository head- type: git+ type: git location: https://github.com/fused-effects/fused-effects
src/Control/Algebra.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -15,17 +19,22 @@ -} module Control.Algebra ( Algebra(..)+, thread , run , Has , send -- * Re-exports+, Handler+, (~<~) , (:+:) (..)-, module Control.Effect.Class ) where +import Control.Algebra.Handler+#if MIN_VERSION_transformers(0,5,4)+import Control.Effect.Accum.Internal+#endif 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@@ -35,31 +44,75 @@ import Control.Effect.Sum ((:+:)(..), Member(..), Members) import Control.Effect.Throw.Internal import Control.Effect.Writer.Internal-import Control.Monad ((<=<))+#if MIN_VERSION_transformers(0,5,4)+import qualified Control.Monad.Trans.Accum as Accum+#endif 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.Coerce+import Data.Functor.Compose 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 (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+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 #-} + -- | Run an action exhausted of effects to produce its final result value. -- -- @since 1.0.0.0@@ -75,56 +128,74 @@ -- 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 = alg . inj+send sig = runIdentity <$> alg (fmap Identity . runIdentity) (inj sig) (Identity ()) {-# INLINE send #-} -- base instance Algebra (Lift IO) IO where- alg (LiftWith with k) = with (Identity ()) coerce >>= k . runIdentity+ alg hdl (LiftWith with) = with hdl+ {-# INLINE alg #-} instance Algebra (Lift Identity) Identity where- alg (LiftWith with k) = with (Identity ()) coerce >>= k . runIdentity+ alg hdl (LiftWith with) = with hdl+ {-# INLINE alg #-} instance Algebra Choose NonEmpty where- alg (Choose m) = m True S.<> m False+ alg _ Choose ctx = (True <$ ctx) :| [ False <$ ctx ]+ {-# INLINE alg #-} instance Algebra Empty Maybe where- alg Empty = Nothing+ alg _ Empty _ = Nothing+ {-# INLINE alg #-} instance Algebra (Error e) (Either e) where- alg (L (Throw e)) = Left e- alg (R (Catch m h k)) = either (k <=< h) k m+ 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 #-} instance Algebra (Reader r) ((->) r) where- alg (Ask k) r = k r r- alg (Local f m k) r = k (m (f r)) r+ alg hdl sig ctx = case sig of+ Ask -> (<$ ctx)+ Local f m -> hdl (m <$ ctx) . f+ {-# INLINE alg #-} instance Algebra NonDet [] where- alg (L Empty) = []- alg (R (Choose k)) = k True ++ k False+ alg _ sig ctx = case sig of+ L Empty -> []+ R Choose -> [ True <$ ctx, False <$ ctx ]+ {-# INLINE alg #-} instance Monoid w => Algebra (Writer w) ((,) w) where- 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')+ 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 #-} -- transformers -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)+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 => Algebra sig (Identity.IdentityT m) where- alg = Identity.IdentityT . alg . handleCoercible +deriving instance Algebra sig m => Algebra sig (Identity.IdentityT m)+ #if MIN_VERSION_base(4,12,0) -- | This instance permits effectful actions to be lifted into the 'Ap' monad -- given a monoidal return type, which can provide clarity when chaining calls@@ -137,8 +208,7 @@ -- > getAp (act1 <> act2 <> act3) -- -- @since 1.0.1.0-instance Algebra sig m => Algebra sig (Ap m) where- alg = Ap . alg . handleCoercible+deriving instance Algebra sig m => Algebra sig (Ap m) #endif -- | This instance permits effectful actions to be lifted into the 'Alt' monad,@@ -151,14 +221,24 @@ -- > getAlt (mconcat [a, b, c, d]) -- -- @since 1.0.1.0-instance Algebra sig m => Algebra sig (Alt m) where- alg = Alt . alg . handleCoercible+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 (Reader r :+: sig) (Reader.ReaderT r m) where- 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)+ 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 #-} + newtype RWSTF w s a = RWSTF { unRWSTF :: (a, s, w) } deriving (Functor) @@ -166,44 +246,98 @@ toRWSTF w (a, s, w') = RWSTF (a, s, mappend w w') {-# INLINE toRWSTF #-} -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)+newtype Swap s a = Swap { getSwap :: (a, s) }+ deriving (Functor) -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)+swapAndLift :: Functor ctx => (ctx a, w) -> ctx (w, a)+swapAndLift p = (,) (snd p) <$> fst p+{-# INLINE swapAndLift #-} -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 (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, 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 (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, 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 (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, 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)++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 => 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 #-}+++#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, 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, 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 #-}++#if MIN_VERSION_transformers(0,5,4)+instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (Accum.AccumT w m) where+ alg hdl sig ctx = case sig of+ L (Add w) -> ctx <$ Accum.add w+ L Look -> Accum.looks (<$ ctx)+ R other -> Accum.AccumT $ \w -> getSwap <$> thread ((\(Swap (x, s)) -> Swap . fmap (mappend s) <$> Accum.runAccumT x s) ~<~ hdl) other (Swap (ctx, w))+ {-# INLINE alg #-}+#endif
+ src/Control/Algebra/Handler.hs view
@@ -0,0 +1,47 @@+{-# 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 ~<~
+ src/Control/Carrier/Accum/Church.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++{- | A high-performance, strict, church-encoded carrier for 'Accum'.++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.2.0+-}++module Control.Carrier.Accum.Church+( -- * Accum carrier+ runAccum+, execAccum+, evalAccum+, AccumC(AccumC)+ -- * Accum effect+, module Control.Effect.Accum+) where++import Control.Algebra+import Control.Applicative (Alternative(..))+import Control.Effect.Accum+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 an 'Accum' effect with a 'Monoid'al log, applying a continuation to the final log and result.+--+-- @+-- 'runAccum' k w0 ('pure' a) = k 'w0' a+-- @+-- @+-- 'runAccum' k w0 ('add' w) = k (w0 <> w) ()+-- @+-- @+-- 'runAccum' k w0 ('add' w >> 'look') = k (w0 <> w) (w0 <> w)+-- @+--+-- @since 1.1.2.0+runAccum :: (w -> a -> m b) -> w -> AccumC w m a -> m b+runAccum k w ma = runAccumC ma k w+{-# INLINE runAccum #-}++-- | Run an 'Accum' effect (typically with a 'Monoid'al log),+-- producing the final log and discarding the result value.+--+-- @+-- 'execAccum' = 'runAccum' ('const' '.' 'pure')+-- @+--+-- @since 1.1.2.0+execAccum :: Applicative m => w -> AccumC w m a -> m w+execAccum = runAccum (const . pure)+{-# INLINE execAccum #-}++-- | Run an 'Accum' effect (typically with a 'Monoid'al log),+-- producing the result value and discarding the final log.+--+-- @+-- 'evalAccum' = 'runAccum' ('const' '.' 'pure')+-- @+--+-- @since 1.1.2.0+evalAccum :: Applicative m => w -> AccumC w m a -> m a+evalAccum = runAccum $ const pure+{-# INLINE evalAccum #-}++-- | @since 1.1.2.0+newtype AccumC w m a = AccumC { runAccumC :: forall r . (w -> a -> m r) -> w -> m r }++instance Monoid w => MonadTrans (AccumC w) where+ lift ma = AccumC $ \k _ -> ma >>= k mempty+ {-# INLINE lift #-}++instance Functor (AccumC w m) where+ fmap f ma = AccumC $ \k w -> runAccumC ma (\w a -> k w $ f a) w+ {-# INLINE fmap #-}++instance Monoid w => Applicative (AccumC w m) where+ pure a = AccumC $ \k _ -> k mempty a+ {-# INLINE pure #-}++ mf <*> ma = AccumC $ \k w ->+ runAccumC mf (\w' f -> runAccumC ma (\w'' a -> k (w' `mappend` w'') $ f a) (w `mappend` w')) w+ {-# INLINE (<*>) #-}++instance (Alternative m, Monoid w) => Alternative (AccumC w m) where+ empty = AccumC $ const $ const empty+ {-# INLINE empty #-}++ ma1 <|> ma2 = AccumC $ \k w -> runAccumC ma1 k w <|> runAccumC ma2 k w+ {-# INLINE (<|>) #-}++instance Monoid w => Monad (AccumC w m) where+ ma >>= f = AccumC $ \k w -> runAccumC ma (\w' a -> runAccumC (f a) (\w'' -> k $ w' `mappend` w'') (w `mappend` w')) w+ {-# INLINE (>>=) #-}++instance (MonadPlus m, Monoid w) => MonadPlus (AccumC w m) where+ mzero = lift mzero+ {-# INLINE mzero #-}++ ma1 `mplus` ma2 = AccumC $ \k w -> runAccumC ma1 k w `mplus` runAccumC ma2 k w+ {-# INLINE mplus #-}++instance (MonadFail m, Monoid w) => MonadFail (AccumC w m) where+ fail msg = AccumC $ const $ const $ Fail.fail msg+ {-# INLINE fail #-}++instance (MonadFix m, Monoid w) => MonadFix (AccumC w m) where+ mfix ma = AccumC $ \ k w -> mfix ((\accumC -> runAccumC accumC (curry pure) w) . ma . snd) >>= uncurry k+ {-# INLINE mfix #-}++instance (MonadIO m, Monoid w) => MonadIO (AccumC w m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (AccumC w m) where+ alg hdl sig ctx = AccumC $ \k w -> case sig of+ L accum -> case accum of+ Add w' -> k w' ctx+ Look -> k mempty $ w <$ ctx+ R other -> thread (uncurry (runAccum (curry pure)) ~<~ hdl) other (mempty, ctx) >>= uncurry k+ {-# INLINE alg #-}
+ src/Control/Carrier/Accum/IORef.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | A carrier for 'Accum' effects.+This carrier performs its append operations strictly and thus avoids the space leaks inherent in lazy writer monads.+These appends are left-associative; as such, @[]@ is a poor choice of monoid for computations that entail many calls to 'add'.+The [Seq](http://hackage.haskell.org/package/containersdocs/Data-Sequence.html) or [DList](http://hackage.haskell.org/package/dlist) monoids may be a superior choice.+This carrier also uses an 'IORef' to store its accumulator, which allows it a 'MonadUnliftIO' instance, but precludes backtracking when run in conjunction with 'Control.Effect.NonDet'.++@since 1.1.2.0+-}++module Control.Carrier.Accum.IORef+( -- * Accum carrier+ runAccum+, execAccum+, evalAccum+, AccumC(AccumC)+ -- * Accum effect+, module Control.Effect.Accum+) where++import Control.Algebra+import Control.Applicative (Alternative(..))+import Control.Effect.Accum+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.IORef+import qualified Data.Semigroup as S+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Carrier.Reader++-- | Run an 'Accum' effect with a 'Semigroup'-based log.+--+-- @+-- 'runAccum' w0 ('pure' a) = 'pure' (w0, a)+-- @+-- @+-- 'runAccum' w0 ('add' w) = 'pure' (w0 <> w, ())+-- @+-- @+-- 'runAccum' w0 ('add' w >> 'look') = 'pure' (w0 <> w, w0 <> w)+-- @+--+-- @since 1.1.2.0+runAccum :: MonadIO m => w -> AccumC w m a -> m (w, a)+runAccum start go = do+ ref <- liftIO (newIORef start)+ result <- runReader ref . runAccumC $ go+ final <- liftIO (readIORef ref)+ pure (final, result)+{-# INLINE runAccum #-}++-- | Run a 'Accum' effect with a 'Semigroup'-based log,+-- producing the final log and discarding the result value.+--+-- @+-- 'execAccum' w = 'fmap' 'fst' . 'runAccum' w+-- @+--+-- @since 1.1.2.0+execAccum :: MonadIO m => w -> AccumC w m a -> m w+execAccum w = fmap fst . runAccum w+{-# INLINE execAccum #-}++-- | Run a 'Accum' effect with a 'Semigroup'-based log,+-- producing the result value and discarding the final log.+--+-- @+-- 'evalAccum' w = 'fmap' 'snd' . 'runAccum' w+-- @+--+-- @since 1.1.2.0+evalAccum :: MonadIO m => w -> AccumC w m a -> m a+evalAccum w = fmap snd . runAccum w+{-# INLINE evalAccum #-}++-- | @since 1.1.2.0+newtype AccumC w m a = AccumC { runAccumC :: ReaderC (IORef w) m a }+ deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans, MonadUnliftIO)++instance (Algebra sig m, S.Semigroup w, MonadIO m) => Algebra (Accum w :+: sig) (AccumC w m) where+ alg hdl sig ctx = case sig of+ L accum -> do+ ref <- AccumC (ask @(IORef w))+ (<$ ctx) <$> case accum of+ Add w' -> liftIO (modifyIORef' ref (S.<> w'))+ Look -> liftIO (readIORef ref)+ R other -> AccumC (alg (runAccumC . hdl) (R other) ctx)+ {-# INLINE alg #-}
+ src/Control/Carrier/Accum/Strict.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | A carrier for 'Accum' effects.+This carrier performs its append operations strictly and thus avoids the space leaks inherent in lazy writer monads.+These appends are left-associative; as such, @[]@ is a poor choice of monoid for computations that entail many calls to 'tell'.+The [Seq](http://hackage.haskell.org/package/containersdocs/Data-Sequence.html) or [DList](http://hackage.haskell.org/package/dlist) monoids may be a superior choice.++@since 1.1.2.0+-}++module Control.Carrier.Accum.Strict+( -- * Accum carrier+ runAccum+, execAccum+, evalAccum+, AccumC(AccumC)+ -- * Accum effect+, module Control.Effect.Accum+) where++import Control.Algebra+import Control.Applicative (Alternative(..))+import Control.Effect.Accum+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 an 'Accum' effect with a 'Monoid'al log, applying a continuation to the final log and result.+--+-- @+-- 'runAccum' w0 ('pure' a) = 'pure' (w0, a)+-- @+-- @+-- 'runAccum' w0 ('add' w) = 'pure' (w0 <> w, ())+-- @+-- @+-- 'runAccum' w0 ('add' w >> 'look') = 'pure' (w0 <> w, w0 <> w)+-- @+--+-- @since 1.1.2.0+runAccum :: w -> AccumC w m a -> m (w, a)+runAccum = flip runAccumC+{-# INLINE runAccum #-}++-- | Run a 'Accum' effect (typically with a 'Monoid'al log),+-- producing the final log and discarding the result value.+--+-- @+-- 'execAccum' w = 'fmap' 'fst' . 'runAccum' w+-- @+--+-- @since 1.1.2.0+execAccum :: (Functor m) => w -> AccumC w m a -> m w+execAccum w = fmap fst . runAccum w+{-# INLINE execAccum #-}++-- | Run a 'Accum' effect (typically with a 'Monoid'al log),+-- producing the result value and discarding the final log.+--+-- @+-- 'evalAccum' w = 'fmap' 'snd' . 'runAccum' w+-- @+--+-- @since 1.1.2.0+evalAccum :: (Functor m) => w -> AccumC w m a -> m a+evalAccum w = fmap snd . runAccum w+{-# INLINE evalAccum #-}++-- | @since 1.1.2.0+newtype AccumC w m a = AccumC { runAccumC :: w -> m (w, a) }++instance Monoid w => MonadTrans (AccumC w) where+ lift ma = AccumC $ \_ -> (mempty, ) <$> ma+ {-# INLINE lift #-}++instance Functor m => Functor (AccumC w m) where+ fmap f ma = AccumC $ fmap (fmap f) . runAccumC ma+ {-# INLINE fmap #-}++instance (Monad m, Monoid w) => Applicative (AccumC w m) where+ pure a = AccumC $ const $ pure (mempty, a)+ {-# INLINE pure #-}++ mf <*> ma = AccumC $ \w -> do+ (w' , f) <- runAccumC mf w+ (w'', a) <- runAccumC ma $ mappend w w'+ let w''' = mappend w' w''+ return $ w''' `seq` (w''', f a)+ {-# INLINE (<*>) #-}++instance (Alternative m, Monad m, Monoid w) => Alternative (AccumC w m) where+ empty = lift empty+ {-# INLINE empty #-}++ ma1 <|> ma2 = AccumC $ \w -> runAccumC ma1 w <|> runAccumC ma2 w+ {-# INLINE (<|>) #-}++instance (Monad m, Monoid w) => Monad (AccumC w m) where+ ma >>= f = AccumC $ \w -> do+ (w', a) <- runAccumC ma w+ (w'', b) <- runAccumC (f a) $ mappend w w'+ let w''' = mappend w' w''+ return $ w''' `seq` (w''', b)+ {-# INLINE (>>=) #-}++instance (MonadPlus m, Monoid w) => MonadPlus (AccumC w m) where+ mzero = lift mzero+ {-# INLINE mzero #-}++ ma1 `mplus` ma2 = AccumC $ \w -> runAccumC ma1 w `mplus` runAccumC ma2 w+ {-# INLINE mplus #-}++instance (MonadFail m, Monoid w) => MonadFail (AccumC w m) where+ fail = AccumC . const . Fail.fail+ {-# INLINE fail #-}++instance (MonadFix m, Monoid w) => MonadFix (AccumC w m) where+ mfix ma = AccumC $ \w -> mfix $ flip runAccumC w . ma . snd+ {-# INLINE mfix #-}++instance (MonadIO m, Monoid w) => MonadIO (AccumC w m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (AccumC w m) where+ alg hdl sig ctx = AccumC $ \w -> case sig of+ L accum -> case accum of+ Add w' -> pure (w', ctx)+ Look -> pure (mempty, w <$ ctx)+ R other -> thread (uncurry runAccum ~<~ hdl) other (mempty, ctx)+ {-# INLINE alg #-}
src/Control/Carrier/Choose/Church.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}@@ -22,30 +24,38 @@ , module Control.Effect.Choose ) where -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)+import Control.Algebra+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif+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) -- | 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). --@@ -56,6 +66,7 @@ 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 (<*>) #-}@@ -74,8 +85,8 @@ mfix f = ChooseC $ \ fork leaf -> mfix (runChooseS (pure . pure) . f . head) >>= \case- a:|[] -> leaf a- a:|_ -> leaf a `fork` runChoose fork leaf (mfix (liftAll . fmap tail . runChooseS (pure . pure) . f))+ a :| [] -> leaf a+ a :| _ -> leaf a `fork` runChoose fork leaf (mfix (liftAll . fmap tail . runChooseS (pure . pure) . f)) where liftAll m = ChooseC $ \ fork leaf -> m >>= foldr1 fork . fmap leaf {-# INLINE mfix #-}@@ -88,9 +99,11 @@ lift m = ChooseC (\ _ leaf -> m >>= leaf) {-# INLINE lift #-} -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+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 dst :: Applicative m => ChooseC Identity (ChooseC m a) -> m (ChooseC Identity a)- dst = runIdentity . runChoose (liftA2 (liftA2 (<|>))) (pure . runChoose (liftA2 (<|>)) (pure . pure))+ dst = run . runChoose (liftA2 (liftA2 (<|>))) (pure . runChoose (liftA2 (<|>)) (pure . pure)) {-# INLINE alg #-}
src/Control/Carrier/Cull/Church.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-}@@ -13,49 +14,60 @@ 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 qualified 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+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 -- | 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 (ReaderC Bool (NonDetC m) a)+newtype CullC m a = CullC { runCullC :: 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 ->@@ -73,9 +85,10 @@ lift = CullC . lift . lift {-# INLINE lift #-} -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))))+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) {-# INLINE alg #-}
src/Control/Carrier/Cut/Church.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-}@@ -20,34 +21,47 @@ , module Control.Effect.NonDet ) where -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+import Control.Algebra+import Control.Applicative+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 -- | 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)@@ -56,6 +70,7 @@ 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 (<*>) #-}@@ -63,6 +78,7 @@ 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 (<|>) #-} @@ -94,12 +110,14 @@ lift m = CutC (\ cons nil _ -> m >>= flip cons nil) {-# INLINE lift #-} -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+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 dst :: Applicative m => CutC Identity (CutC m a) -> m (CutC Identity a)- dst = runIdentity . runCut (fmap . liftA2 (<|>) . runCut (fmap . (<|>) . pure) (pure empty) (pure cutfail)) (pure (pure empty)) (pure (pure cutfail))+ dst = run . runCut (fmap . liftA2 (<|>) . runCut (fmap . (<|>) . pure) (pure empty) (pure cutfail)) (pure (pure empty)) (pure (pure cutfail)) {-# INLINE alg #-}
+ src/Control/Carrier/Empty/Church.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+{-# 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+#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif+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 #-}
src/Control/Carrier/Empty/Maybe.hs view
@@ -14,18 +14,22 @@ 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 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+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) -- | Run an 'Empty' effect, returning 'Nothing' for empty computations, or 'Just' the result otherwise. --@@ -33,7 +37,7 @@ -- 'runEmpty' 'empty' = 'pure' 'Nothing' -- @ -- @--- 'runEmpty' ('pure' a) = 'Just' a+-- 'runEmpty' ('pure' a) = 'pure' ('Just' a) -- @ -- -- @since 1.0.0.0@@ -41,16 +45,43 @@ 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 (Applicative, Functor, Monad, MonadFix, MonadIO, MonadTrans)+ deriving (Algebra (Empty :+: sig), 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 #-}
+ src/Control/Carrier/Error/Church.hs view
@@ -0,0 +1,113 @@+{-# 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+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 #-}
src/Control/Carrier/Error/Either.hs view
@@ -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 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+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 -- | Run an 'Error' effect, returning uncaught errors in 'Left' and successful computations’ values in 'Right'. --@@ -34,27 +34,25 @@ -- '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 (Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadTrans)+ deriving (Algebra (Error e :+: sig), 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 #-}
src/Control/Carrier/Fail/Either.hs view
@@ -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 qualified 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 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,15 +37,12 @@ -- @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 (Alternative, Applicative, Functor, Monad, MonadFix, MonadIO, MonadPlus, MonadTrans)+ deriving (Algebra (Fail :+: sig), Alternative, Applicative, Functor, Monad, MonadFix, MonadIO, MonadPlus, MonadTrans) -instance (Algebra sig m, Effect sig) => Fail.MonadFail (FailC m) where+instance Algebra sig m => 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 #-}
+ src/Control/Carrier/Fresh/Church.hs view
@@ -0,0 +1,66 @@+{-# 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 #-}
src/Control/Carrier/Fresh/Strict.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-}@@ -11,20 +12,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 qualified 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 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. --@@ -38,6 +39,7 @@ -- @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. --@@ -51,12 +53,14 @@ -- @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 (StateC Int m a)+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, 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)))+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 #-}
src/Control/Carrier/Interpret.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -15,29 +16,31 @@ ( -- * Interpret carrier runInterpret , runInterpretState-, InterpretC(..)+, InterpretC(InterpretC) , Reifies-, Handler+, Interpreter -- * Re-exports , Algebra , Has , run ) where -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)+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 Control.Monad.IO.Unlift (MonadUnliftIO)+import Data.Functor.Const (Const(..))+import Data.Kind (Type)+import Unsafe.Coerce (unsafeCoerce) --- | 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 }+-- | 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) } class Reifies s a | s -> a where@@ -51,7 +54,7 @@ -- For more information on this technique, see the @reflection@ library. We use the formulation described in https://github.com/ekmett/reflection/issues/31 for better inlining. ----- Essentially we can view @k@ as internally a function of type @Reifies s a -> Tagged s r@, whch we can again view as just @a -> Tagged s r@ through @unsafeCoerce@. After this coercion, we just apply the function to @a@.+-- Essentially we can view @k@ as internally a function of type @Reifies s a -> Tagged s r@, which we can again view as just @a -> Tagged s r@ through @unsafeCoerce@. After this coercion, we just apply the function to @a@. reify :: a -> (forall s . Reifies s a => Const r s) -> r reify a k = unsafeCoerce (Magic k) a @@ -62,34 +65,37 @@ -- -- @since 1.0.0.0 runInterpret- :: (HFunctor eff, Monad m)- => (forall x . eff m x -> m x)- -> (forall s . Reifies s (Handler eff m) => InterpretC s eff m a)+ :: (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) -> m a-runInterpret f m = reify (Handler (InterpretC . f . handleCoercible)) (go m) where+runInterpret f m = reify (Interpreter (\ hdl sig -> InterpretC . f (runInterpretC . hdl) sig)) (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- :: (HFunctor eff, Monad m)- => (forall x . s -> eff (StateC s m) x -> m (s, x))+ :: (forall ctx n x . Functor ctx => Handler ctx n (StateC s m) -> eff n x -> s -> ctx () -> m (s, ctx x)) -> s- -> (forall t . Reifies t (Handler eff (StateC s m)) => InterpretC t eff (StateC s m) a)+ -> (forall t . Reifies t (Interpreter eff (StateC s m)) => InterpretC t eff (StateC s m) a) -> m (s, a) runInterpretState handler state m = runState state- $ runInterpret (\e -> StateC (`handler` e)) m+ $ runInterpret (\ hdl sig ctx -> StateC (flip (handler hdl sig) ctx)) m+{-# INLINE runInterpretState #-} -- | @since 1.0.0.0-newtype InterpretC s (sig :: (* -> *) -> * -> *) m a = InterpretC (m a)- deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus)+newtype InterpretC s (sig :: (Type -> Type) -> (Type -> Type)) m a = InterpretC { runInterpretC :: m a }+ deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadUnliftIO) instance MonadTrans (InterpretC s sig) where lift = InterpretC+ {-# INLINE lift #-} -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))+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 #-}
src/Control/Carrier/Lift.hs view
@@ -12,28 +12,31 @@ , module Control.Effect.Lift ) where -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+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.Monad.IO.Unlift (MonadUnliftIO) -- | 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)- deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus)+ deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadUnliftIO) instance MonadTrans LiftC where lift = LiftC+ {-# INLINE lift #-} instance Monad m => Algebra (Lift m) (LiftC m) where- alg (LiftWith with k) = LiftC (with (Identity ()) (fmap Identity . runM . runIdentity)) >>= k . runIdentity+ alg hdl (LiftWith with) = LiftC . with (runM . hdl)+ {-# INLINE alg #-}
src/Control/Carrier/NonDet/Church.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-}@@ -22,18 +23,22 @@ , module Control.Effect.NonDet ) where -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+import Control.Algebra+import Control.Applicative+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 -- | 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 ('<|>')@@ -42,6 +47,7 @@ -> 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. --@@ -57,12 +63,14 @@ -- @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). --@@ -73,6 +81,7 @@ 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 (<*>) #-}@@ -80,7 +89,9 @@ instance Alternative (NonDetC m) where empty = NonDetC (\ _ _ nil -> nil) {-# INLINE empty #-}- NonDetC l <|> NonDetC r = NonDetC $ \ fork leaf nil -> fork (l fork leaf nil) (r fork leaf nil)++ NonDetC l <|> NonDetC r = NonDetC $ \ fork leaf nil ->+ l fork leaf nil `fork` r fork leaf nil {-# INLINE (<|>) #-} instance Monad (NonDetC m) where@@ -112,10 +123,12 @@ lift m = NonDetC (\ _ leaf _ -> m >>= leaf) {-# INLINE lift #-} -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+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 dst :: Applicative m => NonDetC Identity (NonDetC m a) -> m (NonDetC Identity a)- dst = runIdentity . runNonDet (liftA2 (liftA2 (<|>))) (Identity . runNonDetA) (pure (pure empty))+ dst = run . runNonDet (liftA2 (liftA2 (<|>))) (pure . runNonDetA) (pure (pure empty)) {-# INLINE alg #-}
src/Control/Carrier/Reader.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -15,14 +16,15 @@ , module Control.Effect.Reader ) where -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+import Control.Algebra+import Control.Applicative+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.Monad.IO.Unlift -- | Run a 'Reader' effect with the passed environment value. --@@ -48,16 +50,24 @@ 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 (<|>) #-} @@ -84,7 +94,12 @@ {-# INLINE lift #-} instance Algebra sig m => Algebra (Reader r :+: sig) (ReaderC r m) where- 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))+ 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 {-# INLINE alg #-}++instance MonadUnliftIO m => MonadUnliftIO (ReaderC r m) where+ withRunInIO inner = ReaderC $ \ r -> withRunInIO $ \ run -> inner (run . runReader r)+ {-# INLINE withRunInIO #-}
+ src/Control/Carrier/State/Church.hs view
@@ -0,0 +1,129 @@+{-# 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+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 #-}
+ src/Control/Carrier/State/IORef.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | A carrier for the 'State' effect. It uses an 'IORef' internally to handle its state, and thus admits a 'MonadUnliftIO' instance. Because the state operations are performed impurely, this carrier will not lose state effects even with nefarious uses of 'Control.Effect.Lift.liftWith'.++Unlike the other carriers for 'State', this carrier's effects will not backtrack when run in conjuction with 'Control.Effect.NonDet' effects.++@since 1.1.2.0+-}+module Control.Carrier.State.IORef+( -- * Impure state carrier+ runState+, runStateRef+, evalState+, execState+, StateC(..)+-- * State effect+, module Control.Effect.State+) where++import Control.Algebra+import Control.Applicative (Alternative(..))+import Control.Carrier.Reader+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.IO.Unlift+import Control.Monad.Trans.Class+import Data.IORef++-- | Run a 'State' effect starting from the passed value.+--+-- @+-- 'runState' s ('pure' a) = 'pure' (s, a)+-- @+-- @+-- 'runState' s 'get' = 'pure' (s, s)+-- @+-- @+-- 'runState' s ('put' t) = 'pure' (t, ())+-- @+--+-- @since 1.1.2.0+runState :: MonadIO m => s -> StateC s m a -> m (s, a)+runState s x = do+ ref <- liftIO $ newIORef s+ result <- runReader ref . runStateC $ x+ final <- liftIO . readIORef $ ref+ pure (final, result)+{-# INLINE[3] runState #-}++-- | Run a 'State' effect starting from the passed 'IORef'. This function is lawless, given that the underlying IORef can be modified by another thread.+--+-- @since 1.1.2.0+runStateRef :: MonadIO m => IORef s -> StateC s m a -> m (s, a)+runStateRef ref x = do+ result <- runReader ref . runStateC $ x+ final <- liftIO . readIORef $ ref+ pure (final, result)+{-# INLINE[3] runStateRef #-}++-- | Run a 'State' effect, yielding the result value and discarding the final state.+--+-- @+-- 'evalState' s m = 'fmap' 'snd' ('runState' s m)+-- @+--+-- @since 1.1.2.0+evalState :: forall s m a . MonadIO m => s -> StateC s m a -> m a+evalState s x = do+ ref <- liftIO $ newIORef s+ runReader ref . runStateC $ x+{-# INLINE[3] evalState #-}++-- | Run a 'State' effect, yielding the final state and discarding the return value.+--+-- @+-- 'execState' s m = 'fmap' 'fst' ('runState' s m)+-- @+--+-- @since 1.1.2.0+execState :: forall s m a . MonadIO m => s -> StateC s m a -> m s+execState s = fmap fst . runState s+{-# INLINE[3] execState #-}++-- | @since 1.1.2.0+newtype StateC s m a = StateC { runStateC :: ReaderC (IORef s) m a }+ deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans, MonadUnliftIO)++instance (MonadIO m, Algebra sig m) => Algebra (State s :+: sig) (StateC s m) where+ alg hdl sig ctx = case sig of+ L act -> do+ ref <- StateC (ask @(IORef s))+ (<$ ctx) <$> case act of+ Put s -> liftIO (writeIORef ref s)+ Get -> liftIO (readIORef ref)+ R other -> StateC (alg (runStateC . hdl) (R other) ctx)+ {-# INLINE alg #-}
src/Control/Carrier/State/Lazy.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -21,14 +22,14 @@ , module Control.Effect.State ) where -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+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 -- | 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. --@@ -70,7 +71,7 @@ {-# INLINE[3] execState #-} -- | @since 1.0.0.0-newtype StateC s m a = StateC { runStateC :: s -> m (s, a) }+newtype StateC s m a = StateC (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@@ -79,11 +80,13 @@ 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 (*>) #-} @@ -96,6 +99,7 @@ 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 (<|>) #-} @@ -117,8 +121,9 @@ lift m = StateC (\ s -> (,) s <$> m) {-# INLINE lift #-} -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))+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) {-# INLINE alg #-}
src/Control/Carrier/State/Strict.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -21,14 +22,14 @@ , module Control.Effect.State ) where -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+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 -- | Run a 'State' effect starting from the passed value. --@@ -77,17 +78,20 @@ 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 (<|>) #-} @@ -115,8 +119,9 @@ lift m = StateC (\ s -> (,) s <$> m) {-# INLINE lift #-} -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))+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) {-# INLINE alg #-}
src/Control/Carrier/Throw/Either.hs view
@@ -10,29 +10,32 @@ 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 qualified 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 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 (ErrorC e m a)+newtype ThrowC e m a = ThrowC { runThrowC :: ErrorC e m a } deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans) -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)))+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 #-}
src/Control/Carrier/Trace/Ignoring.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | A carrier for the 'Control.Effect.Trace' effect that ignores all traced results. Useful when you wish to disable tracing without removing all trace statements.+-- | A carrier for the 'Trace' effect that ignores all traced results. Useful when you wish to disable tracing without removing all trace statements. -- -- @since 1.0.0.0 module Control.Carrier.Trace.Ignoring@@ -15,14 +17,14 @@ , module Control.Effect.Trace ) where -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 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 -- | Run a 'Trace' effect, ignoring all traces. --@@ -36,6 +38,7 @@ -- @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)@@ -46,6 +49,7 @@ {-# INLINE lift #-} instance Algebra sig m => Algebra (Trace :+: sig) (TraceC m) where- alg (L trace) = traceCont trace- alg (R other) = TraceC (alg (handleCoercible other))+ alg hdl = \case+ L (Trace _) -> pure+ R other -> TraceC . alg (runTrace . hdl) other {-# INLINE alg #-}
src/Control/Carrier/Trace/Printing.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | A carrier for the 'Control.Effect.Trace' effect that prints all traced results to stderr.+-- | A carrier for the 'Trace' effect that prints all traced results to stderr. -- -- @since 1.0.0.0 module Control.Carrier.Trace.Printing@@ -15,15 +16,15 @@ , module Control.Effect.Trace ) where -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+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 -- | Run a 'Trace' effect, printing traces to 'stderr'. --@@ -37,6 +38,7 @@ -- @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)@@ -47,6 +49,7 @@ {-# INLINE lift #-} instance (MonadIO m, Algebra sig m) => Algebra (Trace :+: sig) (TraceC m) where- alg (L (Trace s k)) = liftIO (hPutStrLn stderr s) *> k- alg (R other) = TraceC (alg (handleCoercible other))+ alg hdl sig ctx = case sig of+ L (Trace s) -> ctx <$ liftIO (hPutStrLn stderr s)+ R other -> TraceC (alg (runTrace . hdl) other ctx) {-# INLINE alg #-}
src/Control/Carrier/Trace/Returning.hs view
@@ -1,31 +1,32 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | A carrier for the 'Control.Effect.Trace' effect that aggregates and returns all traced values.+-- | A carrier for the 'Trace' effect that aggregates and returns all traced values. -- -- @since 1.0.0.0 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 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(..))+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(..)) -- | Run a 'Trace' effect, returning all traces as a list. --@@ -38,12 +39,15 @@ -- -- @since 1.0.0.0 runTrace :: Functor m => TraceC m a -> m ([String], a)-runTrace (TraceC m) = first (($[]) . appEndo) <$> runWriter m+runTrace (TraceC m) = first (($ []) . appEndo) <$> runWriter m+{-# INLINE runTrace #-} -- | @since 1.0.0.0-newtype TraceC m a = TraceC (WriterC (Endo [String]) m a)+newtype TraceC m a = TraceC { runTraceC :: WriterC (Endo [String]) m a } deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans) -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)))+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 #-}
+ src/Control/Carrier/Writer/Church.hs view
@@ -0,0 +1,82 @@+{-# 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 #-}
src/Control/Carrier/Writer/Strict.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-}@@ -15,20 +17,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 qualified 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 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. --@@ -55,20 +57,22 @@ -- | A space-efficient carrier for 'Writer' effects, implemented atop "Control.Carrier.State.Strict". -- -- @since 1.0.0.0-newtype WriterC w m a = WriterC (StateC w m a)+newtype WriterC w m a = WriterC { runWriterC :: StateC w m a } deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans) -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)))+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 {-# INLINE alg #-}
+ src/Control/Effect/Accum.hs view
@@ -0,0 +1,66 @@+{- | An effect allowing writes to an accumulated quantity alongside a computed value,+and reads from the accumulator.+An 'Accum' @w@ effect keeps track of a monoidal datum of type @w@ and strictly appends to that monoidal value with the 'add' effect.+Previous writes to that value can be read with the 'look' effect.++Predefined carriers:++* "Control.Carrier.Accum.Church"+* "Control.Carrier.Accum.Strict". (A lazy carrier is not provided due to the inherent space leaks associated with lazy accumulation monads, similar to lazy writer monads.)+* "Control.Monad.Trans.Accum"++If 'Accum' @w@ is the last effect in a stack, it can be interpreted to a function @w -> (w, a)@ given some result type @a@ and the presence of a 'Monoid' instance for @w@.++-- | @since 1.1.2.0+-}++module Control.Effect.Accum+( -- * Accumulation effect+ Accum(..)+, add+, look+, looks+ -- * Re-exports+, Algebra+, Has+, run+) where++import Control.Algebra+import Control.Effect.Accum.Internal (Accum(..))+++-- | Write a value to the log.+--+-- @+-- 'runAccum' w0 ('add' w '>>' m) = 'Data.Bifunctor.first' ('mappend' w) '<$>' 'runAccum' w0 m+-- 'runAccum' w0 ('add' w '>>' m) = runAccum (w0 <> w) m+-- @+--+-- @since 1.1.2.0+add :: Has (Accum w) sig m => w -> m ()+add w = send (Add w)+{-# INLINE add #-}++-- | Look up the previous accumulation+--+-- @+-- 'runAccum' w 'look' = 'return' (w, w)+-- 'runAccum' w ('look' >>= continuation) = 'runAccum' w (continuation w)+-- @+--+-- @since 1.1.2.0+look :: Has (Accum w) sig m => m w+look = send Look+{-# INLINE look #-}++-- | Look up the previous accumulation and apply a function to it.+--+-- @+-- looks f = fmap f look+-- @+--+-- @since 1.1.2.0+looks :: Has (Accum w) sig m => (w -> a) -> m a+looks f = fmap f look+{-# INLINE looks #-}
+ src/Control/Effect/Accum/Internal.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+module Control.Effect.Accum.Internal+( Accum(..)+) where++import Data.Kind (Type)++-- | @since 1.1.2.0+data Accum w (m :: Type -> Type) k where+ Add :: w -> Accum w m ()+ Look :: Accum w m w
src/Control/Effect/Catch.hs view
@@ -12,7 +12,6 @@ , catchError -- * Re-exports , Algebra-, Effect , Has , run ) where@@ -30,4 +29,5 @@ -- -- @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 pure)+catchError m h = send (Catch m h)+{-# INLINE catchError #-}
src/Control/Effect/Catch/Internal.hs view
@@ -1,22 +1,10 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-} 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- = 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)+data Catch e m k where+ Catch :: m a -> (e -> m a) -> Catch e m a
src/Control/Effect/Choose.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} {- | An effect modelling nondeterminism without failure (one or more successful results).@@ -24,14 +25,21 @@ , Choosing(..) -- * Re-exports , Algebra-, Effect , Has , run ) where import Control.Algebra+import qualified Control.Applicative as A import Control.Effect.Choose.Internal (Choose(..)) import Control.Effect.Empty+import Control.Monad (MonadPlus)+import Control.Monad.Fail as Fail+import Control.Monad.Fix+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Zip import Data.Bool (bool) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Semigroup as S@@ -53,7 +61,8 @@ -- -- @since 1.0.0.0 (<|>) :: Has Choose sig m => m a -> m a -> m a-(<|>) a b = send (Choose (bool b a))+a <|> b = send Choose >>= bool b a+{-# INLINE (<|>) #-} infixl 3 <|> @@ -69,6 +78,7 @@ -- @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. --@@ -79,6 +89,7 @@ -- @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. --@@ -89,6 +100,7 @@ -- @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. --@@ -99,14 +111,46 @@ -- @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 newtype Choosing m a = Choosing { getChoosing :: m a }+ deriving (Algebra sig, Applicative, Foldable, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadUnliftIO, MonadZip) 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 #-}++instance (Has Choose sig m, Has Empty sig m) => A.Alternative (Choosing m) where+ empty = mempty+ {-# INLINE empty #-}++ (<|>) = mappend+ {-# INLINE (<|>) #-}++instance (Has Choose sig m, Has Empty sig m) => MonadPlus (Choosing m)++instance MonadTrans Choosing where+ lift = Choosing+ {-# INLINE lift #-}++instance Traversable m => Traversable (Choosing m) where+ sequenceA (Choosing m) = fmap Choosing (sequenceA m)+ {-# INLINE sequenceA #-}++ traverse f (Choosing m) = fmap Choosing (traverse f m)+ {-# INLINE traverse #-}++ sequence (Choosing m) = fmap Choosing (sequence m)+ {-# INLINE sequence #-}++ mapM f (Choosing m) = fmap Choosing (mapM f m)+ {-# INLINE mapM #-}
src/Control/Effect/Choose/Internal.hs view
@@ -1,16 +1,11 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} module Control.Effect.Choose.Internal ( Choose(..) ) where -import Control.Effect.Class-import GHC.Generics (Generic1)+import Data.Kind (Type) -- | @since 1.0.0.0-newtype Choose m k- = Choose (Bool -> m k)- deriving (Functor, Generic1)--instance HFunctor Choose-instance Effect Choose+data Choose (m :: Type -> Type) k where+ Choose :: Choose m Bool
− src/Control/Effect/Class.hs
@@ -1,182 +0,0 @@-{-# 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 #-}
src/Control/Effect/Cull.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-} {- | 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.@@ -17,7 +15,6 @@ , cull -- * Re-exports , Algebra-, Effect , Has , run ) where@@ -27,19 +24,10 @@ -- | 'Cull' effects are used with 'Control.Effect.Choose' to provide control over branching. -- -- @since 0.1.2.0-data Cull m k- = forall a . Cull (m a) (a -> m k)+data Cull m k where+ Cull :: m a -> Cull m a -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. -- -- @@@ -48,4 +36,5 @@ -- -- @since 0.1.2.0 cull :: Has Cull sig m => m a -> m a-cull m = send (Cull m pure)+cull m = send (Cull m)+{-# INLINE cull #-}
src/Control/Effect/Cut.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-} {- | Provides an effect to delimit backtracking in a given nondeterministic context. This effect is used in concert with 'Control.Effect.NonDet.NonDet'. @@ -22,7 +19,6 @@ , cut -- * Re-exports , Algebra-, Effect , Has , run ) where@@ -33,22 +29,11 @@ -- | 'Cut' effects are used with 'Control.Effect.Choose' to provide control over backtracking. -- -- @since 0.1.2.0-data Cut m k- = Cutfail- | forall a . Call (m a) (a -> m k)+data Cut m k where+ Cutfail :: Cut m a+ Call :: m a -> Cut m a -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.@@ -73,7 +58,7 @@ -- -- @since 0.1.2.0 call :: Has Cut sig m => m a -> m a-call m = send (Call m pure)+call m = send (Call m) {-# INLINE call #-} -- | Commit to the current branch, preventing backtracking within the nearest enclosing 'call' (if any) on failure.
src/Control/Effect/Empty.hs view
@@ -4,7 +4,9 @@ Predefined carriers: -* "Control.Carrier.Empty.Maybe".+* @"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'@ * If 'Empty' is the last effect in a stack, it can be interpreted directly to a 'Maybe'. @since 1.0.0.0@@ -17,7 +19,6 @@ , guard -- * Re-exports , Algebra-, Effect , Has , run ) where@@ -36,6 +37,7 @@ -- @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'. --@@ -43,3 +45,4 @@ guard :: Has Empty sig m => Bool -> m () guard True = pure () guard False = empty+{-# INLINE guard #-}
src/Control/Effect/Empty/Internal.hs view
@@ -1,16 +1,11 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTSyntax #-} {-# LANGUAGE KindSignatures #-} module Control.Effect.Empty.Internal ( Empty(..) ) where -import Control.Effect.Class-import GHC.Generics (Generic1)+import Data.Kind (Type) -- | @since 1.0.0.0-data Empty (m :: * -> *) k = Empty- deriving (Functor, Generic1)--instance HFunctor Empty-instance Effect Empty+data Empty (m :: Type -> Type) k where+ Empty :: Empty m a
src/Control/Effect/Error.hs view
@@ -4,6 +4,7 @@ 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@.
src/Control/Effect/Fail.hs view
@@ -3,7 +3,7 @@ {- | An effect providing failure with an error message. -This effect is invoked through the 'Control.Monad.Fail.fail' method from 'Control.Monad.Fail.MonadFail'.+This effect is invoked through the 'Fail.fail' method from 'Fail.MonadFail'. Predefined carriers: @@ -19,13 +19,12 @@ , Fail.MonadFail(..) -- * Re-exports , Algebra-, Effect , Has , run ) where -import Control.Effect.Throw-import qualified Control.Monad.Fail as Fail+import Control.Effect.Throw+import Control.Monad.Fail as Fail -- | @since 0.1.0.0 type Fail = Throw String
src/Control/Effect/Fresh.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {- | 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.Strict".-+* "Control.Carrier.Fresh.Church"+* "Control.Carrier.Fresh.Strict" -} module Control.Effect.Fresh ( -- * Fresh effect@@ -14,20 +13,16 @@ , fresh -- * Re-exports , Algebra-, Effect , Has , run ) where import Control.Algebra-import GHC.Generics (Generic1)+import Data.Kind (Type) -- | @since 0.1.0.0-newtype Fresh m k = Fresh (Int -> m k)- deriving (Functor, Generic1)--instance HFunctor Fresh-instance Effect Fresh+data Fresh (m :: Type -> Type) k where+ Fresh :: Fresh m Int -- | Produce a fresh (i.e. unique) 'Int'.@@ -38,4 +33,5 @@ -- -- @since 0.1.0.0 fresh :: Has Fresh sig m => m Int-fresh = send (Fresh pure)+fresh = send Fresh+{-# INLINE fresh #-}
src/Control/Effect/Labelled.hs view
@@ -37,24 +37,37 @@ import Control.Effect.Sum (reassociateSumL) 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.Kind (Type)+import Data.Functor.Identity+import Data.Kind -- | 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, Effect, Functor, HFunctor, Monad, Fail.MonadFail, MonadIO, MonadPlus, MonadTrans)+ deriving+ ( Alternative+ , Applicative+ , Functor+ , Monad+ , Fail.MonadFail+ , MonadFix -- ^ @since 1.1.1+ , 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), 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))+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) {-# INLINE alg #-} @@ -104,7 +117,7 @@ -- -- @since 1.0.2.0 sendLabelled :: forall label eff sig m a . HasLabelled label eff sig m => eff m a -> m a-sendLabelled = alg . injLabelled @label . Labelled+sendLabelled op = runIdentity <$> alg (fmap Identity . runIdentity) (injLabelled @label (Labelled op)) (Identity ()) {-# INLINABLE sendLabelled #-} @@ -112,18 +125,28 @@ -- -- @since 1.0.2.0 newtype UnderLabel (label :: k) (sub :: (Type -> Type) -> (Type -> Type)) (m :: Type -> Type) a = UnderLabel (m a)- deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadIO, MonadPlus)+ deriving+ ( Alternative+ , Applicative+ , Functor+ , Monad+ , Fail.MonadFail+ , MonadFix -- ^ @since 1.1.1+ , MonadIO+ , MonadPlus+ ) -- | @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, 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))+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 {-# INLINE alg #-}
src/Control/Effect/Lift.hs view
@@ -21,7 +21,6 @@ , liftWith -- * Re-exports , Algebra-, Effect , Has , run ) where@@ -35,7 +34,8 @@ -- -- @since 1.0.0.0 sendM :: (Has (Lift n) sig m, Functor n) => n a -> m a-sendM m = send (LiftWith (\ ctx _ -> (<$ ctx) <$> m) pure)+sendM m = liftWith (\ _ ctx -> (<$ ctx) <$> m)+{-# INLINE sendM #-} -- | A type-restricted variant of 'sendM' for 'IO' actions. --@@ -44,6 +44,7 @@ -- @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.@@ -51,16 +52,17 @@ -- This can be used to provide interoperation with @base@ functionality like @"Control.Exception".'Control.Exception.catch'@: -- -- @--- 'liftWith' $ \\ ctx hdl -> 'Control.Exception.catch' (hdl (m <$ ctx)) (hdl . (<$ ctx) . h)+-- 'liftWith' $ \\ hdl ctx -> 'Control.Exception.catch' (hdl (m <$ ctx)) (hdl . (<$ ctx) . h) -- @ ----- 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.+-- 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. -- -- 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 => ctx () -> (forall a . ctx (m a) -> n (ctx a)) -> n (ctx a))+ => (forall ctx . Functor ctx => Handler ctx m n -> ctx () -> n (ctx a)) -> m a-liftWith with = send (LiftWith with pure)+liftWith with = send (LiftWith with)+{-# INLINE liftWith #-}
src/Control/Effect/Lift/Internal.hs view
@@ -1,25 +1,11 @@-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} module Control.Effect.Lift.Internal ( Lift(..) ) where -import Control.Effect.Class-import Data.Functor.Compose+import Control.Algebra.Handler (Handler) -- | @since 1.0.0.0-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)+data Lift sig m k where+ LiftWith :: (forall ctx . Functor ctx => Handler ctx m sig -> ctx () -> sig (ctx a)) -> Lift sig m a
src/Control/Effect/NonDet.hs view
@@ -20,7 +20,6 @@ -- * Re-exports , Alternative(..) , Algebra-, Effect , Has , MonadPlus(..) , guard@@ -53,12 +52,14 @@ -- @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.
src/Control/Effect/Reader.hs view
@@ -21,7 +21,6 @@ , local -- * Re-exports , Algebra-, Effect , Has , run ) where@@ -37,7 +36,7 @@ -- -- @since 0.1.0.0 ask :: Has (Reader r) sig m => m r-ask = send (Ask pure)+ask = send Ask {-# INLINE ask #-} -- | Project a function out of the current environment value.@@ -48,7 +47,7 @@ -- -- @since 0.1.0.0 asks :: Has (Reader r) sig m => (r -> a) -> m a-asks f = send (Ask (pure . f))+asks = (`fmap` ask) {-# INLINE asks #-} -- | Run a computation with an environment value locally modified by the passed function.@@ -59,5 +58,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 pure)+local f m = send (Local f m) {-# INLINE local #-}
src/Control/Effect/Reader/Internal.hs view
@@ -1,23 +1,9 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-} module Control.Effect.Reader.Internal ( Reader(..) ) where -import Control.Effect.Class- -- | @since 0.1.0.0-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)+data Reader r m k where+ Ask :: Reader r m r+ Local :: (r -> r) -> m a -> Reader r m a
src/Control/Effect/Reader/Labelled.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | Labelled 'Reader' operations. --@@ -14,8 +14,8 @@ , local -- * Re-exports , Algebra-, Effect , Has+, HasLabelled , run ) where
src/Control/Effect/State.hs view
@@ -4,8 +4,11 @@ Predefined carriers: -* "Control.Carrier.State.Strict", which is strict in its updates.+* "Control.Carrier.State.Strict", which is strict in its updates; a good default choice. * "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.Carrier.State.Church", which uses continuation-passing style rather than tuple-passing; this may increase performance in some circumstances.+* "Control.Carrier.State.IORef", which performs its updates impurely via an 'Data.IORef.IORef', which admits a 'Control.Monad.IO.Unlift.MonadUnliftIO' instance but precludes rollback during backtracking.+* "Control.Monad.Trans.RWS.CPS" * "Control.Monad.Trans.RWS.Lazy" * "Control.Monad.Trans.RWS.Strict" * "Control.Monad.Trans.State.Lazy"@@ -25,7 +28,6 @@ , state -- * Re-exports , Algebra-, Effect , Has , run ) where@@ -41,7 +43,7 @@ -- -- @since 0.1.0.0 get :: Has (State s) sig m => m s-get = send (Get pure)+get = send Get {-# INLINEABLE get #-} -- | Project a function out of the current state value.@@ -52,7 +54,7 @@ -- -- @since 0.1.0.0 gets :: Has (State s) sig m => (s -> a) -> m a-gets f = send (Get (pure . f))+gets = (`fmap` get) {-# INLINEABLE gets #-} -- | Replace the state value with a new value.@@ -63,7 +65,7 @@ -- -- @since 0.1.0.0 put :: Has (State s) sig m => s -> m ()-put s = send (Put s (pure ()))+put s = send (Put s) {-# INLINEABLE put #-} -- | Replace the state value with the result of applying a function to the current state value.
src/Control/Effect/State/Internal.hs view
@@ -1,17 +1,12 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} module Control.Effect.State.Internal ( State(..) ) where -import Control.Effect.Class-import GHC.Generics (Generic1)+import Data.Kind (Type) -- | @since 0.1.0.0-data State s m k- = Get (s -> m k)- | Put s (m k)- deriving (Functor, Generic1)--instance HFunctor (State s)-instance Effect (State s)+data State s (m :: Type -> Type) k where+ Get :: State s m s+ Put :: s -> State s m ()
src/Control/Effect/State/Labelled.hs view
@@ -17,8 +17,8 @@ , state -- * Re-exports , Algebra-, Effect , Has+, HasLabelled , run ) where
src/Control/Effect/Sum.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -19,22 +19,17 @@ , reassociateSumL ) where -import Control.Effect.Class-import Data.Kind (Constraint)-import GHC.Generics (Generic1)+import Data.Kind (Constraint, Type) -- | Higher-order sums are used to combine multiple effects into a signature, typically by chaining on the right.-data (f :+: g) (m :: * -> *) k+data (f :+: g) (m :: Type -> Type) k = L (f m k) | R (g m k)- deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)+ deriving (Eq, Foldable, Functor, 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.@@ -42,7 +37,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 :: (* -> *) -> (* -> *)) sup where+class Member (sub :: (Type -> Type) -> (Type -> Type)) sup where -- | Inject a member of a signature into the signature. inj :: sub m a -> sup m a
src/Control/Effect/Throw.hs view
@@ -11,9 +11,9 @@ ( -- * Throw effect Throw(..) , throwError+, liftEither -- * Re-exports , Algebra-, Effect , Has , run ) where@@ -23,6 +23,17 @@ -- | Throw an error, escaping the current computation up to the nearest 'Control.Effect.Catch.catchError' (if any). --+-- @+-- runThrow (throwError e >>= k) = runThrow (throwError e)+-- @+-- -- @since 0.1.0.0 throwError :: Has (Throw e) sig m => e -> m a throwError = send . Throw+{-# INLINE throwError #-}++-- | Lifts an @'Either' e@ into Monad m with effect @'Throw' e@+--+-- @since 1.1.0.0+liftEither :: Has (Throw e) sig m => Either e a -> m a+liftEither = either throwError return
src/Control/Effect/Throw/Internal.hs view
@@ -1,16 +1,11 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTSyntax #-} {-# LANGUAGE KindSignatures #-} module Control.Effect.Throw.Internal ( Throw(..) ) where -import Control.Effect.Class-import GHC.Generics (Generic1)+import Data.Kind (Type) -- | @since 1.0.0.0-newtype Throw e (m :: * -> *) k = Throw e- deriving (Functor, Generic1)--instance HFunctor (Throw e)-instance Effect (Throw e)+newtype Throw e (m :: Type -> Type) k where+ Throw :: e -> Throw e m a
src/Control/Effect/Trace.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {- | An effect that provides a record of 'String' values ("traces") aggregate during the execution of a given computation. Predefined carriers:@@ -18,26 +17,20 @@ , trace -- * Re-exports , Algebra-, Effect , Has , run ) where import Control.Algebra-import GHC.Generics (Generic1)+import Data.Kind (Type) -- | @since 0.1.0.0-data Trace m k = Trace- { traceMessage :: String- , traceCont :: m k- }- deriving (Functor, Generic1)--instance HFunctor Trace-instance Effect Trace+data Trace (m :: Type -> Type) k where+ Trace :: { traceMessage :: String } -> Trace m () -- | Append a message to the trace log. -- -- @since 0.1.0.0 trace :: Has Trace sig m => String -> m ()-trace message = send (Trace message (pure ()))+trace message = send (Trace message)+{-# INLINE trace #-}
src/Control/Effect/Writer.hs view
@@ -5,9 +5,12 @@ 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@.@@ -24,13 +27,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. --@@ -40,7 +43,7 @@ -- -- @since 0.1.0.0 tell :: Has (Writer w) sig m => w -> m ()-tell w = send (Tell w (pure ()))+tell w = send (Tell w) {-# INLINE tell #-} -- | Run a computation, returning the pair of its output and its result.@@ -51,18 +54,18 @@ -- -- @since 0.2.0.0 listen :: Has (Writer w) sig m => m a -> m (w, a)-listen m = send (Listen m (curry pure))+listen m = send (Listen m) {-# 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' ('Data.Bifunctor.first' f) ('listen' m)+-- 'listens' f m = 'fmap' ('first' f) ('listen' m) -- @ -- -- @since 0.2.0.0 listens :: Has (Writer w) sig m => (w -> b) -> m a -> m (b, a)-listens f m = send (Listen m (curry pure . f))+listens f = fmap (first f) . listen {-# INLINE listens #-} -- | Run a computation, modifying its output with the passed function.@@ -73,5 +76,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 pure)+censor f m = send (Censor f m) {-# INLINE censor #-}
src/Control/Effect/Writer/Internal.hs view
@@ -1,28 +1,10 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-} module Control.Effect.Writer.Internal ( Writer(..) ) where -import Control.Effect.Class- -- | @since 0.1.0.0-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 #-}+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
+ test/Accum.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Accum+( tests+) where++import qualified Control.Carrier.Accum.Church as C.Accum.Church+import qualified Control.Carrier.Accum.Strict as C.Accum.Strict+import Control.Effect.Accum+#if MIN_VERSION_transformers(0,5,4)+import qualified Control.Monad.Trans.Accum as T.Accum+import Data.Tuple (swap)+#endif+import Gen+import qualified Monad+import qualified MonadFix+import Data.Bifunctor (first)++tests :: TestTree+tests = testGroup "Accum"+ [ testGroup "AccumC (Church)" $+ [ testMonad+ , testMonadFix+ , testAccum+ ] >>= ($ runC (C.Accum.Church.runAccum (curry pure)))+ , testGroup "AccumC (Strict)" $+ [ testMonad+ , testMonadFix+ , testAccum+ ] >>= ($ runC C.Accum.Strict.runAccum)+#if MIN_VERSION_transformers(0,5,4)+ , testGroup "AccumT" $ testAccum (runC (fmap (fmap swap) . flip T.Accum.runAccumT))+#endif+ ] where+ testMonad run = Monad.test (m (gen0 w) (\_ _ -> [])) a b c initial run+ testMonadFix run = MonadFix.test (m (gen0 w) (\_ _ -> [])) a b initial run+ testAccum run = Accum.test (m (gen0 w) (\_ _ -> [])) a w run+ initial = pair <*> w <*> unit++gen0+ :: forall w sig m a+ . (Has (Accum w) sig m, Arg w, Vary w, Show w)+ => GenTerm w+ -> GenTerm a+ -> [GenTerm (m a)]+gen0 w a =+ [ infixL 4 "<$" (<$) <*> a <*> (label "add" add <*> w)+ , label "looks" (looks @w) <*> fn a+ ]++test+ :: forall w sig m a+ . (Has (Accum w) sig m, Arg w, Eq a, Eq w, Show a, Show w, Vary w, Monoid w)+ => GenM m+ -> GenTerm a+ -> GenTerm w+ -> Run ((,) w) ((,) w) m+ -> [TestTree]+test m a w (Run runAccum) =+ [ testProperty "look returns the log variable (simple)" . forall_ (w :. Nil) $+ \ w -> runAccum (w, look) === Identity (mempty, w)+ , testProperty "add appends to the log variable (simple)" . forall_ (w :. w :. Nil) $+ \ w0 w -> runAccum (w0, add w) === Identity (w, ())+ , testProperty "look returns the log variable (continuation)" . forall_ (w :. fn (m a) :. Nil) $+ \ w0 k -> runAccum (w0, look >>= k) === runAccum (w0, k w0)+ , testProperty "add appends to the log variable and alters the environment for look" . forall_ (w :. w :. Nil) $+ \ w0 w -> runAccum (w0, add w >> look) === runAccum (mappend w0 w, look @w <* add w)+ , testProperty "add appends to the log variable and alters the environment for continuations" . forall_ (w :. w :. m a :. Nil) $+ \ w0 w k -> runAccum (w0, add w >> k) === (first (mappend w) <$> runAccum (mappend w0 w, k))+ ]
test/Catch.hs view
@@ -9,8 +9,6 @@ import Control.Effect.Error import Gen-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Catch"@@ -37,6 +35,6 @@ -> Run f (Either e) m -> [TestTree] test e m a _ i (Run runCatch) =- [ testProperty "catchError intercepts throwError" . forall (i :. e :. fn (m a) :. Nil) $+ [ testProperty "catchError intercepts throwError" . forall_ (i :. e :. fn (m a) :. Nil) $ \ i e h -> runCatch ((throwError e `catchError` h) <$ i) === runCatch (h e <$ i) ]
test/Choose.hs view
@@ -14,8 +14,6 @@ import Gen import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Choose"@@ -45,8 +43,8 @@ -> Run f [] m -> [TestTree] test m a b i (Run runChoose) =- [ testProperty ">>= distributes over <|>" . forall (i :. m a :. m a :. fn (m b) :. Nil) $+ [ testProperty ">>= distributes over <|>" . forall_ (i :. m a :. m a :. fn (m b) :. Nil) $ \ i m n k -> runChoose (((m <|> n) >>= k) <$ i) === runChoose (((m >>= k) <|> (n >>= k)) <$ i)- , testProperty "<|> is associative" . forall (i :. m a :. m a :. m a :. Nil) $+ , testProperty "<|> is associative" . forall_ (i :. m a :. m a :. m a :. Nil) $ \ i m n o -> runChoose (((m <|> n) <|> o) <$ i) === runChoose ((m <|> (n <|> o)) <$ i) ]
test/Cull.hs view
@@ -19,8 +19,6 @@ import qualified Monad import qualified MonadFix import qualified NonDet-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Cull"@@ -52,6 +50,6 @@ -> Run f [] m -> [TestTree] test m a b i (Run runCull)- = testProperty "cull returns at most one success" (forall (i :. a :. m a :. m a :. Nil)+ = testProperty "cull returns at most one success" (forall_ (i :. a :. m a :. m a :. Nil) (\ i a m n -> runCull ((cull (pure a <|> m) <|> n) <$ i) === runCull ((pure a <|> n) <$ i))) : NonDet.test m a b i (Run runCull)
test/Cut.hs view
@@ -22,8 +22,6 @@ import qualified MonadFix import qualified NonDet import qualified Reader-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Cut"@@ -61,11 +59,11 @@ -> Run f [] m -> [TestTree] test hom m = (\ a _ i (Run runCut) ->- [ testProperty "cutfail annihilates >>=" (forall (i :. fn @a (m a) :. Nil)+ [ testProperty "cutfail annihilates >>=" (forall_ (i :. fn @a (m a) :. Nil) (\ i k -> runCut ((hom cutfail >>= k) <$ i) === runCut (hom cutfail <$ i)))- , testProperty "cutfail annihilates <|>" (forall (i :. m a :. Nil)+ , testProperty "cutfail annihilates <|>" (forall_ (i :. m a :. Nil) (\ i m -> runCut ((hom cutfail <|> m) <$ i) === runCut (hom cutfail <$ i)))- , testProperty "call delimits cutfail" (forall (i :. m a :. Nil)+ , testProperty "call delimits cutfail" (forall_ (i :. m a :. Nil) (\ i m -> runCut ((hom (call (hom cutfail)) <|> m) <$ i) === runCut (m <$ i))) ]) S.<> NonDet.test m
test/Cut/Church.hs view
@@ -5,13 +5,13 @@ import Control.Carrier.Cut.Church import Control.Effect.Reader-import Test.Tasty-import Test.Tasty.HUnit+import Hedgehog+import Gen tests :: TestTree tests = testGroup "Cut.Church"- [ testCase "cutfail operates through higher-order effects" $+ [ testProperty "cutfail operates through higher-order effects" . property $ runCutA @[] (local (id @()) cutfail <|> pure 'a') ()- @?=+ === runCutA @[] (cutfail <|> pure 'a') () ]
test/Empty.hs view
@@ -10,22 +10,28 @@ , test ) where -import qualified Control.Carrier.Empty.Maybe as EmptyC+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 Control.Effect.Empty import Data.Maybe (maybeToList) import Gen import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Empty"- [ testGroup "EmptyC" $+ [ testGroup "EmptyC (Church)" $ [ testMonad , testMonadFix , testEmpty- ] >>= ($ runL (fmap maybeToList . EmptyC.runEmpty))+ ] >>= ($ runL (fmap maybeToList . C.Church.runEmpty (pure Nothing) (pure . Just)))+ , testGroup "EmptyC (Maybe)" $+ [ testMonad+ , testMonadFix+ , testEmpty+ ] >>= ($ runL (fmap maybeToList . C.Maybe.runEmpty))+ , testGroup "MaybeT" $ testEmpty (runL (fmap maybeToList . T.Maybe.runMaybeT)) , testGroup "Maybe" $ testEmpty (runL (pure . maybeToList)) ] where testMonad run = Monad.test (m gen0 (\ _ _ -> [])) a b c initial run@@ -48,6 +54,6 @@ -> Run f [] m -> [TestTree] test m _ b i (Run runEmpty) =- [ testProperty "empty annihilates >>=" . forall (i :. fn @a (m b) :. Nil) $+ [ testProperty "empty annihilates >>=" . forall_ (i :. fn @a (m b) :. Nil) $ \ i k -> runEmpty ((empty >>= k) <$ i) === runEmpty (empty <$ i) ]
test/Error.hs view
@@ -10,25 +10,30 @@ ) where import qualified Catch-import qualified Control.Carrier.Error.Either as ErrorC+import qualified Control.Carrier.Error.Church as C.Church+import qualified Control.Carrier.Error.Either as C.Either import Control.Effect.Error-import qualified Control.Monad.Trans.Except as ExceptT+import qualified Control.Monad.Trans.Except as T.Except import Data.Semigroup as S ((<>)) import Gen import qualified Monad import qualified MonadFix-import Test.Tasty import qualified Throw tests :: TestTree tests = testGroup "Error"- [ testGroup "ErrorC" $+ [ testGroup "ErrorC (Church)" $ [ testMonad , testMonadFix , testError- ] >>= ($ runL ErrorC.runError)+ ] >>= ($ runL (C.Church.runError (pure . Left) (pure . Right)))+ , testGroup "ErrorC (Either)" $+ [ testMonad+ , testMonadFix+ , testError+ ] >>= ($ runL C.Either.runError) , testGroup "Either" $ testError (runL pure)- , testGroup "ExceptT" $ testError (runL ExceptT.runExceptT)+ , testGroup "ExceptT" $ testError (runL T.Except.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
test/Fail.hs view
@@ -15,8 +15,6 @@ import Hedgehog.Range as Range import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Fail"@@ -48,6 +46,6 @@ -> Run f (Either String) m -> [TestTree] test msg m _ b i (Run runFail) =- [ testProperty "fail annihilates >>=" . forall (i :. msg :. fn @a (m b) :. Nil) $+ [ testProperty "fail annihilates >>=" . forall_ (i :. msg :. fn @a (m b) :. Nil) $ \ i s k -> runFail ((Fail.fail s >>= k) <$ i) === runFail (Fail.fail s <$ i) ]
test/Fresh.hs view
@@ -8,22 +8,26 @@ , test ) where -import qualified Control.Carrier.Fresh.Strict as FreshC+import qualified Control.Carrier.Fresh.Church as C.Church+import qualified Control.Carrier.Fresh.Strict as C.Strict import Control.Effect.Fresh import Gen import qualified Hedgehog.Range as R import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Fresh"- [ testGroup "FreshC" $+ [ testGroup "FreshC (Church)" $ [ testMonad , testMonadFix , testFresh- ] >>= ($ runC FreshC.runFresh)+ ] >>= ($ runC (C.Church.runFresh (curry pure)))+ , testGroup "FreshC (Strict)" $+ [ testMonad+ , testMonadFix+ , testFresh+ ] >>= ($ runC C.Strict.runFresh) ] where testMonad run = Monad.test (m gen (\ _ _ -> [])) a b c initial run testMonadFix run = MonadFix.test (m gen (\ _ _ -> [])) a b initial run@@ -44,6 +48,6 @@ -> Run f ((,) Int) m -> [TestTree] test m a i (Run runFresh) =- [ testProperty "fresh yields unique values" . forall (i :. m a :. Nil) $+ [ testProperty "fresh yields unique values" . forall_ (i :. m a :. Nil) $ \ i m -> runFresh ((m >> fresh) <$ i) /== runFresh ((m >> fresh >> fresh) <$ i) ]
test/Fusion.hs view
@@ -9,24 +9,24 @@ import Control.Algebra import Control.Carrier.Error.Either import Control.Carrier.State.Strict-import Test.Inspection as Inspection-import Test.Tasty-import Test.Tasty.HUnit+import Gen+import Hedgehog+import Test.Inspection as Inspection hiding (property, (===)) tests :: TestTree tests = testGroup "fusion"- [ testCase "eliminates StateCs" $+ [ testProperty "eliminates StateCs" . property $ failureOf $(inspectTest $ 'countDown `doesNotUse` ''StateC)- @?= Nothing- , testCase "eliminates nested StateCs" $+ === Nothing+ , testProperty "eliminates nested StateCs" . property $ failureOf $(inspectTest $ 'countBoth `doesNotUse` ''StateC)- @?= Nothing- , testCase "eliminates catch and throw" $+ === Nothing+ , testProperty "eliminates catch and throw" . property $ failureOf $(inspectTest $ 'throwing `doesNotUse` ''ErrorC)- @?= Nothing- , testCase "eliminates calls to alg" $+ === Nothing+ , testProperty "eliminates calls to alg" . property $ failureOf $(inspectTest $ 'countDown `doesNotUse` 'alg)- @?= Nothing+ === Nothing ]
test/Gen.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}@@ -43,7 +44,7 @@ , runC -- * Generation , Rec(..)-, forall+, forall_ -- * Showing generated values , showing , GenTerm@@ -53,6 +54,11 @@ , infixR , pair , addLabel+ -- * Test trees+, TestTree+, checkTestTree+, testGroup+, testProperty -- * Re-exports , Gen , (===)@@ -84,7 +90,7 @@ import GHC.Generics ((:.:)(..)) import GHC.Stack import GHC.TypeLits-import Hedgehog+import Hedgehog hiding (Rec (..)) import qualified Hedgehog.Function as Fn import Hedgehog.Gen as Hedgehog import Hedgehog.Range@@ -215,8 +221,8 @@ Nil :: Rec '[] (:.) :: a -> Rec as -> Rec (a ': as) -forall :: (Forall g f, HasCallStack) => g -> f -> Hedgehog.Property-forall g f = withFrozenCallStack $ Hedgehog.property (forall' g f)+forall_ :: (Forall g f, HasCallStack) => g -> f -> Hedgehog.Property+forall_ g f = withFrozenCallStack $ Hedgehog.property (forall' g f) class Forall g f | g -> f, f -> g where forall' :: HasCallStack => g -> f -> PropertyT IO ()@@ -303,3 +309,19 @@ InfixL p s _ :<*> a -> showParen True (showsPrec p a . showString " " . showString s) InfixR p s _ :<*> a -> showParen True (showsPrec (succ p) a . showString " " . showString s) f :<*> a -> showParen (d > 10) (showsPrec 10 f . showString " " . showsPrec 11 a)+++data TestTree+ = Leaf String Property+ | Branch String [TestTree]++checkTestTree :: TestTree -> IO Bool+checkTestTree = \case+ Leaf n p -> putStrLn n *> check p <* putStrLn ""+ Branch n ts -> and <$ putStrLn n <*> traverse checkTestTree ts <* putStrLn ""++testGroup :: String -> [TestTree] -> TestTree+testGroup = Branch++testProperty :: String -> Property -> TestTree+testProperty = Leaf
test/Lift.hs view
@@ -6,18 +6,18 @@ import Control.Effect.Lift import qualified Control.Exception as E import Control.Monad.IO.Class-import Test.Tasty-import Test.Tasty.HUnit+import Gen+import Hedgehog tests :: TestTree tests = testGroup "Lift"- [ testCase "liftWith" $ do+ [ testProperty "liftWith" . property $ do r <- liftIO . runState "yep" $ handle (put . getMsg) $ do modify ("heck " ++) liftIO (E.throwIO (E.AssertionFailed "nope"))- r @?= ("nope", ())+ r === ("nope", ()) ] where 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 $ \ ctx run -> E.handle (run . (<$ ctx) . h) (run (m <$ ctx))+handle h m = liftWith $ \ run ctx -> E.handle (run . (<$ ctx) . h) (run (m <$ ctx))
test/Monad.hs view
@@ -9,8 +9,6 @@ import Control.Monad (ap, (>=>)) import Gen-import Test.Tasty-import Test.Tasty.Hedgehog test :: (Monad m, Arg a, Arg b, Eq (g a), Eq (g b), Eq (g c), Show a, Show b, Show (g a), Show (g b), Show (g c), Vary a, Vary b, Functor f)@@ -22,14 +20,14 @@ -> Run f g m -> [TestTree] test m a b c s (Run run) =- [ testProperty "return is the left-identity of >>=" . forall (s :. a :. fn (m b) :. Nil) $+ [ testProperty "return is the left-identity of >>=" . forall_ (s :. a :. fn (m b) :. Nil) $ \ s a k -> run ((return a >>= k) <$ s) === run (k a <$ s)- , testProperty "return is the right-identity of >>=" . forall (s :. m a :. Nil) $+ , testProperty "return is the right-identity of >>=" . forall_ (s :. m a :. Nil) $ \ s m -> run ((m >>= return) <$ s) === run (m <$ s)- , testProperty ">>= is associative" . forall (s :. m a :. fn (m b) :. fn (m c) :. Nil) $+ , testProperty ">>= is associative" . forall_ (s :. m a :. fn (m b) :. fn (m c) :. Nil) $ \ s m k h -> run ((m >>= (k >=> h)) <$ s) === run (((m >>= k) >>= h) <$ s)- , testProperty "return = pure" . forall (s :. a :. Nil) $+ , testProperty "return = pure" . forall_ (s :. a :. Nil) $ \ s a -> run (return a <$ s) === run (pure a <$ s)- , testProperty "ap = (<*>)" . forall (s :. fn b :. m a :. Nil) $+ , testProperty "ap = (<*>)" . forall_ (s :. fn b :. m a :. Nil) $ \ s f m -> run ((pure f `ap` m) <$ s) === run ((pure f <*> m) <$ s) ]
test/MonadFix.hs view
@@ -10,8 +10,6 @@ import Control.Monad (liftM) import Control.Monad.Fix import Gen-import Test.Tasty-import Test.Tasty.Hedgehog test :: (MonadFix m, Arg a, Eq (g a), Eq (g b), Functor f, Show a, Show (g a), Show (g b), Vary a)@@ -22,12 +20,12 @@ -> Run f g m -> [TestTree] test m a b s (Run run) =- [ testProperty "purity" . forall (s :. termFn a :. Nil) $+ [ testProperty "purity" . forall_ (s :. termFn a :. Nil) $ \ s h -> run (mfix (return . h) <$ s) === run (return (fix h) <$ s)- , testProperty "left-shrinking" . forall (s :. m a :. termFn (fn (m b)) :. Nil) $+ , testProperty "left-shrinking" . forall_ (s :. m a :. termFn (fn (m b)) :. Nil) $ \ s m f -> run (mfix (\ x -> m >>= \ y -> f x y) <$ s) === run ((m >>= \ y -> mfix (\ x -> f x y)) <$ s)- , testProperty "sliding" . forall (s :. fn b :. termFn (m a) :. Nil) $+ , testProperty "sliding" . forall_ (s :. fn b :. termFn (m a) :. Nil) $ \ s h f -> run (mfix (liftM h . f) <$ s) === run (liftM h (mfix (f . h)) <$ s)- , testProperty "nesting" . forall (s :. termFn (termFn (m a)) :. Nil) $+ , testProperty "nesting" . forall_ (s :. termFn (termFn (m a)) :. Nil) $ \ s f -> run (mfix (\ x -> mfix (\ y -> f x y)) <$ s) === run (mfix (\ x -> f x x) <$ s) ]
test/NonDet.hs view
@@ -21,8 +21,6 @@ import Gen import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "NonDet"@@ -56,9 +54,9 @@ -> [TestTree] test m = (\ a _ i (Run runNonDet) ->- [ testProperty "empty is the left identity of <|>" (forall (i :. m a :. Nil)+ [ testProperty "empty is the left identity of <|>" (forall_ (i :. m a :. Nil) (\ i m -> runNonDet ((empty <|> m) <$ i) === runNonDet (m <$ i)))- , testProperty "empty is the right identity of <|>" (forall (i :. m a :. Nil)+ , testProperty "empty is the right identity of <|>" (forall_ (i :. m a :. Nil) (\ i m -> runNonDet ((m <|> empty) <$ i) === runNonDet (m <$ i))) ]) S.<> Empty.test m
test/NonDet/Church.hs view
@@ -5,24 +5,24 @@ import Control.Carrier.Error.Either import Control.Carrier.NonDet.Church import Control.Carrier.State.Strict hiding (state)+import Gen+import Hedgehog import Prelude hiding (error)-import Test.Tasty-import Test.Tasty.HUnit tests :: TestTree tests = testGroup "NonDet.Church"- [ testCase "collects results of effects run inside it" $+ [ testProperty "collects results of effects run inside it" . property $ run (runNonDetA (runState 'a' state))- @?= [('a', 'z'), ('b', 'b'), ('a', 'a')]- , testCase "collapses results of effects run outside it" $+ === [('a', 'z'), ('b', 'b'), ('a', 'a')]+ , testProperty "collapses results of effects run outside it" . property $ run (runState 'a' (runNonDetA state))- @?= ('b', "zbb")- , testCase "collects results from higher-order effects run inside it" $+ === ('b', "zbb")+ , testProperty "collects results from higher-order effects run inside it" . property $ run (runNonDetA (runError error))- @?= [Right 'z', Right 'a' :: Either Char Char]- , testCase "collapses results of higher-order effects run outside it" $+ === [Right 'z', Right 'a' :: Either Char Char]+ , testProperty "collapses results of higher-order effects run outside it" . property $ run (runError (runNonDetA error))- @?= (Right "a" :: Either Char String)+ === (Right "a" :: Either Char String) ] state :: (Alternative m, Has (State Char) sig m) => m Char
test/Reader.hs view
@@ -22,8 +22,6 @@ import GHC.Generics ((:.:)(..)) import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Reader"@@ -70,8 +68,8 @@ -> Run (f :.: (,) r) Identity m -> [TestTree] test r m a i (Run runReader) =- [ testProperty "ask returns the environment variable" . forall (i :. r :. fn (m a) :. Nil) $+ [ testProperty "ask returns the environment variable" . forall_ (i :. r :. fn (m a) :. Nil) $ \ i r k -> runReader (Comp1 ((r, ask >>= k) <$ i)) === runReader (Comp1 ((r, k r) <$ i))- , testProperty "local modifies the environment variable" . forall (i :. r :. fn r :. m a :. Nil) $+ , testProperty "local modifies the environment variable" . forall_ (i :. r :. fn r :. m a :. Nil) $ \ i r f m -> runReader (Comp1 ((r, local f m) <$ i)) === runReader (Comp1 ((f r, m) <$ i)) ]
test/State.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -10,36 +11,46 @@ , test ) where -import qualified Control.Carrier.State.Lazy as LazyStateC-import qualified Control.Carrier.State.Strict as StrictStateC+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 Control.Effect.State-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+#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 Data.Tuple (swap) import Gen import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "State"- [ testGroup "StateC (Lazy)" $+ [ testGroup "StateC (Church)" $ [ testMonad , testMonadFix , testState- ] >>= ($ runC LazyStateC.runState)+ ] >>= ($ runC (C.Church.runState (curry pure)))+ , testGroup "StateC (Lazy)" $+ [ testMonad+ , testMonadFix+ , testState+ ] >>= ($ runC C.Lazy.runState) , testGroup "StateC (Strict)" $ [ testMonad , testMonadFix , testState- ] >>= ($ 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))+ ] >>= ($ 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)) ] 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@@ -67,8 +78,8 @@ -> Run ((,) s) ((,) s) m -> [TestTree] test m a s (Run runState) =- [ testProperty "get returns the state variable" . forall (s :. fn (m a) :. Nil) $+ [ testProperty "get returns the state variable" . forall_ (s :. fn (m a) :. Nil) $ \ s k -> runState (s, get >>= k) === runState (s, k s)- , testProperty "put updates the state variable" . forall (s :. s :. m a :. Nil) $+ , testProperty "put updates the state variable" . forall_ (s :. s :. m a :. Nil) $ \ s s' m -> runState (s, put s' >> m) === runState (s', m) ]
test/Test.hs view
@@ -2,6 +2,7 @@ ( main ) where +import qualified Accum import qualified Catch import qualified Choose import qualified Cull@@ -12,18 +13,20 @@ import qualified Fail import qualified Fresh import qualified Fusion+import Gen+import Hedgehog.Main import qualified Lift import qualified NonDet import qualified NonDet.Church import qualified Reader import qualified State-import Test.Tasty import qualified Throw import qualified Writer main :: IO ()-main = defaultMain $ testGroup "unit tests"- [ Catch.tests+main = defaultMain $ map checkTestTree+ [ Accum.tests+ , Catch.tests , Choose.tests , Cull.tests , Cut.tests
test/Throw.hs view
@@ -15,8 +15,6 @@ import Gen import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Throw"@@ -47,6 +45,6 @@ -> Run f (Either e) m -> [TestTree] test e m _ b i (Run runThrow) =- [ testProperty "throwError annihilates >>=" . forall (i :. e :. fn @a (m b) :. Nil) $+ [ testProperty "throwError annihilates >>=" . forall_ (i :. e :. fn @a (m b) :. Nil) $ \ i e k -> runThrow ((throwError e >>= k) <$ i) === runThrow (throwError e <$ i) ]
test/Writer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -12,32 +13,48 @@ ) where import Control.Arrow ((&&&))-import qualified Control.Carrier.Writer.Strict as WriterC+import qualified Control.Carrier.Writer.Church as C.Writer.Church+import qualified Control.Carrier.Writer.Strict as C.Writer.Strict import Control.Effect.Writer-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+#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 Data.Bifunctor (first) import Data.Tuple (swap) import Gen import qualified Monad import qualified MonadFix-import Test.Tasty-import Test.Tasty.Hedgehog tests :: TestTree tests = testGroup "Writer"- [ testGroup "WriterC" $+ [ testGroup "WriterC (Church)" $ [ testMonad , testMonadFix , testWriter- ] >>= ($ runL WriterC.runWriter)+ ] >>= ($ runL (C.Writer.Church.runWriter (curry pure)))+ , testGroup "WriterC (Strict)" $+ [ testMonad+ , testMonadFix+ , testWriter+ ] >>= ($ runL C.Writer.Strict.runWriter) , testGroup "(,)" $ testWriter (runL pure)- , 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))+#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)) ] 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@@ -72,10 +89,10 @@ -> Run f ((,) w) m -> [TestTree] test w m a i (Run runWriter) =- [ testProperty "tell appends a value to the log" . forall (i :. w :. m a :. Nil) $+ [ testProperty "tell appends a value to the log" . forall_ (i :. w :. m a :. Nil) $ \ i w m -> runWriter ((tell w >> m) <$ i) === fmap (first (mappend w)) (runWriter (m <$ i))- , testProperty "listen eavesdrops on written output" . forall (i :. m a :. Nil) $+ , testProperty "listen eavesdrops on written output" . forall_ (i :. m a :. Nil) $ \ i m -> runWriter (listen m <$ i) === fmap (fst &&& id) (runWriter (m <$ i))- , testProperty "censor revises written output" . forall (i :. fn w :. m a :. Nil) $+ , testProperty "censor revises written output" . forall_ (i :. fn w :. m a :. Nil) $ \ i f m -> runWriter (censor f m <$ i) === fmap (first f) (runWriter (m <$ i)) ]