in-other-words (empty) → 0.1.0.0
raw patch · 87 files changed
+12077/−0 lines, 87 filesdep +asyncdep +basedep +exceptionssetup-changed
Dependencies added: async, base, exceptions, hspec, in-other-words, monad-control, mtl, stm, transformers, transformers-base
Files
- ChangeLog.md +4/−0
- LICENSE +30/−0
- README.md +278/−0
- Setup.hs +2/−0
- in-other-words.cabal +146/−0
- src/Control/Effect.hs +114/−0
- src/Control/Effect/Alt.hs +221/−0
- src/Control/Effect/AtomicState.hs +250/−0
- src/Control/Effect/BaseControl.hs +173/−0
- src/Control/Effect/Bracket.hs +170/−0
- src/Control/Effect/Carrier.hs +51/−0
- src/Control/Effect/Carrier/Internal/Compose.hs +140/−0
- src/Control/Effect/Carrier/Internal/Interpret.hs +733/−0
- src/Control/Effect/Carrier/Internal/Intro.hs +148/−0
- src/Control/Effect/Carrier/Internal/Stepped.hs +111/−0
- src/Control/Effect/Conc.hs +341/−0
- src/Control/Effect/Cont.hs +172/−0
- src/Control/Effect/Debug.hs +23/−0
- src/Control/Effect/Embed.hs +141/−0
- src/Control/Effect/Error.hs +468/−0
- src/Control/Effect/ErrorIO.hs +117/−0
- src/Control/Effect/Exceptional.hs +501/−0
- src/Control/Effect/Fail.hs +227/−0
- src/Control/Effect/Fix.hs +43/−0
- src/Control/Effect/Fresh.hs +150/−0
- src/Control/Effect/Intercept.hs +57/−0
- src/Control/Effect/Internal.hs +266/−0
- src/Control/Effect/Internal/BaseControl.hs +31/−0
- src/Control/Effect/Internal/Cont.hs +149/−0
- src/Control/Effect/Internal/Derive.hs +20/−0
- src/Control/Effect/Internal/Effly.hs +77/−0
- src/Control/Effect/Internal/Error.hs +86/−0
- src/Control/Effect/Internal/Intercept.hs +353/−0
- src/Control/Effect/Internal/Itself.hs +20/−0
- src/Control/Effect/Internal/KnownList.hs +142/−0
- src/Control/Effect/Internal/Membership.hs +56/−0
- src/Control/Effect/Internal/Newtype.hs +191/−0
- src/Control/Effect/Internal/NonDet.hs +216/−0
- src/Control/Effect/Internal/Optional.hs +41/−0
- src/Control/Effect/Internal/Reader.hs +59/−0
- src/Control/Effect/Internal/Reflection.hs +33/−0
- src/Control/Effect/Internal/Regional.hs +48/−0
- src/Control/Effect/Internal/State.hs +100/−0
- src/Control/Effect/Internal/Union.hs +283/−0
- src/Control/Effect/Internal/Unlift.hs +32/−0
- src/Control/Effect/Internal/Utils.hs +21/−0
- src/Control/Effect/Internal/ViaAlg.hs +37/−0
- src/Control/Effect/Internal/Writer.hs +324/−0
- src/Control/Effect/Mask.hs +96/−0
- src/Control/Effect/Newtype.hs +19/−0
- src/Control/Effect/NonDet.hs +106/−0
- src/Control/Effect/Optional.hs +113/−0
- src/Control/Effect/Primitive.hs +31/−0
- src/Control/Effect/Reader.hs +168/−0
- src/Control/Effect/Regional.hs +93/−0
- src/Control/Effect/Select.hs +106/−0
- src/Control/Effect/State.hs +246/−0
- src/Control/Effect/Stepped.hs +14/−0
- src/Control/Effect/Trace.hs +204/−0
- src/Control/Effect/Type/Alt.hs +19/−0
- src/Control/Effect/Type/Bracket.hs +122/−0
- src/Control/Effect/Type/Catch.hs +16/−0
- src/Control/Effect/Type/Embed.hs +6/−0
- src/Control/Effect/Type/ErrorIO.hs +9/−0
- src/Control/Effect/Type/Fail.hs +16/−0
- src/Control/Effect/Type/Fix.hs +85/−0
- src/Control/Effect/Type/Internal/BaseControl.hs +143/−0
- src/Control/Effect/Type/ListenPrim.hs +149/−0
- src/Control/Effect/Type/Mask.hs +118/−0
- src/Control/Effect/Type/Optional.hs +112/−0
- src/Control/Effect/Type/ReaderPrim.hs +150/−0
- src/Control/Effect/Type/Regional.hs +83/−0
- src/Control/Effect/Type/Split.hs +100/−0
- src/Control/Effect/Type/Throw.hs +7/−0
- src/Control/Effect/Type/Unlift.hs +104/−0
- src/Control/Effect/Type/Unravel.hs +95/−0
- src/Control/Effect/Type/WriterPrim.hs +176/−0
- src/Control/Effect/Union.hs +157/−0
- src/Control/Effect/Unlift.hs +92/−0
- src/Control/Effect/Writer.hs +1035/−0
- src/Control/Monad/Trans/Free/Church/Alternate.hs +139/−0
- src/Control/Monad/Trans/List/Church.hs +200/−0
- test/BracketSpec.hs +66/−0
- test/ErrorSpec.hs +43/−0
- test/Main.hs +1/−0
- test/NonDetSpec.hs +36/−0
- test/WriterSpec.hs +206/−0
+ ChangeLog.md view
@@ -0,0 +1,4 @@+# Changelog for `in-other-words` + +## 0.1.0.0 (2020-10-10) +Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Love Waern (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Love Waern nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,278 @@+# in-other-words+[](https://github.com/KingoftheHomeless/in-other-words/actions?query=workflow%3A%22build+GHC+8.6%22)+[](https://github.com/KingoftheHomeless/in-other-words/actions?query=workflow%3A%22build+GHC+8.8%22)+[](https://github.com/KingoftheHomeless/in-other-words/actions?query=workflow%3A%22build+GHC+8.10%22)++- [Overview][]+- [Features][]+- [Required Language Extensions][]+- [Examples of Simple Usage][]+- [Advanced Usage][]+- [Troubleshooting][]+- [Performance][]++[Overview]: https://github.com/KingoftheHomeless/in-other-words#overview+[Features]: https://github.com/KingoftheHomeless/in-other-words#features+[Required Language Extensions]: https://github.com/KingoftheHomeless/in-other-words#required-language-extensions+[Examples of Simple Usage]: https://github.com/KingoftheHomeless/in-other-words#examples-of-simple-usage+[Advanced Usage]: https://github.com/KingoftheHomeless/in-other-words#advanced-usage+[Troubleshooting]: https://github.com/KingoftheHomeless/in-other-words#troubleshooting+[Performance]: https://github.com/KingoftheHomeless/in-other-words#performance++## Overview+`in-other-words` is an effect system in the vein of [`freer-simple`](https://github.com/lexi-lambda/freer-simple),+[`fused-effects`](https://github.com/fused-effects/fused-effects),+[`polysemy`](https://github.com/polysemy-research/polysemy),+and [`eff`](https://github.com/hasura/eff). It represents effects through data types,+making it simple to define, use, and interpret them.++The goal of `in-other-words` is to be as expressive and general of an+effect system as possible while solving the *O(n<sup>2</sup>)* instances+problem. Its hallmark feature is the novel approach it takes to support+higher-order effects, making it significantly more powerful -- and sometimes+easier to use -- than other effect libraries of its kind.++If you're experienced with the mechanisms behind `freer-simple`,+`fused-effects`, and `polysemy`, and would like to learn more about what makes+`in-other-words` different, see+[this wiki page](https://github.com/KingoftheHomeless/in-other-words/wiki/The-Inner-Workings-of-the-Library).++Unfortunately, in its current state `in-other-words` is rather inaccessible.+Ample documentation and guides are provided for the library, but inexperienced+users are still likely to run into gotchas that result in very+confusing error messages. As such, if you're a beginner to effect systems,+`freer-simple` or `polysemy` would serve as better starting points.++## Features++### Simple higher-order effects+Unlike `fused-effects` and `polysemy` -- which both have intimidating+boilerplate associated with the interpretation of higher-order effects+--`in-other-words` makes it just as easy to interpret higher-order effects as+first-order effects. Go [here](#higher-order) for an example.++### No cumbersome restrictions to effects+Every effect system previously mentioned has serious restrictions in what+effects they may represent.+* `freer-simple` is restricted to first-order effects.+* `fused-effects` and `polysemy` are built around+[*Effect Handlers in Scope*](https://www.cs.ox.ac.uk/people/nicolas.wu/papers/Scope.pdf),+whose approach doesn't allow for sensible implementations of effects for+continuations, coroutines, or nondeterminism.+* `eff` is limited to what's implementable with delimited continuations, which+excludes actions such as+[`pass`](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Writer-Class.html#v:pass)+from `MonadWriter`, and `async`/`await` style concurrency.++`in-other-words` also places restrictions on what effects may be represented+-- but in contrast to the libraries mentioned above, these restrictions are+almost completely negligable.<sup id="a1">[1](#f1)</sup> This is possible because+unlike most other effect systems, `in-other-words` does not attempt to make+every possible effect play nicely together with every other effect: instead,+just like `mtl`, some effects can't be used together with other effects+(depending on how they're interpreted),+and this is enforced by constraints that interpreters may introduce.++## Required Language Extensions+The following extensions are needed for basic usage of the library:++```+ - ConstraintKinds+ - DataKinds+ - FlexibleContexts+ - GADTs+ - LambdaCase+ - PolyKinds+ - RankNTypes+ - TypeApplications+ - TypeOperators+ - TypeFamilies+```++Some features of the library could require enabling more extensions.+++## Examples of Simple Usage++First-order usage:+```haskell+import Control.Effect+import Control.Effect.Error+import Control.Effect.State+import Control.Effect.Reader+import Control.Effect.Writer++import Text.Read (readMaybe)++data Teletype m a where+ ReadTTY :: Teletype m String+ WriteTTY :: String -> Teletype m ()++readTTY :: Eff Teletype m => m String+readTTY = send ReadTTY++writeTTY :: Eff Teletype m => String -> m ()+writeTTY str = send (WriteTTY str)++challenge :: Eff Teletype m => m ()+challenge = do+ writeTTY "What is 3 + 4?"+ readTTY >>= \str -> case readMaybe @Int str of+ Just 7 -> writeTTY "Correct!"+ _ -> writeTTY "Nope." >> challenge+++-- Interpret a Teletype effect in terms of IO operations+teletypeToIO :: Eff (Embed IO) m => SimpleInterpreterFor Teletype m+teletypeToIO = interpretSimple $ \case+ ReadTTY -> embed getLine -- use 'embed' to lift IO actions.+ WriteTTY msg -> embed $ putStrLn msg+++-- Make a challenge to the user+challengeIO :: IO ()+challengeIO = runM $ teletypeToIO $ challenge+++-- Interpret a `Teletype` effect in terms of `Ask` and `Tell` effects+runTeletype :: Effs '[Ask String, Tell String] m+ => SimpleInterpreterFor Teletype m+runTeletype = interpretSimple $ \case+ ReadTTY -> ask+ WriteTTY msg -> tell msg++-- Runs a challenge with the provided inputs purely.+challengePure :: [String] -> Either String [String]+challengePure testInputs =+ -- Extract the final result, now that all effects have been interpreted.+ run+ -- Run the @Throw String@ effect, resulting in @Either String [String]@+ $ runThrow @String+ -- We discard the return value of @challenge@ -- () --+ -- while retaining the list of told strings.+ $ fmap fst+ -- Run the @Tell String@ effect by gathering all told+ -- strings into a list, resulting in ([String], ())+ $ runTellList @String+ -- Run the @State [String]@ effect with initial state+ -- @testInputs@. @evalState@ discards the end state.+ $ evalState testInputs+ -- Interpret the @Ask String@ effect by going through the provided inputs+ -- one by one.+ -- Throw an exception if we go through all the inputs without completing the+ -- challenge.+ $ runAskActionSimple (do+ get >>= \case+ [] -> throw "Inputs exhausted!"+ (x:xs) -> put xs >> return x+ )+ -- Interpret @Teletype@ in terms of @Ask String@ and @Tell String@+ $ runTeletype+ -- Run the main program @challenge@, which returns ()+ $ challenge++-- evaluates to True+testChallenge :: Bool+testChallenge =+ challengePure ["4","-7", "i dunno", "7"]+ == Right ["What is 3 + 4?", "Nope."+ ,"What is 3 + 4?", "Nope."+ ,"What is 3 + 4?", "Nope."+ ,"What is 3 + 4?", "Correct!"+ ]+```++<span id="higher-order">Higher-order usage:</span>+```haskell+import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Trace+import GHC.Clock (getMonotonicTime)++data ProfileTiming m a where+ ProfileTiming :: String -> m a -> ProfileTiming m a++time :: Eff ProfileTiming m => String -> m a -> m a+time label m = send (ProfileTiming label m)++-- Interpret a ProfileTiming effect in terms of IO operations,+-- 'Trace', and 'Bracket'.+profileTimingToIO :: Effs '[Embed IO, Trace, Bracket] m+ => SimpleInterpreterFor ProfileTiming m+profileTimingToIO = interpretSimple $ \case+ ProfileTiming label action -> do+ before <- embed getMonotonicTime+ -- To execute a provided computation when interpreting a+ -- higher-order effect, just bind it.+ -- You can also use other higher-order effects to interact with it!+ a <- action + `onError` -- Provided by 'Bracket'+ trace ("Timing of " ++ label ++ " failed due to some error!")+ after <- embed getMonotonicTime+ trace ("Timing of " ++ label ++ ": " ++ show (after - before) ++ " seconds.")+ return a++spin :: Monad m => Integer -> m ()+spin 0 = pure ()+spin i = spin (i - 1)++profileSpin :: IO ()+profileSpin = runM $ bracketToIO $ runTracePrinting $ profileTimingToIO $ do+ time "spin" (spin 1000000)+ time "spinAndFail" (spin 1000000 >> undefined)+{-+This prints the following (exact times are machine specific):++ Timing of spin: 1.3399935999768786 seconds.+ Timing of spinAndFail failed due to some error!+ *** Exception: Prelude.undefined+-}+```++## Advanced Usage++The examples above are somewhat disingenuous; they cover only the simplest+uses of the library. The library has a wide variety of features,+and using them properly can get very complicated. Because of this,+[`in-other-words` offers a wiki covering more advanced topics of the+library.](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-Topics)+Check it out if you're interested in learning more about the+library, or are struggling with a feature.+++## Troubleshooting+[The wiki has a page for common error messages.](https://github.com/KingoftheHomeless/in-other-words/wiki/Common-Error-Messages-and-Issues)+If you run into any issues or strange error messages that you can't figure out+from the wiki, feel free to make an issue about it. If not already covered, and+if I can generalize the problem enough, then I'll expand the wiki to cover the+issue.++## Performance+In the microbenchmarks offered by [`effects-zoo`](https://github.com/ocharles/effect-zoo/)+`in-other-words` performs comparably to `mtl` and `fused-effects`;+at worst up to 2x slower than `fused-effects`. +Keep in mind, however, that these *are* only microbenchmarks, and may not+predict performance in the wild with perfect accuracy.+[The benchmark results are available here.](https://github.com/KingoftheHomeless/in-other-words/wiki/Benchmarks)++`in-other-words` is, like `mtl` and `fused-effects`, limited+by how effectively the compiler is able to optimize away the+underlying abstractions.+[As noted by Alexis King](https://github.com/ghc-proposals/ghc-proposals/pull/313#issuecomment-590143835),+the ideal situations under which these libraries are truly zero-cost are unrealistic+in practice. Although this does adversely affect `in-other-words`,+the underlying dispatch cost of effects should be low enough to make+to it largely negligable for most purposes -- in particular, IO-bound+applications.++Further benchmarking, profiling, and optimizations are currently+considered future goals of the library.++***+<b id="f1">[1](#a1)</b> Every effect is required to be *representational*+in the carrier monad. This means that if you can represent your effect using:+* a `mtl`-style effect class+* without any associated type families+* and it can be newtype derived++then you can also represent your effect with `in-other-words`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ in-other-words.cabal view
@@ -0,0 +1,146 @@+cabal-version: 1.12 ++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 391e1bf43205bfa3b9719626f8fbbd2f7e5d117aa180b0780022450a404f75de++name: in-other-words+version: 0.1.0.0+synopsis: A higher-order effect system where the sky's the limit+description: A low-boilerplate effect system with easy higher-order effects and very high expressive power+category: Control+homepage: https://github.com/KingoftheHomeless/in-other-words#readme+author: Love Waern+maintainer: combiner8761@gmail.com+copyright: BSD3+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md++library+ exposed-modules:+ Control.Effect+ Control.Effect.Alt+ Control.Effect.AtomicState+ Control.Effect.BaseControl+ Control.Effect.Bracket+ Control.Effect.Carrier+ Control.Effect.Carrier.Internal.Compose+ Control.Effect.Carrier.Internal.Interpret+ Control.Effect.Carrier.Internal.Intro+ Control.Effect.Carrier.Internal.Stepped+ Control.Effect.Conc+ Control.Effect.Cont+ Control.Effect.Debug+ Control.Effect.Embed+ Control.Effect.Error+ Control.Effect.ErrorIO+ Control.Effect.Exceptional+ Control.Effect.Fail+ Control.Effect.Fix+ Control.Effect.Fresh+ Control.Effect.Intercept+ Control.Effect.Internal+ Control.Effect.Internal.BaseControl+ Control.Effect.Internal.Cont+ Control.Effect.Internal.Derive+ Control.Effect.Internal.Effly+ Control.Effect.Internal.Error+ Control.Effect.Internal.Intercept+ Control.Effect.Internal.Itself+ Control.Effect.Internal.KnownList+ Control.Effect.Internal.Membership+ Control.Effect.Internal.Newtype+ Control.Effect.Internal.NonDet+ Control.Effect.Internal.Optional+ Control.Effect.Internal.Reader+ Control.Effect.Internal.Reflection+ Control.Effect.Internal.Regional+ Control.Effect.Internal.State+ Control.Effect.Internal.Union+ Control.Effect.Internal.Unlift+ Control.Effect.Internal.Utils+ Control.Effect.Internal.ViaAlg+ Control.Effect.Internal.Writer+ Control.Effect.Mask+ Control.Effect.Newtype+ Control.Effect.NonDet+ Control.Effect.Optional+ Control.Effect.Primitive+ Control.Effect.Reader+ Control.Effect.Regional+ Control.Effect.Select+ Control.Effect.State+ Control.Effect.Stepped+ Control.Effect.Trace+ Control.Effect.Type.Alt+ Control.Effect.Type.Bracket+ Control.Effect.Type.Catch+ Control.Effect.Type.Embed+ Control.Effect.Type.ErrorIO+ Control.Effect.Type.Fail+ Control.Effect.Type.Fix+ Control.Effect.Type.Internal.BaseControl+ Control.Effect.Type.ListenPrim+ Control.Effect.Type.Mask+ Control.Effect.Type.Optional+ Control.Effect.Type.ReaderPrim+ Control.Effect.Type.Regional+ Control.Effect.Type.Split+ Control.Effect.Type.Throw+ Control.Effect.Type.Unlift+ Control.Effect.Type.Unravel+ Control.Effect.Type.WriterPrim+ Control.Effect.Union+ Control.Effect.Unlift+ Control.Effect.Writer+ Control.Monad.Trans.Free.Church.Alternate+ Control.Monad.Trans.List.Church+ other-modules:+ Paths_in_other_words+ hs-source-dirs:+ src+ default-extensions: BangPatterns ConstraintKinds DataKinds DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase PolyKinds QuantifiedConstraints RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UndecidableInstances+ ghc-options: -Wall+ build-depends:+ async >=2.2 && <2.3+ , base >=4.7 && <5+ , exceptions >=0.10 && <0.11+ , monad-control >=1.0 && <1.1+ , mtl >=2.2 && <2.3+ , stm >=2.5 && <2.6+ , transformers >=0.5.6 && <0.6+ , transformers-base >=0.4.5 && <0.5+ default-language: Haskell2010++test-suite in-other-words-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ BracketSpec+ ErrorSpec+ NonDetSpec+ WriterSpec+ Paths_in_other_words+ hs-source-dirs:+ test+ default-extensions: BangPatterns ConstraintKinds DataKinds DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase PolyKinds QuantifiedConstraints RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UndecidableInstances+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0+ build-tool-depends:+ hspec-discover:hspec-discover >=2.0+ build-depends:+ async >=2.2 && <2.3+ , base >=4.7 && <5+ , exceptions >=0.10 && <0.11+ , hspec >=2.6.0 && <3+ , in-other-words+ , monad-control >=1.0 && <1.1+ , mtl >=2.2 && <2.3+ , stm >=2.5 && <2.6+ , transformers >=0.5.6 && <0.6+ , transformers-base >=0.4.5 && <0.5+ default-language: Haskell2010
+ src/Control/Effect.hs view
@@ -0,0 +1,114 @@+module Control.Effect+ ( -- * Core class+ Carrier(Derivs)+ , Effect+ , RepresentationalEff++ -- * Effect membership+ , Eff+ , Effs+ , Bundle+ , Member++ -- * Sending actions of effects+ , send++ -- * Running final monad+ , run++ , runM++ -- * Integrating external monads+ , Embed(..)+ , embed++ -- * Effect interpretation+ , interpretSimple+ , SimpleInterpreterFor++ , interpretViaHandler+ , Handler(..)++ , interpret+ , InterpreterFor++ , EffHandler++ -- * Effect reinterpretation+ , reinterpretSimple+ , reinterpretViaHandler+ , reinterpret++ -- * Threading constraints+ , Threaders+ , ReaderThreads++ -- * Effect Introduction+ , intro1+ , intro+ , introUnder1+ , introUnder+ , introUnderMany+ , HeadEff+ , HeadEffs++ -- * Combining effect carriers+ , CompositionC+ , runComposition++ -- * Other utilities+ , Effly(..)+ , subsume++ -- * Reexports from other modules+ , MonadBase(..)+ , MonadTrans(..)++ -- * Carriers and other misc. types+ , RunC+ , RunMC+ , InterpretSimpleC+ , InterpretC+ , InterpretReifiedC+ , ReifiesHandler+ , ViaReifiedH+ , ReinterpretSimpleC+ , ReinterpretC+ , ReinterpretReifiedC+ , IntroConsistent+ , IntroC+ , IntroTopC+ , IntroUnderC+ , IntroUnderManyC+ , KnownList+ , SubsumeC+ ) where++import Control.Effect.Internal+import Control.Effect.Internal.Effly+import Control.Effect.Internal.KnownList+import Control.Effect.Internal.Membership+import Control.Effect.Internal.Union+import Control.Effect.Embed+import Control.Effect.Carrier.Internal.Compose+import Control.Effect.Carrier.Internal.Intro+import Control.Effect.Carrier.Internal.Interpret+import Control.Monad.Base+import Control.Monad.Trans++-- | A useful type synonym for the type of 'interpret' provided a handler+--+-- @m@ is left polymorphic so that you may place @'Eff'/s@ constraints on it.+type InterpreterFor e m =+ forall x+ . InterpretReifiedC e m x+ -> m x++-- | A useful type synonym for the type of 'interpretSimple' provided a handler+--+-- @m@ is left polymorphic so that you may place @'Eff'/s@ constraints on it.+type SimpleInterpreterFor e m =+ forall x p+ . Threaders '[ReaderThreads] m p+ => InterpretSimpleC e m x+ -> m x
+ src/Control/Effect/Alt.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE BlockArguments, DerivingVia #-}+module Control.Effect.Alt+ ( -- * Effects+ Alt(..)+ , Alternative(..)++ -- * Interpretations+ , runAltMaybe++ , altToError++ , altToNonDet++ -- * Simple variants of interpretations+ , altToErrorSimple++ -- * Threading constraints+ , ErrorThreads++ -- * Carriers+ , AltMaybeC++ , InterpretAltC(..)+ , InterpretAltReifiedC++ , AltToNonDetC++ , InterpretAltSimpleC(..)+ ) where++import Control.Applicative+import Control.Monad++import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Error+import Control.Effect.NonDet+import Control.Effect.Type.Alt++-- For coercion purposes+import Control.Effect.Internal.Utils+import Control.Effect.Internal.Error+import Control.Effect.Carrier.Internal.Compose+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Carrier.Internal.Intro+import Control.Monad.Trans.Except+import Control.Monad.Trans.Identity++-- | Like InterpretC specialized to interpret 'Alt', but has 'Alternative' and+-- 'MonadPlus' instances based on the interpreted 'Alt'.+newtype InterpretAltC h m a = InterpretAltC {+ unInterpretAltC :: InterpretC h Alt m a+ }+ deriving ( Functor, Applicative, Monad+ , MonadFix, MonadIO, MonadFail+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl)++-- Like InterpretSimpleC specialized to interpret 'Alt', but has 'Alternative' and+-- 'MonadPlus' instances based on the interpreted 'Alt'.+newtype InterpretAltSimpleC m a = InterpretAltSimpleC {+ unInterpretAltSimpleC :: InterpretSimpleC Alt m a+ }+ deriving ( Functor, Applicative, Monad+ , MonadFix, MonadIO, MonadFail+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving MonadTrans++type InterpretAltReifiedC m a =+ forall s+ . ReifiesHandler s Alt m+ => InterpretAltC (ViaReifiedH s) m a++deriving newtype instance Handler h Alt m => Carrier (InterpretAltC h m)++deriving via Effly (InterpretAltC h m)+ instance Handler h Alt m => Alternative (InterpretAltC h m)++instance Handler h Alt m => MonadPlus (InterpretAltC h m)+++deriving newtype instance+ (Monad m, Carrier (InterpretSimpleC Alt m))+ => Carrier (InterpretAltSimpleC m)++deriving via Effly (InterpretAltSimpleC m)+ instance (Monad m, Carrier (InterpretSimpleC Alt m))+ => Alternative (InterpretAltSimpleC m)++instance (Monad m, Carrier (InterpretSimpleC Alt m))+ => MonadPlus (InterpretAltSimpleC m)++data AltToErrorUnitH++instance Eff (Error ()) m+ => Handler AltToErrorUnitH Alt m where+ effHandler = \case+ Empty -> throw ()+ Alt ma mb -> ma `catch` \() -> mb+ {-# INLINEABLE effHandler #-}++type AltMaybeC = CompositionC+ '[ IntroUnderC Alt '[Catch (), Throw ()]+ , InterpretAltC AltToErrorUnitH+ , ErrorC ()+ ]+++-- | Run an 'Alt' effect purely, returning @Nothing@ on an unhandled+-- 'empty'.+--+-- 'AltMaybeC' has an 'Alternative' instance based on the 'Alt'+-- effect it interprets.+--+-- @'Derivs' ('AltMaybeC' m) = 'Alt' ': 'Derivs' m@+-- @'Prims' ('AltMaybeC' m) = 'Control.Effect.Optional.Optional' ((->) ()) ': 'Prims' m@+runAltMaybe :: forall m a p+ . ( Threaders '[ErrorThreads] m p+ , Carrier m+ )+ => AltMaybeC m a+ -> m (Maybe a)+runAltMaybe =+ fmap (either (const Nothing) Just)+ .# runError+ .# interpretViaHandler+ .# unInterpretAltC+ .# introUnder+ .# runComposition+{-# INLINE runAltMaybe #-}++-- | Transform an 'Alt' effect into 'Error' by describing it in+-- terms of 'throw' and 'catch', using the provided exception to act as 'empty'.+--+-- You can use this in application code to locally get access to an 'Alternative'+-- instance (since 'InterpretAltReifiedC' has an 'Alternative' instance based+-- on the 'Alt' effect this interprets).+--+-- For example:+--+-- @+-- 'altToError' ('throw' exc) 'empty' = 'throw' exc+-- @+--+-- 'altToError' has a higher-rank type, as it makes use of 'InterpretAltReifiedC'.+-- __This makes 'altToError' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower 'altToErrorSimple',+-- which doesn't have a higher-rank type. __However__, you typically don't+-- want to use 'altToErrorSimple' in application code, since 'altToErrorSimple'+-- emits a 'ReaderThreads' threading constraint (see 'Threaders').+altToError :: forall e m a+ . Eff (Error e) m+ => e+ -> InterpretAltReifiedC m a+ -> m a+altToError e m =+ interpret \case+ Empty -> throw e+ Alt ma mb -> ma `catch` \(_ :: e) -> mb+ $ unInterpretAltC+ $ m+{-# INLINE altToError #-}++data AltToNonDetH++instance Eff NonDet m => Handler AltToNonDetH Alt m where+ effHandler = \case+ Empty -> lose+ Alt ma mb -> choose ma mb+ {-# INLINEABLE effHandler #-}+++type AltToNonDetC = InterpretAltC AltToNonDetH++-- | Transform an 'Alt' effect into 'NonDet' by describing it+-- in terms of 'lose' and 'choose'.+--+-- You can use this in application code to locally get access to an 'Alternative'+-- instance (since 'AltToNonDetC' has an 'Alternative' instance based+-- on the 'Alt' effect this interprets).+--+-- For example:+--+-- @+-- 'altToNonDet' 'empty' = 'lose'+-- @+altToNonDet :: Eff NonDet m+ => AltToNonDetC m a+ -> m a+altToNonDet = interpretViaHandler .# unInterpretAltC+{-# INLINE altToNonDet #-}+++-- | Transform an 'Alt' in terms of 'throw' and 'catch', by providing an+-- exception to act as 'empty'.+--+-- This is a less performant version of 'altToError' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+--+-- Unlike 'altToError', __you typically don't want to use this in__+-- __application code__, since this emits a 'ReaderThreads'+-- threading constraint (see 'Threaders').+altToErrorSimple :: forall e m a p+ . ( Eff (Error e) m+ , Threaders '[ReaderThreads] m p+ )+ => e+ -> InterpretAltSimpleC m a+ -> m a+altToErrorSimple e =+ interpretSimple \case+ Empty -> throw e+ Alt ma mb -> ma `catch` \(_ :: e) -> mb+ .# unInterpretAltSimpleC+{-# INLINE altToErrorSimple #-}
+ src/Control/Effect/AtomicState.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE CPP #-}+module Control.Effect.AtomicState+ ( -- * Effects+ AtomicState(..)++ -- * Actions+ , atomicState+ , atomicState'+ , atomicGet+ , atomicGets+ , atomicModify+ , atomicModify'++ , atomicPut++ -- * Interpretations+ , atomicStateToIO+ , runAtomicStateIORef+ , runAtomicStateTVar++ , atomicStateToState++ -- * Simple variants of interpretations+ , atomicStateToIOSimple+ , runAtomicStateIORefSimple+ , runAtomicStateTVarSimple++ -- * Carriers+ , AtomicStateToStateC+ ) where++import Data.IORef+import Control.Concurrent.STM++import Control.Effect+import Control.Effect.State++#if MIN_VERSION_base(4,13,0)+import GHC.IORef (atomicModifyIORefP)+#else++data Box a = Box a++atomicModifyIORefP :: IORef s -> (s -> (s, a)) -> IO a+atomicModifyIORefP ref f = do+ Box a <- atomicModifyIORef ref $ \s -> let !(s', a) = f s in (s', Box a)+ return a+{-# INLINE atomicModifyIORefP #-}+# endif++-- | An effect for atomically reading and modifying a piece of state.+--+-- Convention: the interpreter for the @AtomicState@ action must force+-- the resulting tuple of the function, but not the end state or returned value.+data AtomicState s m a where+ AtomicState :: (s -> (s, a)) -> AtomicState s m a+ AtomicGet :: AtomicState s m s++-- | Atomically read and modify the state.+--+-- The resulting tuple of the computation is forced. You can+-- control what parts of the computation are evaluated by tying+-- their evaluation to the tuple.+atomicState :: Eff (AtomicState s) m => (s -> (s, a)) -> m a+atomicState = send . AtomicState+{-# INLINE atomicState #-}++-- | Atomically read and strictly modify the state.+--+-- The resulting state -- but not the value returned -- is forced.+atomicState' :: Eff (AtomicState s) m => (s -> (s, a)) -> m a+atomicState' f = atomicState $ \s -> let (!s', a) = f s in (s', a)+{-# INLINE atomicState' #-}++-- | Read the state.+--+-- Depending on the interperation of 'AtomicState', this+-- can be more efficient than @'atomicState' (\s -> (s,s))@+atomicGet :: Eff (AtomicState s) m => m s+atomicGet = send AtomicGet+{-# INLINE atomicGet #-}++atomicGets :: Eff (AtomicState s) m => (s -> a) -> m a+atomicGets = (<$> atomicGet)+{-# INLINE atomicGets #-}++-- | Atomically modify the state.+--+-- The resulting state is not forced. 'atomicModify''+-- is a strict version that does force it.+atomicModify :: Eff (AtomicState s) m => (s -> s) -> m ()+atomicModify f = atomicState $ \s -> (f s, ())+{-# INLINE atomicModify #-}++-- | Atomically and strictly modify the state.+--+-- This is a strict version of 'atomicModify'.+atomicModify' :: Eff (AtomicState s) m => (s -> s) -> m ()+atomicModify' f = atomicState $ \s -> let !s' = f s in (s', ())+{-# INLINE atomicModify' #-}++-- | Atomically overwrite the state.+--+-- You typically don't want to use this, as+-- @'atomicGet' >>= 'atomicPut' . f@ isn't atomic.+atomicPut :: Eff (AtomicState s) m => s -> m ()+atomicPut s = atomicState $ \_ -> (s, ())+{-# INLINE atomicPut #-}++-- | Run an 'AtomicState' effect in terms of atomic operations in IO.+--+-- Internally, this simply creates a new 'IORef', passes it to+-- 'runAtomicStateIORef', and then returns the result and the final value+-- of the 'IORef'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'atomicStateToIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'atomicStateToIOSimple', which doesn't have a higher-rank type.+atomicStateToIO :: forall s m a+ . Eff (Embed IO) m+ => s+ -> InterpretReifiedC (AtomicState s) m a+ -> m (s, a)+atomicStateToIO sInit main = do+ ref <- embed $ newIORef sInit+ a <- runAtomicStateIORef ref main+ sEnd <- embed $ readIORef ref+ return (sEnd, a)+{-# INLINE atomicStateToIO #-}++-- | Run an 'AtomicState' effect in terms of atomic operations in IO.+--+-- Internally, this simply creates a new 'IORef', passes it to+-- 'runAtomicStateIORefSimple', and then returns the result and the final value+-- of the 'IORef'.+--+-- This is a less performant version of 'runAtomicStateIORefSimple' that doesn't+-- have a higher-rank type, making it much easier to use partially applied.+atomicStateToIOSimple :: forall s m a p+ . ( Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => s+ -> InterpretSimpleC (AtomicState s) m a+ -> m (s, a)+atomicStateToIOSimple sInit main = do+ ref <- embed $ newIORef sInit+ a <- runAtomicStateIORefSimple ref main+ sEnd <- embed $ readIORef ref+ return (sEnd, a)+{-# INLINE atomicStateToIOSimple #-}++-- | Run an 'AtomicState' effect by transforming it into atomic operations+-- over an 'IORef'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runAtomicStateIORef' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'runAtomicStateIORefSimple', which doesn't have a higher-rank type.+runAtomicStateIORef :: forall s m a+ . Eff (Embed IO) m+ => IORef s+ -> InterpretReifiedC (AtomicState s) m a+ -> m a+runAtomicStateIORef ref = interpret $ \case+ AtomicState f -> embed (atomicModifyIORefP ref f)+ AtomicGet -> embed (readIORef ref)+{-# INLINE runAtomicStateIORef #-}++-- | Run an 'AtomicState' effect by transforming it into atomic operations+-- over an 'IORef'.+--+-- This is a less performant version of 'runAtomicStateIORef' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runAtomicStateIORefSimple :: forall s m a p+ . ( Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => IORef s+ -> InterpretSimpleC (AtomicState s) m a+ -> m a+runAtomicStateIORefSimple ref = interpretSimple $ \case+ AtomicState f -> embed (atomicModifyIORefP ref f)+ AtomicGet -> embed (readIORef ref)+{-# INLINE runAtomicStateIORefSimple #-}++-- | Run an 'AtomicState' effect by transforming it into atomic operations+-- over an 'TVar'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runAtomicStateTVar' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'runAtomicStateTVarSimple', which doesn't have a higher-rank type.+runAtomicStateTVar :: forall s m a+ . Eff (Embed IO) m+ => TVar s+ -> InterpretReifiedC (AtomicState s) m a+ -> m a+runAtomicStateTVar tvar = interpret $ \case+ AtomicState f -> embed $ atomically $ do+ (s, a) <- f <$> readTVar tvar+ writeTVar tvar s+ return a+ AtomicGet -> embed (readTVarIO tvar)+{-# INLINE runAtomicStateTVar #-}++-- | Run an 'AtomicState' effect by transforming it into atomic operations+-- over an 'TVar'.+--+-- This is a less performant version of 'runAtomicStateIORef' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runAtomicStateTVarSimple :: forall s m a p+ . ( Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => TVar s+ -> InterpretSimpleC (AtomicState s) m a+ -> m a+runAtomicStateTVarSimple tvar = interpretSimple $ \case+ AtomicState f -> embed $ atomically $ do+ (s, a) <- f <$> readTVar tvar+ writeTVar tvar s+ return a+ AtomicGet -> embed (readTVarIO tvar)+{-# INLINE runAtomicStateTVarSimple #-}++data AtomicStateToStateH++type AtomicStateToStateC s = InterpretC AtomicStateToStateH (AtomicState s)++instance Eff (State s) m+ => Handler AtomicStateToStateH (AtomicState s) m where+ effHandler = \case+ AtomicState f -> state f+ AtomicGet -> get+ {-# INLINEABLE effHandler #-}++-- | Transform an 'AtomicState' effect into a 'State' effect, discarding atomicity.+atomicStateToState :: Eff (State s) m+ => AtomicStateToStateC s m a+ -> m a+atomicStateToState = interpretViaHandler+{-# INLINE atomicStateToState #-}
+ src/Control/Effect/BaseControl.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE DerivingVia, MagicHash #-}+module Control.Effect.BaseControl+ ( -- * Effects+ BaseControl++ -- * Actions+ , withLowerToBase+ , gainBaseControl++ -- * Interpretations+ , runBaseControl+ , baseControlToFinal++ -- * MonadBaseControl+ , MonadBaseControl(..)+ , control++ -- * Threading utilities+ , threadBaseControlViaClass++ -- * Combinators for 'Algebra's+ -- Intended to be used for custom 'Carrier' instances when+ -- defining 'algPrims'.+ , powerAlgBaseControl+ , powerAlgBaseControlFinal++ -- * Carriers+ , GainBaseControlC(..)++ , BaseControlC+ , BaseControlToFinalC+ ) where++import Data.Coerce++import Control.Monad+import Control.Effect+import Control.Effect.Carrier++import Control.Effect.Type.Internal.BaseControl+import Control.Effect.Internal.BaseControl+import Control.Effect.Internal.Itself++import Control.Effect.Internal.Utils++import Control.Monad.Trans.Identity+import Control.Monad.Trans.Control+import GHC.Exts (Proxy#, proxy#)+++newtype GainBaseControlC b z m a = GainBaseControlC {+ unGainBaseControlC :: m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , Carrier+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance (Monad m, MonadBase b z, Coercible z m)+ => MonadBase b (GainBaseControlC b z m) where+ liftBase = coerce #. liftBase @_ @z+ {-# INLINE liftBase #-}++instance (Monad m, MonadBaseControl b z, Coercible z m)+ => MonadBaseControl b (GainBaseControlC b z m) where+ type StM (GainBaseControlC b z m) a = StM z a++ liftBaseWith m = coerce $ liftBaseWith @_ @z $ \lower -> m (coerceTrans lower)+ {-# INLINE liftBaseWith #-}++ restoreM =+ coerce (restoreM @_ @z @a) :: forall a. StM z a -> GainBaseControlC b z m a+ {-# INLINE restoreM #-}++newtype Stateful m a = Stateful { getStateful :: StM m a }++-- | Gain access to a function that allows for lowering @m@ to the+-- base monad @b@.+--+-- This is less versatile, but easier to use than 'gainBaseControl'.+withLowerToBase :: forall b m a+ . Eff (BaseControl b) m+ => (forall f. (forall x. m x -> b (f x)) -> b (f a))+ -> m a+withLowerToBase main = join $ send $+ GainBaseControl @b $ \(_ :: Proxy# z) -> coerceM $ control @_ @z $ \lower ->+ getStateful @z @a <$> main (fmap (Stateful @z) . coerceTrans lower)+{-# INLINE withLowerToBase #-}++-- | Locally gain access to a @'MonadBaseControl' b@ instance+-- within a region.+--+-- You'll need to use 'lift' if you want to use the 'MonadBaseControl' instance+-- with computations outside of the region.+-- This is common with effect handlers. For example:+--+-- @+-- import System.IO (FilePath, IOMode, Handle)+-- import qualified System.IO as SysIO+--+-- data WithFile m a where+-- WithFile :: FilePath -> IOMode -> (Handle -> m a) -> WithFile m a+--+-- runWithFile :: 'Eff' ('BaseControl' IO) m => 'SimpleInterpreterFor' WithFile m+-- runWithFile = 'interpretSimple' $ \case+-- WithFile fp mode c -> 'gainBaseControl' $ 'control' $ \lower ->+-- SysIO.withFile fp mode (\hdl -> lower (lift (c hdl)))+-- @+--+gainBaseControl+ :: forall b m a+ . Eff (BaseControl b) m+ => ( forall z+ . (MonadBaseControl b z, Coercible z m)+ => GainBaseControlC b z m a+ )+ -> m a+gainBaseControl main = join $ send $+ GainBaseControl @b (\(_ :: Proxy# z) -> unGainBaseControlC (main @z))+{-# INLINE gainBaseControl #-}+++-- | Run a @'BaseControl' m@ effect, where the base @m@ is the current monad.+--+-- @'Derivs' ('BaseControlC' m) = 'BaseControl' m ': 'Derivs' m@+--+-- @'Prims' ('BaseControlC' m) = 'BaseControl' m ': 'Prims' m@+runBaseControl :: Carrier m => BaseControlC m a -> m a+runBaseControl = unBaseControlC+{-# INLINE runBaseControl #-}++data BaseControlToFinalH+type BaseControlToFinalC b = InterpretPrimC BaseControlToFinalH (BaseControl b)++instance ( MonadBaseControl b m+ , Carrier m+ )+ => PrimHandler BaseControlToFinalH (BaseControl b) m where+ effPrimHandler (GainBaseControl main) = return $ main (proxy# :: Proxy# m)+ {-# INLINEABLE effPrimHandler #-}++-- | Run a @'BaseControl' b@ effect, where the base @b@ is the final base monad.+--+-- @'Derivs' ('BaseControlToFinalC' b m) = 'BaseControl' b ': 'Derivs' m@+--+-- @'Prims' ('BaseControlToFinalC' b m) = 'BaseControl' b ': 'Prims' m@+baseControlToFinal :: (MonadBaseControl b m, Carrier m)+ => BaseControlToFinalC b m a -> m a+baseControlToFinal = interpretPrimViaHandler+{-# INLINE baseControlToFinal #-}+++-- | Strengthen an @'Algebra' p m@ by adding a @'BaseControl' m@ handler+powerAlgBaseControl :: forall m p a+ . Monad m+ => Algebra' p m a+ -> Algebra' (BaseControl m ': p) m a+powerAlgBaseControl alg = powerAlg alg $ \case+ GainBaseControl main -> return $ main (proxy# :: Proxy# (Itself m))+{-# INLINEABLE powerAlgBaseControl #-}++-- | Strengthen an @'Algebra' p m@ by adding a @'BaseControl' b@ handler,+-- where @b@ is the final base monad.+powerAlgBaseControlFinal :: forall b m p a+ . MonadBaseControl b m+ => Algebra' p m a+ -> Algebra' (BaseControl b ': p) m a+powerAlgBaseControlFinal alg = powerAlg alg $ \case+ GainBaseControl main -> return $ main (proxy# :: Proxy# m)+{-# INLINEABLE powerAlgBaseControlFinal #-}
+ src/Control/Effect/Bracket.hs view
@@ -0,0 +1,170 @@+module Control.Effect.Bracket+ ( -- * Effects+ Bracket(..)+ , ExitCase(..)++ -- * Actions+ , generalBracket+ , bracket+ , bracket_+ , bracketOnError+ , onError+ , finally++ -- * Interpretations+ , bracketToIO++ , runBracketLocally++ , ignoreBracket++ -- * Threading utilities+ , threadBracketViaClass++ -- * MonadMask+ , C.MonadMask++ -- * Carriers+ , BracketToIOC+ , BracketLocallyC+ , IgnoreBracketC+ ) where++import Control.Effect+import Control.Effect.Primitive+import Control.Effect.Type.Bracket++import Control.Monad+import Control.Monad.Catch (MonadMask)+import qualified Control.Monad.Catch as C++generalBracket :: Eff Bracket m+ => m a+ -> (a -> ExitCase b -> m c)+ -> (a -> m b)+ -> m (b, c)+generalBracket acquire release use = send (GeneralBracket acquire release use)+{-# INLINE generalBracket #-}++bracket :: Eff Bracket m+ => m a+ -> (a -> m c)+ -> (a -> m b)+ -> m b+bracket acquire release use = do+ (b, _) <- generalBracket acquire (\a _ -> release a) use+ return b+{-# INLINE bracket #-}++bracket_ :: Eff Bracket m+ => m a+ -> m c+ -> m b+ -> m b+bracket_ acquire release use = bracket acquire (const release) (const use)+{-# INLINE bracket_ #-}++bracketOnError :: Eff Bracket m+ => m a+ -> (a -> m c)+ -> (a -> m b)+ -> m b+bracketOnError acquire release use = do+ (b, _) <- generalBracket+ acquire+ (\a -> \case+ ExitCaseSuccess _ -> pure ()+ _ -> void $ release a+ )+ use+ return b+{-# INLINE bracketOnError #-}++onError :: Eff Bracket m => m a -> m b -> m a+onError m h = bracketOnError (pure ()) (const h) (const m)+{-# INLINE onError #-}++finally :: Eff Bracket m => m a -> m b -> m a+finally m h = bracket (pure ()) (const h) (const m)+{-# INLINE finally #-}++data BracketToIOH++instance (Carrier m, MonadMask m)+ => PrimHandler BracketToIOH Bracket m where+ effPrimHandler (GeneralBracket acquire release use) =+ C.generalBracket acquire release use+ {-# INLINEABLE effPrimHandler #-}++type BracketToIOC = InterpretPrimC BracketToIOH Bracket+++-- | Run a 'Bracket' by effect that protects against+-- any abortive computation of any effect, as well+-- as any IO exceptions and asynchronous exceptions.+--+-- @'Derivs' ('BracketToIOC' m) = 'Bracket' ': 'Derivs' m@+--+-- @'Prims' ('BracketToIOC' m) = 'Bracket' ': 'Prims' m@+bracketToIO :: (Carrier m, MonadMask m)+ => BracketToIOC m a+ -> m a+bracketToIO = interpretPrimViaHandler+{-# INLINE bracketToIO #-}++data BracketLocallyH++instance Carrier m => PrimHandler BracketLocallyH Bracket m where+ effPrimHandler (GeneralBracket acquire release use) = do+ a <- acquire+ b <- use a+ c <- release a (ExitCaseSuccess b)+ return (b, c)+ {-# INLINEABLE effPrimHandler #-}++type BracketLocallyC = InterpretPrimC BracketLocallyH Bracket++-- | Run a 'Bracket' effect that protects against+-- any abortive computations of purely local effects+-- -- i.e. effects interpreted before 'runBracketLocally'+-- that are not interpreted in terms of the final monad+-- nor other effects interpreted after 'runBracketLocally'.+--+-- This does /not/ protect against IO exceptions of any kind,+-- including asynchronous exceptions.+--+-- This is more situational compared to 'bracketToIO',+-- but can be useful. For an example, see the [wiki](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-topics#bracket).+--+-- @'Derivs' ('BracketLocallyC' m) = 'Bracket' ': 'Derivs' m@+--+-- @'Prims' ('BracketLocallyC' m) = 'Bracket' ': 'Prims' m@+runBracketLocally :: Carrier m+ => BracketLocallyC m a+ -> m a+runBracketLocally = interpretPrimViaHandler+{-# INLINE runBracketLocally #-}+++type IgnoreBracketC = InterpretC IgnoreBracketH Bracket++data IgnoreBracketH++instance Carrier m => Handler IgnoreBracketH Bracket m where+ effHandler (GeneralBracket acquire release use) = do+ a <- acquire+ b <- use a+ c <- release a (ExitCaseSuccess b)+ return (b, c)+ {-# INLINEABLE effHandler #-}++-- | Run a 'Bracket' effect by ignoring it, providing no protection at all.+--+-- @'Derivs' ('IgnoreBracketC' m) = 'Bracket' ': 'Derivs' m@+--+-- @'Prims' ('IgnoreBracketC' m) = 'Prims' m@+ignoreBracket :: Carrier m+ => IgnoreBracketC m a+ -> m a+ignoreBracket = interpretViaHandler+{-# INLINE ignoreBracket #-}
+ src/Control/Effect/Carrier.hs view
@@ -0,0 +1,51 @@+module Control.Effect.Carrier+ ( -- * Core types+ Carrier(..)++ , Algebra+ , Algebra'++ , Reformulation+ , Reformulation'++ -- * Combinators for 'Algebra's+ , powerAlg+ , powerAlg'+ , weakenAlg+ , coerceAlg++ -- * Combinators for 'Reformulation's+ , liftReform+ , addDeriv+ , addPrim+ , weakenReform+ , weakenReformUnder1+ , weakenReformUnder+ , weakenReformUnderMany+ , coerceReform++ -- * Hiding effects+ , StripPrefix++ -- * Type Coercion+ , module Data.Coerce++ -- * Common classes for newtype deriving+ , module Control.Effect.Internal.Derive++ -- * Primitive effects+ , module Control.Effect.Primitive++ -- * Union+ , module Control.Effect.Union+ ) where++import Data.Coerce+import Control.Effect+import Control.Effect.Internal+import Control.Effect.Primitive+import Control.Effect.Union+import Control.Effect.Internal.Derive+import Control.Effect.Internal.KnownList+import Control.Effect.Internal.Union+import Control.Effect.Carrier.Internal.Interpret
+ src/Control/Effect/Carrier/Internal/Compose.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Carrier.Internal.Compose where++import Control.Applicative+import Control.Monad+import qualified Control.Monad.Fail as Fail+import Control.Monad.Trans+import Control.Monad.Trans.Identity+import Control.Monad.Fix+import Control.Effect.Internal+import Control.Effect.Internal.Derive+import Control.Effect.Internal.Utils+import Control.Monad.Trans.Control++import Unsafe.Coerce++-- | Composition of monad/carrier transformers.+newtype ComposeT t (u :: (* -> *) -> * -> *) m a = ComposeT {+ getComposeT :: t (u m) a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ , Carrier+ )++instance ( MonadTrans t+ , MonadTrans u+ , forall m. Monad m => Monad (u m)+ )+ => MonadTrans (ComposeT t u) where+ lift m = ComposeT (lift (lift m))+ {-# INLINEABLE lift #-}++instance ( MonadTransControl t+ , MonadTransControl u+ , forall m. Monad m => Monad (u m)+ )+ => MonadTransControl (ComposeT t u) where+ type StT (ComposeT t u) a = StT u (StT t a)++ liftWith main = ComposeT $+ liftWith $ \lowerT ->+ liftWith $ \lowerU ->+ main (lowerU . lowerT .# getComposeT)+ {-# INLINEABLE liftWith #-}++ restoreT m = ComposeT (restoreT (restoreT m))+ {-# INLINEABLE restoreT #-}++-- | Composition of a list of carrier transformers.+--+-- This is useful when you have multiple interpretations whose+-- carriers you'd like to treat as one larger object, such that+-- 'lift' lifts past all those carriers.+--+-- For example:+--+-- @+-- data Counter m a where+-- Probe :: Counter m Int+--+-- type CounterC = 'CompositionC'+-- '[ 'Control.Effect.ReinterpretSimpleC' Counter '['Control.Effect.State.State' Int]+-- , 'Control.Effect.State.StateC' Int+-- ]+--+-- runCounter :: ('Control.Effect.Carrier' m, 'Control.Effect.Threaders' '['Control.Effect.State.StateThreads'] m p)+-- => CounterC m a+-- -> m a+-- runCounter =+-- 'Control.Effect.State.runState' 0+-- . 'Control.Effect.reinterpretSimple' (\case+-- Probe -> 'Control.Effect.State.state'' (\s -> (s+1,s))+-- )+-- . 'runComposition'+-- @+--+-- Then you have @'lift' :: Monad m => m a -> CounterC m a@+newtype CompositionC ts m a = CompositionC {+ unCompositionC :: CompositionBaseT ts m a+ }++#define DERIVE_COMP_M(ctx) \+deriving newtype instance ctx (CompositionBaseT ts m) \+ => ctx (CompositionC ts m)++#define DERIVE_COMP_T(ctx) \+deriving newtype instance ctx (CompositionBaseT ts) \+ => ctx (CompositionC ts)++DERIVE_COMP_M(Functor)+DERIVE_COMP_M(Applicative)+DERIVE_COMP_M(Monad)+DERIVE_COMP_M(Alternative)+DERIVE_COMP_M(MonadPlus)+DERIVE_COMP_M(MonadFix)+DERIVE_COMP_M(Fail.MonadFail)+DERIVE_COMP_M(MonadIO)+DERIVE_COMP_M(MonadThrow)+DERIVE_COMP_M(MonadCatch)+DERIVE_COMP_M(MonadMask)++-- Yes, this is necessary. Don't ask, I haven't got a clue.+deriving newtype instance (Monad b, MonadBase b (CompositionBaseT ts m))+ => MonadBase b (CompositionC ts m)+DERIVE_COMP_M(MonadBaseControl b)+DERIVE_COMP_M(Carrier)++DERIVE_COMP_T(MonadTrans)+DERIVE_COMP_T(MonadTransControl)++type family CompositionBaseT' acc ts :: (* -> *) -> * -> * where+ CompositionBaseT' acc '[] = acc+ CompositionBaseT' acc (t ': ts) = CompositionBaseT' (ComposeT acc t) ts++type CompositionBaseT ts = CompositionBaseT' IdentityT ts++type family CompositionBaseM (ts :: [(* -> *) -> * -> *]) (m :: * -> *) where+ CompositionBaseM '[] m = m+ CompositionBaseM (t ': ts) m = t (CompositionBaseM ts m)++++-- | Transform @'CompositionC' [t1, t2, ..., tn] m a@ to @t1 (t2 (... (tn m) ...)) a@+runComposition :: CompositionC ts m a+ -> CompositionBaseM ts m a+-- This is a safe use of 'unsafeCoerce'; the two types are always representationally equal,+-- without even needing the transformers in ts to be representational.+-- GHC can only prove that, however, if ts is concrete. We could stick a 'Coercible' constraint,+-- but in order to prove that constraint, both ComposeT and IdentityT needs to be in scope for the+-- user.+-- This seems like too much of a hassle, so unsafeCoerce is used instead.+--+-- TODO(KingoftheHomeless): Investigate if the use of unsafeCoerce messes up optimizations.+runComposition = unsafeCoerce+{-# INLINE runComposition #-}
+ src/Control/Effect/Carrier/Internal/Interpret.hs view
@@ -0,0 +1,733 @@+{-# LANGUAGE AllowAmbiguousTypes, DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Carrier.Internal.Interpret where++import Data.Coerce++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Reader+import Control.Monad.Fix++import Control.Monad.Trans.Identity++import Control.Effect.Internal+import Control.Effect.Internal.Derive+import Control.Effect.Internal.Itself+import Control.Effect.Internal.KnownList+import Control.Effect.Internal.Union+import Control.Effect.Internal.Effly+import Control.Effect.Internal.Reflection+import Control.Effect.Internal.Utils+import Control.Monad.Base+import Control.Effect.Carrier.Internal.Intro++data HandlerCState p m z+ = HandlerCState (forall x. m x -> z x) (Algebra p z)++newtype ReifiedReformulation r p m = ReifiedReformulation {+ getReifiedReformulation :: Reformulation r p m+ }++newtype+ HandlerC+ (sHandler :: *)+ (sReform :: *)+ (r :: [Effect])+ (p :: [Effect])+ (m :: * -> *) z (a :: *)+ = HandlerC { unHandlerC :: z a }+ deriving (Functor, Applicative, Monad) via z++data CarrierReform m++instance (Carrier m, r ~ Derivs m, p ~ Prims m)+ => Reifies (CarrierReform m)+ (ReifiedReformulation r p m) where+ reflect = ReifiedReformulation reformulate+ {-# INLINE reflect #-}+++instance ( Reifies sHandler (HandlerCState p m z)+ , Reifies sReform (ReifiedReformulation r p m)+ , Monad z+ )+ => Carrier (HandlerC sHandler sReform r p m z) where+ type Derivs (HandlerC sHandler sReform r p m z) = r+ type Prims (HandlerC sHandler sReform r p m z) = p++ algPrims =+ let+ HandlerCState _ alg = reflect @sHandler+ in+ coerce #. alg .# coerce+ {-# INLINE algPrims #-}++ reformulate n' alg =+ let+ HandlerCState n _ = reflect @sHandler+ in+ getReifiedReformulation (reflect @sReform) (n' . HandlerC #. n) alg+ {-# INLINE reformulate #-}++ algDerivs =+ let+ HandlerCState n alg = reflect @sHandler+ in+ getReifiedReformulation+ (reflect @sReform)+ (HandlerC #. n)+ (coerce #. alg .# coerce)+ {-# INLINE algDerivs #-}+++instance ( Reifies sHandler (HandlerCState p m z)+ , Monad z+ , Monad m+ )+ => MonadBase m (HandlerC sHandler sReform r p m z) where+ liftBase m =+ let+ HandlerCState n _ = reflect @sHandler+ in+ HandlerC (n m)+ {-# INLINE liftBase #-}++newtype InterpretPrimC (s :: *) (e :: Effect) (m :: * -> *) a =+ InterpretPrimC {+ unInterpretPrimC :: m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++-- | The class of effect handlers for derived effects.+-- Instances of this class can be used together 'interpretViaHandler'+-- in order to interpret effects.+--+-- @h@ is the tag for the handler, @e@ is the effect to interpret,+-- and @m@ is the 'Carrier' on which the handler operates.+--+-- To define your own interpreter using this method, create a new+-- datatype without any constructors to serve as the tag+-- for the handler, and then define a 'Handler' instance for it.+-- Then, you can use your handler to interpret effects with+-- 'interpretViaHandler'.+--+-- Alternatively, you can use 'interpret' or 'interpretSimple',+-- which lets you avoid the need to define instances of 'Handler',+-- but come at other costs.+class ( RepresentationalEff e+ , Carrier m+ )+ => Handler (h :: *) e m where+ effHandler :: EffHandler e m+++-- | The type of effect handlers for a derived effect @e@ with current+-- carrier @m@.+--+-- Don't let the type overwhelm you; in most cases, you can treat this as+-- @e m x -> m x@.+--+-- Any 'EffHandler' is required to work with /any/ carrier monad @z@ that+-- lifts @m@, and has the same derived and primitive effects as @m@ does.+-- The only constraints that are propagated to @z@ are membership+-- constraints:+-- @MonadIO m@ doesn't imply @MonadIO z@, but @Eff (Embed IO) m@ /does/+-- imply @Eff (Embed IO) z@.+--+-- In addition, since @z@ lifts @m@, you can lift values of @m@+-- to @z@ through 'liftBase'. This is most useful when using+-- 'interpret' or 'interpretSimple', as it allows you to+-- bring monadic values of @m@ from outside of the handler+-- (like arguments to the interpreter) into the handler.+--+-- The @z@ provided to the handler has 'Effly' wrapped around it,+-- so the handler may make use of the various instances of 'Effly'.+-- For example, you have access to 'MonadFix' inside the handler+-- if you have @'Eff' 'Control.Effect.Fix.Fix' m@.+--+-- Any effect to be handled needs to be+-- /representational in the monad parameter/. See 'RepresentationalEff'+-- for more information.+type EffHandler e m =+ forall z x+ . ( Carrier z+ , Derivs z ~ Derivs m+ , Prims z ~ Prims m+ , MonadBase m z+ )+ => e (Effly z) x -> Effly z x++-- | The type of effect handlers for a primitive effect @e@ with current+-- carrier @m@.+--+-- Unlike 'EffHandler's, 'EffPrimHandler's have direct access to @m@,+-- giving them significantly more powerful.+--+-- That said, __you should interpret your own effects as primitives only as a__+-- __last resort.__ Every primitive effect comes at the cost of enormous amounts+-- of boilerplate: namely, the need for a 'ThreadsEff' instance for every+-- monad transformer that can thread that effect.+--+-- Some effects in this library are intended to be used as primitive effects,+-- such as 'Control.Effect.Regional.Regional'. Try to use such effects+-- to gain the power you need to interpret your effects instead of+-- defining your own primitive effects, since the primitive effects offered+-- in this library already have 'ThreadsEff' instances defined for them.+type EffPrimHandler e m = forall x. e m x -> m x++-- | The class of effect handlers for primitive effects.+-- Instances of this class can be used together 'interpretPrimViaHandler'+-- in order to interpret primitive effects.+--+-- @h@ is the tag for the handler, @e@ is the effect to interpret,+-- and @m@ is the 'Carrier' on which the handler operates.+--+-- To define your own interpreter using this method, create a new+-- datatype without any constructors to serve as the tag+-- for the handler, and then define a 'PrimHandler' instance for it.+-- Then, you can use your handler to interpret effects with+-- 'interpretPrimViaHandler'.+--+-- Alternatively, you can use 'interpretPrim' or 'interpretPrimSimple',+-- which lets you avoid the need to define instances of 'PrimHandler',+-- but come at other costs.+--+-- __Only interpret your own effects as primitives as a last resort.__+-- See 'EffPrimHandler'.+class ( RepresentationalEff e+ , Carrier m+ ) => PrimHandler (h :: *) e m where+ effPrimHandler :: EffPrimHandler e m++instance ( Carrier m+ , Handler h e m+ ) => Carrier (InterpretC h e m) where+ type Derivs (InterpretC h e m) = e ': Derivs m+ type Prims (InterpretC h e m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg (reformulate (n .# InterpretC) alg) $+ let+ !handlerState = HandlerCState (n .# InterpretC) alg+ in+ reify handlerState $ \(_ :: p s) ->+ \e -> unHandlerC @s @(CarrierReform m) @_ @_ @m $ runEffly $+ effHandler @h @e @m (coerce e)+ {-# INLINEABLE reformulate #-}++ algDerivs = powerAlg (coerce (algDerivs @m)) $ \e ->+ InterpretC $ unItself $ runEffly $ effHandler @h @e (coerce e)+ {-# INLINEABLE algDerivs #-}++newtype InterpretC (h :: *) (e :: Effect) (m :: * -> *) a = InterpretC {+ unInterpretC :: m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT+++newtype ReifiedHandler e m = ReifiedHandler {+ getReifiedHandler :: EffHandler e m+ }++++newtype ReifiedPrimHandler (e :: Effect) m = ReifiedPrimHandler {+ getReifiedPrimHandler :: forall z x. Coercible z m => e z x -> m x+ }++coerceHandler :: (RepresentationalEff e, Coercible m n)+ => (e m a -> m a) -> e n a -> n a+coerceHandler = coerce+{-# INLINE coerceHandler #-}++instance PrimHandler h e m => Carrier (InterpretPrimC h e m) where+ type Derivs (InterpretPrimC h e m) = e ': Derivs m+ type Prims (InterpretPrimC h e m) = e ': Prims m++ algPrims =+ powerAlg+ (coerce (algPrims @m))+ (coerceHandler (effPrimHandler @h @e @m))+ {-# INLINEABLE algPrims #-}++ reformulate = addPrim (coerceReform (reformulate @m))+ {-# INLINEABLE reformulate #-}++ algDerivs =+ powerAlg+ (coerce (algDerivs @m))+ (coerceHandler (effPrimHandler @h @e @m))+ {-# INLINEABLE algDerivs #-}++data ViaReifiedH (s :: *)++instance ( RepresentationalEff e+ , Carrier m+ , Reifies s (ReifiedHandler e m)+ ) => Handler (ViaReifiedH s) e m where+ effHandler = getReifiedHandler (reflect @s)+ {-# INLINE effHandler #-}++instance ( RepresentationalEff e+ , Carrier m+ , Reifies s (ReifiedPrimHandler e m)+ ) => PrimHandler (ViaReifiedH s) e m where+ effPrimHandler = getReifiedPrimHandler (reflect @s)+ {-# INLINE effPrimHandler #-}++type InterpretReifiedC e m a =+ forall s+ . ReifiesHandler s e m+ => InterpretC (ViaReifiedH s) e m a++type InterpretPrimReifiedC e m a =+ forall s+ . ReifiesPrimHandler s e m+ => InterpretPrimC (ViaReifiedH s) e m a++newtype InterpretSimpleC (e :: Effect) (m :: * -> *) a = InterpretSimpleC {+ unInterpretSimpleC :: ReaderT (ReifiedHandler e m) m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ via ReaderT (ReifiedHandler e m) m++instance MonadTrans (InterpretSimpleC e) where+ lift m = InterpretSimpleC (lift m)+ {-# INLINE lift #-}++instance ( Threads (ReaderT (ReifiedHandler e m)) (Prims m)+ , RepresentationalEff e+ , Carrier m+ )+ => Carrier (InterpretSimpleC e m) where+ type Derivs (InterpretSimpleC e m) = e ': Derivs m+ type Prims (InterpretSimpleC e m) = Prims m++ algPrims = coerceAlg (thread @(ReaderT (ReifiedHandler e m)) (algPrims @m))+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \e -> do+ ReifiedHandler handler <- n (InterpretSimpleC ask)+ let !handlerState = HandlerCState (n . lift) alg+ reify handlerState $ \(_ :: p s) ->+ unHandlerC @s @(CarrierReform m) @_ @_ @m $ runEffly $+ handler (coerce e)+ {-# INLINEABLE reformulate #-}++newtype InterpretPrimSimpleC (e :: Effect) (m :: * -> *) a =+ InterpretPrimSimpleC {+ unInterpretPrimSimpleC :: ReaderT (ReifiedPrimHandler e m) m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ via ReaderT (ReifiedPrimHandler e m) m++instance MonadTrans (InterpretPrimSimpleC e) where+ lift m = InterpretPrimSimpleC (lift m)+ {-# INLINE lift #-}++instance ( Threads (ReaderT (ReifiedPrimHandler e m)) (Prims m)+ , ThreadsEff (ReaderT (ReifiedPrimHandler e m)) e+ , RepresentationalEff e+ , Carrier m+ )+ => Carrier (InterpretPrimSimpleC e m) where+ type Derivs (InterpretPrimSimpleC e m) = e ': Derivs m+ type Prims (InterpretPrimSimpleC e m) = e ': Prims m++ algPrims =+ powerAlg+ (coerce (thread @(ReaderT (ReifiedPrimHandler e m)) (algPrims @m)))+ $ \e -> InterpretPrimSimpleC $ ReaderT $ \rh@(ReifiedPrimHandler h) ->+ runReaderT (threadEff @(ReaderT (ReifiedPrimHandler e m)) h (coerce e)) rh+ {-# INLINEABLE algPrims #-}++ reformulate = addPrim (liftReform reformulate)+ {-# INLINEABLE reformulate #-}++-- | Interpret an effect in terms of other effects, without needing to+-- define an explicit 'Handler' instance. This is an alternative to+-- 'interpretViaHandler', and is more performant than 'interpretSimple'.+--+-- See 'EffHandler' for more information about the handler you pass to+-- this function.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'interpret' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__ You must use+-- paranthesis or '$'.+--+-- Consider using 'interpretSimple' instead if performance is secondary.+--+-- Example usage:+--+-- @+-- data Teletype :: Effect where+-- ReadTTY :: Teletype m String+-- WriteTTY :: String -> Teletype m ()+--+-- readTTY :: 'Eff' Teletype m => m String+-- readTTY = send ReadTTY+--+-- writeTTY :: 'Eff' Teletype m => String -> m ()+-- writeTTY = send . WriteTTY+--+-- echo :: 'Eff' Teletype m => m ()+-- echo = readTTY >>= sendTTY+--+-- teletypeToIO :: 'Eff' ('Control.Effect.Embed' IO) m => 'Control.Effect.InterpreterFor' Teletype m+-- teletypeToIO = 'interpret' $ \case+-- ReadTTY -> 'Control.Effect.embed' getLine+-- WriteTTY str -> 'Control.Effect.embed' $ putStrLn str+--+-- main :: IO ()+-- main = 'Control.Effect.runM' $ teletypeToIO $ echo+-- @+--+interpret :: forall e m a+ . (RepresentationalEff e, Carrier m)+ => EffHandler e m+ -> InterpretReifiedC e m a+ -> m a+interpret h m = reify (ReifiedHandler h) $ \(_ :: p s) ->+ unInterpretC @(ViaReifiedH s) m+{-# INLINE interpret #-}++-- | Interpret an effect in terms of other effects, without needing to+-- define an explicit 'Handler' instance. This is an alternative to+-- 'interpretViaHandler'.+--+-- See 'EffHandler' for more information about the handler you pass to+-- this function.+--+-- This is a significantly slower variant of 'interpret' that doesn't have+-- a higher-ranked type, making it much easier to use partially applied.+--+-- Note: this emits the threading constraint 'ReaderThreads' (see 'Threaders').+-- This makes 'interpretSimple' significantly less attractive to use+-- in application code, as it means propagating that constraint+-- through your application.+--+-- Example usage:+--+-- @+-- data Teletype :: Effect where+-- ReadTTY :: Teletype m String+-- WriteTTY :: String -> Teletype m ()+--+-- readTTY :: 'Eff' Teletype m => m String+-- readTTY = send ReadTTY+--+-- writeTTY :: 'Eff' Teletype m => String -> m ()+-- writeTTY = send . WriteTTY+--+-- echo :: 'Eff' Teletype m => m ()+-- echo = readTTY >>= sendTTY+--+-- teletypeToIO :: 'Eff' ('Control.Effect.Embed' IO) m => 'Control.Effect.SimpleInterpreterFor' Teletype m+-- teletypeToIO = 'interpretSimple' $ \case+-- ReadTTY -> 'Control.Effect.embed' getLine+-- WriteTTY str -> 'Control.Effect.embed' $ putStrLn str+--+-- main :: IO ()+-- main = 'Control.Effect.runM' $ teletypeToIO $ echo+-- @+--+interpretSimple+ :: forall e m a p+ . ( RepresentationalEff e+ , Threaders '[ReaderThreads] m p+ , Carrier m+ )+ => EffHandler e m+ -> InterpretSimpleC e m a+ -> m a+interpretSimple h m = coerce m (ReifiedHandler @e @m h)+{-# INLINE interpretSimple #-}++-- | Interpret an effect in terms of other effects by using+-- an explicit 'Handler' instance.+--+-- See 'Handler' for more information.+--+-- Unlike 'interpret', this does not have a higher-rank type,+-- making it easier to use partially applied, and unlike+-- 'interpretSimple' doesn't sacrifice performance.+--+-- Example usage:+--+-- @+-- data Teletype :: Effect where+-- ReadTTY :: Teletype m String+-- WriteTTY :: String -> Teletype m ()+--+-- readTTY :: 'Eff' Teletype m => m String+-- readTTY = send ReadTTY+--+-- writeTTY :: 'Eff' Teletype m => String -> m ()+-- writeTTY = send . WriteTTY+--+-- echo :: 'Eff' Teletype m => m ()+-- echo = readTTY >>= sendTTY+--+-- data TeletypeToIOH+--+-- instance 'Eff' ('Control.Effect.Embed' IO) m+-- => 'Handler' TeletypeToIOH Teletype m where+-- effHandler = \case+-- ReadTTY -> 'Control.Effect.embed' getLine+-- WriteTTY str -> 'Control.Effect.embed' $ putStrLn str+--+-- type TeletypeToIOC = 'InterpretC' TeletypeToIOH Teletype+--+-- teletypeToIO :: 'Eff' ('Control.Effect.Embed' IO) m => TeletypeToIOC m a -> m a+-- teletypeToIO = 'interpretViaHandler'+--+-- main :: IO ()+-- main = 'Control.Effect.runM' $ teletypeToIO $ echo+-- @+--+interpretViaHandler :: forall h e m a+ . Handler h e m+ => InterpretC h e m a+ -> m a+interpretViaHandler = unInterpretC+{-# INLINE interpretViaHandler #-}++-- | Interpret an effect as a new primitive effect.+--+-- __*Only interpret your own effects as primitives as a last resort.__+-- See 'EffPrimHandler'.+--+-- This has a higher-rank type, as it makes use of 'InterpretPrimReifiedC'.+-- __This makes 'interpretPrim' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__ You must use+-- paranthesis or '$'.+--+-- Consider using 'interpretPrimSimple' instead if performance is secondary.+interpretPrim :: forall e m a+ . (RepresentationalEff e, Carrier m)+ => EffPrimHandler e m+ -> InterpretPrimReifiedC e m a+ -> m a+interpretPrim h m =+ let+ int :: ReifiedPrimHandler e m+ int = ReifiedPrimHandler (h .# coerce)+ in+ reify int $+ \(_ :: p s) -> interpretPrimViaHandler @(ViaReifiedH s) m+{-# INLINE interpretPrim #-}++-- | Interpret an effect as a new primitive effect by using+-- an explicit 'PrimHandler' instance.+--+-- See 'PrimHandler' for more information.+--+-- __Only interpret your own effects as primitives as a last resort.__+-- See 'EffPrimHandler'.+--+-- Unlike 'interpretPrim', this does not have a higher-rank type,+-- making it easier to use partially applied, and unlike+-- 'interpretPrimSimple' doesn't sacrifice performance.+interpretPrimViaHandler+ :: forall h e m a+ . PrimHandler h e m+ => InterpretPrimC h e m a+ -> m a+interpretPrimViaHandler = unInterpretPrimC+{-# INLINE interpretPrimViaHandler #-}++-- | A significantly slower variant of 'interpretPrim' that doesn't have+-- a higher-ranked type, making it much easier to use partially applied.+--+-- __*Only interpret your own effects as primitives as a last resort.__+-- See 'EffPrimHandler'.+--+-- Note the @ReaderThreads '[e]@ constraint, meaning+-- you need to define a @ThreadsEff e (ReaderT i)@ instance in order+-- to use 'interpretPrimSimple'.+interpretPrimSimple+ :: forall e m a p+ . ( RepresentationalEff e+ , Threaders '[ReaderThreads] m p+ , ReaderThreads '[e]+ , Carrier m+ )+ => EffPrimHandler e m+ -> InterpretPrimSimpleC e m a+ -> m a+interpretPrimSimple h m = coerce m (ReifiedPrimHandler @e @m (h .# coerce))+{-# INLINE interpretPrimSimple #-}++-- | Add a derived effect to a 'Reformulation'+-- by providing a handler for that effect.+--+-- The handler is an 'EffHandler', but with derived and primitive effects+-- determined by the transformed 'Reformulation'.+addDeriv :: ( RepresentationalEff e+ , Monad m+ )+ => ( forall z x+ . ( Carrier z+ , Derivs z ~ r+ , Prims z ~ p+ , MonadBase m z+ )+ => e (Effly z) x -> Effly z x+ )+ -> Reformulation r p m+ -> Reformulation (e ': r) p m+addDeriv !h !reform = \ !n !alg ->+ let+ !handlerState = HandlerCState n alg+ in+ reify handlerState $ \(_ :: pr sHandler) ->+ reify (ReifiedReformulation reform) $ \(_ :: pr sReform) ->+ powerAlg (reform n alg) $ \e ->+ unHandlerC @sHandler @sReform $ runEffly $ h (coerce e)+{-# INLINE addDeriv #-}++++newtype ReinterpretC h e new m a = ReinterpretC {+ unReinterpretC :: IntroUnderC e new (InterpretC h e m) a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++deriving+ via+ IntroUnderC e new (InterpretC h e m)+ instance+ ( Handler h e m+ , Carrier m+ , KnownList new+ , IntroConsistent '[] new m+ )+ => Carrier (ReinterpretC h e new m)++type ReifiesHandler s e m = Reifies s (ReifiedHandler e m)+type ReifiesPrimHandler s e m = Reifies s (ReifiedPrimHandler e m)++type ReinterpretReifiedC e new m a =+ forall s+ . ReifiesHandler s e m+ => ReinterpretC (ViaReifiedH s) e new m a++-- | Reinterpret an effect in terms of newly introduced effects.+--+-- This combines 'interpret' and 'introUnder' in order to introduce the effects+-- @new@ under @e@, which you then may make use of inside the handler for @e@.+--+-- This has a higher-rank type, as it makes use of 'ReinterpretReifiedC'.+-- __This makes 'reinterpret' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__ You must use+-- paranthesis or '$'.+--+-- Consider using 'reinterpretSimple' instead if performance is secondary.+reinterpret :: forall e new m a+ . ( RepresentationalEff e+ , KnownList new+ , HeadEffs new m+ )+ => EffHandler e m+ -> ReinterpretReifiedC e new m a+ -> m a+reinterpret h main = interpret h $ introUnder (unReinterpretC main)+{-# INLINE reinterpret #-}++-- | Reinterpret an effect in terms of newly introduced effects by using+-- an explicit 'Handler' instance.+--+-- See 'Handler' for more information.+--+-- This combines 'interpretViaHandler' and 'introUnder' in order to introduce+-- the effects @new@ under @e@, which you then may make use of inside the handler+-- for @e@.+--+-- Unlike 'reinterpret', this does not have a higher-rank type,+-- making it easier to use partially applied, and unlike+-- 'reinterpretSimple' doesn't sacrifice performance.+reinterpretViaHandler :: forall h e new m a+ . ( Handler h e m+ , KnownList new+ , HeadEffs new m+ )+ => ReinterpretC h e new m a+ -> m a+reinterpretViaHandler = coerce+{-# INLINE reinterpretViaHandler #-}++newtype ReinterpretSimpleC e new m a = ReinterpretSimpleC {+ unReinterpretSimpleC :: IntroUnderC e new (InterpretSimpleC e m) a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving MonadTrans via InterpretSimpleC e++deriving via IntroUnderC e new (InterpretSimpleC e m)+ instance ( Threads (ReaderT (ReifiedHandler e m)) (Prims m)+ , RepresentationalEff e+ , KnownList new+ , HeadEffs new m+ , Carrier m+ )+ => Carrier (ReinterpretSimpleC e new m)++-- | Reinterpret an effect in terms of newly introduced effects.+--+-- This combines 'interpretSimple' and 'introUnder' in order to introduce+-- the effects @new@ under @e@, which you then may make use of inside the+-- handler for @e@.+--+-- This is a significantly slower variant of 'reinterpret' that doesn't have+-- a higher-ranked type, making it much easier to use partially applied.+reinterpretSimple :: forall e new m a p+ . ( RepresentationalEff e+ , KnownList new+ , HeadEffs new m+ , Threaders '[ReaderThreads] m p+ )+ => EffHandler e m+ -> ReinterpretSimpleC e new m a+ -> m a+reinterpretSimple h =+ interpretSimple h+ .# introUnder+ .# unReinterpretSimpleC+{-# INLINE reinterpretSimple #-}
+ src/Control/Effect/Carrier/Internal/Intro.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Carrier.Internal.Intro where++import Data.Coerce++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Catch+import Control.Monad.Fix++import Control.Effect.Internal+import Control.Effect.Internal.Derive+import Control.Effect.Internal.Union+import Control.Effect.Internal.Utils+import Control.Effect.Internal.KnownList+import Control.Monad.Trans.Identity++newtype IntroC (top :: [Effect])+ (new :: [Effect])+ (m :: * -> *)+ a+ = IntroC { runIntroC :: m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++type RestDerivs top new m = StripPrefix new (StripPrefix top (Derivs m))++instance ( Carrier m+ , KnownList top+ , KnownList new+ , IntroConsistent top new m+ ) => Carrier (IntroC top new m) where+ type Derivs (IntroC top new m) = Append top (RestDerivs top new m)+ type Prims (IntroC top new m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ weakenAlgMid+ @(RestDerivs top new m)+ (singList @top)+ (singList @new)+ (reformulate (n .# IntroC) alg)+ {-# INLINEABLE reformulate #-}++ algDerivs =+ weakenAlgMid+ @(RestDerivs top new m)+ (singList @top)+ (singList @new)+ (coerce (algDerivs @m))+ {-# INLINEABLE algDerivs #-}+++type IntroTopC = IntroC '[]+type IntroUnderC e = IntroC '[e]++-- | Synonym for 'IntroC' to match 'introUnderMany'+type IntroUnderManyC = IntroC++-- | A constraint that the effect stack of @m@ -- @'Control.Effect.Derivs' m@ --+-- begins with the effect @e@.+--+-- Note that unlike 'Control.Effect.Eff', this does not give+-- 'Control.Effect.Bundle' special treatment.+type HeadEff e m = (IntroConsistent '[] '[e] m, Carrier m)++-- | A constraint that the effect stack of @m@ -- @'Control.Effect.Derivs' m@ --+-- begins with @new@.+--+-- Note that unlike 'Control.Effect.Effs', this does not give+-- 'Control.Effect.Bundle' special treatment.+type HeadEffs new m = (IntroConsistent '[] new m, Carrier m)++-- | A constraint that the effect stack of @m@ -- @'Control.Effect.Derivs' m@ --+-- begins with @Append top new@.+type IntroConsistent top new m+ = (Append top (Append new (StripPrefix new (StripPrefix top (Derivs m)))) ~ Derivs m)++-- | Introduce multiple effects under a number of top effects of the effect+-- stack -- or rather, reveal those effects which were previously hidden.+--+-- @'Derivs' ('IntroC' top new m) = Append top ('Control.Effect.Carrier.StripPrefix' (Append top new) ('Derivs' m))@+introUnderMany :: forall top new m a+ . ( KnownList top+ , KnownList new+ , IntroConsistent top new m+ )+ => IntroUnderManyC top new m a+ -> m a+introUnderMany = runIntroC+{-# INLINE introUnderMany #-}++-- | Introduce multiple effects under the top effect of the effect stack+-- -- or rather, reveal those effects which were previously hidden.+--+-- @'Derivs' ('IntroUnderC' e new m) = e ': 'Control.Effect.Carrier.StripPrefix' (e ': new) ('Derivs' m)@+introUnder :: forall new e m a+ . ( KnownList new+ , IntroConsistent '[e] new m+ )+ => IntroUnderC e new m a+ -> m a+introUnder = runIntroC+{-# INLINE introUnder #-}++-- | Introduce an effect under the top effect of the effect stack+-- -- or rather, reveal that effect which was previously hidden.+--+-- @'Derivs' ('IntroUnderC' e '[new] m) = e ': 'Control.Effect.Carrier.StripPrefix' [e, new] ('Derivs' m)@+introUnder1 :: forall new e m a+ . IntroConsistent '[e] '[new] m+ => IntroUnderC e '[new] m a+ -> m a+introUnder1 = runIntroC+{-# INLINE introUnder1 #-}++-- | Introduce multiple effects on the top of the effect stack+-- -- or rather, reveal effects previously hidden.+--+-- @'Derivs' ('IntroTopC' new m) = 'Control.Effect.Carrier.StripPrefix' new ('Derivs' m)@+intro :: forall new m a+ . ( KnownList new+ , IntroConsistent '[] new m+ )+ => IntroTopC new m a+ -> m a+intro = runIntroC+{-# INLINE intro #-}++-- | Introduce an effect at the top of the stack -- or rather, reveal an effect+-- previously hidden.+--+-- @'Derivs' ('IntroTopC' [e] m) = 'Control.Effect.Carrier.StripPrefix' '[e] ('Derivs' m)@+intro1 :: forall e m a+ . IntroConsistent '[] '[e] m+ => IntroTopC '[e] m a+ -> m a+intro1 = runIntroC+{-# INLINE intro1 #-}
+ src/Control/Effect/Carrier/Internal/Stepped.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Carrier.Internal.Stepped where++import Data.Coerce+import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.Free.Church.Alternate+import Control.Effect.Internal+import Control.Effect.Internal.Utils+import Control.Effect.Internal.Membership+import Control.Effect.Internal.Derive+import Control.Effect.Internal.Union++data FOEff e x where+ FOEff :: e q x -> FOEff e x++-- | A constraint that @e@ is first-order.+--+-- This is automatically deduced by the compiler.+class (forall m n x. Coercible (e m x) (e n x))+ => FirstOrder (e :: Effect)+instance (forall m n x. Coercible (e m x) (e n x))+ => FirstOrder e++-- | A carrier for any __first-order__ effect @e@ that allows for+-- dividing a computation into several steps, where+-- each step is seperated by the use of the effect.+--+-- This can be used to implement coroutines.+newtype SteppedC (e :: Effect) m a = SteppedC {+ unSteppedC :: FreeT (FOEff e) m a+ }+ deriving ( Functor, Applicative, Monad+ , MonadFail, MonadIO, MonadBase b+ , MonadThrow, MonadCatch+ )+ deriving MonadTrans++sendStepped :: e q a -> SteppedC e m a+sendStepped = SteppedC #. liftF . FOEff+{-# INLINE sendStepped #-}++instance ( Threads (FreeT (FOEff e)) (Prims m)+ , Carrier m+ )+ => Carrier (SteppedC e m) where+ type Derivs (SteppedC e m) = e ': Derivs m+ type Prims (SteppedC e m) = Prims m++ algPrims = coerce (thread @(FreeT (FOEff e)) (algPrims @m))+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg' (reformulate (n . lift) alg) (n . sendStepped)+ {-# INLINEABLE reformulate #-}++-- | A stack of continuations of @m@ that eventually produces a result of type @a@.+-- Each continuation is seperated by the use of the effect @e@.+data Steps (e :: Effect) m a where+ Done :: a -> Steps e m a+ More :: e q x -> (x -> m (Steps e m a)) -> Steps e m a++deriving instance Functor m => Functor (Steps e m)++instance Functor m => Applicative (Steps e m) where+ pure = Done+ {-# INLINE pure #-}++ liftA2 f (Done a) fb = fmap (f a) fb+ liftA2 f (More e c) fb = More e (fmap (\fa -> liftA2 f fa fb) . c)++instance Functor m => Monad (Steps e m) where+ Done a >>= f = f a+ More e c >>= f = More e (fmap (>>= f) . c)++-- | Run the __first-order__ effect @e@ by breaking the computation using it+-- into steps, where each step is seperated by the use of an action of @e@.+steps :: forall e m a p+ . ( Carrier m+ , Threaders '[SteppedThreads] m p+ )+ => SteppedC e m a -> m (Steps e m a)+steps =+ foldFreeT+ Done+ (\c (FOEff e) -> return (More e c))+ .# unSteppedC+{-# INLINE steps #-}++liftSteps :: (MonadTrans t, Monad m) => Steps e m a -> Steps e (t m) a+liftSteps (Done a) = Done a+liftSteps (More e c) = More e (lift . fmap liftSteps . c)++-- | Execute all the steps of a computation.+unsteps :: forall e m a+ . ( FirstOrder e+ , Member e (Derivs m)+ , Carrier m+ )+ => Steps e m a -> m a+unsteps (Done a) = return a+unsteps (More e c) = send @e (coerce e) >>= c >>= unsteps++-- | 'SteppedThreads' accepts the following primitive effects:+--+-- * 'Control.Effect.Regional.Regional' @s@+-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)+-- * 'Control.Effect.Type.Unravel.Unravel' @p@+-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@+type SteppedThreads = FreeThreads
+ src/Control/Effect/Conc.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE DerivingVia #-}+-- | Interface adapted from "Control.Concurrent.Async"+module Control.Effect.Conc+ ( -- * Effects+ Conc+ , Async++ -- * Interpretations+ , concToIO++ , concToUnliftIO++ -- * Key actions+ , async+ , withAsync+ , wait+ , poll++ , concurrently+ , race++ , waitEither+ , waitBoth+ , link+ , link2++ , waitAny+ , mapConcurrently+ , forConcurrently++ -- * Concurrently applicative+ , Concurrently(..)++ -- * Other actions+ , asyncBound+ , asyncOn+ , asyncWithUnmask+ , asyncOnWithUnmask+ , withAsyncBound+ , withAsyncWithUnmask+ , withAsyncOnWithUnmask+ , waitCatch+ , cancel+ , uninterruptibleCancel+ , cancelWith+ , waitAnyCatch+ , waitAnyCancel+ , waitAnyCatchCancel+ , waitEitherCatch+ , waitEitherCancel+ , waitEitherCatchCancel+ , waitEither_+ , linkOnly+ , link2Only+ , race_+ , concurrently_+ , mapConcurrently_+ , forConcurrently_+ , replicateConcurrently+ , replicateConcurrently_++ -- * Re-exports from "Control.Concurrent.Async"+ , A.asyncThreadId+ , A.AsyncCancelled(..)+ , A.ExceptionInLinkedThread(..)+ , A.waitAnySTM+ , A.waitAnyCatchSTM+ , A.waitEitherSTM+ , A.waitEitherCatchSTM+ , A.waitEitherSTM_+ , A.waitBothSTM+ , A.compareAsyncs++ -- * Carriers+ , ConcToIOC+ , ConcToUnliftIOC+ ) where++import Control.Applicative+import Control.Monad++import Control.Concurrent.Async (Async)+import qualified Control.Concurrent.Async as A++import Control.Effect+import Control.Effect.Unlift++import Control.Exception (SomeException, Exception)+import Control.Effect.Internal.Newtype++-- For coercion purposes+import Control.Effect.Internal.Utils+import Control.Monad.Trans.Identity+import Control.Effect.Carrier.Internal.Compose+import Control.Effect.Carrier.Internal.Interpret++-- | An effect for concurrent execution.+newtype Conc m a = Conc (Unlift IO m a)+ deriving EffNewtype via Conc `WrapperOf` Unlift IO++unliftConc :: Eff Conc m => ((forall x. m x -> IO x) -> IO a) -> m a+unliftConc main = wrapWith Conc $ unlift (\lower -> main (lower .# lift))+{-# INLINE unliftConc #-}++type ConcToIOC = CompositionC+ '[ UnwrapTopC Conc+ , UnliftToFinalC IO+ ]++type ConcToUnliftIOC = UnwrapC Conc++-- | Run a 'Conc' effect if __all__ effects used in the program --+-- past and future -- are eventually reduced to operations on 'IO'.+--+-- Due to its very restrictive primitive effect and carrier constraint,+-- `concToIO` can't be used together with most pure interpreters.+-- For example, instead of 'Control.Effect.Error.runError', you must use+-- 'Control.Effect.Error.errorToIO'.+--+-- This poses a problem if you want to use some effect that /doesn't have/+-- an interpreter compatible with 'concToIO' -- like+-- 'Control.Effect.NonDet.NonDet'.+-- In that case, you might sitll be able to use both effects in the same program+-- by applying+-- [/Split Interpretation/](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-Topics#split-interpretation)+-- to seperate their uses.+--+-- @'Derivs' ('ConcToIOC' m) = 'Conc' ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ConcToIOC' m) = 'Unlift' 'IO' ': 'Control.Effect.Primitive.Prims' m@+--+concToIO :: ( Carrier m+ , MonadBaseControlPure IO m+ )+ => ConcToIOC m a+ -> m a+concToIO =+ unliftToFinal+ .# unwrapTop+ .# runComposition+{-# INLINE concToIO #-}++-- | Transform a 'Conc' effect into @'Unlift' IO@.+concToUnliftIO :: Eff (Unlift IO) m+ => ConcToUnliftIOC m a+ -> m a+concToUnliftIO = unwrap+{-# INLINE concToUnliftIO #-}++async :: Eff Conc m => m a -> m (Async a)+async m = unliftConc $ \lower -> A.async (lower m)+{-# INLINE async #-}++asyncBound :: Eff Conc m => m a -> m (Async a)+asyncBound m = unliftConc $ \lower -> A.asyncBound (lower m)+{-# INLINE asyncBound #-}++asyncOn :: Eff Conc m => Int -> m a -> m (Async a)+asyncOn i m = unliftConc $ \lower -> A.asyncOn i (lower m)+{-# INLINE asyncOn #-}++asyncWithUnmask :: Eff Conc m => ((forall x. m x -> m x) -> m a) -> m (Async a)+asyncWithUnmask main = unliftConc $ \lower -> A.asyncWithUnmask $ \restore ->+ lower $ main $ \m -> unliftConc $ \lower' -> restore (lower' m)+{-# INLINE asyncWithUnmask #-}++asyncOnWithUnmask :: Eff Conc m => Int -> ((forall x. m x -> m x) -> m a) -> m (Async a)+asyncOnWithUnmask i main = unliftConc $ \lower -> A.asyncOnWithUnmask i $ \restore ->+ lower $ main $ \m -> unliftConc $ \lower' -> restore (lower' m)+{-# INLINE asyncOnWithUnmask #-}++withAsync :: Eff Conc m => m a -> (Async a -> m b) -> m b+withAsync m c = unliftConc $ \lower -> A.withAsync (lower m) (lower . c)+{-# INLINE withAsync #-}++withAsyncBound :: Eff Conc m => m a -> (Async a -> m b) -> m b+withAsyncBound m c = unliftConc $ \lower -> A.withAsyncBound (lower m) (lower . c)+{-# INLINE withAsyncBound #-}++withAsyncWithUnmask :: Eff Conc m => ((forall x. m x -> m x) -> m a) -> (Async a -> m b) -> m b+withAsyncWithUnmask main c = unliftConc $ \lower ->+ A.withAsyncWithUnmask+ (\restore -> lower $ main $ \m -> unliftConc $ \lower' -> restore (lower' m))+ (lower . c)+{-# INLINE withAsyncWithUnmask #-}+++withAsyncOnWithUnmask :: Eff Conc m => Int -> ((forall x. m x -> m x) -> m a) -> (Async a -> m b) -> m b+withAsyncOnWithUnmask i main c = unliftConc $ \lower ->+ A.withAsyncOnWithUnmask i+ (\restore -> lower $ main $ \m -> unliftConc $ \lower' -> restore (lower' m))+ (lower . c)+{-# INLINE withAsyncOnWithUnmask #-}++wait :: Eff Conc m => Async a -> m a+wait a = unliftConc $ \_ -> A.wait a+{-# INLINE wait #-}++poll :: Eff Conc m => Async a -> m (Maybe (Either SomeException a))+poll a = unliftConc $ \_ -> A.poll a+{-# INLINE poll #-}++waitCatch :: Eff Conc m => Async a -> m (Either SomeException a)+waitCatch a = unliftConc $ \_ -> A.waitCatch a+{-# INLINE waitCatch #-}++cancel :: Eff Conc m => Async a -> m ()+cancel a = unliftConc $ \_ -> A.cancel a+{-# INLINE cancel #-}++uninterruptibleCancel :: Eff Conc m => Async a -> m ()+uninterruptibleCancel a = unliftConc $ \_ -> A.uninterruptibleCancel a+{-# INLINE uninterruptibleCancel #-}++cancelWith :: Eff Conc m => (Exception e, Eff Conc m) => Async a -> e -> m ()+cancelWith a e = unliftConc $ \_ -> A.cancelWith a e+{-# INLINE cancelWith #-}++waitAny :: Eff Conc m => [Async a] -> m (Async a, a)+waitAny as = unliftConc $ \_ -> A.waitAny as+{-# INLINE waitAny #-}++waitAnyCatch :: Eff Conc m => [Async a] -> m (Async a, Either SomeException a)+waitAnyCatch as = unliftConc $ \_ -> A.waitAnyCatch as+{-# INLINE waitAnyCatch #-}++waitAnyCancel :: Eff Conc m => [Async a] -> m (Async a, a)+waitAnyCancel as = unliftConc $ \_ -> A.waitAnyCancel as+{-# INLINE waitAnyCancel #-}++waitAnyCatchCancel :: Eff Conc m => [Async a] -> m (Async a, Either SomeException a)+waitAnyCatchCancel as = unliftConc $ \_ -> A.waitAnyCatchCancel as+{-# INLINE waitAnyCatchCancel #-}++waitEither :: Eff Conc m => Async a -> Async b -> m (Either a b)+waitEither aa ab = unliftConc $ \_ -> A.waitEither aa ab+{-# INLINE waitEither #-}+++waitEitherCatch :: Eff Conc m => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatch aa ab = unliftConc $ \_ -> A.waitEitherCatch aa ab+{-# INLINE waitEitherCatch #-}++waitEitherCancel :: Eff Conc m => Async a -> Async b -> m (Either a b)+waitEitherCancel aa ab = unliftConc $ \_ -> A.waitEitherCancel aa ab+{-# INLINE waitEitherCancel #-}++waitEitherCatchCancel :: Eff Conc m => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatchCancel aa ab = unliftConc $ \_ -> A.waitEitherCatchCancel aa ab+{-# INLINE waitEitherCatchCancel #-}++waitEither_ :: Eff Conc m => Async a -> Async b -> m ()+waitEither_ aa ab = unliftConc $ \_ -> A.waitEither_ aa ab+{-# INLINE waitEither_ #-}++waitBoth :: Eff Conc m => Async a -> Async b -> m (a, b)+waitBoth aa ab = unliftConc $ \_ -> A.waitBoth aa ab+{-# INLINE waitBoth #-}++link :: Eff Conc m => Async a -> m ()+link a = unliftConc $ \_ -> A.link a+{-# INLINE link #-}++linkOnly :: Eff Conc m => (SomeException -> Bool) -> Async a -> m ()+linkOnly h a = unliftConc $ \_ -> A.linkOnly h a+{-# INLINE linkOnly #-}++link2 :: Eff Conc m => Async a -> Async b -> m ()+link2 a b = unliftConc $ \_ -> A.link2 a b+{-# INLINE link2 #-}++link2Only :: Eff Conc m => (SomeException -> Bool) -> Async a -> Async b -> m ()+link2Only h a b = unliftConc $ \_ -> A.link2Only h a b+{-# INLINE link2Only #-}++race :: Eff Conc m => m a -> m b -> m (Either a b)+race ma mb = unliftConc $ \lower -> A.race (lower ma) (lower mb)+{-# INLINE race #-}++race_ :: Eff Conc m => m a -> m b -> m ()+race_ ma mb = unliftConc $ \lower -> A.race_ (lower ma) (lower mb)+{-# INLINE race_ #-}++concurrently :: Eff Conc m => m a -> m b -> m (a, b)+concurrently ma mb = unliftConc $ \lower -> A.concurrently (lower ma) (lower mb)+{-# INLINE concurrently #-}++concurrently_ :: Eff Conc m => m a -> m b -> m ()+concurrently_ ma mb = unliftConc $ \lower -> A.concurrently_ (lower ma) (lower mb)+{-# INLINE concurrently_ #-}++mapConcurrently :: (Traversable t, Eff Conc m) => (a -> m b) -> t a -> m (t b)+mapConcurrently = (runConcurrently .) #. traverse .# (Concurrently .)+{-# INLINE mapConcurrently #-}++forConcurrently :: (Traversable t, Eff Conc m) => t a -> (a -> m b) -> m (t b)+forConcurrently = flip mapConcurrently+{-# INLINE forConcurrently #-}++mapConcurrently_ :: (Foldable t, Eff Conc m) => (a -> m b) -> t a -> m ()+mapConcurrently_ f = runConcurrently #. foldMap (Concurrently #. void . f)+{-# INLINE mapConcurrently_ #-}++forConcurrently_ :: (Foldable t, Eff Conc m) => t a -> (a -> m b) -> m ()+forConcurrently_ = flip mapConcurrently_+{-# INLINE forConcurrently_ #-}++replicateConcurrently :: Eff Conc m => Int -> m a -> m [a]+replicateConcurrently cnt = runConcurrently #. replicateM cnt .# Concurrently+{-# INLINE replicateConcurrently #-}++replicateConcurrently_ :: Eff Conc m => Int -> m a -> m ()+replicateConcurrently_ cnt = runConcurrently #. replicateM_ cnt .# Concurrently+{-# INLINE replicateConcurrently_ #-}++newtype Concurrently m a = Concurrently { runConcurrently :: m a }+ deriving Functor++instance Eff Conc m => Applicative (Concurrently m) where+ pure = Concurrently #. return+ {-# INLINE pure #-}++ Concurrently fs <*> Concurrently as = Concurrently $ unliftConc $ \lower ->+ A.runConcurrently (A.Concurrently (lower fs) <*> A.Concurrently (lower as))+ {-# INLINE (<*>) #-}++instance Eff Conc m => Alternative (Concurrently m) where+ empty = Concurrently $ unliftConc $ \_ -> A.runConcurrently empty+ {-# INLINE empty #-}++ Concurrently as <|> Concurrently bs = Concurrently $ unliftConc $ \lower ->+ A.runConcurrently (A.Concurrently(lower as) <|> A.Concurrently (lower bs))+ {-# INLINE (<|>) #-}++instance (Eff Conc m, Semigroup a) => Semigroup (Concurrently m a) where+ (<>) = liftA2 (<>)+ {-# INLINE (<>) #-}++instance (Eff Conc m, Monoid a) => Monoid (Concurrently m a) where+ mempty = pure mempty+ {-# INLINE mempty #-}
+ src/Control/Effect/Cont.hs view
@@ -0,0 +1,172 @@+module Control.Effect.Cont+ ( -- * Effects+ Cont(..)+ , Shift(..)++ -- * Actions+ , callCC+ , shift++ -- * Interpretations+ , runCont+ , runContFast++ , runShift+ , runShiftFast++ , contToShift++ -- * Threading constraints+ , ContThreads+ , ContFastThreads++ -- * Carriers+ , ContC+ , ContFastC+ , ShiftC+ , ShiftFastC+ , ContToShiftC+ ) where++import Data.Coerce++import Control.Effect+import Control.Effect.Internal.Cont++import Control.Effect.Internal.Utils++import qualified Control.Monad.Trans.Cont as C+import Control.Monad.Trans.Free.Church.Alternate++-- | Call with current continuation. The argument computation is provided+-- the /continuation/ of the program at the point that 'callCC' was invoked.+-- If the continuation is executed, then control will immediately abort+-- and jump to the point 'callCC' was invoked, which will then return+-- the argument provided to the continuation.+--+-- The way higher-order actions interact with the continuation depends+-- on the interpretation of 'Cont'. In general, you cannot expect to interact+-- with the continuation in any meaningful way: for example, you should not+-- assume that you will be able to catch an exception thrown at some point in+-- the future of the computation by using 'Control.Effect.Error.catch' on the+-- continuation.+callCC :: Eff Cont m+ => ((forall b. a -> m b) -> m a) -> m a+callCC main = send (CallCC main)+{-# INLINE callCC #-}++-- | Non-abortive call with current continuation. The argument computation is+-- provided the /continuation/ of the program at the point that 'shift' was invoked.+-- If the continuation is executed, then control will jump to the point 'shift'+-- was invoked, which will then return the argument provided to the continuation.+--+-- Once the program finishes, and produces an @r@, control will jump /back/+-- to where the continuation was executed, and return that @r@.+-- From that point, you may decide whether or not to modify the final @r@,+-- or invoke the continuation again with a different argument.+--+-- You can also use 'shift' to abort the execution of the program early+-- by simply not executing the provided continuation, and instead+-- provide the final @r@ directly.+--+-- The way higher-order actions interact with the continuation depends+-- on the interpretation of 'Shift'. In general, you cannot expect to interact+-- with the continuation in any meaningful way: for example, you should not+-- assume that you will be able to catch an exception thrown at some point in+-- the future of the computation by using 'Control.Effect.Error.catch' on the+-- continuation.+shift :: Eff (Shift r) m+ => ((a -> m r) -> m r) -> m a+shift = send .# Shift+{-# INLINE shift #-}++-- | Run a 'Cont' effect.+--+-- @'Derivs' ('ContC' r m) = 'Cont' ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ContC' r m) = 'Prims' m@+runCont :: forall a m p+ . ( Carrier m+ , Threaders '[ContThreads] m p+ )+ => ContC a m a -> m a+runCont =+ foldFreeT+ id+ (\c -> \case+ Exit a -> a+ GetCont -> c $ Left (c . Right)+ )+ .# unContC+{-# INLINE runCont #-}++-- | Run a 'Cont' effect.+--+-- Compared to 'runCont', this is quite a bit faster, but is significantly more+-- restrictive in what interpreters are used after it, since there are very+-- few primitive effects that the carrier for 'runContFast' is able to thread.+-- In fact, of all the primitive effects provided by this library, only+-- one satisfies 'ContFastThreads': namely,+-- 'Control.Effect.Type.ReaderPrim.ReaderPrim'.+--+-- @'Derivs' ('ContFastC' r m) = 'Cont' ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ContFastC' r m) = 'Control.Effect.Primitive.Prims' m@+runContFast :: forall a m p+ . ( Carrier m+ , Threaders '[ContFastThreads] m p+ )+ => ContFastC a m a -> m a+runContFast = C.evalContT .# unContFastC+{-# INLINE runContFast #-}++-- | Run a @'Shift' r@ effect if the program returns @r@.+--+-- @'Derivs' ('ShiftC' r m) = 'Shift' r ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ShiftC' r m) = 'Control.Effect.Primitive.Prims' m@+runShift :: forall r m p+ . ( Carrier m+ , Threaders '[ContThreads] m p+ )+ => ShiftC r m r -> m r+runShift = coerce (runCont @r @m @p)+{-# INLINE runShift #-}++-- | Run a @'Shift' r@ effect if the program returns @r@.+--+-- Compared to 'runCont', this is quite a bit faster, but is significantly more+-- restrictive in what interpreters are used after it, since there are very+-- few primitive effects that the carrier for 'runContFast' is able to thread.+-- In fact, of all the primitive effects provided by this library, only+-- one satisfies 'ContFastThreads': namely,+-- 'Control.Effect.Type.ReaderPrim.ReaderPrim'.+--+-- @'Derivs' ('ShiftFastC' r m) = 'Shift' r ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ShiftFastC' r m) = 'Control.Effect.Primitive.Prims' m@+runShiftFast :: forall r m p+ . ( Carrier m+ , Threaders '[ContFastThreads] m p+ )+ => ShiftFastC r m r -> m r+runShiftFast = C.evalContT .# unShiftFastC+{-# INLINE runShiftFast #-}++data ContToShiftH r++instance Eff (Shift r) m+ => Handler (ContToShiftH r) Cont m where+ effHandler = \case+ CallCC main -> shift @r $ \c ->+ main (\a -> shift $ \_ -> c a) >>= c+ {-# INLINEABLE effHandler #-}++type ContToShiftC r = InterpretC (ContToShiftH r) Cont++-- | Transform a 'Cont' effect into a @'Shift' r@ effect.+contToShift :: Eff (Shift r) m+ => ContToShiftC r m a+ -> m a+contToShift = interpretViaHandler+{-# INLINE contToShift #-}
+ src/Control/Effect/Debug.hs view
@@ -0,0 +1,23 @@+-- | Utilities for debugging +module Control.Effect.Debug where + +import Control.Effect.Carrier +import GHC.TypeLits + +-- Type family needed to delay the TypeError until when 'debugEffects' +-- is used. +type family DebugEffects (m :: * -> *) :: k where + DebugEffects m = TypeError ( 'Text "Control.Effect.Debug.debugEffects" + ':$$: 'Text "Derivs: " ':<>: 'ShowType (Derivs m) + ':$$: 'Text "Prims: " ':<>: 'ShowType (Prims m) + ':$$: 'Text "Carrier is:" + ':$$: 'Text "\t" ':<>: 'ShowType m + ) + +-- | A placeholder action of @m@ that causes a compile-time error +-- that tells you the derived and primitive effects of @m@. +-- +-- Doesn't work when @m@ is polymorphic. +debugEffects :: DebugEffects m + => m a +debugEffects = errorWithoutStackTrace "debugEffects: impossible"
+ src/Control/Effect/Embed.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DerivingVia #-}+module Control.Effect.Embed+ ( -- * Effects+ Embed(..)++ -- * Actions+ , embed++ -- * Interpreters+ , runM++ , embedToEmbed++ , embedToMonadBase++ , embedToMonadIO++ -- * Simple variants+ , embedToEmbedSimple++ -- * Carriers+ , RunMC(RunMC)+ , EmbedToMonadBaseC+ , EmbedToMonadIOC+ ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.Identity+import qualified Control.Monad.Fail as Fail+import Control.Effect.Internal+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Type.Embed+import Control.Effect.Internal.Union+import Control.Effect.Internal.Utils+import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+import Control.Monad.Trans.Control (MonadBaseControl, MonadTransControl)++embed :: Eff (Embed b) m => b a -> m a+embed = send .# Embed+{-# INLINE embed #-}++-- | The carrier for 'runM', which carries no effects but @'Embed' m@.+newtype RunMC m a = RunMC { unRunMC :: m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, Fail.MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance Monad m => Carrier (RunMC m) where+ type Derivs (RunMC m) = '[Embed m]+ type Prims (RunMC m) = '[]++ algPrims = absurdU+ {-# INLINE algPrims #-}++ reformulate n _ u = n (RunMC (unEmbed (extract u)))+ {-# INLINE reformulate #-}++ algDerivs u = RunMC (unEmbed (extract u))+ {-# INLINE algDerivs #-}++-- | Extract the final monad @m@ from a computation of which+-- no effects remain to be handled except for @'Embed' m@.+runM :: Monad m => RunMC m a -> m a+runM = unRunMC+{-# INLINE runM #-}++data EmbedToMonadBaseH+data EmbedToMonadIOH++instance ( MonadBase b m+ , Carrier m+ )+ => Handler EmbedToMonadBaseH (Embed b) m where+ effHandler = liftBase . liftBase .# unEmbed+ {-# INLINEABLE effHandler #-}++instance (MonadIO m, Carrier m) => Handler EmbedToMonadIOH (Embed IO) m where+ effHandler = liftBase . liftIO .# unEmbed+ {-# INLINEABLE effHandler #-}++type EmbedToMonadBaseC b = InterpretC EmbedToMonadBaseH (Embed b)+type EmbedToMonadIOC = InterpretC EmbedToMonadIOH (Embed IO)++-- | Transform an 'Embed' effect into another 'Embed' effect+-- by providing a natural transformation to convert monadic values+-- of one monad to the other.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'embedToEmbed' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'embedToEmbedSimple', which doesn't have a higher-rank type.+embedToEmbed :: forall b b' m a+ . Eff (Embed b') m+ => (forall x. b x -> b' x)+ -> InterpretReifiedC (Embed b) m a+ -> m a+embedToEmbed n = interpret $ \case+ Embed m -> embed (n m)+{-# INLINE embedToEmbed #-}++-- | Run an @'Embed' b@ effect if @b@ is the base of the current+-- monad @m@.+embedToMonadBase :: (MonadBase b m, Carrier m)+ => EmbedToMonadBaseC b m a+ -> m a+embedToMonadBase = interpretViaHandler+{-# INLINE embedToMonadBase #-}++-- | Run an @'Embed' IO@ effect if the current monad @m@ is a @MonadIO@.+embedToMonadIO :: (MonadIO m, Carrier m)+ => EmbedToMonadIOC m a+ -> m a+embedToMonadIO = interpretViaHandler+{-# INLINE embedToMonadIO #-}++-- | Transform an 'Embed' effect into another 'Embed' effect+-- by providing a natural transformation to convert monadic values+-- of one monad to the other.+--+-- This is a less performant version of 'embedToEmbed' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+embedToEmbedSimple :: forall b b' m a p+ . ( Eff (Embed b') m+ , Threaders '[ReaderThreads] m p+ )+ => (forall x. b x -> b' x)+ -> InterpretSimpleC (Embed b) m a+ -> m a+embedToEmbedSimple n = interpretSimple $ \case+ Embed m -> embed (n m)+{-# INLINE embedToEmbedSimple #-}
+ src/Control/Effect/Error.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE BlockArguments #-}+module Control.Effect.Error+ ( -- * Effects+ Throw(..)+ , Catch(..)+ , Error++ -- * Actions+ , throw+ , catch+ , try+ , catchJust+ , tryJust+ , note+ , fromEither++ -- * Main Interpreters+ , runThrow++ , runError++ , errorToIO++ -- * Other interpreters+ , errorToErrorIO++ , throwToThrow+ , catchToError+ , errorToError++ -- * Simple variants+ , errorToIOSimple+ , errorToErrorIOSimple++ , throwToThrowSimple+ , catchToErrorSimple+ , errorToErrorSimple++ -- * Threading constraints+ , ErrorThreads++ -- * MonadCatch+ , C.MonadCatch++ -- * Carriers+ , ThrowC+ , ErrorC+ , ErrorToIOC+ , ErrorToIOC'+ , ReifiesErrorHandler+ , InterpretErrorC+ , InterpretErrorC'+ , ErrorToIOSimpleC+ , InterpretErrorSimpleC+ ) where++import Data.Function+import Data.Coerce++import Control.Effect+import Control.Effect.ErrorIO+import Control.Effect.Type.Throw+import Control.Effect.Type.Catch+import Control.Effect.Internal.Error++import qualified Control.Exception as X+import qualified Control.Monad.Catch as C++-- For coercion purposes+import Control.Effect.Internal.Utils+import Control.Monad.Trans.Except+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Carrier.Internal.Intro+import Control.Effect.Carrier.Internal.Compose+import Control.Monad.Trans.Identity++-- For errorToIO+import Data.Unique+import GHC.Exts (Any)+import Unsafe.Coerce++throw :: Eff (Throw e) m => e -> m a+throw = send . Throw+{-# INLINE throw #-}++catch :: Eff (Catch e) m => m a -> (e -> m a) -> m a+catch m h = send (Catch m h)+{-# INLINE catch #-}++try :: Eff (Catch e) m => m a -> m (Either e a)+try m = fmap Right m `catch` (return . Left)+{-# INLINE try #-}+++catchJust :: forall smallExc bigExc m a+ . Eff (Error bigExc) m+ => (bigExc -> Maybe smallExc)+ -> m a+ -> (smallExc -> m a)+ -> m a+catchJust f m h = m `catch` \e -> maybe (throw e) h (f e)+{-# INLINE catchJust #-}++tryJust :: forall smallExc bigExc m a+ . Eff (Error bigExc) m+ => (bigExc -> Maybe smallExc)+ -> m a+ -> m (Either smallExc a)+tryJust f m = fmap Right m &(catchJust f)$ (return . Left)+{-# INLINE tryJust #-}++note :: Eff (Throw e) m => e -> Maybe a -> m a+note _ (Just a) = return a+note e Nothing = throw e+{-# INLINE note #-}++fromEither :: Eff (Throw e) m => Either e a -> m a+fromEither = either throw pure+{-# INLINE fromEither #-}++-- | Run a 'Throw' effect purely.+--+-- Unlike 'runError', this does not provide the ability to catch exceptions.+-- However, it also doesn't impose any primitive effects, meaning 'runThrow' doesn't+-- restrict what interpreters are run before it.+--+-- @'Derivs' ('ThrowC' e m) = 'Throw' e ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ThrowC' e m) = 'Control.Effect.Primitive.Prims' m@+runThrow :: forall e m a p+ . ( Carrier m+ , Threaders '[ErrorThreads] m p+ )+ => ThrowC e m a+ -> m (Either e a)+runThrow = coerce+{-# INLINE runThrow #-}++-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- purely.+--+-- @'Derivs' ('ErrorC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ErrorC' e m) = 'Control.Effect.Optional.Optional' ((->) e) ': 'Control.Effect.Primitive.Prims' m@+runError :: forall e m a p+ . ( Carrier m+ , Threaders '[ErrorThreads] m p+ )+ => ErrorC e m a+ -> m (Either e a)+runError = coerce+{-# INLINE runError #-}+++-- | Transforms a @'Throw' smallExc@ effect into a @'Throw' bigExc@ effect,+-- by providing a function to convert exceptions of the smaller exception type+-- @smallExc@ to the larger exception type @bigExc@.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'throwToThrow' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'throwToThrowSimple', which doesn't have a higher-rank type.+throwToThrow :: forall smallExc bigExc m a+ . Eff (Throw bigExc) m+ => (smallExc -> bigExc)+ -> InterpretReifiedC (Throw smallExc) m a+ -> m a+throwToThrow to = interpret $ \case+ Throw e -> throw (to e)+{-# INLINE throwToThrow #-}++-- | Transforms a @'Catch' smallExc@ effect into an @'Error' bigExc@ effect, by+-- providing a function that identifies when exceptions of the larger exception type+-- @bigExc@ correspond to exceptions of the smaller exception type @smallExc@.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'catchToError' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'catchToErrorSimple', which doesn't have a higher-rank type.+catchToError :: forall smallExc bigExc m a+ . Eff (Error bigExc) m+ => (bigExc -> Maybe smallExc)+ -> InterpretReifiedC (Catch smallExc) m a+ -> m a+catchToError from = interpret $ \case+ Catch m h -> m &(catchJust from)$ h+{-# INLINE catchToError #-}++type ReifiesErrorHandler s s' e m =+ ( ReifiesHandler s (Catch e) (InterpretC (ViaReifiedH s') (Throw e) m)+ , ReifiesHandler s' (Throw e) m+ )++type InterpretErrorC' s s' smallExc = CompositionC+ '[ InterpretC (ViaReifiedH s) (Catch smallExc)+ , InterpretC (ViaReifiedH s') (Throw smallExc)+ ]++type InterpretErrorC e m a =+ forall s s'+ . ReifiesErrorHandler s s' e m+ => InterpretErrorC' s s' e m a+++-- | Transforms connected 'Throw' and 'Catch' effects -- i.e. 'Error' --+-- into another 'Error' effect by providing functions to convert+-- between the two types of exceptions.+--+-- This has a higher-rank type, as it makes use of 'InterpretErrorC'.+-- __This makes 'errorToError' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'errorToErrorSimple', which doesn't have a higher-rank type.+errorToError :: forall smallExc bigExc m a+ . Eff (Error bigExc) m+ => (smallExc -> bigExc)+ -> (bigExc -> Maybe smallExc)+ -> InterpretErrorC smallExc m a+ -> m a+errorToError to from m0 =+ throwToThrow to+ -- can't use 'catchToError' directly,+ -- since it can't tell if it should use smallExc or bigExc for its 'Throw'.+ -- We fix that by using 'intro1'.+ $ interpret \case+ Catch m h -> m `catch` \e -> case from e of+ Just e' -> h e'+ Nothing -> intro1 $ throw e+ $ runComposition+ $ m0+{-# INLINE errorToError #-}++-- KingoftheHomeless: We could skip having to use 'OpaqueExc'+-- by requiring the exception type @e@ to be typeable. Or have it be+-- an instance of 'Exception'.+--+-- I choose not to for two reasons:+-- 1. By making use of OpaqueExc and checking unique references,+-- we guarantee that exceptions belonging to an @'Error' e@ effect+-- interpreted with 'errorToErrorIO' won't get caught by 'catch'es+-- belonging to /another/, identical @'Error' e@ effect interpreted+-- using 'errorToErrorIO'. So by using OpaqueExc, we get coherency.+--+-- 2. In case we eventually implement a system for polymorphic effect+-- interpreters inside of application code, like something like this:+-- @+-- manageError :: HasErrorInterpreter s m+-- => ProvidedErrorInterpreterC s e m a+-- -> m (Either e a)+-- @+-- of which 'errorToErrorIO' should be a valid implementation, then+-- we shouldn't place any constraints upon @e@.+data OpaqueExc = OpaqueExc Unique Any++instance Show OpaqueExc where+ showsPrec _ (OpaqueExc uniq _) =+ showString "errorToIO/errorToErrorIO: Escaped opaque exception. \+ \Unique hash is: " . shows (hashUnique uniq) . showString ". \+ \This should only happen if the computation that threw the \+ \exception was somehow invoked outside of the argument of \+ \'errorToIO'; for example, if you 'async' an exceptional \+ \computation inside of the argument provided to 'errorToIO', \+ \and then 'await' on it *outside* of the argument provided to \+ \'errorToIO'. \+ \If that or any similar shenanigans seems unlikely, then \+ \please open an issue on the GitHub repository."++instance X.Exception OpaqueExc+++-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --+-- by transforming them into 'ErrorIO' and @'Embed' IO@+--+-- This has a higher-rank type, as it makes use of 'InterpretErrorC'.+-- __This makes 'errorToErrorIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'throwToThrowSimple', which doesn't have a higher-rank type.+errorToErrorIO :: forall e m a+ . Effs '[ErrorIO, Embed IO] m+ => InterpretErrorC e m a+ -> m (Either e a)+errorToErrorIO main = do+ !uniq <- embed newUnique+ let+ main' =+ interpret \case+ Throw e -> throwIO (OpaqueExc uniq (unsafeCoerce e))+ $ interpret \case+ Catch m h -> m `catchIO` \exc@(OpaqueExc uniq' e) ->+ if uniq == uniq' then+ h (unsafeCoerce e)+ else+ throwIO exc+ $ runComposition+ $ main+ fmap Right main' `catchIO` \exc@(OpaqueExc uniq' e) ->+ if uniq == uniq' then+ return $ Left (unsafeCoerce e)+ else+ throwIO exc++type ErrorToIOC' s s' e = CompositionC+ '[ IntroC '[Catch e, Throw e] '[ErrorIO]+ , InterpretErrorC' s s' e+ , ErrorIOToIOC+ ]++type ErrorToIOC e m a =+ forall s s'+ . ReifiesErrorHandler s s' e (ErrorIOToIOC m)+ => ErrorToIOC' s s' e m a++-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --+-- by making use of 'IO' exceptions.+--+-- @'Derivs' ('ErrorToIOC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ErrorToIOC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@+--+-- This has a higher-rank type, as it makes use of 'ErrorToIOC'.+-- __This makes 'errorToIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'errorToIOSimple', which doesn't have a higher-rank type.+errorToIO :: forall e m a+ . ( C.MonadCatch m+ , Eff (Embed IO) m+ )+ => ErrorToIOC e m a+ -> m (Either e a)+errorToIO m =+ errorIOToIO+ $ errorToErrorIO+ $ introUnderMany+ $ runComposition+ $ m+{-# INLINE errorToIO #-}+++-- | Transforms a @'Throw' smallExc@ effect into a @'Throw' bigExc@ effect,+-- by providing a function to convert exceptions of the smaller exception type+-- @smallExc@ to the larger exception type @bigExc@.+--+-- This is a less performant version of 'throwToThrow' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+throwToThrowSimple :: forall smallExc bigExc m a p+ . ( Eff (Throw bigExc) m+ , Threaders '[ReaderThreads] m p+ )+ => (smallExc -> bigExc)+ -> InterpretSimpleC (Throw smallExc) m a+ -> m a+throwToThrowSimple to = interpretSimple $ \case+ Throw e -> throw (to e)+{-# INLINE throwToThrowSimple #-}++-- | Transforms a @'Catch' smallExc@ effect into an @'Error' bigExc@ effect, by+-- providing a function that identifies when exceptions of the larger exception type+-- @bigExc@ correspond to exceptions of the smaller exception type @smallExc@.+--+-- This is a less performant version of 'catchToError' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+catchToErrorSimple :: forall smallExc bigExc m a p+ . ( Eff (Error bigExc) m+ , Threaders '[ReaderThreads] m p+ )+ => (bigExc -> Maybe smallExc)+ -> InterpretSimpleC (Catch smallExc) m a+ -> m a+catchToErrorSimple from = interpretSimple $ \case+ Catch m h -> catchJust from m h+{-# INLINE catchToErrorSimple #-}+++type InterpretErrorSimpleC e = CompositionC+ '[ InterpretSimpleC (Catch e)+ , InterpretSimpleC (Throw e)+ ]++-- | Transforms connected 'Throw' and 'Catch' effects -- i.e. 'Error' --+-- into another 'Error' effect by providing functions to convert+-- between the two types of exceptions.+--+-- This is a less performant version of 'errorToError' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+errorToErrorSimple :: forall smallExc bigExc m a p+ . ( Eff (Error bigExc) m+ , Threaders '[ReaderThreads] m p+ )+ => (smallExc -> bigExc)+ -> (bigExc -> Maybe smallExc)+ -> InterpretErrorSimpleC smallExc m a+ -> m a+errorToErrorSimple to from =+ throwToThrowSimple to+ . interpretSimple \case+ Catch m h -> intro1 $ catchJust from (lift m) (lift #. h)+ .# runComposition+{-# INLINE errorToErrorSimple #-}+++type ErrorToIOSimpleC e = CompositionC+ '[ IntroC '[Catch e, Throw e] '[ErrorIO]+ , InterpretErrorSimpleC e+ , ErrorIOToIOC+ ]+++-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --+-- by transforming them into 'ErrorIO' and @'Embed' IO@+--+-- This is a less performant version of 'errorToErrorIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+errorToErrorIOSimple :: forall e m a p+ . ( Effs '[ErrorIO, Embed IO] m+ , Threaders '[ReaderThreads] m p+ )+ => InterpretErrorSimpleC e m a+ -> m (Either e a)+errorToErrorIOSimple main = do+ !uniq <- embed newUnique+ let+ main' =+ interpretSimple \case+ Throw e -> throwIO (OpaqueExc uniq (unsafeCoerce e))+ $ interpretSimple \case+ Catch m h -> m `catchIO` \exc@(OpaqueExc uniq' e) ->+ if uniq == uniq' then+ h (unsafeCoerce e)+ else+ throwIO exc+ $ runComposition+ $ main+ fmap Right main' `catchIO` \exc@(OpaqueExc uniq' e) ->+ if uniq == uniq' then+ return $ Left (unsafeCoerce e)+ else+ throwIO exc++-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' --+-- by making use of 'IO' exceptions.+--+-- @'Derivs' ('ErrorToIOSimpleC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('ErrorToIOSimpleC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@+--+-- This is a less performant version of 'errorToIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+errorToIOSimple :: forall e m a p+ . ( Eff (Embed IO) m+ , MonadCatch m+ , Threaders '[ReaderThreads] m p+ )+ => ErrorToIOSimpleC e m a+ -> m (Either e a)+errorToIOSimple =+ errorIOToIO+ #. errorToErrorIOSimple+ .# introUnderMany+ .# runComposition+{-# INLINE errorToIOSimple #-}
+ src/Control/Effect/ErrorIO.hs view
@@ -0,0 +1,117 @@+module Control.Effect.ErrorIO+ ( -- * Effects+ ErrorIO(..)+ , X.Exception(..)+ , SomeException++ -- * Actions+ , throwIO+ , catchIO++ -- * Interpretations+ , errorIOToIO++ , errorIOToError++ -- * MonadCatch+ , C.MonadCatch++ -- * Carriers+ , ErrorIOToIOC+ , ErrorIOToErrorC+ ) where++import Control.Monad++import Control.Effect+import Control.Effect.Optional+import Control.Effect.Type.ErrorIO+import Control.Effect.Type.Throw+import Control.Effect.Type.Catch++import Control.Exception (SomeException)+import qualified Control.Exception as X+import qualified Control.Monad.Catch as C++-- For coercion purposes+import Control.Monad.Trans.Identity+import Control.Effect.Carrier.Internal.Intro+import Control.Effect.Carrier.Internal.Compose+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Internal.Utils++throwIO :: (X.Exception e, Eff ErrorIO m) => e -> m a+throwIO = send . ThrowIO++catchIO :: (X.Exception e, Eff ErrorIO m) => m a -> (e -> m a) -> m a+catchIO m h = send (CatchIO m h)++data ErrorIOFinalH++data ErrorIOToErrorH++instance ( C.MonadThrow m+ , Eff (Optional ((->) SomeException)) m+ )+ => Handler ErrorIOFinalH ErrorIO m where+ effHandler = \case+ ThrowIO x -> liftBase $ C.throwM x+ CatchIO m h -> join $+ optionally+ (\x -> case X.fromException x of+ Just e -> h e+ Nothing -> liftBase $ C.throwM x+ )+ (fmap pure m)+ {-# INLINEABLE effHandler #-}++instance ( C.MonadCatch m+ , Carrier m+ )+ => PrimHandler ErrorIOFinalH (Optional ((->) SomeException)) m where+ effPrimHandler = \case+ Optionally h m -> m `C.catch` (return . h)+ {-# INLINEABLE effPrimHandler #-}+++instance ( Eff (Error SomeException) m+ , Carrier m+ )+ => Handler ErrorIOToErrorH ErrorIO m where+ effHandler = \case+ ThrowIO e -> send $ Throw (X.toException e)+ CatchIO m h -> send $ Catch m $ \e -> case X.fromException e of+ Just e' -> h e'+ _ -> send $ Throw e+ {-# INLINEABLE effHandler #-}+++type ErrorIOToIOC = CompositionC+ '[ ReinterpretC ErrorIOFinalH ErrorIO+ '[Optional ((->) SomeException)]+ , InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))+ ]++type ErrorIOToErrorC = InterpretC ErrorIOToErrorH ErrorIO++-- | Transform an @'ErrorIO'@ effect into an @'Error' 'SomeException'@+-- effect.+errorIOToError :: Eff (Error SomeException) m+ => ErrorIOToErrorC m a+ -> m a+errorIOToError = interpretViaHandler+{-# INLINE errorIOToError #-}++-- | Run an @'ErrorIO'@ effect by making use of 'IO' exceptions.+--+-- @'Derivs' (ErrorIOToIOC e m) = 'ErrorIO' ': 'Derivs' m@+--+-- @'Control.Effect.Carrier.Prims' (ErrorIOToIOC e m) = 'Control.Effect.Optional.Optional' ((->) 'SomeException') ': 'Control.Effect.Carrier.Prims' m@+errorIOToIO :: (Carrier m, C.MonadCatch m)+ => ErrorIOToIOC m a+ -> m a+errorIOToIO =+ interpretPrimViaHandler+ .# reinterpretViaHandler+ .# runComposition+{-# INLINE errorIOToIO #-}
+ src/Control/Effect/Exceptional.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE DerivingVia #-}+module Control.Effect.Exceptional+ ( -- * Effects+ Exceptional+ , SafeError++ -- * Actions+ , catching+ , trying+ , throwing++ , catchSafe+ , trySafe++ -- * Interpretations+ , runExceptional++ , runExceptionalJust++ , safeErrorToError++ , runSafeError++ , safeErrorToIO++ , safeErrorToErrorIO++ -- * Simple variants of interpretations+ , runExceptionalJustSimple++ , safeErrorToIOSimple++ , safeErrorToErrorIOSimple++ -- * Threading constraints+ , ErrorThreads++ -- * MonadCatch+ , MonadCatch++ -- * Carriers+ , ExceptionallyC+ , ExceptionalC+ , SafeErrorToErrorC+ , SafeErrorC+ , SafeErrorToIOC'+ , SafeErrorToIOC+ , SafeErrorToErrorIOC'+ , SafeErrorToErrorIOC+ , SafeErrorToIOSimpleC+ , SafeErrorToErrorIOSimpleC+ ) where++import Data.Coerce+import Data.Either++import Control.Effect+import Control.Effect.Error+import Control.Effect.ErrorIO+import Control.Effect.Union++import Control.Effect.Carrier++import Control.Effect.Internal.Utils+import Control.Monad.Trans.Identity++-- For coercion purposes+import Control.Monad.Trans.Except+import Control.Effect.Internal.Error+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Carrier.Internal.Intro+import Control.Effect.Carrier.Internal.Compose+++-- | An effect that allows for the safe use of an effect @eff@ that may+-- throw exceptions of the type @exc@ by forcing the user to eventually+-- catch those exceptions at some point of the program.+--+-- The main combinator of 'Exceptional' is 'catching'.+--+-- __This could be unsafe in the presence of 'Control.Effect.Conc.Conc'__.+-- If you use 'catching' on a computation that:+--+-- * Spawns an asynchronous computation+-- * Throws an exception inside the asynchronous computation from a use of @eff@+-- * Returns the 'Control.Effect.Conc.Async' of that asynchronous computation+--+-- Then 'Control.Effect.Conc.wait'ing on that 'Control.Effect.Conc.Async'+-- outside of the 'catching' will throw that exception without it being caught.+newtype Exceptional eff exc m a = Exceptional (Union '[eff, Catch exc] m a)++-- | A particularly useful specialization of 'Exceptional', for gaining+-- restricted access to an @'Error' exc@ effect.+-- Main combinators are 'catchSafe' and 'trySafe'.+type SafeError exc = Exceptional (Throw exc) exc++{-+"ExceptionallyC" can easily be implemented using Handler:++data ExceptionallyH exc++instance ( Eff (Exceptional eff exc) m+ , RepresentationalEff eff+ )+ => Handler (ExceptionallH exc) eff m where where+ effHandler e = send $ Exceptionally $ inj e++type ExceptionallyC eff exc = InterpretC (ExceptionallH exc) eff++catching :: forall eff exc m a+ . ( Eff (Exceptional eff exc) m+ , RepresentationalEff eff+ )+ => ExceptionallyC exc eff m a+ -> (exc -> m a)+ -> m a+catching m h =+ send $ Exceptional @eff @exc $+ inj (Catch @exc (interpretViaHandler m) h)++We use a standalone carrier to hide the RepresentationalEff constraint,+which is just noise in this case.+-}++newtype ExceptionallyC (eff :: Effect) (exc :: *) m a = ExceptionallyC {+ unExceptionallyC :: m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance Eff (Exceptional eff exc) m+ => Carrier (ExceptionallyC eff exc m) where+ type Derivs (ExceptionallyC eff exc m) = eff ': Catch exc ': Derivs m+ type Prims (ExceptionallyC eff exc m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg' (+ powerAlg (+ reformulate (n .# lift) alg+ ) $ \e ->+ reformulate (n .# lift) alg $ inj $+ Exceptional @eff @exc (Union (There Here) e)+ ) $ \e ->+ reformulate (n .# lift) alg $ inj $+ Exceptional @eff @exc (Union Here e)+ {-# INLINEABLE reformulate #-}++ algDerivs =+ powerAlg' (+ powerAlg (+ coerce (algDerivs @m)+ ) $ \e ->+ coerceAlg (algDerivs @m) $ inj $ Exceptional @eff @exc (Union (There Here) e)+ ) $ \e ->+ coerceAlg (algDerivs @m) $ inj $ Exceptional @eff @exc (Union Here e)+ {-# INLINEABLE algDerivs #-}++-- | Gain access to @eff@ and @'Catch' exc@ within a region,+-- but only if you're ready to handle any unhandled exception @e :: exc@+-- that may arise from the use of @eff@ within that region.+--+-- For example:+--+-- @+-- -- A part of the program unknowing and uncaring that the use of SomeEffect+-- -- may throw exceptions.+-- uncaringProgram :: 'Eff' SomeEffect m => m String+-- uncaringProgram = do+-- doSomeThing+-- doSomeOtherThing+--+-- caringProgram :: 'Eff' ('Exceptional' SomeEffect SomeEffectExc) m => m String+-- caringProgram =+-- 'catching' @eff uncaringProgram (\(exc :: SomeEffectExc) -> handlerForSomeEffectExc exc)+-- @+--+catching :: forall eff exc m a+ . Eff (Exceptional eff exc) m+ => ExceptionallyC eff exc m a+ -> (exc -> m a)+ -> m a+catching m h =+ send $ Exceptional @eff @exc $+ Union (There Here) (Catch (unExceptionallyC m) h)+{-# INLINE catching #-}++-- | Gain access to @'Error' exc@ within a region,+-- but only if you're ready to handle any unhandled exception @e :: exc@+-- that may arise from within that region.+catchSafe :: forall exc m a+ . Eff (SafeError exc) m+ => ExceptionallyC (Throw exc) exc m a+ -> (exc -> m a)+ -> m a+catchSafe = catching+{-# INLINE catchSafe #-}++-- | Gain access to @eff@ within a region. If any use of @eff@+-- within that region 'throw's an unhandled exception @e :: exc@,+-- then this returns @Left e@.+trying :: forall eff exc m a+ . Eff (Exceptional eff exc) m+ => ExceptionallyC eff exc m a+ -> m (Either exc a)+trying m = fmap Right m `catching` (return . Left)+{-# INLINE trying #-}++-- | Gain access to @'Error' exc@ within a region. If any unhandled exception+-- @e :: exc@ is 'throw'n within that region, then this returns @Left e@.+trySafe :: forall exc m a+ . Eff (SafeError exc) m+ => ExceptionallyC (Throw exc) exc m a+ -> m (Either exc a)+trySafe = trying+{-# INLINE trySafe #-}++-- | Gain access to @eff@ within a region, rethrowing+-- any exception @e :: exc@ that may occur from the use of+-- @eff@ within that region.+throwing :: forall eff exc m a+ . Effs [Exceptional eff exc, Throw exc] m+ => ExceptionallyC eff exc m a+ -> m a+throwing m = m `catching` throw+{-# INLINE throwing #-}++data ExceptionalH++instance ( Member eff (Derivs m)+ , Eff (Catch exc) m+ )+ => Handler ExceptionalH (Exceptional eff exc) m where+ -- Explicit pattern mathing and use of 'algDerivs' instead of using+ -- 'decomp' and 'send' so that we don't introduce the+ -- RepresentationalEff constraint.+ effHandler (Exceptional e) = case e of+ Union Here eff -> algDerivs (Union membership eff)+ Union (There Here) eff -> algDerivs (Union membership eff)+ Union (There (There pr)) _ -> absurdMember pr+ {-# INLINEABLE effHandler #-}++type ExceptionalC eff exc = InterpretC ExceptionalH (Exceptional eff exc)++type SafeErrorToErrorC exc = ExceptionalC (Throw exc) exc++-- | Run an @'Exceptional' eff exc@ effect if both @eff@ and @'Catch' exc@+-- are part of the effect stack.+--+-- In order for this to be safe, you must ensure that the @'Catch' exc@+-- catches all exceptions that arise from the use of @eff@ and that+-- only uses of @eff@ throws those exceptions.+-- Otherwise, the use of 'catching' is liable to catch+-- exceptions not arising from uses of @eff@, or fail to catch+-- exceptions that do arise from uses of @eff@.+runExceptional :: forall eff exc m a+ . ( Member eff (Derivs m)+ , Eff (Catch exc) m+ )+ => ExceptionalC eff exc m a+ -> m a+runExceptional = interpretViaHandler+{-# INLINE runExceptional #-}++-- | Run an @'Exceptional' eff exc@ effect if @eff@ is part of the+-- effect stack, provided a function that identifies the kind of exceptions+-- that may arise from the use of @eff@.+--+-- In order for this to be safe, you must ensure that the function+-- identifies all exceptions that arise from the use of @eff@ and that+-- only uses of @eff@ throws those exceptions.+-- Otherwise, the use of 'catching' is liable to catch+-- other exceptions not arising from uses of @eff@, or fail to catch+-- exceptions that do arise from uses of @eff@.+--+-- The type of this interpreter is higher-rank, as it makes use of+-- 'InterpretReifiedC'. __This makes 'runExceptionalJust' difficult to__+-- __use partially applied; for example, you can't compose it using @'.'@.__+-- You may prefer the simpler, but less performant, 'runExceptionalJustSimple'.+runExceptionalJust :: forall eff smallExc bigExc m a+ . ( Member eff (Derivs m)+ , Eff (Error bigExc) m+ )+ => (bigExc -> Maybe smallExc)+ -> InterpretReifiedC (Exceptional eff smallExc) m a+ -> m a+runExceptionalJust from = interpret $ \(Exceptional e) -> case e of+ Union Here eff -> algDerivs (Union membership eff)+ Union (There pr) eff -> case extract (Union pr eff) of+ Catch m h -> catchJust from m h+{-# INLINE runExceptionalJust #-}++-- | Run an @'Exceptional' eff exc@ effect if @eff@ is part of the+-- effect stack, provided a function that identifies the kind of exceptions+-- that may arise from the use of @eff@.+--+-- In order for this to be safe, you must ensure that the function+-- identifies all exceptions that arise from the use of @eff@ and that+-- only uses of @eff@ throws those exceptions.+-- Otherwise, the use of 'catching' is liable to catch+-- exceptions not arising from uses of @eff@, or fail to catch+-- exceptions that do arise from uses of @eff@.+--+-- This is a less performant version of 'runExceptionalJust', but doesn't have+-- a higher-rank type. This makes 'runExceptionalJustSimple' much easier to use+-- partially applied.+runExceptionalJustSimple :: forall eff smallExc bigExc m a p+ . ( Member eff (Derivs m)+ , Eff (Error bigExc) m+ , Threaders '[ReaderThreads] m p+ )+ => (bigExc -> Maybe smallExc)+ -> InterpretSimpleC (Exceptional eff smallExc) m a+ -> m a+runExceptionalJustSimple from = interpretSimple $ \(Exceptional e) -> case e of+ Union Here eff -> algDerivs (Union membership eff)+ Union (There pr) eff -> case extract (Union pr eff) of+ Catch m h -> catchJust from m h+{-# INLINE runExceptionalJustSimple #-}++-- | Run a @'SafeError' exc@ effect by transforming it into an @'Error' exc@+-- effect.+safeErrorToError :: forall exc m a+ . Eff (Error exc) m+ => SafeErrorToErrorC exc m a+ -> m a+safeErrorToError = runExceptional+{-# INLINE safeErrorToError #-}++type SafeErrorC exc = CompositionC+ '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]+ , SafeErrorToErrorC exc+ , ErrorC exc+ ]++-- | Run a @'SafeError' e@ effect purely.+--+-- @'Derivs' ('SafeErrorC' e m) = 'SafeError' e ': 'Prims' m@+--+-- @'Prims' ('SafeErrorC' e m) = 'Control.Effect.Optional.Optional' ((->) e) ': 'Prims' m@+runSafeError :: forall e m a p+ . ( Carrier m+ , Threaders '[ErrorThreads] m p+ )+ => SafeErrorC e m a+ -> m a+runSafeError =+ fmap (fromRight bombPure)+ .# runError+ .# safeErrorToError+ .# introUnder+ .# runComposition+{-# INLINE runSafeError #-}++bombPure :: a+bombPure = errorWithoutStackTrace+ "runSafeError: Escaped exception! Unless you've imported some internal \+ \modules and did something REALLY stupid, this is a bug. Make an issue about \+ \it on the GitHub repository for in-other-words."++bombIO :: String -> a+bombIO str = errorWithoutStackTrace $+ str ++ ": Escaped exception! This is likely because an `async`ed exceptional \+ \computation escaped a `catching` through an `Async`. See \+ \Control.Effect.Exceptional.Exceptional. If that sounds unlikely, and you \+ \didn't import any internal modules and do something really stupid, \+ \then this could be a bug. If so, make an issue about \+ \it on the GitHub repository for in-other-words."+++type SafeErrorToIOC' s s' exc = CompositionC+ '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]+ , SafeErrorToErrorC exc+ , ErrorToIOC' s s' exc+ ]++type SafeErrorToIOC e m a =+ forall s s'+ . ReifiesErrorHandler s s' e (ErrorIOToIOC m)+ => SafeErrorToIOC' s s' e m a++-- | Runs a @'SafeError' e@ effect by making use of 'IO' exceptions.+--+-- @'Derivs' ('SafeErrorToIOC' e m) = 'SafeError' e ': 'Derivs' m@+--+-- @'Prims' ('SafeErrorToIOC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Prims' m@+--+-- This has a higher-rank type, as it makes use of 'SafeErrorToIOC'.+-- __This makes 'safeErrorToIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'safeErrorToIOSimple', which doesn't have a higher-rank type.+safeErrorToIO :: forall e m a+ . ( Eff (Embed IO) m+ , MonadCatch m+ )+ => SafeErrorToIOC e m a+ -> m a+safeErrorToIO m =+ fmap (fromRight (bombIO "safeErrorToIO"))+ $ errorToIO+ $ safeErrorToError+ $ introUnder+ $ runComposition+ $ m+{-# INLINE safeErrorToIO #-}++type SafeErrorToErrorIOC' s s' exc = CompositionC+ '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]+ , SafeErrorToErrorC exc+ , InterpretErrorC' s s' exc+ ]++type SafeErrorToErrorIOC e m a =+ forall s s'+ . ReifiesErrorHandler s s' e m+ => SafeErrorToErrorIOC' s s' e m a++-- | Runs a @'SafeError' e@ effect by transforming it into 'ErrorIO'+-- and @'Embed' IO@.+--+-- This has a higher-rank type, as it makes use of 'SafeErrorToErrorIOC'.+-- __This makes 'safeErrorToErrorIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'safeErrorToErrorIOSimple', which doesn't have a higher-rank type.+safeErrorToErrorIO :: forall e m a+ . Effs '[Embed IO, ErrorIO] m+ => SafeErrorToErrorIOC e m a+ -> m a+safeErrorToErrorIO m =+ fmap (fromRight (bombIO "safeErrorToErrorIO"))+ $ errorToErrorIO+ $ safeErrorToError+ $ introUnder+ $ runComposition+ $ m+{-# INLINE safeErrorToErrorIO #-}++type SafeErrorToIOSimpleC exc = CompositionC+ '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]+ , SafeErrorToErrorC exc+ , ErrorToIOSimpleC exc+ ]++-- | Runs a @'SafeError' e@ effect by making use of 'IO' exceptions.+--+-- @'Derivs' ('SafeErrorToIOSimpleC' e m) = 'SafeError' e ': 'Derivs' m@+--+-- @'Prims' ('SafeErrorToIOSimpleC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Prims' m@+--+-- This is a less performant version of 'safeErrorToIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+safeErrorToIOSimple :: forall e m a p+ . ( Eff (Embed IO) m+ , MonadCatch m+ , Threaders '[ReaderThreads] m p+ )+ => SafeErrorToIOSimpleC e m a+ -> m a+safeErrorToIOSimple =+ fmap (fromRight (bombIO "safeErrorToIOSimple"))+ . errorToIOSimple+ .# safeErrorToError+ .# introUnder+ .# runComposition+{-# INLINE safeErrorToIOSimple #-}++type SafeErrorToErrorIOSimpleC exc = CompositionC+ '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc]+ , SafeErrorToErrorC exc+ , InterpretErrorSimpleC exc+ ]++-- | Runs a @'SafeError' e@ effect by transforming it into 'ErrorIO'+-- and @'Embed' IO@.+--+-- This is a less performant version of 'safeErrorToErrorIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+safeErrorToErrorIOSimple :: forall e m a p+ . ( Effs '[ErrorIO, Embed IO] m+ , Threaders '[ReaderThreads] m p+ )+ => SafeErrorToErrorIOSimpleC e m a+ -> m a+safeErrorToErrorIOSimple =+ fmap (fromRight (bombIO "safeErrorToErrorIOSimple"))+ . errorToErrorIOSimple+ .# safeErrorToError+ .# introUnder+ .# runComposition+{-# INLINE safeErrorToErrorIOSimple #-}
+ src/Control/Effect/Fail.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE BlockArguments, DerivingVia #-}+module Control.Effect.Fail+ ( -- * Effects+ Fail(..)++ -- * Interpretations+ , runFail++ , failToThrow++ , failToNonDet++ , failToAlt++ -- * Simple variants of interpretations+ , failToThrowSimple++ -- * Threading constraints+ , ErrorThreads++ -- * Carriers+ , FailC+ , InterpretFailC(..)+ , InterpretFailReifiedC+ , FailToNonDetC+ , FailToAltC+ , InterpretFailSimpleC(..)+ ) where++import Data.Coerce++import Control.Applicative+import Control.Monad+import qualified Control.Monad.Fail as Fail++import Control.Effect+import Control.Effect.Error+import Control.Effect.NonDet+import Control.Effect.Type.Alt+import Control.Effect.Type.Fail++import Control.Effect.Carrier++-- Imports for coercion+import Control.Effect.Internal.Utils+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Carrier.Internal.Intro+import Control.Effect.Carrier.Internal.Compose+import Control.Monad.Trans.Identity+++-- | Like 'InterpretC' specialized to interpret 'Fail', but with a 'MonadFail'+-- instance based on the interpreted 'Fail'.+newtype InterpretFailC h m a = InterpretFailC {+ unInterpretFailC :: InterpretC h Fail m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++type InterpretFailReifiedC m a+ = forall s+ . ReifiesHandler s Fail m+ => InterpretFailC (ViaReifiedH s) m a++deriving via InterpretC h Fail m instance+ Handler h Fail m => Carrier (InterpretFailC h m)++deriving via Effly (InterpretFailC h m)+ instance Handler h Fail m+ => MonadFail (InterpretFailC h m)++-- | Transform a 'Fail' effect to a 'Throw' effect by providing a function+-- to transform a pattern match failure into an exception.+--+-- You can use this in application code to locally get access to a 'MonadFail'+-- instance (since 'InterpretFailReifiedC' has a 'MonadFail' instance based+-- on the 'Fail' effect this interprets).+--+-- For example:+--+-- @+-- 'failToThrow' (\_ -> 'throw' exc) (do { Just a <- pure Nothing; return a})+-- = 'throw' exc+-- @+--+-- This has a higher-rank type, as it makes use of 'InterpretFailReifiedC'.+-- __This makes 'failToThrow' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower 'failToThrowSimple',+-- which doesn't have a higher-rank type. __However__, you typically don't+-- want to use 'failToThrowSimple' in application code, since 'failToThrowSimple'+-- emits a 'ReaderThreads' threading constraint (see 'Threaders').+failToThrow :: Eff (Throw e) m+ => (String -> e)+ -> InterpretFailReifiedC m a+ -> m a+failToThrow f m =+ interpret \case+ Fail s -> throw (f s)+ $ unInterpretFailC+ $ m+{-# INLINE failToThrow #-}++data FailToAltH++type FailToAltC = InterpretFailC FailToAltH++instance Eff Alt m => Handler FailToAltH Fail m where+ effHandler _ = runEffly empty+ {-# INLINEABLE effHandler #-}++data FailToNonDetH++instance Eff NonDet m => Handler FailToNonDetH Fail m where+ effHandler _ = lose+ {-# INLINEABLE effHandler #-}++type FailToNonDetC = InterpretFailC FailToNonDetH++-- | Transform a 'Fail' effect to an 'Alt' effect by having a+-- pattern match failure be 'empty'.+--+-- You can use this in application code to locally get access to a 'MonadFail'+-- instance (since 'FailToAltC' has a 'MonadFail' instance based+-- on the 'Fail' effect this interprets).+failToAlt :: Eff Alt m+ => FailToAltC m a+ -> m a+failToAlt = interpretViaHandler .# unInterpretFailC+{-# INLINE failToAlt #-}++-- | Transform a 'Fail' effect to a 'NonDet' effect by having a+-- pattern match failure be 'lose'.+--+-- You can use this in application code to locally get access to a 'MonadFail'+-- instance (since 'FailToNonDetC' has a 'MonadFail' instance based+-- on the 'Fail' effect this interprets).+--+-- For example:+--+-- @+-- 'failToNonDet' (do { Just a <- pure Nothing; return a})+-- = 'lose'+-- @+failToNonDet :: Eff NonDet m+ => FailToNonDetC m a+ -> m a+failToNonDet = interpretViaHandler .# unInterpretFailC+{-# INLINE failToNonDet #-}++data FailH++type FailC = CompositionC+ '[ ReinterpretC FailH Fail '[Throw String]+ , ThrowC String+ ]++instance Eff (Throw String) m+ => Handler FailH Fail m where+ effHandler = throw @String .# coerce+ {-# INLINEABLE effHandler #-}++-- | Run a 'Fail' effect purely, by returning @Left failureMessage@+-- upon a pattern match failure.+--+-- 'FailC' has an 'Alternative' instance based on the 'Alt'+-- effect it interprets.+runFail :: forall m a p+ . ( Threaders '[ErrorThreads] m p+ , Carrier m+ )+ => FailC m a+ -> m (Either String a)+runFail =+ runThrow+ .# reinterpretViaHandler+ .# runComposition++-- | Like 'InterpretSimpleC' specialized to interpret 'Fail', but with+-- a 'MonadFail' instance based on the interpreted 'Fail'.+newtype InterpretFailSimpleC m a = InterpretFailSimpleC {+ unInterpretFailSimpleC :: InterpretSimpleC Fail m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving MonadTrans++deriving newtype instance+ (Monad m, Carrier (InterpretSimpleC Fail m))+ => Carrier (InterpretFailSimpleC m)++instance (Monad m, Carrier (InterpretSimpleC Fail m))+ => Fail.MonadFail (InterpretFailSimpleC m) where+ fail = send .# Fail+ {-# INLINE fail #-}++-- | Transform a 'Fail' effect to a 'Throw' effect by providing a function+-- to transform a pattern match failure into an exception.+--+-- This is a less performant version of 'failToThrow' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+--+-- Unlike 'failToThrow', __you typically don't want to use this in__+-- __application code__, since this emits a 'ReaderThreads'+-- threading constraint (see 'Threaders').+failToThrowSimple :: forall e m a p+ . ( Eff (Throw e) m+ , Threaders '[ReaderThreads] m p+ )+ => (String -> e)+ -> InterpretFailSimpleC m a+ -> m a+failToThrowSimple f =+ interpretSimple \case+ Fail s -> throw (f s)+ .# unInterpretFailSimpleC+{-# INLINE failToThrowSimple #-}
+ src/Control/Effect/Fix.hs view
@@ -0,0 +1,43 @@+module Control.Effect.Fix+ ( -- * Effects+ Fix(..)+ , module Control.Monad.Fix++ -- * Interpretations+ , fixToFinal++ -- * Threading utilities+ , threadFixViaClass++ -- * Carriers+ , FixToFinalC+ ) where++import Control.Monad.Fix++import Control.Effect+import Control.Effect.Primitive+import Control.Effect.Type.Fix++data FixToFinalH++instance (Carrier m, MonadFix m)+ => PrimHandler FixToFinalH Fix m where+ effPrimHandler (Fix f) = mfix f+ {-# INLINEABLE effPrimHandler #-}++type FixToFinalC = InterpretPrimC FixToFinalH Fix++-- | Run a 'Fix' effect if the final monad and+-- all carriers transforming it are 'MonadFix'.+--+-- @'Derivs' (FixToFinalC m) = 'Fix' ': 'Derivs' m@+--+-- @'Prims' (FixToFinalC m) = 'Fix' ': 'Prims' m@+fixToFinal :: ( Carrier m+ , MonadFix m+ )+ => FixToFinalC m a+ -> m a+fixToFinal = interpretPrimViaHandler+{-# INLINEABLE fixToFinal #-}
+ src/Control/Effect/Fresh.hs view
@@ -0,0 +1,150 @@+module Control.Effect.Fresh+ ( -- * Effects+ Fresh(..)++ -- * Actions+ , fresh++ -- * Interpretations+ , freshToIO++ , runFreshEnumIO++ -- * Unsafe interpretations+ , runFreshEnum++ -- * Simple variants of interpretations+ , runFreshEnumIOSimple++ -- * Threading constraints+ , StateThreads++ -- * Carriers+ , FreshToIOC+ , FreshEnumC+ ) where++import Data.Unique+import Data.IORef++import Control.Effect+import Control.Effect.State++-- For coercion purposes+import Control.Effect.Internal.Utils+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Carrier.Internal.Compose+import Control.Effect.Carrier.Internal.Intro+import Control.Monad.Trans.Identity+++-- | An effect for creating unique objects which may be used as references,+-- a la 'Unique'. Polymorphic code making use of 'Fresh' is expected+-- to place constraints upon @uniq@ as necessary.+--+-- Any interpreter for 'Fresh' has the responsibilty of ensuring+-- that any call to 'fresh' produces an object that /never/+-- compares equal to an object produced by a previous call to 'fresh'.+data Fresh uniq m a where+ Fresh :: Fresh uniq m uniq++fresh :: Eff (Fresh uniq) m => m uniq+fresh = send Fresh+{-# INLINE fresh #-}++data FreshToIOH++instance Eff (Embed IO) m+ => Handler FreshToIOH (Fresh Unique) m where+ effHandler Fresh = embed newUnique+ {-# INLINEABLE effHandler #-}++type FreshToIOC = InterpretC FreshToIOH (Fresh Unique)++-- | Runs a 'Fresh' effect through generating 'Unique's using 'IO'.+freshToIO :: Eff (Embed IO) m+ => FreshToIOC m a+ -> m a+freshToIO = interpretViaHandler+{-# INLINE freshToIO #-}++-- | Run a 'Fresh' effect through atomic operations in 'IO'+-- by specifying an 'Enum' to be used as the type of unique objects.+--+-- This is a safe variant of 'runFreshEnum'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runFreshEnumIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'runFreshEnumIOSimple', which doesn't have a higher-rank type.+runFreshEnumIO :: forall uniq m a+ . ( Enum uniq+ , Eff (Embed IO) m+ )+ => InterpretReifiedC (Fresh uniq) m a+ -> m a+runFreshEnumIO m = do+ ref <- embed $ newIORef (toEnum @uniq 0)+ (`interpret` m) $ \case+ Fresh -> embed $ atomicModifyIORef' ref (\s -> (succ s, s))+{-# INLINE runFreshEnumIO #-}++-- | Run a 'Fresh' effect though atomic operations in 'IO'+-- by specifying an 'Enum' to be used as the type of unique objects.+--+-- This is a less performant version of 'runFreshEnumIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runFreshEnumIOSimple :: forall uniq m a p+ . ( Enum uniq+ , Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => InterpretSimpleC (Fresh uniq) m a+ -> m a+runFreshEnumIOSimple m = do+ ref <- embed $ newIORef (toEnum @uniq 0)+ (`interpretSimple` m) $ \case+ Fresh -> embed $ atomicModifyIORef' ref (\s -> (succ s, s))+{-# INLINE runFreshEnumIOSimple #-}++data FreshEnumH++instance (Enum uniq, Eff (State uniq) m)+ => Handler FreshEnumH (Fresh uniq) m where+ effHandler Fresh = state' (\s -> (succ s, s))+ {-# INLINEABLE effHandler #-}++type FreshEnumC uniq = CompositionC+ '[ ReinterpretC FreshEnumH (Fresh uniq) '[State uniq]+ , StateC uniq+ ]+-- | Run a 'Fresh' effect purely by specifying an 'Enum' to be used as the+-- type of unique objects.+--+-- __Beware:__ This is safe only if:+--+-- 1. This is run after all interpreters which may revert local state+-- or produce multiple, inconsistent instances of local state.+-- This includes interpreters that may backtrack or produce multiple results+-- (such as 'Control.Error.Error.runError' or 'Control.Effect.NonDet.runNonDet').+--+-- 2. You don't use any interpreter which may cause the final monad+-- to revert local state or produce multiple, inconsistent instances+-- of local state. This includes 'Control.Effect.Error.errorToIO' and+-- 'Control.Effect.Conc.asyncToIO'.+--+-- Prefer 'freshToIO' whenever possible.+runFreshEnum :: forall uniq m a p+ . ( Enum uniq+ , Threaders '[StateThreads] m p+ , Carrier m+ )+ => FreshEnumC uniq m a+ -> m a+runFreshEnum =+ evalState (toEnum 0)+ .# reinterpretViaHandler+ .# runComposition+{-# INLINE runFreshEnum #-}
+ src/Control/Effect/Intercept.hs view
@@ -0,0 +1,57 @@+module Control.Effect.Intercept+ ( -- * Effects+ Intercept(..)+ , InterceptCont(..)+ , InterceptionMode(..)++ -- * Actions+ , intercept+ , interceptCont+ , interceptCont1++ -- * Interpretations+ , runInterceptCont+ , runInterceptR++ -- * Interpretations for other effects+ , runStateStepped+ , runTellStepped+ , runTellListStepped+ , runListenStepped++ -- * Threading constraints+ , SteppedThreads++ -- * Carriers+ , InterceptContC+ , InterceptRC+ , SteppedC+ , ListenSteppedC+ ) where++import Control.Effect+import Control.Effect.Stepped+import Control.Effect.Internal.Intercept++-- | Intercept all uses of an effect within a region.+intercept :: Eff (Intercept e) m => (forall x. e m x -> m x) -> m a -> m a+intercept h m = send (Intercept h m)+{-# INLINE intercept #-}++-- | Intercept all uses of an effect within a region -- and at each use-site,+-- capture the continuation of the argument computation, and also allow for+-- early abortion (by not invoking the continuation).+interceptCont :: Eff (InterceptCont e) m+ => (forall x. (x -> m a) -> e m x -> m a)+ -> m a -> m a+interceptCont h m = send (InterceptCont InterceptAll h m)+{-# INLINE interceptCont #-}++-- | Intercept only the _first_ use of an effect within a region --+-- and at that use-site, capture the continuation of the argument computation,+-- and also allow for early abortion (by not invoking the continuation).+interceptCont1 :: Eff (InterceptCont e) m+ => (forall x. (x -> m a) -> e m x -> m a)+ -> m a -> m a+interceptCont1 h m = send (InterceptCont InterceptOne h m)+{-# INLINE interceptCont1 #-}
+ src/Control/Effect/Internal.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal where++import Data.Coerce+import Data.Kind (Constraint)++import Data.Functor.Identity+import Data.Monoid+import Control.Monad.Trans+import Control.Monad.Trans.Identity+import Control.Effect.Internal.Membership+import Control.Effect.Internal.Union+import Control.Effect.Internal.Utils+import Control.Effect.Internal.Derive+import Control.Effect.Internal.Itself++-- | The class of effect carriers, and the underlying mechanism with which+-- effects are implemented.+--+-- Each carrier is able to implement a number of /derived/ effects,+-- and /primitive/ effects. Users usually only interact with derived+-- effects, as these determine the effects that users have access to.+--+-- The standard interpretation tools are typically powerful enough to+-- let you avoid making instances of this class directly. If you need to make+-- your own instance of 'Carrier', import "Control.Effect.Carrier" and consult the+-- [wiki](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-topics#novel-carriers).+class Monad m => Carrier m where+ -- | The derived effects that @m@ carries. Each derived effect is eventually+ -- reformulated into terms of the primitive effects @'Prims' m@ or other+ -- effects in @'Derivs' m@.+ --+ -- In application code, you gain access to effects by placing membership+ -- constraints upon @'Derivs' m@. You can use 'Eff' or 'Effs' for this+ -- purpose.+ --+ -- Although rarely relevant for users, @'Derivs' m@ can also contain effects+ -- that aren't expressed in terms of other effects, as longs as the handlers+ -- for those effects can be lifted generically using 'lift'. Such effects don't+ -- need to be part of @'Prims' m@, which is exclusively for primitive effects+ -- whose handlers need special treatment to be lifted.+ --+ -- For example, first order effects such as 'Control.Effect.State.State'+ -- never need to be part of @'Prims' m@. Certain higher-order effects -+ -- such as 'Control.Effect.Cont.Cont' - can also be handled such that they+ -- never need to be primitive.+ type Derivs m :: [Effect]++ -- | The primitive effects that @m@ carries. These are higher-order effects+ -- whose handlers aren't expressed in terms of other effects, and thus need to+ -- be lifted on a carrier-by-carrier basis.+ --+ -- __Never place membership constraints on @'Prims' m@.__+ -- You should only gain access to effects by placing membership constraints+ -- on @'Derivs' m@.+ --+ -- /However/, running interpreters may place other kinds of constraints upon+ -- @'Prims' m@, namely /threading constraints/, marked by the use of+ -- 'Threaders'.+ -- If you want to run such an effect interpreter inside application code, you+ -- have to propagate such threading constraints through your application.+ --+ -- @'Prims' m@ should only contain higher-order effects that can't be lifted+ -- generically using 'lift'. Any other effects can be placed in @'Derivs' m@.+ type Prims m :: [Effect]++ -- | An @m@-based 'Algebra' (i.e effect handler) over the union+ -- of the primitive effects:+ -- effects that aren't formulated in terms of other effects.+ -- See 'Prims'.+ algPrims :: Algebra' (Prims m) m a++ -- | Any 'Carrier' @m@ must provide a way to describe the derived effects it+ -- carries in terms of the primitive effects.+ --+ -- 'reformulate' is that decription: given any monad @z@ such that+ -- @z@ lifts @m@, then a @z@-based 'Algebra' (i.e. effect handler)+ -- over the derived effects can be created out of a @z@-based 'Algebra' over+ -- the primitive effects.+ reformulate :: Monad z+ => Reformulation' (Derivs m) (Prims m) m z a++ -- | An @m@-based algebra (i.e. effect handler) over the union of derived+ -- effects (see @'Derivs' m@).+ --+ -- This is what 'send' makes use of.+ --+ -- 'algDerivs' is subject to the law:+ --+ -- @+ -- algDerivs = 'reformulate' id 'algPrims'+ -- @+ --+ -- which serves as the default implementation.+ algDerivs :: Algebra' (Derivs m) m a+ algDerivs = reformulate id algPrims+ {-# INLINE algDerivs #-}++deriving newtype instance Carrier m => Carrier (Alt m)+deriving newtype instance Carrier m => Carrier (Ap m)++-- | (Morally) a type synonym for+-- @('Member' e ('Derivs' m), 'Carrier' m)@.+-- This and 'Effs' are the typical methods to gain+-- access to effects.+--+-- Unlike 'Member', 'Eff' gives 'Bundle' special treatment.+-- As a side-effect, 'Eff' will get stuck if @e@ is a type variable.+--+-- If you need access to some completely polymorphic effect @e@,+-- use @('Member' e ('Derivs' m), 'Carrier' m)@ instead of @Eff e m@.+type Eff e m = Effs '[e] m++-- | A variant of 'Eff' that takes a list of effects, and expands them into+-- multiple 'Member' constraints on @'Derivs' m@.+-- This and 'Eff' are the typical methods to gain access to effects.+--+-- Like 'Eff', 'Effs' gives 'Bundle' special treatment.+-- As a side-effect, 'Effs' will get stuck if any element of the list+-- is a type variable.+--+-- If you need access to some completetely polymorphic effect @e@,+-- use a separate @'Member' e ('Derivs' m)@ constraint.+type Effs es m = (EffMembers es (Derivs m), Carrier m)+++-- | Perform an action of an effect.+--+-- 'send' should be used to create actions of your own effects.+-- For example:+--+-- @+-- data CheckString :: Effect where+-- CheckString :: String -> CheckString m Bool+--+-- checkString :: Eff CheckString m => String -> m Bool+-- checkString str = send (CheckString str)+-- @+--+send :: (Member e (Derivs m), Carrier m) => e m a -> m a+send = algDerivs . inj+{-# INLINE send #-}++deriving via (m :: * -> *) instance Carrier m => Carrier (IdentityT m)++-- | A constraint that @'Prims' m@ satisfies all the constraints in the list+-- @cs@.+--+-- This is used for /threading constraints/.+--+-- Every interpreter that relies on an underlying+-- non-trivial monad transformer -- such as 'Control.Effect.State.runState',+-- which uses 'Control.Monad.Trans.State.Strict.StateT' internally --+-- must be able to lift all primitive effect handlers of the monad it's transforming+-- so that the resulting transformed monad can also handle the primitive effects.+--+-- The ability of a monad transformer to lift handlers of a particular+-- primitive effect is called /threading/ that effect. /Threading constraints/+-- correspond to the requirement that the primitive effects of the monad that's+-- being transformed can be thread by certain monad transformer.+--+-- For example, the 'Control.Effect.State.runState' places the threading+-- constraint 'Control.Effect.State.StateThreads' on @'Prims' m@, so that+-- @'Control.Effect.State.StateC' s m@ can carry all primitive effects that+-- @m@ does.+--+-- 'Threaders' is used to handle threading constraints.+-- @'Threaders' '['Control.Effect.State.StateThreads', 'Control.Effect.Error.ExceptThreads'] m p@+-- allows you to use 'Control.Effect.State.runState' and+-- 'Control.Effect.Error.runError' with the carrier @m@.+--+-- Sometimes, you may want to have a local effect which you interpret+-- inside of application code; such as a local 'Control.Effect.State.State'+-- or 'Control.Effect.Error.Error' effect. In such cases, /try to use/+-- [split interpretation](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-Topics#abstract-effect-interpretation) /instead of using interpreters with threading constraints/+-- /inside of application code./ If you can't, then using 'Threaders'+-- is necessary to propagate the threading constraints+-- throughout the application.+--+-- __The third argument @p@ should always be a polymorphic type variable, which__+-- __you can simply provide and ignore.__+-- It exists as a work-around to the fact that many threading constraints+-- /don't actually work/ if they operate on @'Prims' m@ directly, since+-- threading constraints often involve quantified constraints, which are fragile+-- in combination with type families -- like 'Prims'.+--+-- So @'Threaders' '['Control.Effect.State.StateThreads'] m p@+-- doesn't expand to @'Control.Effect.State.StateThreads' ('Prims' m)@, but rather,+-- @(p ~ 'Prims' m, 'Control.Effect.State.StateThreads' p)@+type Threaders cs m p = (p ~ Prims m, SatisfiesAll p cs)++type family SatisfiesAll (q :: k) cs :: Constraint where+ SatisfiesAll q '[] = ()+ SatisfiesAll q (c ': cs) = (c q, SatisfiesAll q cs)++-- | The identity carrier, which carries no effects at all.+type RunC = Identity++-- | Extract the final result from a computation of which no effects remain+-- to be handled.+run :: RunC a -> a+run = runIdentity+{-# INLINE run #-}++instance Carrier Identity where+ type Derivs Identity = '[]+ type Prims Identity = '[]++ algPrims = absurdU+ {-# INLINE algPrims #-}++ reformulate _ _ = absurdU+ {-# INLINE reformulate #-}++ algDerivs = absurdU+ {-# INLINE algDerivs #-}++deriving newtype instance Carrier m => Carrier (Itself m)+++newtype SubsumeC (e :: Effect) m a = SubsumeC {+ unSubsumeC :: m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ via m+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance ( Carrier m+ , Member e (Derivs m)+ )+ => Carrier (SubsumeC e m) where+ type Derivs (SubsumeC e m) = e ': Derivs m+ type Prims (SubsumeC e m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINE algPrims #-}++ reformulate n alg = powerAlg' (reformulate (n .# SubsumeC) alg) $ \e ->+ reformulate (n .# SubsumeC) alg (Union membership e)+ {-# INLINE reformulate #-}++ algDerivs = powerAlg' (coerce (algDerivs @m)) $ \e ->+ coerceAlg (algDerivs @m) (Union membership e)+ {-# INLINE algDerivs #-}++-- | Interpret an effect in terms of another, identical effect.+--+-- This is very rarely useful, but one use-case is to transform+-- reinterpreters into regular interpreters.+--+-- For example,+-- @'subsume' . 'Control.Effect.reinterpretSimple' \@e h@ is morally equivalent+-- to @'Control.Effect.interpretSimple' \@e h@+subsume :: ( Carrier m+ , Member e (Derivs m)+ )+ => SubsumeC e m a+ -> m a+subsume = unSubsumeC+{-# INLINE subsume #-}
+ src/Control/Effect/Internal/BaseControl.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DerivingVia, MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.BaseControl where++import Control.Effect.Carrier+import Control.Effect.Internal.Itself+import Control.Effect.Carrier.Internal.Interpret++import Control.Monad.Trans.Identity+import Control.Effect.Type.Internal.BaseControl++import GHC.Exts (Proxy#, proxy#)++data BaseControlH++instance Carrier m => PrimHandler BaseControlH (BaseControl m) m where+ effPrimHandler (GainBaseControl main) = return $ main (proxy# :: Proxy# (Itself m))+ {-# INLINE effPrimHandler #-}++newtype BaseControlC m a = BaseControlC {+ unBaseControlC :: m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++deriving via InterpretPrimC BaseControlH (BaseControl m) m+ instance Carrier m => Carrier (BaseControlC m)
+ src/Control/Effect/Internal/Cont.hs view
@@ -0,0 +1,149 @@+{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Internal.Cont where + +import Data.Coerce + +import Control.Monad.Trans +import Control.Monad.Base +import qualified Control.Monad.Fail as Fail + +import Control.Effect +import Control.Effect.Carrier + +import Control.Effect.Internal.Utils + +import qualified Control.Monad.Trans.Cont as C +import Control.Monad.Trans.Free.Church.Alternate + +-- | An effect for abortive continuations. +newtype Cont m a where + CallCC :: ((forall b. a -> m b) -> m a) -> Cont m a + +-- | An effect for non-abortive continuations of a program +-- that eventually produces a result of type @r@. +-- +-- This isn't quite as powerful as proper delimited continuations, +-- as this doesn't provide any equivalent of the @reset@ operator. +-- +-- This can be useful as a helper effect. +newtype Shift r m a where + Shift :: ((a -> m r) -> m r) -> Shift r m a + +data ContBase r a where + Exit :: r -> ContBase r a + GetCont :: ContBase r (Either (a -> r) a) + + +newtype ContC r m a = ContC { unContC :: FreeT (ContBase (m r)) m a } + deriving ( Functor, Applicative, Monad + , MonadBase b, Fail.MonadFail, MonadIO + , MonadThrow, MonadCatch + ) + +instance MonadTrans (ContC s) where + lift = ContC #. lift + {-# INLINE lift #-} + +instance ( Carrier m + , Threads (FreeT (ContBase (m r))) (Prims m) + ) + => Carrier (ContC r m) where + type Derivs (ContC r m) = Cont ': Derivs m + type Prims (ContC r m) = Prims m + + algPrims = coerce (thread @(FreeT (ContBase (m r))) (algPrims @m)) + {-# INLINEABLE algPrims #-} + + reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case + CallCC main -> n (ContC $ liftF $ GetCont) >>= \case + Left c -> main (n . ContC #. liftF . Exit . c) + Right a -> return a + {-# INLINEABLE reformulate #-} + + +newtype ContFastC (r :: *) m a = ContFastC { unContFastC :: C.ContT r m a } + deriving (Functor, Applicative, Monad, MonadBase b, MonadIO, Fail.MonadFail) + deriving MonadTrans + +instance ( Carrier m + , Threads (C.ContT r) (Prims m) + ) + => Carrier (ContFastC r m) where + type Derivs (ContFastC r m) = Cont ': Derivs m + type Prims (ContFastC r m) = Prims m + + algPrims = coerce (thread @(C.ContT r) (algPrims @m)) + {-# INLINEABLE algPrims #-} + + reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case + CallCC main -> + n (ContFastC $ C.ContT $ \c -> c (Left (c . Right))) >>= \case + Left c -> main (\a -> n $ ContFastC $ C.ContT $ \_ -> c a) + Right a -> return a + {-# INLINEABLE reformulate #-} + +newtype ShiftC r m a = ShiftC { unShiftC :: FreeT (ContBase (m r)) m a } + deriving ( Functor, Applicative, Monad + , MonadBase b, Fail.MonadFail, MonadIO + , MonadThrow, MonadCatch + ) + +instance MonadTrans (ShiftC s) where + lift = ShiftC #. lift + {-# INLINE lift #-} + +instance ( Carrier m + , Threads (FreeT (ContBase (m r))) (Prims m) + ) + => Carrier (ShiftC r m) where + type Derivs (ShiftC r m) = Shift r ': Derivs m + type Prims (ShiftC r m) = Prims m + + algPrims = coerce (thread @(FreeT (ContBase (m r))) (algPrims @m)) + {-# INLINEABLE algPrims #-} + + reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case + Shift main -> n (ShiftC $ liftF $ GetCont) >>= \case + Left c -> main (n . lift . c) >>= \r -> + n (ShiftC $ liftF $ Exit (pure r)) + Right a -> return a + {-# INLINEABLE reformulate #-} + +instance ( Carrier m + , Threads (C.ContT r) (Prims m) + ) + => Carrier (ShiftFastC r m) where + type Derivs (ShiftFastC r m) = Shift r ': Derivs m + type Prims (ShiftFastC r m) = Prims m + + algPrims = coerce (thread @(C.ContT r) (algPrims @m)) + {-# INLINEABLE algPrims #-} + + reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case + Shift main -> + n (ShiftFastC $ C.ContT $ \c -> c (Left (c . Right))) >>= \case + Left c -> main (n . lift . c) >>= \r -> + n (ShiftFastC $ C.ContT $ \_ -> return r) + Right a -> return a + {-# INLINEABLE reformulate #-} + +newtype ShiftFastC (r :: *) m a = ShiftFastC { unShiftFastC :: C.ContT r m a } + deriving (Functor, Applicative, Monad, MonadBase b, MonadIO, Fail.MonadFail) + deriving MonadTrans + +-- | 'ContThreads' accepts the following primitive effects: +-- +-- * 'Control.Effect.Regional.Regional' @s@ +-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor) +-- * 'Control.Effect.Type.Unravel.Unravel' @p@ +-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid') +-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@ +type ContThreads = FreeThreads + +-- | 'ContFastThreads' accepts the following primitive effects: +-- +-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@ +class ( forall s. Threads (C.ContT s) p + ) => ContFastThreads p +instance ( forall s. Threads (C.ContT s) p + ) => ContFastThreads p
+ src/Control/Effect/Internal/Derive.hs view
@@ -0,0 +1,20 @@+-- | Module exporting typical type classes that are newtype-derived by Carriers +module Control.Effect.Internal.Derive + ( Alternative, MonadPlus + , MonadFix, Fail.MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase, MonadBaseControl + , MonadTrans, MonadTransControl + , IdentityT + ) where + +-- TODO(KingoftheHomeless?): Make a TH macro which may be used to newtype-derive as many of these classes as possible. +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import qualified Control.Monad.Fail as Fail +import Control.Monad.Fix +import Control.Monad.Catch +import Control.Monad.Base +import Control.Monad.Trans.Control +import Control.Monad.Trans.Identity
+ src/Control/Effect/Internal/Effly.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.Effly where++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+import qualified Control.Monad.Fail as Fail+import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Identity+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+import qualified Control.Monad.Catch+import Control.Monad.Trans.Control hiding (embed)++import Control.Effect.Type.Alt+import Control.Effect.Type.ErrorIO+import Control.Effect.Type.Mask+import Control.Effect.Type.Bracket+import Control.Effect.Type.Embed+import Control.Effect.Type.Fail+import Control.Effect.Type.Fix+import Control.Effect.Internal+import Control.Effect.Internal.Utils++-- | A newtype wrapper with instances based around the effects of @m@+-- when possible; 'Effly' as in "Effectfully."+--+-- This is often useful for making use of these instances inside of+-- interpreter handlers, or within application code.+newtype Effly m a = Effly { runEffly :: m a }+ deriving ( Functor, Applicative, Monad+ -- , MonadThrow, MonadCatch, MonadMask -- TODO: Should we keep these?+ , MonadBase b, MonadBaseControl b+ , Carrier+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance Eff Alt m => Alternative (Effly m) where+ empty = send Empty+ {-# INLINE empty #-}++ ma <|> mb = send (Alt ma mb)+ {-# INLINE (<|>) #-}++instance Eff Alt m => MonadPlus (Effly m)++instance Eff (Embed IO) m => MonadIO (Effly m) where+ liftIO = send .# Embed+ {-# INLINE liftIO #-}++instance Eff Fix m => MonadFix (Effly m) where+ mfix = send .# Fix+ {-# INLINE mfix #-}++instance Eff Fail m => Fail.MonadFail (Effly m) where+ fail = send .# Fail+ {-# INLINE fail #-}++instance Eff ErrorIO m => MonadThrow (Effly m) where+ throwM = send . ThrowIO+ {-# INLINE throwM #-}++instance Eff ErrorIO m => MonadCatch (Effly m) where+ catch m h = send (CatchIO m h)+ {-# INLINE catch #-}++instance Effs '[Mask, Bracket, ErrorIO] m => MonadMask (Effly m) where+ mask main = send (Mask InterruptibleMask main)+ {-# INLINE mask #-}++ uninterruptibleMask main = send (Mask UninterruptibleMask main)+ {-# INLINE uninterruptibleMask #-}++ generalBracket acquire release use =+ send (GeneralBracket acquire release use)+ {-# INLINE generalBracket #-}
+ src/Control/Effect/Internal/Error.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE DerivingVia #-}+module Control.Effect.Internal.Error where++import Data.Coerce++import Control.Applicative+import Control.Monad++import Control.Effect+import Control.Effect.Type.Throw+import Control.Effect.Type.Catch+import Control.Effect.Optional++import Control.Effect.Carrier++import Control.Monad.Trans.Except++newtype ThrowC e m a = ThrowC { unThrowC :: ExceptT e m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl)++newtype ErrorC e m a = ErrorC { unErrorC :: ExceptT e m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl)++instance ( Carrier m+ , Threads (ExceptT e) (Prims m)+ )+ => Carrier (ThrowC e m) where+ type Derivs (ThrowC e m) = Throw e ': Derivs m+ type Prims (ThrowC e m) = Prims m++ algPrims = coerce (thread @(ExceptT e) (algPrims @m))+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case+ Throw e -> n (ThrowC (throwE e))+ {-# INLINEABLE reformulate #-}+++instance ( Carrier m+ , Threads (ExceptT e) (Prims m)+ )+ => Carrier (ErrorC e m) where+ type Derivs (ErrorC e m) = Catch e ': Throw e ': Derivs m+ type Prims (ErrorC e m) = Optional ((->) e) ': Prims m++ algPrims = powerAlg (coerce (algPrims @(ThrowC e m))) $ \case+ Optionally h m -> ErrorC (unErrorC m `catchE` (return . h))+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg (+ coerceReform (reformulate @(ThrowC e m)) n (weakenAlg alg)+ ) $ \case+ Catch m h -> join $ (alg . inj) $ Optionally h (fmap pure m)+ {-# INLINEABLE reformulate #-}+++-- | 'ErrorThreads' accepts the following primitive effects:+--+-- * 'Control.Effect.Regional.Regional' @s@+-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)+-- * 'Control.Effect.BaseControl.BaseControl' @b@+-- * 'Control.Effect.Type.Unravel.Unravel' @p@+-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.WriterPrim.WriterPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@+-- * 'Control.Effect.Mask.Mask'+-- * 'Control.Effect.Bracket.Bracket'+-- * 'Control.Effect.Fix.Fix'+class ( forall e. Threads (ExceptT e) p+ ) => ErrorThreads p+instance ( forall e. Threads (ExceptT e) p+ ) => ErrorThreads p
+ src/Control/Effect/Internal/Intercept.hs view
@@ -0,0 +1,353 @@+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.Intercept where++import Data.Coerce++import Control.Monad+import Control.Effect+import Control.Effect.Unlift+import Control.Effect.Carrier+import Control.Effect.State+import Control.Effect.Writer+import Control.Effect.Carrier.Internal.Stepped+import Control.Monad.Trans.Free.Church.Alternate+import Control.Monad.Trans.Reader++import Control.Effect.Type.Unravel+import Control.Effect.Type.ListenPrim++import Control.Effect.Internal.Utils+++-- | An effect for intercepting actions of a first-order effect.+--+-- Even for this library, proper usage of this effect is very complicated.+-- When properly used, this can be a very useful helper effect,+-- allowing you write interpretations for a class of higher-order effects+-- that wouldn't otherwise be possible.+--+-- For more information, see the+-- [wiki](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-Topics#effect-interception).+data Intercept (e :: Effect) :: Effect where+ Intercept :: Coercible z m+ => (forall x. e z x -> m x)+ -> m a+ -> Intercept e m a++-- | A variant of 'InterceptCont' that is significantly more powerful, allowing+-- you to capture the continuation of the program at each use-site of an+-- effect, as well as aborting execution of the parameter computation+-- early.+data InterceptCont (e :: Effect) :: Effect where+ InterceptCont :: Coercible z m+ => InterceptionMode+ -> (forall x. (x -> m a) -> e z x -> m a)+ -> m a+ -> InterceptCont e m a++data InterceptionMode+ = InterceptOne+ | InterceptAll++data InterceptB e a where+ InterceptB :: (forall q x. (x -> a) -> e q x -> a)+ -> InterceptB e a++interceptB :: forall e m q a+ . ( FirstOrder e+ , Eff (Unravel (InterceptB e)) m+ )+ => (forall x. (x -> m a) -> e q x -> m a)+ -> m a -> m a+interceptB h m = join $ send $+ Unravel @(InterceptB e)+ (InterceptB (\c -> h c .# coerce))+ join+ (fmap pure m)+{-# INLINE interceptB #-}++type InterceptContC e = CompositionC+ '[ IntroC '[InterceptCont e, Intercept e]+ '[Unravel (InterceptB e)]+ , InterpretC InterceptH (InterceptCont e)+ , InterpretC InterceptH (Intercept e)+ , InterpretPrimC InterceptH (Unravel (InterceptB e))+ , SteppedC e+ ]++data InterceptH++instance ( FirstOrder e+ , Eff (Unravel (InterceptB e)) m+ )+ => Handler InterceptH (Intercept e) m where+ effHandler (Intercept h m) =+ interceptB+ (\c e -> h e >>= c)+ m+ {-# INLINEABLE effHandler #-}++instance ( FirstOrder e+ , Member e (Derivs m)+ , Eff (Unravel (InterceptB e)) m+ )+ => Handler InterceptH (InterceptCont e) m where+ effHandler (InterceptCont mode h main) = case mode of+ InterceptAll -> interceptB h main+ InterceptOne ->+ send (Unravel+ @(InterceptB e)+ (InterceptB $ \c e b ->+ if b then+ h (`c` False) (coerce e)+ else+ send @e (coerce e) >>= (`c` b)+ )+ (\m b -> m >>= \f -> f b)+ (fmap (const . pure) main)+ )+ >>= \f -> f True+ {-# INLINEABLE effHandler #-}++instance ( FirstOrder e+ , Carrier m+ , Threaders '[SteppedThreads] m p+ )+ => PrimHandler InterceptH+ (Unravel (InterceptB e))+ (SteppedC e m) where+ effPrimHandler (Unravel (InterceptB cataEff) cataM main) =+ return $+ unFreeT (unSteppedC main)+ (\mx c -> cataM $ fmap c $ lift mx)+ (\(FOEff e) c -> cataEff c e)+ id+ {-# INLINEABLE effPrimHandler #-}+++-- | Run @'Intercept' e@, @'InterceptCont' e@ and @e@ effects, provided+-- that @e@ is first-order and also part of the remaining effect stack.+--+-- There are three very important things to note here:+--+-- * __@e@ must be first-order.__+-- * __Any action of @e@ made by a handler run after 'runInterceptCont'__+-- __won't get be intercepted__. What this means is __that you typically want__+-- __to run the handler for @e@ immediately after 'runInterceptCont'__.+-- * __This imposes the very restrictive primitive effect__+-- __'Control.Effect.Type.Unravel.Unravel'__. Most notably, neither+-- 'StateThreads' nor 'WriterThreads' accepts it.+-- Because of that, this module offers various alternatives+-- of several common 'State' and 'Tell' interpreters with threading+-- constraints that do accept 'Unravel'.+--+-- @'Derivs' ('InterceptContC' e m) = 'InterceptCont' e ': 'Intercept' e ': e ': Derivs m@+--+-- @'Prims' ('InterceptContC' e m) = 'Unravel' (InterceptB e) ': 'Prims' m@+runInterceptCont :: forall e m a p+ . ( FirstOrder e+ , Carrier m+ , Member e (Derivs m)+ , Threaders '[SteppedThreads] m p+ )+ => InterceptContC e m a+ -> m a+runInterceptCont m =+ (\m' -> unFreeT m'+ (>>=)+ (\(FOEff e) c -> send @e (coerce e) >>= c)+ return+ )+ $ unSteppedC+ $ interpretPrimViaHandler+ $ interpretViaHandler+ $ interpretViaHandler+ $ introUnderMany+ $ runComposition+ $ m+{-# INLINE runInterceptCont #-}++-- | A variant of 'runState' with a 'SteppedThreads' threading constraint+-- instead of a 'StateThreads' threading constraint.+runStateStepped :: forall s m a p+ . (Carrier m, Threaders '[SteppedThreads] m p)+ => s+ -> SteppedC (State s) m a+ -> m (s, a)+runStateStepped s0 m =+ unFreeT+ (unSteppedC m)+ (\mx c s -> mx >>= (`c` s))+ (\(FOEff e) c s -> case e of+ Get -> c s s+ Put s' -> c () s'+ )+ (\a s -> return (s, a))+ s0+{-# INLINE runStateStepped #-}++-- | A variant of 'runTell' with a 'SteppedThreads' threading constraint+-- instead of a 'StateThreads' threading constraint.+runTellListStepped :: forall o m a p+ . ( Carrier m+ , Threaders '[SteppedThreads] m p+ )+ => SteppedC (Tell o) m a+ -> m ([o], a)+runTellListStepped m =+ unFreeT+ (unSteppedC m)+ (\mx c s -> mx >>= (`c` s))+ (\(FOEff (Tell o)) c s -> c () (o : s))+ (\a s -> return (reverse s, a))+ []+{-# INLINE runTellListStepped #-}++-- | A variant of 'runTell' with a 'SteppedThreads' threading constraint+-- instead of a 'StateThreads' threading constraint.+runTellStepped :: forall w m a p+ . ( Monoid w+ , Carrier m+ , Threaders '[SteppedThreads] m p+ )+ => SteppedC (Tell w) m a+ -> m (w, a)+runTellStepped m =+ unFreeT+ (unSteppedC m)+ (\mx c s -> mx >>= (`c` s))+ (\(FOEff (Tell o)) c s -> c () $! s <> o)+ (\a s -> return (s, a))+ mempty+{-# INLINE runTellStepped #-}++data ListenSteppedH++instance Eff (ListenPrim w) m+ => Handler ListenSteppedH (Listen w) m where+ effHandler (Listen m) = send $ ListenPrimListen m+ {-# INLINEABLE effHandler #-}++instance (Monoid w, Carrier m, Threaders '[SteppedThreads] m p)+ => PrimHandler ListenSteppedH (ListenPrim w) (SteppedC (Tell w) m) where+ effPrimHandler = \case+ ListenPrimTell w -> tell w+ ListenPrimListen m -> SteppedC $ FreeT $ \bind handler c ->+ unFreeT (unSteppedC m)+ (\mx c' s -> mx `bind` (`c'` s))+ (\e@(FOEff (Tell o)) c' s -> handler e $ \a -> c' a $! s <> o)+ (\a s -> c (s, a))+ mempty+ {-# INLINEABLE effPrimHandler #-}++type ListenSteppedC w = CompositionC+ '[ ReinterpretC ListenSteppedH (Listen w) '[ListenPrim w]+ , InterpretPrimC ListenSteppedH (ListenPrim w)+ , SteppedC (Tell w)+ ]++-- | A variant of 'runListen' with a 'SteppedThreads' threading constraint+-- instead of a 'StateThreads' threading constraint.+--+-- @'Derivs' ('ListenSteppedC' w m) = 'Listen' w ': 'Tell' w ': Derivs m@+--+-- @'Prims' ('ListenSteppedC' w m) = 'ListenPrim' w ': Derivs m@+runListenStepped :: forall w m a p+ . ( Monoid w+ , Carrier m+ , Threaders '[SteppedThreads] m p+ )+ => ListenSteppedC w m a+ -> m (w, a)+runListenStepped m =+ runTellStepped+ $ interpretPrimViaHandler+ $ reinterpretViaHandler+ $ runComposition+ $ m+{-# INLINE runListenStepped #-}++++newtype ReifiedFOHandler e m = ReifiedFOHandler (forall q x. e q x -> m x)++newtype InterceptRC (e :: Effect) m a = InterceptRC {+ unInterceptRC :: ReaderT (ReifiedFOHandler e m) m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )++instance MonadTrans (InterceptRC e) where+ lift = InterceptRC #. lift+ {-# INLINE lift #-}++instance ( FirstOrder e+ , Carrier m+ , Threads (ReaderT (ReifiedFOHandler e m)) (Prims m)+ )+ => Carrier (InterceptRC e m) where+ type Derivs (InterceptRC e m) = Intercept e ': e ': Derivs m+ type Prims (InterceptRC e m) = Unlift (ReaderT (ReifiedFOHandler e m) m)+ ': Prims m++ algPrims =+ powerAlg (+ coerce (thread @(ReaderT (ReifiedFOHandler e m)) (algPrims @m))+ ) $ \case+ Unlift main -> InterceptRC (main unInterceptRC)+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg (+ powerAlg' (+ reformulate (n . lift) (weakenAlg alg)+ ) $ \e -> do+ ReifiedFOHandler h <- n $ InterceptRC ask+ n $ lift $ h e+ ) $ \case+ Intercept h m ->+ (alg . inj) $ Unlift @(ReaderT (ReifiedFOHandler e m) m) $ \lower ->+ local+ (\h' -> ReifiedFOHandler $ \e ->+ runReaderT (lower (h (coerce e))) h'+ )+ (lower m)+ {-# INLINEABLE reformulate #-}+++-- | Run @'Intercept' e@ and @e@ effects, provided+-- @e@ is first-order and part of the effect stack.+--+-- 'runInterceptR' differs from 'runInterceptCont' in four different ways:+--+-- * It doesn't handle 'InterceptCont'.+-- * It has the significantly less restrictive threading constraint+-- 'ReaderThreads' instead of 'SteppedThreads'+-- * It imposes the significantly /more/ restrictive primitive effect 'Unlift'+-- instead of 'Unravel'.+-- * It is significantly faster.+--+-- There are some interpreters -- such as 'Control.Effect.Bracket.bracketToIO' and 'Control.Effect.Conc.concToIO' --+-- that 'runInterceptCont' can't be used together with in any capacity+-- due to its 'SteppedThreads' threading constraint. In+-- these cases, 'runInterceptR' can be used instead.+--+-- @'Derivs' ('InterceptRC' e m) = 'Intercept' e ': e ': 'Derivs m'@+--+-- @'Prims' ('InterceptRC' e m) = 'Unlift' (ReaderT (ReifiedFOHandler e m)) ': 'Derivs m'@+runInterceptR :: forall e m a p+ . ( FirstOrder e+ , Member e (Derivs m)+ , Carrier m+ , Threaders '[ReaderThreads] m p+ )+ => InterceptRC e m a+ -> m a+runInterceptR m =+ runReaderT (unInterceptRC m)+ (ReifiedFOHandler $ \e -> send @e (coerce e))+{-# INLINE runInterceptR #-}
+ src/Control/Effect/Internal/Itself.hs view
@@ -0,0 +1,20 @@+module Control.Effect.Internal.Itself where + +import Control.Monad.Base +import Control.Monad.Trans.Control + +newtype Itself m a = Itself { unItself :: m a } + deriving (Functor, Applicative, Monad) + +instance Monad m => MonadBase m (Itself m) where + liftBase = Itself + {-# INLINE liftBase #-} + +instance Monad m => MonadBaseControl m (Itself m) where + type StM (Itself m) a = a + + liftBaseWith m = Itself (m unItself) + {-# INLINE liftBaseWith #-} + + restoreM = return + {-# INLINE restoreM #-}
+ src/Control/Effect/Internal/KnownList.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.KnownList where++import Data.Bifunctor+import Control.Effect.Internal.Membership+import Control.Effect.Internal.Union+++-- | Remove the prefix @xs@ from the list @r@.+--+-- 'Control.Effect.IntroC', 'Control.Effect.ReinterpretC' and friends don't+-- as much introduce effects as they /hide/ them, through removing effects from+-- the derived effects that the transformed carrier carries.+-- This is done thorugh 'StripPrefix'.+--+-- For example:+--+-- @+-- 'Control.Effect.Derivs' ('Control.Effect.ReinterpretSimpleC' e '[newE, newE2])+-- = e ': 'StripPrefix' '[newE, newE2] ('Control.Effcet.Derivs' m)+-- @+--+type family StripPrefix xs r where+ StripPrefix '[] r = r+ StripPrefix (x ': xs) (x ': r) = StripPrefix xs r++data SList l where+ SEnd :: SList '[]+ SCons :: SList xs -> SList (x ': xs)++class KnownList l where+ singList :: SList l++instance KnownList '[] where+ singList = SEnd+ {-# INLINE singList #-}++instance KnownList xs => KnownList (x ': xs) where+ singList = SCons singList+ {-# INLINE singList #-}+++extendMembership :: forall r e l. SList l -> ElemOf e r -> ElemOf e (Append l r)+extendMembership SEnd pr = pr+extendMembership (SCons l) pr = There (extendMembership l pr)+++splitMembership :: forall r e l+ . SList l+ -> ElemOf e (Append l r)+ -> Either (ElemOf e l) (ElemOf e r)+splitMembership SEnd pr = Right pr+splitMembership (SCons _) Here = Left Here+splitMembership (SCons sl) (There pr) = first There (splitMembership @r sl pr)++injectMembership :: forall right e left mid+ . SList left+ -> SList mid+ -> ElemOf e (Append left right)+ -> ElemOf e (Append left (Append mid right))+injectMembership SEnd sm pr = extendMembership sm pr+injectMembership (SCons _) _ Here = Here+injectMembership (SCons sl) sm (There pr) = There (injectMembership @right sl sm pr)++-- TODO(KingoftheHomeless): This is safe to unsafeCoerce, but would it wreck optimizations?+lengthenMembership :: forall r e l. ElemOf e l -> ElemOf e (Append l r)+lengthenMembership Here = Here+lengthenMembership (There xs) = There (lengthenMembership @r xs)++weakenN :: SList l -> Union r m a -> Union (Append l r) m a+weakenN sl (Union pr e) = Union (extendMembership sl pr) e+{-# INLINE weakenN #-}++weakenMid :: forall right m a left mid+ . SList left -> SList mid+ -> Union (Append left right) m a+ -> Union (Append left (Append mid right)) m a+weakenMid sl sm (Union pr e) = Union (injectMembership @right sl sm pr) e+{-# INLINE weakenMid #-}++weakenAlgN :: SList l -> Algebra (Append l r) m -> Algebra r m+weakenAlgN sl alg u = alg (weakenN sl u)+{-# INLINE weakenAlgN #-}++weakenAlgMid :: forall right m left mid+ . SList left -> SList mid+ -> Algebra (Append left (Append mid right)) m+ -> Algebra (Append left right) m+weakenAlgMid sl sm alg u = alg (weakenMid @right sl sm u)+{-# INLINE weakenAlgMid #-}+++weakenReformMid :: forall right p m z a left mid+ . SList left -> SList mid+ -> Reformulation' (Append left (Append mid right)) p m z a+ -> Reformulation' (Append left right) p m z a+weakenReformMid sl sm reform = \n alg u -> reform n alg (weakenMid @right sl sm u)+{-# INLINE weakenReformMid #-}+++-- | Weaken a 'Reformulation' by removing a number of derived effects under+-- the topmost effect.+--+-- This needs a type application to specify what effects to remove.+weakenReformUnder :: forall new e r p m z a+ . KnownList new+ => Reformulation' (e ': Append new r) p m z a+ -> Reformulation' (e ': r) p m z a+weakenReformUnder = weakenReformMid @r (singList @'[e]) (singList @new)+{-# INLINE weakenReformUnder #-}++-- | Weaken a 'Reformulation' by removing a derived effect under+-- the topmost effect.+weakenReformUnder1 :: forall e' e r p m z a+ . Reformulation' (e ': e' ': r) p m z a+ -> Reformulation' (e ': r) p m z a+weakenReformUnder1 = weakenReformMid @r (singList @'[e]) (singList @'[e'])+{-# INLINE weakenReformUnder1 #-}++-- | Weaken a 'Reformulation' by removing a number of derived effects under+-- a number of topmost effects.+--+-- This needs a type application to specify the top effects of the stack+-- underneath which effects are removed, and another+-- type application to specify what effects to remove.+--+-- For example:+--+-- @+-- weakenReformUnderMany \@'['Control.Effect.Error.Catch' e] \@'['Control.Effect.Optional.Optional' ((->) e)]+-- :: Reformulation ('Control.Effect.Error.Catch' e ': 'Control.Effect.Optional.Optional' ((->) e) ': r) p m+-- -> Reformulation ('Control.Effect.Error.Catch' e ': r) p m+-- @+weakenReformUnderMany :: forall top new r p m z a+ . ( KnownList top+ , KnownList new+ )+ => Reformulation' (Append top (Append new r)) p m z a+ -> Reformulation' (Append top r) p m z a+weakenReformUnderMany = weakenReformMid @r (singList @top) (singList @new)+{-# INLINE weakenReformUnderMany #-}
+ src/Control/Effect/Internal/Membership.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Internal.Membership where + +import GHC.TypeLits +import Data.Type.Equality + +data ElemOf (e :: a) (r :: [a]) where + Here :: ElemOf e (e ': r) + There :: ElemOf e r -> ElemOf e (_e ': r) + +absurdMember :: ElemOf e '[] -> b +absurdMember = \case +{-# INLINE absurdMember #-} + +deriving instance Show (ElemOf e r) + +sameMember :: forall e e' r + . ElemOf e r + -> ElemOf e' r + -> Maybe (e :~: e') +sameMember Here Here = Just Refl +sameMember (There pr) (There pr') = sameMember pr pr' +sameMember _ _ = Nothing + +-- | A constraint that @e@ is part of the effect row @r@. +-- +-- @r@ is typically @'Control.Effect.Derivs' m@ for some @m@. +-- @Member e ('Control.Effect.Derivs' m)@ allows you to use +-- actions of @e@ with @m@. +-- +-- If @e@ occurs multiple times in @r@, then the first +-- occurence will be used. +-- +-- If possible, use @'Control.Effect.Eff'/s@ instead. +class Member e r where + membership :: ElemOf e r + +instance {-# OVERLAPPING #-} Member e (e ': r) where + membership = Here + {-# INLINE membership #-} + +instance Member e r => Member e (_e ': r) where + membership = There membership + {-# INLINEABLE membership #-} + +instance TypeError ( 'Text "Unhandled effect: " ':<>: 'ShowType e + ':$$: 'Text "You need to either add or replace an \ + \interpreter in your interpretation stack \ + \so that the effect gets handled." + ':$$: 'Text "To check what effects are currently \ + \handled by your interpretation stack, use \ + \`debugEffects' from `Control.Effect.Debug'." + ) + => Member e '[] where + membership = error "impossible"
+ src/Control/Effect/Internal/Newtype.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE DefaultSignatures, DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.Newtype+ (+ WrapC(WrapC)+ , wrap+ , wrapWith++ , UnwrapC(UnwrapC)+ , unwrap++ , UnwrapTopC(UnwrapTopC)+ , unwrapTop++ , EffNewtype(..)++ , WrapperOf(..)+ ) where++import Data.Coerce++import Control.Monad.Trans.Identity+import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Internal.Utils++newtype WrapC (e :: Effect)+ (e' :: Effect)+ m+ (a :: *) = WrapC { unWrapC :: m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance ( Member e' (Derivs m)+ , Coercible e e'+ , Carrier m+ )+ => Carrier (WrapC e e' m) where+ type Derivs (WrapC e e' m) = e ': Derivs m+ type Prims (WrapC e e' m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg' (reformulate (n .# WrapC) alg) $+ \(e :: e z x) -> reformulate n alg (Union membership (coerce e :: e' z x))+ {-# INLINEABLE reformulate #-}++ algDerivs = powerAlg' (coerce (algDerivs @m)) $+ \(e :: e z x) -> algDerivs (Union membership (coerce e :: e' z x))+ {-# INLINEABLE algDerivs #-}++wrap :: ( Member e (Derivs m)+ , Carrier m+ , Coercible unwrappedE e+ )+ => WrapC unwrappedE e m a+ -> m a+wrap = unWrapC+{-# INLINE wrap #-}++-- | Wrap uses of an effect, injecting them into a newtype of that effect.+-- The first argument is ignored.+--+-- This is useful for creating actions of effect newtypes.+-- For example:+--+-- @+-- newtype Counter m a = Counter ('Control.Effect.State.State' Int m)+--+-- probe :: Eff Counter m => m Int+-- probe = 'wrapWith' Counter $ 'Control.Effect.State.state'' \@Int (\s -> (s + 1, s))+-- @+--+wrapWith :: ( Member e (Derivs m)+ , Carrier m+ , Coercible unwrappedE e+ )+ => (unwrappedE z x -> e z x)+ -> WrapC unwrappedE e m a+ -> m a+wrapWith _ = wrap+{-# INLINE wrapWith #-}++newtype UnwrapC (e :: Effect)+ m+ (a :: *) = UnwrapC { unUnwrapC :: m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance ( Carrier m+ , Member (UnwrappedEff e) (Derivs m)+ , EffNewtype e+ )+ => Carrier (UnwrapC e m) where+ type Derivs (UnwrapC e m) = e ': Derivs m+ type Prims (UnwrapC e m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg' (reformulate (n .# UnwrapC) alg) $+ \e -> reformulate (n .# UnwrapC) alg (Union membership (unwrapped e))+ {-# INLINEABLE reformulate #-}++ algDerivs = powerAlg' (coerce (algDerivs @m)) $+ \e -> coerceAlg (algDerivs @m) (Union membership (unwrapped e))+ {-# INLINEABLE algDerivs #-}++newtype UnwrapTopC (e :: Effect)+ m+ (a :: *) = UnwrapTopC { unUnwrapTopC :: m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance ( IntroConsistent '[] '[UnwrappedEff e] m+ , EffNewtype e+ , Carrier m+ )+ => Carrier (UnwrapTopC e m) where+ type Derivs (UnwrapTopC e m) = e ': StripPrefix '[UnwrappedEff e] (Derivs m)+ type Prims (UnwrapTopC e m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg' (weakenAlg (reformulate (n .# UnwrapTopC) alg)) $+ \e -> reformulate (n .# UnwrapTopC) alg (Union Here (unwrapped e))+ {-# INLINEABLE reformulate #-}++ algDerivs = powerAlg' (weakenAlg (coerce (algDerivs @m))) $+ \e -> coerceAlg (algDerivs @m) (Union Here (unwrapped e))+ {-# INLINEABLE algDerivs #-}++++-- | Unwrap uses of an effect+unwrap :: forall e m a+ . ( Carrier m+ , Member (UnwrappedEff e) (Derivs m)+ , EffNewtype e+ )+ => UnwrapC e m a+ -> m a+unwrap = unUnwrapC+{-# INLINE unwrap #-}++-- | Unwrap uses of an effect, placing its unwrapped version on top+-- of the effect stack.+unwrapTop :: forall e m a+ . ( HeadEff (UnwrappedEff e) m+ , EffNewtype e+ , Carrier m+ )+ => UnwrapTopC e m a+ -> m a+unwrapTop = unUnwrapTopC+{-# INLINE unwrapTop #-}++class EffNewtype (e :: Effect) where+ type UnwrappedEff e :: Effect+ unwrapped :: e z x -> UnwrappedEff e z x+ default unwrapped :: Coercible e (UnwrappedEff e) => e z x -> UnwrappedEff e z x+ unwrapped = coerce+ {-# INLINE unwrapped #-}++-- | Useful for deriving instances of 'EffNewtype'.+--+-- @+-- newtype SomeWrapper m a = SomeWrapper (SomeEffect m a)+-- deriving 'EffNewtype' via SomeWrapper `'WrapperOf'` SomeEffect+-- @+newtype WrapperOf (e :: Effect) (e' :: Effect) m a = WrapperOf (e m a)++instance Coercible e e' => EffNewtype (WrapperOf e e') where+ type UnwrappedEff (WrapperOf e e') = e'
+ src/Control/Effect/Internal/NonDet.hs view
@@ -0,0 +1,216 @@+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.NonDet where++import Data.Coerce++import Control.Effect+import Control.Effect.Carrier++import Control.Effect.Type.Split+import Control.Effect.Type.Regional++import Control.Effect.Internal.Utils+++import qualified Control.Monad.Trans.List.Church as L++-- | An effect for nondeterministic computations+newtype NonDet m a where+ FromList :: [a] -> NonDet m a++-- | An effect for culling nondeterministic computations.+newtype Cull m a where+ Cull :: m a -> Cull m a++-- | An effect to delimit backtracking within nondeterministic contexts.+data Cut m a where+ Cutfail :: Cut m a+ Call :: m a -> Cut m a++-- | A pseudo-effect for connected 'NonDet', 'Cull', 'Cut', and 'Split' effects.+--+-- @'Logic'@ should only ever be used inside of 'Eff' and 'Effs'+-- constraints. It is not a real effect! See 'Bundle'.+type Logic = Bundle '[NonDet, Cull, Cut, Split]+++-- | 'NonDetThreads' accepts the following primitive effects:+--+-- * 'Control.Effect.Regional.Regional' @s@+-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)+-- * 'Control.Effect.Type.Unravel.Unravel' @p@+-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@+type NonDetThreads = Threads L.ListT++newtype LogicC m a = LogicC { unLogicC :: L.ListT m a }+ deriving ( Functor, Applicative, Monad+ , MonadFail, MonadIO, MonadBase b+ , MonadThrow, MonadCatch+ )+ deriving MonadTrans+++instance ( Carrier m+ , Threads L.ListT (Prims m)+ ) => Carrier (LogicC m) where+ type Derivs (LogicC m) = Split ': Cull ': Cut ': NonDet ': Derivs m+ type Prims (LogicC m) = Split ': Regional CullOrCall ': Prims m++ algPrims = powerAlg (coerce (algPrims @(CullCutC m))) $ \case+ Split cn (m :: LogicC m a) -> fmap cn (coerce (L.split @m @a) m)+ {-# INLINE algPrims #-}++ reformulate = addPrim $ coerceReform $ reformulate @(CullCutC m)+ {-# INLINE reformulate #-}++data CullOrCall+ = DoCull+ | DoCall++newtype CullCutC m a = CullCutC { unCullCutC :: L.ListT m a }+ deriving ( Functor, Applicative, Monad+ , MonadFail, MonadIO, MonadBase b+ , MonadThrow, MonadCatch+ )+ deriving MonadTrans++instance ( Carrier m+ , Threads L.ListT (Prims m)+ ) => Carrier (CullCutC m) where+ type Derivs (CullCutC m) = Cull ': Cut ': NonDet ': Derivs m+ type Prims (CullCutC m) = Regional CullOrCall ': Prims m++ algPrims =+ powerAlg (+ coerce (algPrims @(NonDetC m))+ ) $ \case+ Regionally DoCull m -> coerceTrans (L.cull @m) m+ Regionally DoCall m -> coerceTrans (L.call @m) m+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg (+ powerAlg (+ coerceReform (reformulate @(NonDetC m)) n (weakenAlg alg)+ ) $ \case+ Cutfail -> n (CullCutC L.cutfail)+ Call m -> (alg . inj) $ Regionally DoCall m+ ) $ \case+ Cull m -> (alg . inj) $ Regionally DoCull m+ {-# INLINEABLE reformulate #-}++newtype NonDetC m a = NonDetC { unNonDetC :: L.ListT m a }+ deriving ( Functor, Applicative, Monad+ , MonadFail, MonadIO, MonadBase b+ , MonadThrow, MonadCatch+ )+ deriving MonadTrans++instance ( Carrier m+ , Threads L.ListT (Prims m)+ ) => Carrier (NonDetC m) where+ type Derivs (NonDetC m) = NonDet ': Derivs m+ type Prims (NonDetC m) = Prims m++ algPrims = coerce (thread @L.ListT (algPrims @m))+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg+ (liftReform reformulate n alg)+ $ \case+ FromList l -> n $ NonDetC $ L.ListT $ \_ c b _ -> foldr c b l+ {-# INLINEABLE reformulate #-}+++-- | Runs a 'NonDet' effect.+--+-- Unlike 'runLogic' and 'runCullCut', this doesn't provide any means of interacting+-- with created branches through 'Split', 'Cull' or 'Cut'.+--+-- However, it also doesn't impose any primitive effects, meaning 'runNonDet' doesn't+-- restrict what interpreters are run before it.+--+-- @'Derivs' ('NonDetC' m) = 'NonDet' ': 'Derivs' m@+--+-- @'Prims' ('NonDetC' m) = 'Prims' m@+runNonDet :: forall f m a p+ . ( Alternative f+ , Carrier m+ , Threaders '[NonDetThreads] m p+ )+ => NonDetC m a+ -> m (f a)+runNonDet = L.runListT .# unNonDetC+{-# INLINE runNonDet #-}+++-- | Runs a 'NonDet' effect, but stop once the first valid result is found.+--+-- This is like 'runNonDet' with the 'Alternative' specialized to 'Maybe',+-- but once a valid result is found, it won't run all other branches.+--+-- This is the equivalent of+-- @'runCullCut' \@Maybe . 'Control.Effect.NonDet.cull'@+-- or @'runLogic' \@Maybe . 'Control.Effect.NonDet.cull'@, but doesn't impose+-- any primitive effects, meaning 'runNonDet1' doesn't restrict what interpreters+-- are run before it.+--+-- @'Derivs' ('NonDetC' m) = 'NonDet' ': 'Derivs' m@+--+-- @'Prims' ('NonDetC' m) = 'Prims' m@+runNonDet1 :: forall m a p+ . ( Carrier m+ , Threaders '[NonDetThreads] m p+ )+ => NonDetC m a+ -> m (Maybe a)+runNonDet1 m =+ L.unListT (unNonDetC m)+ (>>=)+ (\a _ -> pure (Just a))+ (pure Nothing)+ (pure Nothing)+{-# INLINE runNonDet1 #-}++-- | Runs connected 'NonDet', 'Cull', and 'Cut' effects.+--+-- Unlike 'runLogic', this doesn't provide the full power of 'Split'.+-- This allows for a larger variety of interpreters to be run before+-- 'runCullCut' compared to 'runLogic', since 'Split' is significantly harder to+-- thread compared to 'Cull' and 'Cut'.+--+-- @'Derivs' ('CullCutC' m) = 'Cull' ': 'Cut' ': 'NonDet' ': 'Derivs' m@+--+-- @'Prims' ('CullCutC' m) = 'Regional' CullOrCall ': 'Prims' m@+runCullCut :: forall f m a p+ . ( Alternative f+ , Carrier m+ , Threaders '[NonDetThreads] m p+ )+ => CullCutC m a+ -> m (f a)+runCullCut = L.runListT .# unCullCutC++-- | Runs connected 'NonDet', 'Cull', 'Cut', and 'Split' effects+-- -- i.e. 'Control.Effect.NonDet.Logic'.+--+-- @'Derivs' ('LogicC' m) = 'Split' ': 'Cull' ': 'Cut' ': 'NonDet' ': 'Derivs' m@+--+-- @'Prims' ('LogicC' m) = 'Split' ': 'Regional' CullOrCall ': 'Prims' m@+--+-- 'Split' is a very restrictive primitive effect. Most notably,+-- interpreters for effects with failure -- such as+-- 'Control.Effect.Error.runError' -- can't be used before 'runLogic'.+-- If you want to use such interpreters before 'runLogic',+-- consider using 'runCullCut' or 'runNonDet' instead.+runLogic :: forall f m a p+ . ( Alternative f+ , Carrier m+ , Threaders '[NonDetThreads] m p+ )+ => LogicC m a+ -> m (f a)+runLogic = L.runListT .# unLogicC
+ src/Control/Effect/Internal/Optional.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveFunctor, DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.Optional where++import Control.Monad+import Control.Monad.Trans.Control+import Control.Monad.Trans.Identity++import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Carrier.Internal.Interpret++import Control.Effect.Type.Optional+++newtype HoistOptionCall b a = HoistOptionCall (forall x. (a -> x) -> b x -> b x)+ deriving (Functor)++-- | A useful specialization of 'Optional' where the functor is+-- @'HoistOptionCall' b@. From this, you can derive+-- 'Control.Effect.Optional.hoistOption'.+type HoistOption (b :: * -> *) = Optional (HoistOptionCall b)++data HoistOptionH++instance Carrier m => PrimHandler HoistOptionH (HoistOption m) m where+ effPrimHandler (Optionally (HoistOptionCall b) m) = b id m+ {-# INLINEABLE effPrimHandler #-}++newtype HoistOptionC m a = HoistOptionC {+ unHoistOptionC :: m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++deriving via InterpretPrimC HoistOptionH (HoistOption m) m+ instance Carrier m => Carrier (HoistOptionC m)
+ src/Control/Effect/Internal/Reader.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Internal.Reader where + +import Data.Coerce + +import Control.Effect +import Control.Effect.Carrier + +import Control.Effect.Type.ReaderPrim + +import Control.Monad.Trans.Reader (ReaderT(..)) +import qualified Control.Monad.Trans.Reader as R + +-- | An effect for gaining access to information. +data Ask i m a where + Ask :: Ask i m i + +-- | An effect for locally modifying an environment +-- used to gain access to information. +data Local i m a where + Local :: (i -> i) -> m a -> Local i m a + +-- | A pseudo-effect for connected @'Ask' i@ and @'Local' i@ effects. +-- +-- @'Reader'@ should only ever be used inside of 'Eff' and 'Effs' +-- constraints. It is not a real effect! See 'Bundle'. +type Reader i = Bundle [Local i, Ask i] + +newtype ReaderC i m a = ReaderC { + unReaderC :: ReaderT i m a + } + deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + +instance ( Threads (ReaderT i) (Prims m) + , Carrier m + ) + => Carrier (ReaderC i m) where + type Derivs (ReaderC i m) = Local i ': Ask i ': Derivs m + type Prims (ReaderC i m) = ReaderPrim i ': Prims m + algPrims = powerAlg (coerce (thread @(ReaderT i) (algPrims @m))) $ \case + ReaderPrimAsk -> ReaderC R.ask + ReaderPrimLocal f (ReaderC m) -> ReaderC (R.local f m) + {-# INLINEABLE algPrims #-} + + reformulate n alg = + powerAlg ( + powerAlg ( + reformulate (n . lift) (weakenAlg alg) + ) $ \case + Ask -> n (ReaderC R.ask) + ) $ \case + Local f m -> (alg . inj) $ ReaderPrimLocal f m + {-# INLINEABLE reformulate #-}
+ src/Control/Effect/Internal/Reflection.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies #-} +module Control.Effect.Internal.Reflection + ( Reifies (..) + , Tagged(..) + , unproxy + , reify + , reifyTagged + ) where + +import Unsafe.Coerce +import Data.Proxy + +newtype Tagged s a = Tagged { getTagged :: a } + +unproxy :: (Proxy s -> a) -> Tagged s a +unproxy f = Tagged (f Proxy) +{-# INLINE unproxy #-} + +class Reifies s a | s -> a where + reflect :: a + +data Skolem + +newtype Magic a r = Magic (Reifies Skolem a => Tagged Skolem r) + + +reifyTagged :: forall a r. a -> (forall (s :: *). Reifies s a => Tagged s r) -> r +reifyTagged a k = unsafeCoerce (Magic k :: Magic a r) a +{-# INLINE reifyTagged #-} + +reify :: forall a r. a -> (forall (s :: *) pr. (pr ~ Proxy, Reifies s a) => pr s -> r) -> r +reify a k = reifyTagged a (unproxy k) +{-# INLINE reify #-}
+ src/Control/Effect/Internal/Regional.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.Regional where++import Control.Effect+import Control.Effect.Carrier++import Control.Effect.Type.Regional++import Control.Effect.Carrier.Internal.Interpret++import Control.Monad.Trans.Control+import Control.Monad.Trans.Identity++newtype HoistCall b = HoistCall (forall x. b x -> b x)++-- | A useful specialization of 'Regional' where the+-- constant type is @'HoistCall' b@. From this,+-- you can derive 'Control.Effect.Regional.hoist'.+type Hoist (b :: * -> *) = Regional (HoistCall b)++data HoistH++instance Carrier m => PrimHandler HoistH (Hoist m) m where+ effPrimHandler (Regionally (HoistCall b) m) = b m+ {-# INLINEABLE effPrimHandler #-}++data HoistToFinalH++newtype HoistC m a = HoistC {+ unHoistC :: m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++deriving via InterpretPrimC HoistH (Hoist m) m+ instance Carrier m => Carrier (HoistC m)++instance ( Carrier m+ , MonadBaseControl b m+ )+ => PrimHandler HoistToFinalH (Hoist b) m where+ effPrimHandler (Regionally (HoistCall b) m) = control $ \lower -> b (lower m)+ {-# INLINEABLE effPrimHandler #-}
+ src/Control/Effect/Internal/State.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.State where++import Data.Coerce++import Control.Effect+import Control.Effect.Carrier++import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.State.Lazy as LSt++-- | An effect for __non-atomic__ stateful operations.+--+-- If you need atomicity, use 'Control.Effect.AtomicState.AtomicState'+-- instead.+data State s m a where+ Get :: State s m s+ Put :: s -> State s m ()++newtype StateC s m a = StateC { unStateC :: SSt.StateT s m a }+ deriving ( Functor, Applicative, Monad+ , MonadFix, Alternative, MonadPlus+ , MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl)++instance ( Carrier m+ , Threads (SSt.StateT s) (Prims m)+ )+ => Carrier (StateC s m) where+ type Derivs (StateC s m) = State s ': Derivs m+ type Prims (StateC s m) = Prims m++ algPrims = coerce (thread @(SSt.StateT s) (algPrims @m))+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case+ Put s -> n $ StateC $ SSt.put s+ Get -> n (StateC SSt.get)+ {-# INLINEABLE reformulate #-}++newtype StateLazyC s m a = StateLazyC { unStateLazyC :: LSt.StateT s m a }+ deriving ( Functor, Applicative, Monad+ , MonadFix, Alternative, MonadPlus+ , MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl)++instance ( Carrier m+ , Threads (LSt.StateT s) (Prims m)+ )+ => Carrier (StateLazyC s m) where+ type Derivs (StateLazyC s m) = State s ': Derivs m+ type Prims (StateLazyC s m) = Prims m++ algPrims = coerce (thread @(LSt.StateT s) (algPrims @m))+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case+ Put s -> n $ StateLazyC $ LSt.put s+ Get -> n (StateLazyC LSt.get)+ {-# INLINEABLE reformulate #-}++-- | 'StateLazyThreads' accepts the following primitive effects:+--+-- * 'Control.Effect.Regional.Regional' @s@+-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)+-- * 'Control.Effect.BaseControl.BaseControl' @b@+-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.WriterPrim.WriterPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@+-- * 'Control.Effect.Mask.Mask'+-- * 'Control.Effect.Bracket.Bracket'+-- * 'Control.Effect.Fix.Fix'+-- * 'Control.Effect.NonDet.Split'+class ( forall s. Threads (LSt.StateT s) p+ ) => StateLazyThreads p+instance ( forall s. Threads (LSt.StateT s) p+ ) => StateLazyThreads p++-- | 'StateThreads' accepts the following primitive effects:+--+-- * 'Control.Effect.Regional.Regional' @s@+-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)+-- * 'Control.Effect.BaseControl.BaseControl' @b@+-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.WriterPrim.WriterPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@+-- * 'Control.Effect.Mask.Mask'+-- * 'Control.Effect.Bracket.Bracket'+-- * 'Control.Effect.Fix.Fix'+-- * 'Control.Effect.NonDet.Split'+class ( forall s. Threads (SSt.StateT s) p+ ) => StateThreads p+instance ( forall s. Threads (SSt.StateT s) p+ ) => StateThreads p
+ src/Control/Effect/Internal/Union.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.Union where++import Data.Coerce+import Data.Kind (Constraint)++import Control.Monad.Trans+import Control.Monad.Trans.Reader (ReaderT)++import Control.Effect.Internal.Membership+import Control.Effect.Internal.Utils++-- | The kind of effects.+--+-- Helpful for defining new effects:+--+-- @+-- data InOut i o :: Effect where+-- Input :: InOut i o m i+-- Output :: o -> InOut i o m ()+-- @+--+type Effect = (* -> *) -> * -> *++-- | An effect for collecting multiple effects into one effect.+--+-- Behind the scenes, 'Union' is the most important effect+-- in the entire library, as the 'Control.Effect.Carrier' class is built+-- around handling 'Union's of effects.+--+-- However, even outside of defining novel 'Control.Effect.Carrier' instances,+-- 'Union' can be useful as an effect in its own right.+-- 'Union' is useful for effect newtypes -- effects defined through creating a+-- newtype over an existing effect.+-- By making a newtype of 'Union', it's possible to wrap multiple effects in one+-- newtype.+--+-- Not to be confused with 'Control.Effect.Bundle'.+-- Unlike 'Control.Effect.Bundle', 'Union' is a proper effect that is given no+-- special treatment by 'Control.Effect.Eff' or 'Control.Effect.Effs'.+data Union (r :: [Effect]) m a where+ Union :: Coercible z m => ElemOf e r -> e z a -> Union r m a++-- | An @'Algebra' r m@ desribes a collection of effect handlers for @m@ over+-- all effects in the list @r@.+type Algebra r m = forall x. Union r m x -> m x++-- | A first-rank type which can often be used instead of 'Algebra'+type Algebra' r m a = Union r m a -> m a++-- | 'RepresentationalEff' is the constraint every effect is expected+-- to satisfy: namely, that any effect @e m a@ is representational in @m@,+-- which -- in practice -- means that no constraints are ever placed upon+-- @m@ within the definion of @e@.+--+-- You don't need to make instances of 'RepresentationalEff'; the compiler+-- will automatically infer if your effect satisfies it.+--+-- 'RepresentationalEff' is not a very serious requirement, and+-- even effects that don't satisfy it can typically be rewritten into+-- equally powerful variants that do.+--+-- If you ever encounter that an effect you've written doesn't satisfy+-- 'RepresentationalEff', please consult+-- [the wiki](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-topics#making-effects-representationaleff).+class ( forall m n x. Coercible m n => Coercible (e m x) (e n x) )+ => RepresentationalEff (e :: Effect)+instance ( forall m n x. Coercible m n => Coercible (e m x) (e n x) )+ => RepresentationalEff (e :: Effect)+++decomp :: RepresentationalEff e+ => Union (e ': r) m a+ -> Either (Union r m a) (e m a)+decomp (Union Here e) = Right (coerce e)+decomp (Union (There pr) e) = Left (Union pr e)+{-# INLINE decomp #-}++-- | Extract the only effect of an 'Union'.+extract :: RepresentationalEff e+ => Union '[e] m a+ -> e m a+extract (Union Here e) = coerce e+extract (Union (There pr) _) = absurdMember pr+{-# INLINE extract #-}++weaken :: Union r m a -> Union (e ': r) m a+weaken (Union pr e) = Union (There pr) e+{-# INLINE weaken #-}++absurdU :: Union '[] m a -> b+absurdU (Union pr _) = case pr of {}+{-# INLINE absurdU #-}+++-- | Weaken an 'Algebra' by removing the topmost effect.+weakenAlg :: Algebra' (e ': r) m a -> Algebra' r m a+weakenAlg alg u = alg (weaken u)+{-# INLINE weakenAlg #-}++-- | Strengthen an 'Algebra' by providing a handler for a new effect @e@.+powerAlg :: forall e r m a+ . RepresentationalEff e+ => Algebra' r m a+ -> (e m a -> m a)+ -> Algebra' (e ': r) m a+powerAlg alg h = powerAlg' alg (h .# coerce)+{-# INLINE powerAlg #-}++powerAlg' :: forall e r m a+ . Algebra' r m a+ -> (forall z. Coercible z m => e z a -> m a)+ -> Algebra' (e ': r) m a+powerAlg' _ h (Union Here e) = h e+powerAlg' alg _ (Union (There pr) e) = alg (Union pr e)+{-# INLINEABLE powerAlg' #-}+++-- | Add a primitive effect and corresponding derived effect to a 'Reformulation'.+addPrim :: forall e r p m z a+ . Monad z+ => Reformulation' r p m z a+ -> Reformulation' (e ': r) (e ': p) m z a+addPrim reform n alg = powerAlg' (reform n (weakenAlg alg)) (alg . Union Here)+{-# INLINE addPrim #-}++-- | Lift an @m@-based 'Reformulation' to a @t m@-based 'Reformulation',+-- where @t@ is any 'MonadTrans'+liftReform+ :: (MonadTrans t, Monad m)+ => Reformulation' r p m z a+ -> Reformulation' r p (t m) z a+liftReform reform = \n -> reform (n . lift)+{-# INLINE liftReform #-}++coerceReform :: Coercible m n+ => Reformulation' r p m z a+ -> Reformulation' r p n z a+coerceReform reform n alg = coerce (reform (n .# coerce) alg)+{-# INLINE coerceReform #-}++-- | Weaken a 'Reformulation' by removing the topmost+-- derived effect.+weakenReform :: Reformulation' (e ': r) p m z a+ -> Reformulation' r p m z a+weakenReform reform n alg = weakenAlg (reform n alg)+{-# INLINE weakenReform #-}++-- | A /less/ higher-rank variant of 'Reformulation', which is sometimes+-- important.+type Reformulation' r p m z a+ = (forall x. m x -> z x)+ -> Algebra p z+ -> Algebra' r z a++-- | The type of 'Control.Effect.Carrier.reformulate'.+--+-- A @'Reformulation' r p m@ describes how the derived effects @r@ are+-- formulated in terms of the primitive effects @p@ and first-order operations+-- of @m@.+-- This is done by providing an @'Algebra' r z@ for any monad @z@ that lifts+-- @m@ and implements an 'Algebra' over @p@.+type Reformulation r p m+ = forall z+ . Monad z+ => (forall x. m x -> z x)+ -> Algebra p z+ -> Algebra r z++-- | An instance of 'ThreadsEff' represents the ability for a monad transformer+-- @t@ to thread a primitive effect @e@ -- i.e. lift handlers of that effect.+--+-- Instances of 'ThreadsEff' are accumulated into entire stacks of primitive+-- effects by 'Threads'.+--+-- You only need to make 'ThreadsEff' instances for monad transformers that+-- aren't simply newtypes over existing monad transformers. You also don't need+-- to make them for 'Control.Monad.Trans.Identity.IdentityT'.+class RepresentationalEff e => ThreadsEff t e where+ threadEff :: Monad m+ => (forall x. e m x -> m x)+ -> e (t m) a+ -> t m a++-- | @'Threads' t p@ is satisfied if @ThreadsEff t e@ instances are defined for+-- each effect @e@ in @p@. By using the @'Threads' t p@ constraint, you're+-- able to lift 'Algebra's over p from any monad @m@ to @t m@. This is useful+-- when defining custom 'Control.Effect.Carrier.Carrier' instances.+--+-- Note that you /should not/ place a @'Threads' t p@ constraint if @t@ is+-- simply a newtype over an existsing monad transformer @u@ that already has+-- 'ThreadsEff' instances defined for it. Instead, you should place a+-- @'Threads' u p@ constraint, and use its 'thread' by coercing the resulting+-- algebra from @'Algebra' p (u m)@ to @'Algebra' p (t m)@'.+-- That way, you avoid having to define redundant 'ThreadsEff' instances for+-- every newtype of a monad transformer.+--+-- 'Threads' forms the basis of /threading constraints/+-- (see 'Control.Effect.Threaders'), and every threading constraint offered+-- in the library makes use of 'Threads' in one way or another.+class Threads t p where+ thread :: Monad m+ => Algebra p m+ -> Algebra p (t m)++instance Threads t '[] where+ thread _ = absurdU+ {-# INLINE thread #-}++instance (ThreadsEff t e, Threads t p) => Threads t (e ': p) where+ thread alg = powerAlg (thread (weakenAlg alg)) (threadEff (alg . Union Here))+ {-# INLINEABLE thread #-}++-- | Inject an effect into a 'Union' containing that effect.+inj :: Member e r => e m a -> Union r m a+inj = Union membership+{-# INLINE inj #-}++-- | The most common threading constraint of the library, as it is emitted by+-- @-Simple@ interpreters (interpreters that internally make use of+-- 'Control.Effect.interpretSimple' or 'Control.Effect.reinterpretSimple').+--+-- 'ReaderThreads' accepts all the primitive effects+-- (intended to be used as such) offered in this library.+--+-- Most notably, 'ReaderThreads' accepts @'Control.Effect.Unlift.Unlift' b@.+class (forall i. Threads (ReaderT i) p) => ReaderThreads p+instance (forall i. Threads (ReaderT i) p) => ReaderThreads p++coerceEff :: forall n m e a+ . (Coercible n m, RepresentationalEff e)+ => e m a+ -> e n a+coerceEff = coerce+{-# INLINE coerceEff #-}++coerceAlg :: forall n m e a b+ . (Coercible n m, RepresentationalEff e)+ => (e m a -> m b)+ -> e n a -> n b+coerceAlg = coerce+{-# INLINE coerceAlg #-}++-- | A pseudo-effect given special treatment by 'Control.Effect.Eff'+-- and 'Control.Effect.Effs'.+--+-- An @'Control.Effect.Eff'/s@ constraint on+-- @'Bundle' '[eff1, eff2, ... , effn]@+-- will expand it into membership constraints for @eff1@ through @effn@.+-- For example:+--+-- @+-- 'Control.Effect.Error.Error' e = 'Bundle' '['Control.Effect.Error.Throw' e, 'Control.Effect.Error.Catch' e]+-- @+--+-- so+--+-- @+-- 'Control.Effect.Eff' ('Control.Effect.Error.Error' e) m = ('Control.Effect.Carrier' m, 'Control.Effect.Member' ('Control.Effect.Error.Throw' e) ('Control.Effect.Derivs' m), 'Control.Effect.Member' ('Control.Effect.Error.Catch' e) ('Control.Effect.Derivs' m))+-- @+--+-- 'Bundle' should /never/ be used in any other contexts but within+-- 'Control.Effect.Eff' and 'Control.Effect.Effs', as it isn't an actual effect.+--+-- Not to be confused with 'Control.Effect.Union.Union', which is a proper+-- effect that combines multiple effects into one.+data Bundle :: [Effect] -> Effect++type family Append l r where+ Append '[] r = r+ Append (x ': l) r = x ': (Append l r)++type family FlattenBundles (e :: [Effect]) :: [Effect] where+ FlattenBundles '[] = '[]+ FlattenBundles (Bundle bs ': es) = Append (FlattenBundles bs) (FlattenBundles es)+ FlattenBundles (e ': es) = e ': FlattenBundles es++type family Members (es :: [Effect]) (r :: [Effect]) :: Constraint where+ Members '[] r = ()+ Members (e ': es) r = (Member e r, Members es r)++type EffMembers (xs :: [Effect]) (r :: [Effect]) = Members (FlattenBundles xs) r
+ src/Control/Effect/Internal/Unlift.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Internal.Unlift where + +import Control.Effect +import Control.Effect.Carrier +import Control.Effect.Carrier.Internal.Interpret + +import Control.Effect.Type.Unlift + +import Control.Monad.Trans.Identity + + +data UnliftH + +instance Carrier m + => PrimHandler UnliftH (Unlift m) m where + effPrimHandler (Unlift main) = main id + {-# INLINEABLE effPrimHandler #-} + +newtype UnliftC m a = UnliftC { + unUnliftC :: m a + } + deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + ) + deriving (MonadTrans, MonadTransControl) via IdentityT + +deriving via InterpretPrimC UnliftH (Unlift m) m + instance Carrier m => Carrier (UnliftC m)
+ src/Control/Effect/Internal/Utils.hs view
@@ -0,0 +1,21 @@+module Control.Effect.Internal.Utils where + +import Data.Coerce + +infixr 9 #. +(#.) :: Coercible c b => (b -> c) -> (a -> b) -> (a -> c) +(#.) _ = coerce +{-# INLINE (#.) #-} + +infixl 8 .# +(.#) :: Coercible b a => (b -> c) -> (a -> b) -> (a -> c) +(.#) pbc _ = coerce pbc +{-# INLINE (.#) #-} + +coerceTrans :: (Coercible m z, Coercible n y) => (m a -> n b) -> z a -> y b +coerceTrans = coerce +{-# INLINE coerceTrans #-} + +coerceM :: Coercible m n => m a -> n a +coerceM = coerce +{-# INLINE coerceM #-}
+ src/Control/Effect/Internal/ViaAlg.hs view
@@ -0,0 +1,37 @@+module Control.Effect.Internal.ViaAlg where + +import Data.Coerce +import Control.Effect.Internal.Union + +type RepresentationalT = RepresentationalEff + +newtype ViaAlg (s :: *) (e :: Effect) m a = ViaAlg { + unViaAlg :: m a + } + deriving (Functor, Applicative, Monad) + +newtype ReifiedEffAlgebra e m = ReifiedEffAlgebra (forall x. e m x -> m x) + +viaAlgT :: forall s e t m a. RepresentationalT t => t m a -> t (ViaAlg s e m) a +viaAlgT = coerce +{-# INLINE viaAlgT #-} + +unViaAlgT :: forall s e t m a. RepresentationalT t => t (ViaAlg s e m) a -> t m a +unViaAlgT = coerce +{-# INLINE unViaAlgT #-} + +mapViaAlgT :: forall s e t m n a b + . RepresentationalT t + => (t m a -> t n b) + -> t (ViaAlg s e m) a + -> t (ViaAlg s e n) b +mapViaAlgT = coerce +{-# INLINE mapViaAlgT #-} + +mapUnViaAlgT :: forall s e t m n a b + . RepresentationalT t + => (t (ViaAlg s e m) a -> t (ViaAlg s e n) b) + -> t m a + -> t n b +mapUnViaAlgT = coerce +{-# INLINE mapUnViaAlgT #-}
+ src/Control/Effect/Internal/Writer.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Internal.Writer where++import Data.Coerce+import Data.Tuple (swap)++import Control.Applicative+import Control.Monad++import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Type.ListenPrim+import Control.Effect.Type.WriterPrim++import Control.Effect.Carrier++import Control.Monad.Trans.Control hiding (embed)+import qualified Control.Monad.Catch as C++import Control.Monad.Trans.Writer.CPS (WriterT, writerT, runWriterT)+import qualified Control.Monad.Trans.Writer.CPS as W+import qualified Control.Monad.Trans.Writer.Lazy as LW++import Control.Effect.Internal.Utils++-- | An effect for arbitrary output.+data Tell s m a where+ Tell :: s -> Tell s m ()++-- | An effect for hearing what a computation+-- has to 'Control.Effect.Writer.tell'.+data Listen s m a where+ Listen :: m a -> Listen s m (s, a)++-- | An effect for altering what a computation+-- 'Control.Effect.Writer.tell's.+data Pass s m a where+ Pass :: m (s -> s, a) -> Pass s m a++newtype TellC s m a = TellC {+ unTellC :: WriterT s m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ )+ via WriterT s m+ deriving MonadTrans via (WriterT s)++instance MonadThrow m => MonadThrow (TellC s m) where+ throwM = lift . C.throwM+ {-# INLINEABLE throwM #-}++instance (Monoid s, MonadCatch m) => MonadCatch (TellC s m) where+ catch (TellC m) h = TellC $ writerT $+ runWriterT m `C.catch` (runWriterT . unTellC #. h)+ {-# INLINEABLE catch #-}++instance (Monoid s, MonadMask m) => MonadMask (TellC s m) where+ mask main = TellC $ writerT $ C.mask $ \restore ->+ runWriterT (unTellC (main (TellC #. W.mapWriterT restore .# unTellC)))+ {-# INLINEABLE mask #-}++ uninterruptibleMask main = TellC $ writerT $ C.uninterruptibleMask $ \restore ->+ runWriterT (unTellC (main (TellC #. W.mapWriterT restore .# unTellC)))+ {-# INLINEABLE uninterruptibleMask #-}++ generalBracket acquire release use =+ coerceAlg+ (threadEff @(WriterT s) @_ @m+ (\(GeneralBracket a r u) -> C.generalBracket a r u)+ )+ (GeneralBracket acquire release use)+ {-# INLINEABLE generalBracket #-}++instance MonadBase b m => MonadBase b (TellC s m) where+ liftBase = lift . liftBase+ {-# INLINEABLE liftBase #-}++instance ( MonadBaseControl b m+ , Monoid s+ )+ => MonadBaseControl b (TellC s m) where+ type StM (TellC s m) a = StM m (a, s)++ liftBaseWith = defaultLiftBaseWith+ {-# INLINEABLE liftBaseWith #-}++ restoreM = defaultRestoreM+ {-# INLINEABLE restoreM #-}++instance Monoid s => MonadTransControl (TellC s) where+ type StT (TellC s) a = (a, s)++ liftWith main = lift (main (runWriterT .# unTellC))+ {-# INLINEABLE liftWith #-}++ restoreT = TellC #. writerT+ {-# INLINEABLE restoreT #-}++instance ( Carrier m+ , Monoid s+ , Threads (WriterT s) (Prims m)+ )+ => Carrier (TellC s m) where+ type Derivs (TellC s m) = Tell s ': Derivs m+ type Prims (TellC s m) = Prims m++ algPrims = coerceAlg (thread @(WriterT s) (algPrims @m))+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case+ Tell s -> n (TellC (W.tell s))+ {-# INLINEABLE reformulate #-}+++newtype ListenC s m a = ListenC {+ unListenC :: WriterT s m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ via TellC s m+ deriving (MonadTrans, MonadTransControl) via (TellC s)++instance ( Carrier m+ , Monoid s+ , Threads (WriterT s) (Prims m)+ )+ => Carrier (ListenC s m) where+ type Derivs (ListenC s m) = Listen s ': Tell s ': Derivs m+ type Prims (ListenC s m) = ListenPrim s ': Prims m++ algPrims =+ powerAlg (+ coerce (algPrims @(TellC s m))+ ) $ \case+ ListenPrimTell s -> ListenC $ W.tell s+ ListenPrimListen (ListenC m) -> ListenC $ do+ (a, s) <- W.listen m+ return (s, a)+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg (+ coerceReform (reformulate @(TellC s m)) n (weakenAlg alg)+ ) $ \case+ Listen m -> (alg . inj) $ ListenPrimListen m+ {-# INLINEABLE reformulate #-}+++newtype WriterC s m a = WriterC {+ unWriterC :: WriterT s m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ via TellC s m+ deriving (MonadTrans, MonadTransControl) via (TellC s)++instance ( Carrier m+ , Monoid s+ , Threads (WriterT s) (Prims m)+ )+ => Carrier (WriterC s m) where+ type Derivs (WriterC s m) = Pass s ': Listen s ': Tell s ': Derivs m+ type Prims (WriterC s m) = WriterPrim s ': Prims m++ algPrims =+ algListenPrimIntoWriterPrim (+ coerce (algPrims @(ListenC s m))+ ) $ \(WriterC m) -> WriterC $ W.pass $ do+ (f, a) <- m+ return (a, f)+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg (+ powerAlg (+ coerceReform (reformulate @(TellC s m)) n (weakenAlg alg)+ ) $ \case+ Listen m -> (alg . inj) $ WriterPrimListen m+ ) $ \case+ Pass m -> (alg . inj) $ WriterPrimPass m+ {-# INLINEABLE reformulate #-}+++newtype TellLazyC s m a = TellLazyC {+ unTellLazyC :: LW.WriterT s m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadThrow, MonadCatch, MonadMask+ , MonadFix, MonadFail, MonadIO+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl)++instance ( Monoid s+ , Carrier m+ , Threads (LW.WriterT s) (Prims m)+ )+ => Carrier (TellLazyC s m) where+ type Derivs (TellLazyC s m) = Tell s ': Derivs m+ type Prims (TellLazyC s m) = Prims m++ algPrims = coerce (thread @(LW.WriterT s) (algPrims @m))+ {-# INLINEABLE algPrims #-}++ reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case+ Tell s -> n $ TellLazyC $ LW.tell s+ {-# INLINEABLE reformulate #-}++newtype ListenLazyC s m a = ListenLazyC {+ unListenLazyC :: LW.WriterT s m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadThrow, MonadCatch, MonadMask+ , MonadFix, MonadFail, MonadIO+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl)++instance ( Monoid s+ , Carrier m+ , Threads (LW.WriterT s) (Prims m)+ )+ => Carrier (ListenLazyC s m) where+ type Derivs (ListenLazyC s m) = Listen s ': Tell s ': Derivs m+ type Prims (ListenLazyC s m) = ListenPrim s ': Prims m++ algPrims =+ powerAlg (+ coerce (algPrims @(TellLazyC s m))+ ) $ \case+ ListenPrimTell w ->+ ListenLazyC $ LW.tell w+ ListenPrimListen (ListenLazyC m) ->+ ListenLazyC $ swap <$> LW.listen m+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg (+ coerceReform (reformulate @(TellLazyC s m)) n (weakenAlg alg)+ ) $ \case+ Listen m -> (alg . inj) $ ListenPrimListen m+ {-# INLINEABLE reformulate #-}++newtype WriterLazyC s m a = WriterLazyC {+ _unWriterLazyC :: LW.WriterT s m a+ }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadThrow, MonadCatch, MonadMask+ , MonadFix, MonadFail, MonadIO+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl)++instance ( Monoid s+ , Carrier m+ , Threads (LW.WriterT s) (Prims m)+ )+ => Carrier (WriterLazyC s m) where+ type Derivs (WriterLazyC s m) = Pass s ': Listen s ': Tell s ': Derivs m+ type Prims (WriterLazyC s m) = WriterPrim s ': Prims m++ algPrims =+ algListenPrimIntoWriterPrim (+ coerce (algPrims @(ListenLazyC s m))+ ) $ \(WriterLazyC m) -> WriterLazyC $ LW.pass (swap <$> m)+ {-# INLINEABLE algPrims #-}++ reformulate n alg =+ powerAlg (+ powerAlg (+ coerceReform (reformulate @(TellLazyC s m)) n (weakenAlg alg)+ ) $ \case+ Listen m -> (alg . inj) $ WriterPrimListen m+ ) $ \case+ Pass m -> (alg . inj) $ WriterPrimPass m+ {-# INLINEABLE reformulate #-}++-- | 'WriterThreads' accepts the following primitive effects:+--+-- * 'Control.Effect.Regional.Regional' @s@+-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)+-- * 'Control.Effect.BaseControl.BaseControl' @b@+-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.WriterPrim.WriterPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@+-- * 'Control.Effect.Mask.Mask'+-- * 'Control.Effect.Bracket.Bracket'+-- * 'Control.Effect.Fix.Fix'+-- * 'Control.Effect.NonDet.Split'+class ( forall s. Monoid s => Threads (WriterT s) p+ ) => WriterThreads p+instance ( forall s. Monoid s => Threads (WriterT s) p+ ) => WriterThreads p++-- | 'WriterLazyThreads' accepts the following primitive effects:+--+-- * 'Control.Effect.Regional.Regional' @s@+-- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor)+-- * 'Control.Effect.BaseControl.BaseControl' @b@+-- * 'Control.Effect.Type.ListenPrim.ListenPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.WriterPrim.WriterPrim' @s@ (when @s@ is a 'Monoid')+-- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@+-- * 'Control.Effect.Mask.Mask'+-- * 'Control.Effect.Bracket.Bracket'+-- * 'Control.Effect.Fix.Fix'+-- * 'Control.Effect.NonDet.Split'+class ( forall s. Monoid s => Threads (LW.WriterT s) p+ ) => WriterLazyThreads p+instance ( forall s. Monoid s => Threads (LW.WriterT s) p+ ) => WriterLazyThreads p
+ src/Control/Effect/Mask.hs view
@@ -0,0 +1,96 @@+module Control.Effect.Mask+ ( -- * Effects+ Mask(..)+ , MaskMode(..)++ -- * Actions+ , mask+ , mask_+ , uninterruptibleMask+ , uninterruptibleMask_++ -- * Interpretations+ , maskToIO++ , ignoreMask++ -- * Threading utilities+ , threadMaskViaClass++ -- * MonadMask+ , C.MonadMask++ -- * Carriers+ , MaskToIOC+ , IgnoreMaskC+ ) where++import Control.Effect+import Control.Effect.Primitive+import Control.Effect.Type.Mask++import Control.Monad.Catch (MonadMask)+import qualified Control.Monad.Catch as C++mask :: Eff Mask m => ((forall x. m x -> m x) -> m a) -> m a+mask main = send (Mask InterruptibleMask main)+{-# INLINE mask #-}++mask_ :: Eff Mask m => m a -> m a+mask_ main = mask $ \_ -> main+{-# INLINE mask_ #-}++uninterruptibleMask :: Eff Mask m => ((forall x. m x -> m x) -> m a) -> m a+uninterruptibleMask main = send (Mask UninterruptibleMask main)+{-# INLINE uninterruptibleMask #-}++uninterruptibleMask_ :: Eff Mask m => m a -> m a+uninterruptibleMask_ main = uninterruptibleMask $ \_ -> main+{-# INLINE uninterruptibleMask_ #-}++data MaskToIOH++instance ( Carrier m+ , MonadMask m+ )+ => PrimHandler MaskToIOH Mask m where+ effPrimHandler (Mask InterruptibleMask main) = C.mask main+ effPrimHandler (Mask UninterruptibleMask main) = C.uninterruptibleMask main+ {-# INLINEABLE effPrimHandler #-}++type MaskToIOC = InterpretPrimC MaskToIOH Mask++-- | Run a 'Mask' effect by making use of the 'IO'-based 'Control.Exception.mask' and+-- 'Control.Exception.uninterruptibleMask'.+--+-- @'Derivs' ('MaskToIOC' m) = 'Mask' ': 'Derivs' m@+--+-- @'Prims' ('MaskToIOC' m) = 'Mask' ': 'Prims' m@+maskToIO :: ( Carrier m+ , MonadMask m+ )+ => MaskToIOC m a+ -> m a+maskToIO = interpretPrimViaHandler+{-# INLINE maskToIO #-}++data IgnoreMaskH++instance Carrier m+ => Handler IgnoreMaskH Mask m where+ effHandler (Mask _ main) = main id+ {-# INLINEABLE effHandler #-}++type IgnoreMaskC = InterpretC IgnoreMaskH Mask++-- | Run a 'Mask' effect by ignoring it, providing no protection+-- against asynchronous exceptions.+--+-- @'Derivs' ('IgnoreMaskC' m) = 'Mask' ': 'Derivs' m@+--+-- @'Prims' ('IgnoreMaskC' m) = 'Prims' m@+ignoreMask :: Carrier m+ => IgnoreMaskC m a+ -> m a+ignoreMask = interpretViaHandler+{-# INLINE ignoreMask #-}
+ src/Control/Effect/Newtype.hs view
@@ -0,0 +1,19 @@+module Control.Effect.Newtype + ( -- * Wrapping + wrapWith + + -- * Unwrapping + , EffNewtype(..) + , WrapperOf + + , unwrap + + , unwrapTop + + -- * Carriers + , WrapC + , UnwrapC + , UnwrapTopC + ) where + +import Control.Effect.Internal.Newtype
+ src/Control/Effect/NonDet.hs view
@@ -0,0 +1,106 @@+module Control.Effect.NonDet+ ( -- * Effects+ NonDet(..)+ , Cull(..)+ , Cut(..)+ , Split(..)+ , Logic++ -- * Actions+ , choose+ , lose+ , fromList++ , cull++ , cutfail+ , cut+ , call++ , split++ -- * Interpretations+ , runNonDet+ , runNonDet1++ , runCullCut++ , runLogic++ -- * Threading constraints+ , NonDetThreads++ -- * Carriers+ , NonDetC+ , CullCutC+ , LogicC+ ) where++import Control.Monad++import Control.Effect+import Control.Effect.Internal.NonDet+import Control.Effect.Internal.Utils++import Control.Effect.Type.Split++-- | Introduce new branches stemming from the current one using a list of values.+fromList :: Eff NonDet m => [a] -> m a+fromList = send .# FromList++-- | Introduce two new branches stemming from the current one.+choose :: Eff NonDet m => m a -> m a -> m a+choose ma mb = join $ fromList [ma, mb]+{-# INLINE choose #-}++-- | Fail the current branch and proceed to the next branch,+-- backtracking to the nearest use of 'choose'/'fromList' that+-- still has unprocessed branches.+lose :: Eff NonDet m => m a+lose = fromList []+{-# INLINE lose #-}++-- | Cull nondeterminism in the argument, limiting the number of branches+-- it may introduce to be at most 1.+--+-- @'cull' (return True `'choose'` return False) == return True@+--+-- @'cull' ('lose' `'choose'` return False) == return False@+cull :: Eff Cull m => m a -> m a+cull = send .# Cull+{-# INLINE cull #-}++-- | Fail the current branch, and prevent backtracking up until the nearest+-- enclosing use of 'call' (if any).+--+-- @'cutfail' `'choose'` m == 'cutfail'@+cutfail :: Eff Cut m => m a+cutfail = send Cutfail+{-# INLINE cutfail #-}++-- | Commit to the current branch: prevent all backtracking that would move+-- execution to before 'cut' was invoked, up until the nearest enclosing use+-- of 'call' (if any).+--+-- @'call' ('fromList' [1,2] >>= \\a -> 'cut' >> fromList [a,a+3]) == 'fromList' [1,4]@+--+-- @ call (('cut' >> return True) `choose` return False) == return True@+cut :: Effs '[NonDet, Cut] m => m ()+cut = pure () `choose` cutfail+{-# INLINE cut #-}++-- | Delimit the prevention of backtracking from uses of 'cut' and 'cutfail'.+--+-- @'call' 'cutfail' `'choose'` m = m@+call :: Eff Cut m => m a -> m a+call = send . Call+{-# INLINE call #-}++-- | Split a nondeterministic computation into its first result+-- and the rest of the computation, if possible.+--+-- Note that @'split' 'cutfail' == 'cutfail'@. If you don't want that behavior,+-- use @'split' ('call' m)@ instead of @'split' m@.+split :: Eff Split m => m a -> m (Maybe (a, m a))+split = send . Split id+{-# INLINE split #-}
+ src/Control/Effect/Optional.hs view
@@ -0,0 +1,113 @@+module Control.Effect.Optional+ ( -- * Effects+ Optional(..)+ , HoistOption+ , HoistOptionCall(..)++ -- * Actions+ , optionally+ , hoistOption++ -- * Interpretations+ , runHoistOption++ , hoistOptionToFinal++ -- * Threading utilities+ , threadOptionalViaBaseControl++ -- * Combinators for 'Algebra's+ -- Intended to be used for custom 'Carrier' instances when+ -- defining 'algPrims'.+ , powerAlgHoistOption+ , powerAlgHoistOptionFinal++ -- * Carriers+ , HoistOptionC+ , HoistOptionToFinalC+ ) where++import Control.Monad+import Control.Monad.Trans.Control++import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Internal.Optional++import Control.Effect.Type.Internal.BaseControl+import Control.Effect.Type.Optional+++-- | Execute the provided computation, providing the+-- interpretation of @'Optional' s@ the option to execute+-- it in full or in part.+optionally :: Eff (Optional s) m => s a -> m a -> m a+optionally s m = send (Optionally s m)+{-# INLINE optionally #-}++-- | Hoist a natural transformation of the base monad into the current+-- monad, equipped with the option to execute the provided computation+-- in full or in part.+hoistOption :: Eff (HoistOption b) m+ => (forall x. (a -> x) -> b x -> b x)+ -> m a -> m a+hoistOption n = optionally (HoistOptionCall n)+{-# INLINE hoistOption #-}++-- | Runs a @'HoistOption' m@ effect, where the base monad+-- @m@ is the current monad.+--+-- @'Derivs' ('HoistOptionC' m) = 'HoistOption' m ': 'Derivs' m@+--+-- @'Prims' ('HoistOptionC' m) = 'HoistOption' m ': 'Prims' m@+runHoistOption :: Carrier m+ => HoistOptionC m a+ -> m a+runHoistOption = unHoistOptionC+{-# INLINE runHoistOption #-}++data HoistOptionToFinalH++instance ( Carrier m+ , MonadBaseControl b m+ )+ => PrimHandler HoistOptionToFinalH (HoistOption b) m where+ effPrimHandler (Optionally (HoistOptionCall b) m) =+ join $ liftBaseWith $ \lower ->+ b pure (restoreM <$> lower m)+ {-# INLINEABLE effPrimHandler #-}++type HoistOptionToFinalC b = InterpretPrimC HoistOptionToFinalH (HoistOption b)++-- | Runs a @'HoistOption' b@ effect, where the base monad+-- @b@ is the final base monad.+--+-- @'Derivs' ('HoistOptionToFinalC' b m) = 'HoistOption' b ': 'Derivs' m@+--+-- @'Prims' ('HoistOptionToFinalC' b m) = 'HoistOption' b ': 'Prims' m@+hoistOptionToFinal :: ( MonadBaseControl b m+ , Carrier m+ )+ => HoistOptionToFinalC b m a+ -> m a+hoistOptionToFinal = interpretPrimViaHandler+{-# INLINE hoistOptionToFinal #-}++-- | Strengthen an @'Algebra' p m@ by adding a @'HoistOption' m@ handler+powerAlgHoistOption :: forall m p a+ . Algebra' p m a+ -> Algebra' (HoistOption m ': p) m a+powerAlgHoistOption alg = powerAlg alg $ \case+ Optionally (HoistOptionCall b) m -> b id m+{-# INLINE powerAlgHoistOption #-}++-- | Strengthen an @'Algebra' p m@ by adding a @'HoistOption' b@ handler, where+-- @b@ is the final base monad.+powerAlgHoistOptionFinal :: forall b m p a+ . MonadBaseControl b m+ => Algebra' p m a+ -> Algebra' (HoistOption b ': p) m a+powerAlgHoistOptionFinal alg = powerAlg alg $ \case+ Optionally (HoistOptionCall b) m -> join $ liftBaseWith $ \lower ->+ b pure (restoreM <$> lower m)+{-# INLINE powerAlgHoistOptionFinal #-}
+ src/Control/Effect/Primitive.hs view
@@ -0,0 +1,31 @@+module Control.Effect.Primitive+ ( -- * Primitive effects+ Carrier(Derivs, Prims)++ -- * Interpretation of primitive effects+ , EffPrimHandler++ -- ** 'interpretPrimSimple'+ , interpretPrimSimple++ -- ** 'interpretPrimViaHandler'+ , interpretPrimViaHandler+ , PrimHandler(..)++ -- ** 'interpretPrim'+ , interpretPrim+++ -- * Threading primitive effects+ , Threads(..)+ , ThreadsEff(..)++ -- * Carriers+ , InterpretPrimSimpleC+ , InterpretPrimC+ , InterpretPrimReifiedC+ ) where++import Control.Effect.Internal+import Control.Effect.Internal.Union+import Control.Effect.Carrier.Internal.Interpret
+ src/Control/Effect/Reader.hs view
@@ -0,0 +1,168 @@+module Control.Effect.Reader+ ( -- * Effects+ Ask(..)+ , Local(..)+ , Reader++ -- * Actions+ , ask+ , asks+ , local++ -- * Interpretations+ , runAskConst++ , runAskAction++ , askToAsk++ , runReader++ -- * Simple variants+ , runAskConstSimple+ , runAskActionSimple+ , askToAskSimple++ -- * Threading constraints+ , ReaderThreads++ -- * Carriers+ , ReaderC+ ) where++import Control.Effect++import Control.Effect.Internal.Reader++import Control.Monad.Trans.Reader (ReaderT(..))+++ask :: Eff (Ask i) m => m i+ask = send Ask+{-# INLINE ask #-}++asks :: Eff (Ask i) m => (i -> a) -> m a+asks = (<$> ask)+{-# INLINE asks #-}++local :: Eff (Local i) m => (i -> i) -> m a -> m a+local f m = send (Local f m)+{-# INLINE local #-}+++-- | Run connected @'Ask' i@ and @'Local' i@ effects -- i.e. @'Reader' i@.+--+-- @'Derivs' ('ReaderC' i m) = 'Local' i ': 'Ask' i ': 'Derivs' m@+--+-- @'Control.Effect.Carrier.Prims' ('ReaderC' i m) = 'Control.Effect.Type.ReaderPrim.ReaderPrim' i ': 'Control.Effect.Carrier.Prims' m@+runReader :: forall i m a p+ . ( Carrier m+ , Threaders '[ReaderThreads] m p+ )+ => i+ -> ReaderC i m a+ -> m a+runReader i m = runReaderT (unReaderC m) i+{-# INLINE runReader #-}++-- | Run an 'Ask' effect by providing a constant to be given+-- at each use of 'ask'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runAskConst' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower 'runAskConstSimple',+-- which doesn't have a higher-rank type.+runAskConst :: forall i m a+ . Carrier m+ => i+ -> InterpretReifiedC (Ask i) m a+ -> m a+runAskConst i = interpret $ \case+ Ask -> return i+{-# INLINE runAskConst #-}++-- | Run an 'Ask' effect by providing an action to be executed+-- at each use of 'ask'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runAskAction' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower 'runAskActionSimple',+-- which doesn't have a higher-rank type.+runAskAction :: forall i m a+ . Carrier m+ => m i+ -> InterpretReifiedC (Ask i) m a+ -> m a+runAskAction m = interpret $ \case+ Ask -> liftBase m+{-# INLINE runAskAction #-}++-- | Transform an @'Ask' i@ effect into an @'Ask' j@ effect by+-- providing a function to convert @j@ to @i@.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'askToAsk' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower 'askToAskSimple',+-- which doesn't have a higher-rank type.+askToAsk :: forall i j m a+ . Eff (Ask j) m+ => (j -> i)+ -> InterpretReifiedC (Ask i) m a+ -> m a+askToAsk f = interpret $ \case+ Ask -> asks f+{-# INLINE askToAsk #-}++-- | Run an 'Ask' effect by providing a constant to be given+-- at each use of 'ask'+--+-- This is a less performant version of 'runAskConst' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runAskConstSimple :: forall i m a p+ . ( Carrier m+ , Threaders '[ReaderThreads] m p+ )+ => i+ -> InterpretSimpleC (Ask i) m a+ -> m a+runAskConstSimple i = interpretSimple $ \case+ Ask -> return i+{-# INLINE runAskConstSimple #-}++-- | Run an 'Ask' effect by providing an action to be executed+-- at each use of 'ask'.+--+-- This is a less performant version of 'runAskAction' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runAskActionSimple :: forall i m a p+ . ( Carrier m+ , Threaders '[ReaderThreads] m p+ )+ => m i+ -> InterpretSimpleC (Ask i) m a+ -> m a+runAskActionSimple mi = interpretSimple $ \case+ Ask -> liftBase mi+{-# INLINE runAskActionSimple #-}++-- | Transform an @'Ask' i@ effect into an @'Ask' j@ effect by+-- providing a function to convert @j@ to @i@.+--+-- This is a less performant version of 'askToAsk' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+askToAskSimple :: forall i j m a p+ . ( Eff (Ask j) m+ , Threaders '[ReaderThreads] m p+ )+ => (j -> i)+ -> InterpretSimpleC (Ask i) m a+ -> m a+askToAskSimple f = interpretSimple $ \case+ Ask -> asks f+{-# INLINE askToAskSimple #-}
+ src/Control/Effect/Regional.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DerivingVia #-}+module Control.Effect.Regional+ ( -- * Effects+ Regional(..)+ , Hoist++ -- * Actions+ , regionally+ , hoist++ -- * Interpretations+ , runHoist++ , hoistToFinal++ -- * Threading utilities+ , threadRegionalViaOptional++ -- * Combinators for 'Algebra's+ -- Intended to be used for custom 'Carrier' instances when+ -- defining 'algPrims'.+ , powerAlgHoist+ , powerAlgHoistFinal++ -- * Carriers+ , HoistC+ , HoistToFinalC+ ) where++import Control.Effect+import Control.Effect.Carrier++import Control.Effect.Type.Regional+import Control.Effect.Type.Optional+import Control.Effect.Internal.Regional++import Control.Monad.Trans.Control (control)++-- | Execute a computation modified in some way, providing+-- the interpreter of @'Regional' s@ a constant to indicate+-- how the computation should be modified.+regionally :: Eff (Regional s) m => s -> m a -> m a+regionally s m = send (Regionally s m)+{-# INLINE regionally #-}++-- | Lift a natural transformation of a base monad to the+-- current monad.+hoist :: Eff (Hoist b) m => (forall x. b x -> b x) -> m a -> m a+hoist n = regionally (HoistCall n)+{-# INLINE hoist #-}++type HoistToFinalC b = InterpretPrimC HoistToFinalH (Hoist b)++-- | Run a @'Hoist' m@ effect, where the base monad @m@ is the current monad.+--+-- @'Derivs' ('HoistC' m) = 'Hoist' m ': 'Derivs' m@+--+-- @'Prims' ('HoistC' m) = 'Hoist' m ': 'Prims' m@+runHoist :: Carrier m+ => HoistC m a+ -> m a+runHoist = unHoistC+{-# INLINE runHoist #-}++-- | Run a @'Hoist' b@ effect, where the base monad @b@ is the final base monad.+--+-- @'Derivs' ('HoistToFinalC' b m) = 'Hoist' b ': 'Derivs' m@+--+-- @'Prims' ('HoistToFinalC' b m) = 'Hoist' b ': 'Prims' m@+hoistToFinal :: ( MonadBaseControl b m+ , Carrier m+ )+ => HoistToFinalC b m a+ -> m a+hoistToFinal = interpretPrimViaHandler+{-# INLINE hoistToFinal #-}++-- | Strengthen an @'Algebra' p m@ by adding a @'Hoist' m@ handler+powerAlgHoist :: forall m p a+ . Algebra' p m a+ -> Algebra' (Hoist m ': p) m a+powerAlgHoist alg = powerAlg alg $ \(Regionally (HoistCall n) m) -> n m+{-# INLINE powerAlgHoist #-}++-- | Strengthen an @'Algebra' p m@ by adding a @'Hoist' b@ handler, where+-- @b@ is the final base monad.+powerAlgHoistFinal :: forall b m p a+ . MonadBaseControl b m+ => Algebra' p m a+ -> Algebra' (Hoist b ': p) m a+powerAlgHoistFinal alg = powerAlg alg $ \case+ Regionally (HoistCall n) m -> control $ \lower -> n (lower m)+{-# INLINE powerAlgHoistFinal #-}
+ src/Control/Effect/Select.hs view
@@ -0,0 +1,106 @@+module Control.Effect.Select+ ( -- * Effect+ Select(..)++ -- * Actions+ , select++ -- * Interpretations+ , runSelect+ , runSelectFast++ -- * Carriers+ , SelectC+ , SelectFastC+ ) where++import Control.Effect+import Control.Effect.Cont++-- | An effect for backtracking search.+data Select s m a where+ Select :: (forall r. (a -> m (s, r)) -> m r) -> Select s m a++-- | Perform a search: capture the continuation+-- of the program, so that you may test values of @a@ and observe+-- what corresponding @s@ each value would result in+-- at the end of the program (which may be seen as the evaluation of @a@).+-- When you find a satisfactory @a@, you may return the associated @r@.+--+-- The way higher-order actions interact with the continuation depends+-- on the interpretation of 'Select'. In general, you cannot expect to interact+-- with the continuation in any meaningful way: for example, you should not+-- assume that you will be able to catch an exception thrown at some point in+-- the future of the computation by using 'Control.Effect.Error.catch' on the+-- continuation.+select :: Eff (Select s) m+ => (forall r. (a -> m (s, r)) -> m r) -> m a+select main = send (Select main)+{-# INLINE select #-}++data SelectH r++instance Eff (Shift (s, r)) m+ => Handler (SelectH r) (Select s) m where+ effHandler = \case+ Select main -> shift @(s, r) $ \c ->+ main (\a -> (\(s,r) -> (s, (s, r))) <$> c a)+ >>= \t -> shift $ \_ -> return t+ {-# INLINEABLE effHandler #-}++type SelectC s r = CompositionC+ '[ ReinterpretC (SelectH r) (Select s) '[Shift (s, r)]+ , ShiftC (s, r)+ ]++type SelectFastC s r = CompositionC+ '[ ReinterpretC (SelectH r) (Select s) '[Shift (s, r)]+ , ShiftFastC (s, r)+ ]++-- | Run a @'Select' s@ effect by providing an evaluator+-- for the final result of type @a@.+--+-- @'Derivs' ('SelectC' s r m) = 'Select' s ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('SelectC' s r m) = 'Control.Effect.Primitive.Prims' m@+runSelect :: forall s a m p+ . (Carrier m, Threaders '[ContThreads] m p)+ => (a -> m s)+ -> SelectC s a m a+ -> m a+runSelect c m =+ fmap snd+ $ runShift+ $ (>>= \a -> (\s -> (s, a)) <$> lift (c a))+ $ reinterpretViaHandler+ $ runComposition+ $ m+{-# INLINE runSelect #-}++-- | Run a @'Select' s@ effect by providing an evaluator+-- for the final result of type @a@.+--+-- Compared to 'runSelect', this is quite a bit faster, but is significantly+-- more restrictive in what interpreters are used after it, since there are+-- very few primitive effects that the carrier for 'runSelectFast' is able to+-- thread.+-- In fact, of all the primitive effects featured in this library, only+-- one satisfies 'ContFastThreads': namely, 'Control.Effect.Reader.Reader'.+--+-- @'Derivs' ('SelectFastC' s r m) = 'Select' s ': 'Derivs' m@+--+-- @'Control.Effect.Primitive.Prims' ('SelectFastC' s r m) = 'Control.Effect.Primitive.Prims' m@+runSelectFast :: forall s a m p+ . (Carrier m, Threaders '[ContFastThreads] m p)+ => (a -> m s)+ -> SelectFastC s a m a+ -> m a+runSelectFast c m =+ fmap snd+ $ runShiftFast+ $ (>>= \a -> (\s -> (s, a)) <$> lift (c a))+ $ reinterpretViaHandler+ $ runComposition+ $ m+{-# INLINE runSelectFast #-}
+ src/Control/Effect/State.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE BlockArguments #-}+module Control.Effect.State+ ( -- * Effect+ State(..)++ -- * Actions+ , state+ , state'+ , get+ , gets+ , put+ , modify+ , modify'++ -- * Interpretations+ , runState+ , evalState+ , execState++ , runStateLazy+ , evalStateLazy+ , execStateLazy++ , stateToIO+ , runStateIORef++ -- * Simple variants of interpretations+ , stateToIOSimple+ , runStateIORefSimple++ -- * Threading constraints+ , StateThreads+ , StateLazyThreads++ -- * Carriers+ , StateC+ , StateLazyC+ ) where++import Data.IORef+import Data.Tuple++import Control.Effect++import Control.Effect.Internal.State++import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.State.Lazy as LSt++state :: Eff (State s) m => (s -> (s, a)) -> m a+state f = do+ (s, a) <- f <$> get+ put s+ return a+{-# INLINE state #-}++-- | A variant of 'state' that forces the resulting state (but not the return value)+state' :: Eff (State s) m => (s -> (s, a)) -> m a+state' f = do+ (s, a) <- f <$> get+ put $! s+ return a+{-# INLINE state' #-}++get :: Eff (State s) m => m s+get = send Get+{-# INLINE get #-}++gets :: Eff (State s) m => (s -> a) -> m a+gets = (<$> get)+{-# INLINE gets #-}++put :: Eff (State s) m => s -> m ()+put = send . Put+{-# INLINE put #-}++modify :: Eff (State s) m => (s -> s) -> m ()+modify f = do+ s <- get+ put (f s)++-- | A variant of 'modify' that forces the resulting state.+modify' :: Eff (State s) m => (s -> s) -> m ()+modify' f = do+ s <- get+ put $! f s++-- | Runs a @'State' s@ effect by transforming it into non-atomic+-- operations over an 'IORef'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runStateIORef' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'runStateIORefSimple', which doesn't have a higher-rank type.+runStateIORef :: forall s m a+ . Eff (Embed IO) m+ => IORef s+ -> InterpretReifiedC (State s) m a+ -> m a+runStateIORef ref = interpret $ \case+ Get -> embed $ readIORef ref+ Put s -> embed $ writeIORef ref s+{-# INLINE runStateIORef #-}++-- | Runs a @'State' s@ effect by transforming it into non-atomic+-- operations in IO.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'stateToIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'stateToIOSimple', which doesn't have a higher-rank type.+stateToIO :: forall s m a+ . Eff (Embed IO) m+ => s+ -> InterpretReifiedC (State s) m a+ -> m (s, a)+stateToIO s main = do+ ref <- embed $ newIORef s+ a <- runStateIORef ref main+ s' <- embed $ readIORef ref+ return (s', a)+{-# INLINE stateToIO #-}++-- | Runs a @'State' s@ effect by transforming it into non-atomic+-- operations over an 'IORef'.+--+-- This is a less performant version of 'runStateIORef' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runStateIORefSimple :: forall s m a p+ . ( Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => IORef s+ -> InterpretSimpleC (State s) m a+ -> m a+runStateIORefSimple ref = interpretSimple $ \case+ Get -> embed $ readIORef ref+ Put s -> embed $ writeIORef ref s+{-# INLINE runStateIORefSimple #-}++-- | Runs a @'State' s@ effect by transforming it into non-atomic+-- operations in IO.+--+-- This is a less performant version of 'stateToIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+stateToIOSimple :: forall s m a p+ . ( Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => s+ -> InterpretSimpleC (State s) m a+ -> m (s, a)+stateToIOSimple s main = do+ ref <- embed $ newIORef s+ a <- runStateIORefSimple ref main+ s' <- embed $ readIORef ref+ return (s', a)+{-# INLINE stateToIOSimple #-}++-- | Runs a @'State' s@ effect purely.+--+-- @'Derivs' ('StateC' s m) = 'State' s ': 'Derivs' m@+--+-- @'Control.Effect.Carrier.Prims' ('StateC' e m) = 'Control.Effect.Carrier.Prims' m@+runState :: forall s m a p+ . ( Carrier m+ , Threaders '[StateThreads] m p+ )+ => s+ -> StateC s m a+ -> m (s, a)+runState sInit m = do+ (a, sEnd) <- SSt.runStateT (unStateC m) sInit+ return (sEnd, a)+{-# INLINE runState #-}++-- | Runs a @'State' s@ effect purely, discarding+-- the end state.+evalState :: forall s m a p+ . ( Carrier m+ , Threaders '[StateThreads] m p+ )+ => s+ -> StateC s m a+ -> m a+evalState sInit m = do+ (a, _) <- SSt.runStateT (unStateC m) sInit+ return a+{-# INLINE evalState #-}++-- | Runs a @'State' s@ effect purely, discarding+-- the end result.+execState :: forall s m a p+ . ( Carrier m+ , Threaders '[StateThreads] m p+ )+ => s+ -> StateC s m a+ -> m s+execState sInit m = do+ (_, sEnd) <- SSt.runStateT (unStateC m) sInit+ return sEnd+{-# INLINE execState #-}++-- | Runs a @'State' s@ effect purely and lazily.+--+-- @'Derivs' ('StateLazyC' s m) = 'State' s ': 'Derivs' m@+--+-- @'Control.Effect.Carrier.Prims' ('StateLazyC' e m) = 'Control.Effect.Carrier.Prims' m@+runStateLazy :: forall s m a p+ . ( Carrier m+ , Threaders '[StateLazyThreads] m p+ )+ => s+ -> StateLazyC s m a+ -> m (s, a)+runStateLazy sInit m = swap <$> LSt.runStateT (unStateLazyC m) sInit+{-# INLINE runStateLazy #-}++-- | Runs a @'State' s@ effect purely and lazily,+-- discarding the final state.+evalStateLazy :: forall s m a p+ . ( Carrier m+ , Threaders '[StateLazyThreads] m p+ )+ => s+ -> StateLazyC s m a+ -> m a+evalStateLazy sInit m = fst <$> LSt.runStateT (unStateLazyC m) sInit+{-# INLINE evalStateLazy #-}++-- | Runs a @'State' s@ effect purely and lazily,+-- discarding the end result.+execStateLazy :: forall s m a p+ . ( Carrier m+ , Threaders '[StateLazyThreads] m p+ )+ => s+ -> StateLazyC s m a+ -> m s+execStateLazy sInit m = snd <$> LSt.runStateT (unStateLazyC m) sInit+{-# INLINE execStateLazy #-}
+ src/Control/Effect/Stepped.hs view
@@ -0,0 +1,14 @@+module Control.Effect.Stepped + ( SteppedC + , Steps(..) + , steps + , unsteps + , liftSteps + + , FirstOrder + + -- Threading constraints + , SteppedThreads + ) where + +import Control.Effect.Carrier.Internal.Stepped
+ src/Control/Effect/Trace.hs view
@@ -0,0 +1,204 @@+module Control.Effect.Trace+ ( -- * Effects+ Trace(..)++ -- * Actions+ , trace+ , traceShow++ -- * Interpretations+ , runTraceList++ , runTraceListIO++ , runTracePrinting+ , runTraceToHandle++ , ignoreTrace++ , traceIntoTell++ -- * Simple variants of interprations+ , runTraceListIOSimple+ , runTraceToHandleSimple++ -- * Threading constraints+ , WriterThreads++ -- * Carriers+ , TraceListC+ , TracePrintingC+ , IgnoreTraceC+ , TraceIntoTellC+ ) where++import Data.IORef++import Control.Effect+import Control.Effect.Writer++import System.IO++-- For coercion purposes+import Control.Effect.Internal.Utils+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Carrier.Internal.Compose+import Control.Effect.Carrier.Internal.Intro+import Control.Monad.Trans.Identity+++-- | An effect for debugging by printing/logging strings.+data Trace m a where+ Trace :: String -> Trace m ()++-- | Log the provided string+trace :: Eff Trace m => String -> m ()+trace = send . Trace+{-# INLINE trace #-}++-- | 'show' the provided item and log it.+traceShow :: (Show a, Eff Trace m) => a -> m ()+traceShow = trace . show+{-# INLINE traceShow #-}++type TraceListC = CompositionC+ '[ TraceIntoTellC+ , TellListC String+ ]++-- | Run a 'Trace' effect purely by accumulating all 'trace'd strings+-- into a list.+runTraceList :: forall m a p+ . ( Threaders '[WriterThreads] m p+ , Carrier m+ )+ => TraceListC m a+ -> m ([String], a)+runTraceList =+ runTellList+ .# traceIntoTell+ .# runComposition+{-# INLINE runTraceList #-}++data TracePrintingH++instance Eff (Embed IO) m+ => Handler TracePrintingH Trace m where+ effHandler (Trace str) = embed $ hPutStrLn stderr str+ {-# INLINEABLE effHandler #-}++type TracePrintingC = InterpretC TracePrintingH Trace++-- | Run a 'Trace' effect by printing each 'trace'd string+-- to stderr.+runTracePrinting :: Eff (Embed IO) m+ => TracePrintingC m a+ -> m a+runTracePrinting = interpretViaHandler+{-# INLINE runTracePrinting #-}++-- | Run 'Trace' effect by providing each 'trace'd string+-- to the provided 'Handle'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runTraceToHandle' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower 'runTraceToHandleSimple',+-- which doesn't have a higher-rank type.+runTraceToHandle :: Eff (Embed IO) m+ => Handle+ -> InterpretReifiedC Trace m a+ -> m a+runTraceToHandle hdl = interpret $ \case+ Trace str -> embed $ hPutStrLn hdl str+{-# INLINE runTraceToHandle #-}++-- | Run 'Trace' effect by providing each 'trace'd string+-- to the provided 'Handle'.+--+-- This is a less performant version of 'runTraceToHandle' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runTraceToHandleSimple :: forall m a p+ . ( Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => Handle+ -> InterpretSimpleC Trace m a+ -> m a+runTraceToHandleSimple hdl = interpretSimple $ \case+ Trace str -> embed $ hPutStrLn hdl str+{-# INLINE runTraceToHandleSimple #-}++-- | Run a 'Trace' effect by accumulating all 'trace'd strings+-- into a list using atomic operations in IO.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runTraceListIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower 'runTraceListIOSimple',+-- which doesn't have a higher-rank type.+runTraceListIO :: Eff (Embed IO) m+ => InterpretReifiedC Trace m a+ -> m ([String], a)+runTraceListIO m = do+ ref <- embed (newIORef [])+ a <- (`interpret` m) $ \case+ Trace o -> embed (atomicModifyIORef' ref (\s -> (o:s, ())))+ s <- reverse <$> embed (readIORef ref)+ return (s, a)+{-# INLINE runTraceListIO #-}+++-- | Run a 'Trace' effect by accumulating all 'trace'd strings+-- into a list using atomic operations in IO.+--+-- This is a less performant version of 'runTraceListIOSimple' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runTraceListIOSimple :: forall m a p+ . ( Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => InterpretSimpleC Trace m a+ -> m ([String], a)+runTraceListIOSimple m = do+ ref <- embed (newIORef [])+ a <- (`interpretSimple` m) $ \case+ Trace o -> embed (atomicModifyIORef' ref (\s -> (o:s, ())))+ s <- reverse <$> embed (readIORef ref)+ return (s, a)+{-# INLINE runTraceListIOSimple #-}++data IgnoreTraceH++instance Carrier m+ => Handler IgnoreTraceH Trace m where+ effHandler (Trace _) = pure ()+ {-# INLINEABLE effHandler #-}++type IgnoreTraceC = InterpretC IgnoreTraceH Trace++-- | Run a 'Trace' effect by ignoring it, doing no logging at all.+ignoreTrace :: Carrier m+ => IgnoreTraceC m a+ -> m a+ignoreTrace = interpretViaHandler+{-# INLINE ignoreTrace #-}++data TraceToTellH++instance Eff (Tell String) m+ => Handler TraceToTellH Trace m where+ effHandler (Trace str) = tell str+ {-# INLINEABLE effHandler #-}++type TraceIntoTellC = ReinterpretC TraceToTellH Trace '[Tell String]++-- | Rewrite a 'Trace' effect into a @'Tell' String@ effect on top of the+-- effect stack.+traceIntoTell :: HeadEff (Tell String) m+ => TraceIntoTellC m a+ -> m a+traceIntoTell = reinterpretViaHandler+{-# INLINE traceIntoTell #-}
+ src/Control/Effect/Type/Alt.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Alt where++-- | An effect corresponding to the+-- 'Control.Applicative.Alternative' type class.+--+-- 'Control.Effect.Effly.Effly''s 'Control.Applicative.Alternative' instance+-- is based on this effect; by having access to 'Alt', you're able to use+-- 'Control.Applicative.<|>' and 'Control.Applicative.empty' inside of effect+-- handlers.+--+-- Each 'Alt' interpreter's associated carrier+-- has an 'Control.Applicative.Alternative' instance based on+-- how it interprets 'Alt'. This means you can use+-- an 'Alt' interpreter to locally gain access to an 'Control.Applicative.Alternative'+-- instance inside of application code.+data Alt m a where+ Empty :: Alt m a+ Alt :: m a -> m a -> Alt m a
+ src/Control/Effect/Type/Bracket.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Bracket+ ( -- * Effects+ Bracket(..)+ , ExitCase(..)++ -- * Threading utilities+ , threadBracketViaClass+ ) where++import Control.Effect.Internal.Union+import Control.Effect.Internal.Utils+import Control.Effect.Internal.Reflection+import Control.Effect.Internal.ViaAlg+-- import qualified Control.Exception as X+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask, ExitCase(..))+import qualified Control.Monad.Catch as C+-- import Control.Applicative+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Except (ExceptT)+import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.State.Lazy as LSt+import qualified Control.Monad.Trans.Writer.Lazy as LWr+import qualified Control.Monad.Trans.Writer.Strict as SWr+import qualified Control.Monad.Trans.Writer.CPS as CPSWr+++-- | An effect for exception-safe acquisition and release of resources.+--+-- __'Bracket' is typically used as a primitive effect__.+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer @t@, then you need to make+-- a @'ThreadsEff' t 'Bracket'@ instance (if possible).+-- 'threadBracketViaClass' can help you with that.+--+-- The following threading constraints accept 'Bracket':+--+-- * 'Control.Effect.ReaderThreads'+-- * 'Control.Effect.State.StateThreads'+-- * 'Control.Effect.State.StateLazyThreads'+-- * 'Control.Effect.Error.ErrorThreads'+-- * 'Control.Effect.Writer.WriterThreads'+-- * 'Control.Effect.Writer.WriterLazyThreads'+data Bracket m a where+ GeneralBracket :: m a+ -> (a -> ExitCase b -> m c)+ -> (a -> m b)+ -> Bracket m (b, c)++instance Monad m => MonadThrow (ViaAlg s Bracket m) where+ throwM = error "threadBracketViaClass: Transformers threading Bracket \+ \are not allowed to use throwM."+instance Monad m => MonadCatch (ViaAlg s Bracket m) where+ catch = error "threadBracketViaClass: Transformers threading Bracket \+ \are not allowed to use catch."++instance ( Reifies s (ReifiedEffAlgebra Bracket m)+ , Monad m+ )+ => MonadMask (ViaAlg s Bracket m) where+ mask m = m id+ uninterruptibleMask m = m id++ generalBracket acquire release use = case reflect @s of+ ReifiedEffAlgebra alg -> coerceAlg alg (GeneralBracket acquire release use)+ {-# INLINE generalBracket #-}++-- | A valid definition of 'threadEff' for a @'ThreadsEff' t 'Bracket'@ instance,+-- given that @t@ lifts @'MonadMask'@.+--+-- __BEWARE__: 'threadBracketViaClass' is only safe if the implementation of+-- 'C.generalBracket' for @t m@ only makes use of 'C.generalBracket' for @m@,+-- and no other methods of 'MonadThrow', 'MonadCatch', or 'MonadMask'.+threadBracketViaClass :: forall t m a+ . Monad m+ => ( RepresentationalT t+ , forall b. MonadMask b => MonadMask (t b)+ )+ => (forall x. Bracket m x -> m x)+ -> Bracket (t m) a -> t m a+threadBracketViaClass alg (GeneralBracket acquire release use) =+ reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) ->+ unViaAlgT @s @Bracket $+ C.generalBracket+ (viaAlgT acquire)+ ((viaAlgT .) #. release)+ (viaAlgT #. use)+{-# INLINE threadBracketViaClass #-}+++#define THREAD_BRACKET(monadT) \+instance ThreadsEff (monadT) Bracket where \+ threadEff = threadBracketViaClass; \+ {-# INLINE threadEff #-}++#define THREAD_BRACKET_CTX(ctx, monadT) \+instance (ctx) => ThreadsEff (monadT) Bracket where \+ threadEff = threadBracketViaClass; \+ {-# INLINE threadEff #-}+++THREAD_BRACKET(ReaderT i)+THREAD_BRACKET(ExceptT e)+THREAD_BRACKET(LSt.StateT s)+THREAD_BRACKET(SSt.StateT s)+THREAD_BRACKET_CTX(Monoid s, LWr.WriterT s)+THREAD_BRACKET_CTX(Monoid s, SWr.WriterT s)++instance Monoid s => ThreadsEff (CPSWr.WriterT s) Bracket where+ threadEff alg (GeneralBracket acq rel use) = CPSWr.writerT $+ fmap (\( (b,sUse), (c,sEnd) ) -> ((b, c), sUse <> sEnd))+ . alg $+ GeneralBracket+ (CPSWr.runWriterT acq)+ (\(a, _) ec -> CPSWr.runWriterT $ rel a $ case ec of+ ExitCaseSuccess (b, _) -> ExitCaseSuccess b+ ExitCaseException exc -> ExitCaseException exc+ ExitCaseAbort -> ExitCaseAbort+ )+ (\(a, s) -> CPSWr.runWriterT (CPSWr.tell s >> use a))+ {-# INLINE threadEff #-}
+ src/Control/Effect/Type/Catch.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Catch where++import Control.Effect.Type.Throw+import Control.Effect.Internal.Union++-- | An effect for catching exceptions of type @e@.+data Catch e m a where+ Catch :: m a -> (e -> m a) -> Catch e m a++-- | A pseudo-effect for connected @'Throw' e@ and @'Catch' e@ effects.+--+-- @'Error' e@ should only ever be used inside of 'Control.Effect.Eff'+-- and 'Control.Effect.Effs' constraints. It is not a real effect!+-- See 'Bundle'.+type Error e = Bundle '[Throw e, Catch e]
+ src/Control/Effect/Type/Embed.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Type.Embed where + +-- | An effect for embedding actions of a base monad into the current one. +newtype Embed b m a where + Embed :: { unEmbed :: b a } -> Embed b m a
+ src/Control/Effect/Type/ErrorIO.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Type.ErrorIO where + +import Control.Exception + +-- | An effect for throwing and catching 'IO'-based exceptions. +data ErrorIO m a where + ThrowIO :: Exception e => e -> ErrorIO m a + CatchIO :: Exception e => m a -> (e -> m a) -> ErrorIO m a
+ src/Control/Effect/Type/Fail.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Type.Fail where + +-- | An effect corresponding to the 'Control.Monad.Fail.MonadFail' type class. +-- +-- 'Control.Effect.Effly.Effly''s 'Control.Monad.Fail.MonadFail' instance is based +-- on this effect; by having access to 'Fail', you're able to invoke +-- handle pattern-match failure automatically inside of effect handlers. +-- +-- Each 'Fail' interpreter's associated carrier +-- has an 'Control.Monad.Fail.MonadFail' instance based on +-- how it interprets 'Fail'. This means you can use +-- an 'Fail' interpreter to locally gain access to an 'Control.Monad.Fail.MonadFail' +-- instance inside of application code. +newtype Fail m a where + Fail :: String -> Fail m a
+ src/Control/Effect/Type/Fix.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Fix+ ( -- * Effects+ Fix(..)++ -- * Threading utilities+ , threadFixViaClass+ ) where++import Control.Monad.Fix+import qualified Control.Monad.Trans.Except as E+import qualified Control.Monad.Trans.Reader as R+import qualified Control.Monad.Trans.State.Lazy as LSt+import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.Writer.Lazy as LWr+import qualified Control.Monad.Trans.Writer.Strict as SWr+import qualified Control.Monad.Trans.Writer.CPS as CPSWr++import Control.Effect.Internal.ViaAlg+import Control.Effect.Internal.Reflection+import Control.Effect.Internal.Utils+import Control.Effect.Internal.Union++-- | An effect corresponding to the 'MonadFix' type class.+--+-- 'Control.Effect.Effly.Effly''s 'MonadFix' instance is based+-- on this effect; by having access to 'Fix', you're able to+-- use recursive do notation inside of effect handlers.+--+-- __Fix is typically used as a primitive effect__.+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer @t@, then you need to make+-- a @'ThreadsEff' t 'Fix'@ instance (if possible).+-- 'threadFixViaClass' can help you with that.+--+-- The following threading constraints accept 'Fix':+--+-- * 'Control.Effect.ReaderThreads'+-- * 'Control.Effect.State.StateThreads'+-- * 'Control.Effect.State.StateLazyThreads'+-- * 'Control.Effect.Error.ErrorThreads'+-- * 'Control.Effect.Writer.WriterThreads'+-- * 'Control.Effect.Writer.WriterLazyThreads'+newtype Fix m a where+ Fix :: (a -> m a) -> Fix m a++instance ( Reifies s (ReifiedEffAlgebra Fix m)+ , Monad m+ ) => MonadFix (ViaAlg s Fix m) where+ mfix f = case reflect @s of+ ReifiedEffAlgebra alg -> coerceAlg alg (Fix f)+ {-# INLINE mfix #-}+++-- | A valid definition of 'threadEff' for a @'ThreadsEff' t 'Fix'@ instance,+-- given that @t@ lifts 'MonadFix'.+threadFixViaClass :: Monad m+ => ( RepresentationalT t+ , forall b. MonadFix b => MonadFix (t b)+ )+ => (forall x. Fix m x -> m x)+ -> Fix (t m) a -> t m a+threadFixViaClass alg (Fix f) = reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) ->+ unViaAlgT (mfix (viaAlgT @s @Fix #. f))+{-# INLINE threadFixViaClass #-}++#define THREADFIX(monadT) \+instance ThreadsEff (monadT) Fix where \+ threadEff = threadFixViaClass; \+ {-# INLINE threadEff #-}++#define THREADFIX_CTX(ctx, monadT) \+instance ctx => ThreadsEff (monadT) Fix where \+ threadEff = threadFixViaClass; \+ {-# INLINE threadEff #-}++-- TODO(KingoftheHomeless): Benchmark this vs hand-written instances.+THREADFIX(LSt.StateT s)+THREADFIX(SSt.StateT s)+THREADFIX_CTX(Monoid s, LWr.WriterT s)+THREADFIX_CTX(Monoid s, SWr.WriterT s)+THREADFIX(CPSWr.WriterT s)+THREADFIX(E.ExceptT e)+THREADFIX(R.ReaderT i)
+ src/Control/Effect/Type/Internal/BaseControl.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE CPP, MagicHash #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Internal.BaseControl where++import Data.Coerce+import GHC.Exts (Proxy#, proxy#)+import Control.Effect.Internal.Union+import Control.Effect.Internal.Utils+import Control.Effect.Internal.Itself+import Control.Effect.Type.Optional+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict as SSt+import Control.Monad.Trans.State.Lazy as LSt+import Control.Monad.Trans.Writer.Lazy as LWr+import Control.Monad.Trans.Writer.Strict as SWr+import Control.Monad.Trans.Writer.CPS as CPSWr++-- | A /helper primitive effect/ that allows for lowering computations to a+-- base monad.+--+-- Helper primitive effects are effects that allow you to avoid interpreting one+-- of your own effects as a primitive if the power needed from direct access to+-- the underlying monad can instead be provided by the relevant helper primitive+-- effect. The reason why you'd want to do this is that helper primitive effects+-- already have 'ThreadsEff' instances defined for them; so you don't have to+-- define any for your own effect.+--+-- The helper primitive effects offered in this library are -- in order of+-- ascending power -- 'Control.Effect.Regional.Regional',+-- 'Control.Effect.Optional.Optional', 'Control.Effect.BaseControl.BaseControl'+-- and 'Control.Effect.Unlift.Unlift'.+--+-- __'BaseControl' is typically used as a primitive effect__.+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer @t@, then you need to make a+-- a @'ThreadsEff' t ('BaseControl' b)@ instance (if possible).+-- 'threadBaseControlViaClass' can help you with that.+--+-- The following threading constraints accept 'BaseControl':+--+-- * 'Control.Effect.ReaderThreads'+-- * 'Control.Effect.State.StateThreads'+-- * 'Control.Effect.State.StateLazyThreads'+-- * 'Control.Effect.Error.ErrorThreads'+-- * 'Control.Effect.Writer.WriterThreads'+-- * 'Control.Effect.Writer.WriterLazyThreads'+newtype BaseControl b m a where+ GainBaseControl :: ( forall z+ . (MonadBaseControl b z, Coercible z m)+ => Proxy# z+ -> a+ )+ -> BaseControl b m a++-- | A valid definition of 'threadEff' for a @'ThreadsEff' t ('BaseControl' b)@+-- instance, given that @t@ lifts @'MonadBaseControl' b@ for any @b@.+threadBaseControlViaClass :: forall b t m a+ . ( MonadTrans t+ , Monad m+ , forall z+ . MonadBaseControl b z+ => MonadBaseControl b (t z)+ , forall z+ . Coercible z m+ => Coercible (t z) (t m)+ )+ => (forall x. BaseControl b m x -> m x)+ -> BaseControl b (t m) a -> t m a+threadBaseControlViaClass alg (GainBaseControl main) =+ lift $ alg $ GainBaseControl $ \(_ :: Proxy# z) ->+ main (proxy# :: Proxy# (t z))+{-# INLINE threadBaseControlViaClass #-}++-- | A valid definition of 'threadEff' for a @'ThreadsEff' t ('Optional' s)@+-- instance, given that @t@ threads @'BaseControl' b@ for any @b@.+threadOptionalViaBaseControl :: forall s t m a+ . ( Functor s+ , Monad m+ , Monad (t m)+ , ThreadsEff t (BaseControl m)+ )+ => (forall x. Optional s m x -> m x)+ -> Optional s (t m) a -> t m a+threadOptionalViaBaseControl alg (Optionally sa m) =+ join+ $ threadEff (\(GainBaseControl main) -> return $ main (proxy# :: Proxy# (Itself m)))+ $ GainBaseControl @m $ \(_ :: Proxy# z) ->+ coerce $ join $ liftBaseWith @m @z @(z a) $ \lower -> do+ coerceAlg alg+ $ Optionally (fmap (pure @z) sa)+ (fmap restoreM (coerce (lower @a) m))+{-# INLINE threadOptionalViaBaseControl #-}+++#define THREAD_BASE_CONTROL(monadT) \+instance ThreadsEff (monadT) (BaseControl b) where \+ threadEff = threadBaseControlViaClass; \+ {-# INLINE threadEff #-}++#define THREAD_BASE_CONTROL_CTX(ctx, monadT) \+instance ctx => ThreadsEff (monadT) (BaseControl b) where \+ threadEff = threadBaseControlViaClass; \+ {-# INLINE threadEff #-}++THREAD_BASE_CONTROL(ReaderT i)+THREAD_BASE_CONTROL(ExceptT e)+THREAD_BASE_CONTROL(LSt.StateT s)+THREAD_BASE_CONTROL(SSt.StateT s)+THREAD_BASE_CONTROL_CTX(Monoid w, LWr.WriterT w)+THREAD_BASE_CONTROL_CTX(Monoid w, SWr.WriterT w)++-- monad-control still doesn't have a MonadBaseControl instance for CPS+-- WriterT, so we use a work-around to make this instance.+instance Monoid w => ThreadsEff (CPSWr.WriterT w) (BaseControl b) where+ threadEff alg (GainBaseControl main) =+ lift $ alg $ GainBaseControl $ \(_ :: Proxy# z) ->+ main (proxy# :: Proxy# (WriterCPS w z))+ {-# INLINE threadEff #-}+++newtype WriterCPS s m a = WriterCPS { unWriterCPS :: CPSWr.WriterT s m a }+ deriving (Functor, Applicative, Monad)+ deriving MonadTrans++instance MonadBase b m => MonadBase b (WriterCPS s m) where+ liftBase = lift . liftBase+ {-# INLINE liftBase #-}++instance (Monoid s, MonadBaseControl b m)+ => MonadBaseControl b (WriterCPS s m) where+ type StM (WriterCPS s m) a = StM m (a, s)++ liftBaseWith main = lift $ liftBaseWith $ \run_it ->+ main (run_it . CPSWr.runWriterT .# unWriterCPS)+ {-# INLINE liftBaseWith #-}++ restoreM = WriterCPS #. CPSWr.writerT . restoreM+ {-# INLINE restoreM #-}
+ src/Control/Effect/Type/ListenPrim.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE CPP #-} +module Control.Effect.Type.ListenPrim + ( -- * Effects + ListenPrim(..) + + -- * Threading utilities + , threadListenPrim + , threadListenPrimViaClass + ) where + +import Control.Monad.Trans +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Except (ExceptT) +import qualified Control.Monad.Trans.State.Strict as SSt +import qualified Control.Monad.Trans.State.Lazy as LSt +import qualified Control.Monad.Trans.Writer.Lazy as LWr +import qualified Control.Monad.Trans.Writer.Strict as SWr +import qualified Control.Monad.Trans.Writer.CPS as CPSWr +import Control.Monad.Writer.Class +import Control.Effect.Internal.ViaAlg +import Control.Effect.Internal.Reflection +import Control.Effect.Internal.Union + +-- | A primitive effect that may be used for +-- interpreters of connected 'Control.Effect.Writer.Tell' and +-- 'Control.Effect.Writer.Listen' effects. +-- +-- This combines 'Control.Effect.Writer.Tell' and +-- 'Control.Effect.Writer.Listen'. This may be relevant if there +-- are monad transformers that may only lift +-- 'Control.Effect.Writer.listen' if they also have access to +-- 'Control.Effect.Writer.tell'. +-- +-- __'ListenPrim' is only used as a primitive effect.__ +-- If you define a 'Control.Effect.Carrier' that relies on a novel +-- non-trivial monad transformer @t@, then you need to make +-- a @'Monoid' w => 'ThreadsEff' t ('ListenPrim' w)@ instance (if possible). +-- 'threadListenPrim' and 'threadListenPrimViaClass' can help you with that. +-- +-- The following threading constraints accept 'ListenPrim': +-- +-- * 'Control.Effect.ReaderThreads' +-- * 'Control.Effect.State.StateThreads' +-- * 'Control.Effect.State.StateLazyThreads' +-- * 'Control.Effect.Error.ErrorThreads' +-- * 'Control.Effect.Writer.WriterThreads' +-- * 'Control.Effect.Writer.WriterLazyThreads' +-- * 'Control.Effect.NonDet.NonDetThreads' +-- * 'Control.Effect.Stepped.SteppedThreads' +-- * 'Control.Effect.Cont.ContThreads' +data ListenPrim w m a where + ListenPrimTell :: w -> ListenPrim w m () + ListenPrimListen :: m a -> ListenPrim w m (w, a) + +-- | Construct a valid definition of 'threadEff' for a +-- @'ThreadsEff' t ('ListenPrim' w)@ instance +-- only be specifying how 'ListenPrimListen' should be lifted. +-- +-- This uses 'lift' to lift 'ListenPrimTell'. +threadListenPrim :: forall w t m a + . (MonadTrans t, Monad m) + => ( forall x + . (forall y. ListenPrim w m y -> m y) + -> t m x -> t m (w, x) + ) + -> (forall x. ListenPrim w m x -> m x) + -> ListenPrim w (t m) a -> t m a +threadListenPrim h alg = \case + ListenPrimTell w -> lift (alg (ListenPrimTell w)) + ListenPrimListen m -> h alg m +{-# INLINE threadListenPrim #-} + +instance ( Reifies s (ReifiedEffAlgebra (ListenPrim w) m) + , Monoid w + , Monad m + ) + => MonadWriter w (ViaAlg s (ListenPrim w) m) where + tell w = case reflect @s of + ReifiedEffAlgebra alg -> coerceAlg alg (ListenPrimTell w) + + pass = error "threadListenPrimViaClass: Transformers threading ListenPrim \ + \are not allowed to use pass." + + listen m = case reflect @s of + ReifiedEffAlgebra alg -> + fmap (\(s, a) -> (a, s)) $ coerceAlg alg (ListenPrimListen m) + {-# INLINE listen #-} + +-- | A valid definition of 'threadEff' for a @'ThreadsEff' t ('ListenPrim' w)@ +-- instance, given that @t@ lifts @'MonadWriter' w@. +-- +-- __BEWARE__: 'threadListenPrimViaClass' is only safe if the implementation of +-- 'listen' for @t m@ only makes use of 'listen' and 'tell' for @m@, and not +-- 'pass'. +threadListenPrimViaClass :: forall w t m a + . (Monoid w, Monad m) + => ( RepresentationalT t + , MonadTrans t + , forall b. MonadWriter w b => MonadWriter w (t b) + ) + => (forall x. ListenPrim w m x -> m x) + -> ListenPrim w (t m) a -> t m a +threadListenPrimViaClass alg = \case + ListenPrimTell w -> lift $ alg (ListenPrimTell w) + ListenPrimListen m -> + reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) -> + unViaAlgT + $ fmap (\(a, s) -> (s, a)) + $ listen + $ viaAlgT @s @(ListenPrim w) m +{-# INLINE threadListenPrimViaClass #-} + +#define THREAD_LISTENPRIM(monadT) \ +instance Monoid threadedMonoid \ + => ThreadsEff (monadT) (ListenPrim threadedMonoid) where \ + threadEff = threadListenPrimViaClass; \ + {-# INLINE threadEff #-} + +THREAD_LISTENPRIM(ReaderT i) +THREAD_LISTENPRIM(ExceptT e) +THREAD_LISTENPRIM(LSt.StateT s) +THREAD_LISTENPRIM(SSt.StateT s) + +instance Monoid s => ThreadsEff (LWr.WriterT s) (ListenPrim w) where + threadEff = threadListenPrim $ \alg m -> + LWr.WriterT + $ fmap (\(s, (a, w)) -> ((s, a), w)) + $ alg + $ ListenPrimListen + $ LWr.runWriterT m + {-# INLINE threadEff #-} + +instance Monoid s => ThreadsEff (SWr.WriterT s) (ListenPrim w) where + threadEff = threadListenPrim $ \alg m -> + SWr.WriterT + $ fmap (\(s, (a, w)) -> ((s, a), w)) + $ alg + $ ListenPrimListen + $ SWr.runWriterT m + {-# INLINE threadEff #-} + +instance Monoid s => ThreadsEff (CPSWr.WriterT s) (ListenPrim w) where + threadEff = threadListenPrim $ \alg m -> + CPSWr.writerT + $ fmap (\(s, (a, w)) -> ((s, a), w)) + $ alg + $ ListenPrimListen + $ CPSWr.runWriterT m + {-# INLINE threadEff #-}
+ src/Control/Effect/Type/Mask.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Mask+ ( -- * Effects+ Mask(..)+ , MaskMode(..)++ -- * Threading utilities+ , threadMaskViaClass+ ) where++import Control.Effect.Internal.Union+import Control.Effect.Internal.Reflection+import Control.Effect.Internal.ViaAlg+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+import qualified Control.Monad.Catch as C+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Except (ExceptT)+import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.State.Lazy as LSt+import qualified Control.Monad.Trans.Writer.Lazy as LWr+import qualified Control.Monad.Trans.Writer.Strict as SWr+import qualified Control.Monad.Trans.Writer.CPS as CPSWr+++data MaskMode+ = InterruptibleMask+ | UninterruptibleMask++-- | An effect for masking asynchronous exceptions.+--+-- __'Mask' is typically used as a primitive effect.__+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer @t@, then you need to make+-- a @'ThreadsEff' t 'Mask'@ instance (if possible).+-- 'threadMaskViaClass' can help you with that.+--+-- The following threading constraints accept 'Mask':+--+-- * 'Control.Effect.ReaderThreads'+-- * 'Control.Effect.State.StateThreads'+-- * 'Control.Effect.State.StateLazyThreads'+-- * 'Control.Effect.Error.ErrorThreads'+-- * 'Control.Effect.Writer.WriterThreads'+-- * 'Control.Effect.Writer.WriterLazyThreads'+data Mask m a where+ Mask :: MaskMode+ -> ((forall x. m x -> m x) -> m a)+ -> Mask m a++instance Monad m => MonadThrow (ViaAlg s Mask m) where+ throwM = error "threadMaskViaClass: Transformers threading Mask \+ \are not allowed to use throwM."++instance Monad m => MonadCatch (ViaAlg s Mask m) where+ catch = error "threadMaskViaClass: Transformers threading Mask \+ \are not allowed to use catch."++instance ( Reifies s (ReifiedEffAlgebra Mask m)+ , Monad m+ )+ => MonadMask (ViaAlg s Mask m) where+ mask main = case reflect @s of+ ReifiedEffAlgebra alg -> coerceAlg alg (Mask InterruptibleMask main)+ {-# INLINE mask #-}++ uninterruptibleMask main = case reflect @s of+ ReifiedEffAlgebra alg -> coerceAlg alg (Mask UninterruptibleMask main)+ {-# INLINE uninterruptibleMask #-}++ generalBracket = error "threadMaskViaClass: Transformers threading Mask \+ \are not allowed to use generalBracket."++-- | A valid definition of 'threadEff' for a @'ThreadsEff' t 'Mask'@ instance,+-- given that @t@ lifts @'MonadMask'@.+--+-- __BEWARE__: 'threadMaskViaClass' is only safe if the implementation of+-- 'Control.Monad.Catch.mask' and 'Control.Monad.Catch.uninterruptibleMask'+-- for @t m@ only makes use of 'Conrol.Monad.Catch.mask'+-- and 'Control.Monad.Catch.uninterruptibleMask' for @m@, and no other methods of+-- 'MonadThrow', 'MonadCatch', and 'MonadMask'.+threadMaskViaClass :: forall t m a+ . Monad m+ => ( RepresentationalT t+ , forall b. MonadMask b => MonadMask (t b)+ )+ => (forall x. Mask m x -> m x)+ -> Mask (t m) a -> t m a+threadMaskViaClass alg (Mask mode main) =+ reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) ->+ unViaAlgT $ case mode of+ InterruptibleMask -> C.mask $ \restore ->+ viaAlgT @s @Mask $ main (mapUnViaAlgT restore)+ UninterruptibleMask -> C.uninterruptibleMask $ \restore ->+ viaAlgT @s @Mask $ main (mapUnViaAlgT restore)+{-# INLINE threadMaskViaClass #-}++#define THREAD_MASK(monadT) \+instance ThreadsEff (monadT) Mask where \+ threadEff = threadMaskViaClass; \+ {-# INLINE threadEff #-}++#define THREAD_MASK_CTX(ctx, monadT) \+instance (ctx) => ThreadsEff (monadT) Mask where \+ threadEff = threadMaskViaClass; \+ {-# INLINE threadEff #-}++THREAD_MASK(ReaderT i)+THREAD_MASK(ExceptT e)+THREAD_MASK(LSt.StateT s)+THREAD_MASK(SSt.StateT s)+THREAD_MASK_CTX(Monoid s, LWr.WriterT s)+THREAD_MASK_CTX(Monoid s, SWr.WriterT s)++instance Monoid s => ThreadsEff (CPSWr.WriterT s) Mask where+ threadEff alg (Mask mode main) = CPSWr.writerT $ alg $ Mask mode $ \restore ->+ CPSWr.runWriterT (main (CPSWr.mapWriterT restore))+ {-# INLINE threadEff #-}
+ src/Control/Effect/Type/Optional.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP, TupleSections #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Optional+ ( -- * Effects+ Optional(..)++ -- * Threading utilities+ , threadRegionalViaOptional+ ) where++import Data.Functor.Const+import Control.Effect.Internal.Union+import Control.Effect.Type.Regional+import Control.Monad.Trans.Reader (ReaderT(..), mapReaderT)+import Control.Monad.Trans.Except (ExceptT(..), mapExceptT)+import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.State.Lazy as LSt+import qualified Control.Monad.Trans.Writer.Lazy as LWr+import qualified Control.Monad.Trans.Writer.Strict as SWr+import qualified Control.Monad.Trans.Writer.CPS as CPSWr+++-- | A /helper primitive effect/ for manipulating a region, with the option+-- to execute it in full or in part. @s@ is expected to be a functor.+--+-- Helper primitive effects are effects that allow you to avoid interpreting one+-- of your own effects as a primitive if the power needed from direct access to+-- the underlying monad can instead be provided by the relevant helper primitive+-- effect. The reason why you'd want to do this is that helper primitive effects+-- already have 'ThreadsEff' instances defined for them, so you don't have to+-- define any for your own effect.+--+-- The helper primitive effects offered in this library are -- in order of+-- ascending power -- 'Control.Effect.Regional.Regional',+-- 'Control.Effect.Optional.Optional', 'Control.Effect.BaseControl.BaseControl'+-- and 'Control.Effect.Unlift.Unlift'.+--+-- The typical use-case of 'Optional' is to lift a natural transformation+-- of a base monad equipped with the power to recover from an exception.+-- 'Control.Effect.Optional.HoistOption' and accompanying interpreters is+-- provided as a specialization of 'Optional' for this purpose.+--+-- 'Optional' in its most general form lacks a pre-defined interpreter:+-- when not using 'Control.Effect.Optional.HoistOption', you're expected to+-- define your own interpreter for 'Optional' (treating it as a primitive effect).+--+-- __'Optional' is typically used as a primitive effect.__+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer @t@, then you need to make+-- a @Functor s => 'ThreadsEff' t ('Optional' s)@ instance (if possible).+-- 'Control.Effect.Optional.threadOptionalViaBaseControl'+-- can help you with that.+--+-- The following threading constraints accept 'Optional':+--+-- * 'Control.Effect.ReaderThreads'+-- * 'Control.Effect.State.StateThreads'+-- * 'Control.Effect.State.StateLazyThreads'+-- * 'Control.Effect.Error.ErrorThreads'+-- * 'Control.Effect.Writer.WriterThreads'+-- * 'Control.Effect.Writer.WriterLazyThreads'+-- * 'Control.Effect.NonDet.NonDetThreads'+-- * 'Control.Effect.Stepped.SteppedThreads'+-- * 'Control.Effect.Cont.ContThreads'+data Optional s m a where+ Optionally :: s a -> m a -> Optional s m a++-- | A valid definition of 'threadEff' for a @'ThreadsEff' ('Regional' s) t@ instance,+-- given that @t@ threads @'Optional' f@ for any functor @f@.+threadRegionalViaOptional :: ( ThreadsEff t (Optional (Const s))+ , Monad m)+ => (forall x. Regional s m x -> m x)+ -> Regional s (t m) a -> t m a+threadRegionalViaOptional alg (Regionally s m) =+ threadEff+ (\(Optionally (Const s') m') -> alg (Regionally s' m'))+ (Optionally (Const s) m)+{-# INLINE threadRegionalViaOptional #-}++instance Functor s => ThreadsEff (ExceptT e) (Optional s) where+ threadEff alg (Optionally sa m) = mapExceptT (alg . Optionally (fmap Right sa)) m+ {-# INLINE threadEff #-}++instance ThreadsEff (ReaderT i) (Optional s) where+ threadEff alg (Optionally sa m) = mapReaderT (alg . Optionally sa) m+ {-# INLINE threadEff #-}++instance Functor s => ThreadsEff (SSt.StateT s') (Optional s) where+ threadEff alg (Optionally sa m) = SSt.StateT $ \s ->+ alg $ Optionally (fmap (, s) sa) (SSt.runStateT m s)+ {-# INLINE threadEff #-}++instance Functor s => ThreadsEff (LSt.StateT s') (Optional s) where+ threadEff alg (Optionally sa m) = LSt.StateT $ \s ->+ alg $ Optionally (fmap (, s) sa) (LSt.runStateT m s)+ {-# INLINE threadEff #-}++instance (Functor s, Monoid w) => ThreadsEff (LWr.WriterT w) (Optional s) where+ threadEff alg (Optionally sa m) =+ LWr.mapWriterT (alg . Optionally (fmap (, mempty) sa)) m+ {-# INLINE threadEff #-}++instance (Functor s, Monoid w) => ThreadsEff (SWr.WriterT w) (Optional s) where+ threadEff alg (Optionally sa m) =+ SWr.mapWriterT (alg . Optionally (fmap (, mempty) sa)) m+ {-# INLINE threadEff #-}++instance (Functor s, Monoid w)+ => ThreadsEff (CPSWr.WriterT w) (Optional s) where+ threadEff alg (Optionally sa m) =+ CPSWr.mapWriterT (alg . Optionally (fmap (, mempty) sa)) m+ {-# INLINE threadEff #-}
+ src/Control/Effect/Type/ReaderPrim.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE CPP #-}+module Control.Effect.Type.ReaderPrim+ ( -- * Effects+ ReaderPrim(..)++ -- * Threading utilities+ , threadReaderPrim+ , threadReaderPrimViaClass+ , threadReaderPrimViaRegional+ ) where++import Control.Monad.Trans++import Control.Monad.Reader.Class (MonadReader)+import qualified Control.Monad.Reader.Class as RC+import Control.Monad.Trans.Except (ExceptT(..))++import Control.Monad.Trans.Reader (ReaderT(..))+import qualified Control.Monad.Trans.Reader as R++import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.State.Lazy as LSt+import qualified Control.Monad.Trans.Writer.Lazy as LWr+import qualified Control.Monad.Trans.Writer.Strict as SWr+import qualified Control.Monad.Trans.Writer.CPS as CPSWr+import Control.Monad.Trans.Cont (ContT(..))+import qualified Control.Monad.Trans.Cont as C++import Control.Effect.Internal.ViaAlg+import Control.Effect.Type.Regional+import Control.Effect.Internal.Reflection+import Control.Effect.Internal.Union++-- | A primitive effect that may be used for+-- interpreters of connected 'Control.Effect.Reader.Ask' and+-- 'Control.Effect.Reader.Local' effects.+--+-- This combines 'Control.Effect.Reader.Ask' and 'Control.Effect.Reader.Local',+-- which is relevant since certain monad transformers may only lift+-- 'Control.Effect.Reader.local' if they also have access to+-- 'Control.Effect.Reader.ask'.+--+-- __'ReaderPrim' is only used as a primitive effect.__+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer @t@, then you need to make+-- a @'ThreadsEff' t ('ReaderPrim' i)@ instance (if possible).+-- 'threadReaderPrimViaClass' and 'threadReaderPrimViaRegional'+-- can help you with that.+--+-- The following threading constraints accept 'ReaderPrim':+--+-- * 'Control.Effect.ReaderThreads'+-- * 'Control.Effect.State.StateThreads'+-- * 'Control.Effect.State.StateLazyThreads'+-- * 'Control.Effect.Error.ErrorThreads'+-- * 'Control.Effect.Writer.WriterThreads'+-- * 'Control.Effect.Writer.WriterLazyThreads'+-- * 'Control.Effect.NonDet.NonDetThreads'+-- * 'Control.Effect.Stepped.SteppedThreads'+-- * 'Control.Effect.Cont.ContThreads'+-- * 'Control.Effect.Cont.ContFastThreads'+data ReaderPrim i m a where+ ReaderPrimAsk :: ReaderPrim i m i+ ReaderPrimLocal :: (i -> i) -> m a -> ReaderPrim i m a++instance ( Reifies s (ReifiedEffAlgebra (ReaderPrim i) m)+ , Monad m+ ) => MonadReader i (ViaAlg s (ReaderPrim i) m) where+ ask = case reflect @s of+ ReifiedEffAlgebra alg -> coerceAlg alg ReaderPrimAsk+ {-# INLINE ask #-}++ local f m = case reflect @s of+ ReifiedEffAlgebra alg -> coerceAlg alg (ReaderPrimLocal f m)+ {-# INLINE local #-}++-- | Construct a valid definition of 'threadEff' for a+-- @'ThreadsEff' t ('ReaderPrim' w)@ instance+-- only be specifying how 'ReaderPrimLocal' should be lifted.+--+-- This uses 'lift' to lift 'ReaderPrimAsk'.+threadReaderPrim :: forall i t m a+ . (MonadTrans t, Monad m)+ => ( (forall x. ReaderPrim i m x -> m x)+ -> (i -> i) -> t m a -> t m a+ )+ -> (forall x. ReaderPrim i m x -> m x)+ -> ReaderPrim i (t m) a -> t m a+threadReaderPrim h alg = \case+ ReaderPrimAsk -> lift (alg ReaderPrimAsk)+ ReaderPrimLocal f m -> h alg f m+{-# INLINE threadReaderPrim #-}++-- | A valid definition of 'threadEff' for a @'ThreadsEff' t ('ReaderPrim' i)@+-- instance, given that @t@ lifts @'MonadReader' i@.+threadReaderPrimViaClass :: forall i t m a+ . Monad m+ => ( RepresentationalT t+ , MonadTrans t+ , forall b. MonadReader i b => MonadReader i (t b)+ )+ => (forall x. ReaderPrim i m x -> m x)+ -> ReaderPrim i (t m) a -> t m a+threadReaderPrimViaClass alg e = reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) ->+ case e of+ ReaderPrimAsk -> lift (alg ReaderPrimAsk)+ ReaderPrimLocal f m -> unViaAlgT (RC.local f (viaAlgT @s @(ReaderPrim i) m))+{-# INLINE threadReaderPrimViaClass #-}++-- | A valid definition of 'threadEff' for a @'ThreadsEff' t ('ReaderPrim' i)@+-- instance, given that @t@ threads @'Regional' s@ for any @s@.+threadReaderPrimViaRegional :: forall i t m a+ . ( Monad m+ , MonadTrans t+ , ThreadsEff t (Regional ())+ )+ => (forall x. ReaderPrim i m x -> m x)+ -> ReaderPrim i (t m) a -> t m a+threadReaderPrimViaRegional alg ReaderPrimAsk = lift (alg ReaderPrimAsk)+threadReaderPrimViaRegional alg (ReaderPrimLocal f m) =+ threadEff (\(Regionally _ m') -> alg $ ReaderPrimLocal f m') (Regionally () m)+{-# INLINE threadReaderPrimViaRegional #-}++#define THREAD_READER(monadT) \+instance ThreadsEff (monadT) (ReaderPrim threadedInput) where \+ threadEff = threadReaderPrimViaClass; \+ {-# INLINE threadEff #-}++#define THREAD_READER_CTX(ctx, monadT) \+instance ctx => ThreadsEff (monadT) (ReaderPrim threadedInput) where \+ threadEff = threadReaderPrimViaClass; \+ {-# INLINE threadEff #-}++instance ThreadsEff (ReaderT i') (ReaderPrim i) where+ threadEff = threadReaderPrim $ \alg f m ->+ R.mapReaderT (alg . ReaderPrimLocal f) m+ {-# INLINE threadEff #-}++instance Monoid w => ThreadsEff (CPSWr.WriterT w) (ReaderPrim i) where+ threadEff = threadReaderPrim $ \alg f m ->+ CPSWr.mapWriterT (alg . ReaderPrimLocal f) m+ {-# INLINE threadEff #-}++-- TODO(KingoftheHomeless): Benchmark this vs hand-written instances.+THREAD_READER(ExceptT e)+THREAD_READER(SSt.StateT s)+THREAD_READER(LSt.StateT s)+THREAD_READER_CTX(Monoid w, LWr.WriterT w)+THREAD_READER_CTX(Monoid w, SWr.WriterT w)+THREAD_READER(C.ContT r)
+ src/Control/Effect/Type/Regional.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Regional where+import Control.Effect.Internal.Union+import Control.Monad.Trans.Reader (ReaderT(..), mapReaderT)+import Control.Monad.Trans.Except (ExceptT(..), mapExceptT)+import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.State.Lazy as LSt+import qualified Control.Monad.Trans.Writer.Lazy as LWr+import qualified Control.Monad.Trans.Writer.Strict as SWr+import qualified Control.Monad.Trans.Writer.CPS as CPSWr++-- | A /helper primitive effect/ for manipulating a region.+--+-- Helper primitive effects are effects that allow you to avoid interpreting one+-- of your own effects as a primitive if the power needed from direct access to+-- the underlying monad can instead be provided by the relevant helper primitive+-- effect. The reason why you'd want to do this is that helper primitive effects+-- already have 'ThreadsEff' instances defined for them; so you don't have to+-- define any for your own effect.+--+-- The helper primitive effects offered in this library are -- in order of+-- ascending power -- 'Control.Effect.Regional.Regional',+-- 'Control.Effect.Optional.Optional', 'Control.Effect.BaseControl.BaseControl'+-- and 'Control.Effect.Unlift.Unlift'.+--+-- The typical use-case of 'Regional' is to lift a natural transformation+-- of a base monad.+-- 'Control.Effect.Regional.Hoist' and accompaning interpreters is+-- provided as a specialization of 'Regional' for this purpose.+--+-- 'Regional' in its most general form lacks a pre-defined interpreter:+-- when not using 'Control.Effect.Regional.Hoist', you're expected to define+-- your own interpreter for 'Regional' (treating it as a primitive effect).+--+-- __'Regional' is typically used as a primitive effect.__+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer @t@, then you need to make a+-- a @'ThreadsEff' t ('Regional' s)@ instance (if possible).+-- 'Control.Effect.Regional.threadRegionalViaOptional'+-- can help you with that.+--+-- The following threading constraints accept 'Regional':+--+-- * 'Control.Effect.ReaderThreads'+-- * 'Control.Effect.State.StateThreads'+-- * 'Control.Effect.State.StateLazyThreads'+-- * 'Control.Effect.Error.ErrorThreads'+-- * 'Control.Effect.Writer.WriterThreads'+-- * 'Control.Effect.Writer.WriterLazyThreads'+-- * 'Control.Effect.NonDet.NonDetThreads'+-- * 'Control.Effect.Stepped.SteppedThreads'+-- * 'Control.Effect.Cont.ContThreads'+data Regional s m a where+ Regionally :: s -> m a -> Regional s m a++instance ThreadsEff (ExceptT e) (Regional s) where+ threadEff alg (Regionally s m) = mapExceptT (alg . Regionally s) m+ {-# INLINE threadEff #-}++instance ThreadsEff (ReaderT i) (Regional s) where+ threadEff alg (Regionally s m) = mapReaderT (alg . Regionally s) m+ {-# INLINE threadEff #-}++instance ThreadsEff (SSt.StateT i) (Regional s) where+ threadEff alg (Regionally s m) = SSt.mapStateT (alg . Regionally s) m+ {-# INLINE threadEff #-}++instance ThreadsEff (LSt.StateT i) (Regional s) where+ threadEff alg (Regionally s m) = LSt.mapStateT (alg . Regionally s) m+ {-# INLINE threadEff #-}++instance ThreadsEff (LWr.WriterT w) (Regional s) where+ threadEff alg (Regionally s m) = LWr.mapWriterT (alg . Regionally s) m+ {-# INLINE threadEff #-}++instance ThreadsEff (SWr.WriterT w) (Regional s) where+ threadEff alg (Regionally s m) = SWr.mapWriterT (alg . Regionally s) m+ {-# INLINE threadEff #-}++instance Monoid w => ThreadsEff (CPSWr.WriterT w) (Regional s) where+ threadEff alg (Regionally s m) = CPSWr.mapWriterT (alg . Regionally s) m+ {-# INLINE threadEff #-}
+ src/Control/Effect/Type/Split.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Split where++import Control.Effect.Internal.Union+import Control.Monad.Trans+import Control.Monad.Trans.Reader+import qualified Control.Monad.Trans.State.Lazy as LSt+import qualified Control.Monad.Trans.State.Strict as SSt+import qualified Control.Monad.Trans.Writer.Lazy as LWr+import qualified Control.Monad.Trans.Writer.Strict as SWr+import qualified Control.Monad.Trans.Writer.CPS as CPSWr++-- | An effect for spliting a nondeterministic computation+-- into its head and tail.+--+-- __'Split' is typically used as a primitive effect.__+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer, then you need to make+-- a @'ThreadsEff'@ instance for that monad transformer+-- to lift 'Split' (if possible).+--+-- The following threading constraints accept 'Split':+--+-- * 'Control.Effect.ReaderThreads'+-- * 'Control.Effect.State.StateThreads'+-- * 'Control.Effect.State.StateLazyThreads'+-- * 'Control.Effect.Writer.WriterThreads'+-- * 'Control.Effect.Writer.WriterLazyThreads'+data Split m a where+ Split :: (Maybe (a, m a) -> b) -> m a -> Split m b++instance ThreadsEff (ReaderT s) Split where+ threadEff alg (Split c m) = ReaderT $ \s ->+ alg $ Split (c . (fmap . fmap) lift) (runReaderT m s)+ {-# INLINE threadEff #-}++instance ThreadsEff (LSt.StateT s) Split where+ threadEff alg (Split c m) = LSt.StateT $ \s ->+ alg $+ Split+ (maybe+ (c Nothing, s)+ (\ ~( ~(a, s'), m') ->+ (c $ Just (a, LSt.StateT $ \_ -> m'), s')+ )+ )+ (LSt.runStateT m s)+ {-# INLINE threadEff #-}++instance ThreadsEff (SSt.StateT s) Split where+ threadEff alg (Split c m) = SSt.StateT $ \s ->+ alg $+ Split+ (maybe+ (c Nothing, s)+ (\((a, s'), m') ->+ (c $ Just (a, SSt.StateT $ \_ -> m'), s')+ )+ )+ (SSt.runStateT m s)+ {-# INLINE threadEff #-}++instance Monoid s => ThreadsEff (LWr.WriterT s) Split where+ threadEff alg (Split c m) = LWr.WriterT $+ alg $+ Split+ (maybe+ (c Nothing, mempty)+ (\ ~( ~(a, s'), m') ->+ (c $ Just (a, LWr.WriterT m'), s')+ )+ )+ (LWr.runWriterT m)+ {-# INLINE threadEff #-}++instance Monoid s => ThreadsEff (SWr.WriterT s) Split where+ threadEff alg (Split c m) = SWr.WriterT $+ alg $+ Split+ (maybe+ (c Nothing, mempty)+ (\((a, s'), m') ->+ (c $ Just (a, SWr.WriterT m'), s')+ )+ )+ (SWr.runWriterT m)+ {-# INLINE threadEff #-}++instance Monoid s => ThreadsEff (CPSWr.WriterT s) Split where+ threadEff alg (Split c m) = CPSWr.writerT $+ alg $+ Split+ (maybe+ (c Nothing, mempty)+ (\((a, s'), m') ->+ (c $ Just (a, CPSWr.writerT m'), s')+ )+ )+ (CPSWr.runWriterT m)+ {-# INLINE threadEff #-}
+ src/Control/Effect/Type/Throw.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Throw where++-- | An effect for throwing exceptions of type @e@.+newtype Throw e m a where+ Throw :: e -> Throw e m a+
+ src/Control/Effect/Type/Unlift.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_HADDOCK not-home #-}+module Control.Effect.Type.Unlift+ ( -- * Effects+ Unlift(..)++ -- Threading utilities+ , threadUnliftViaClass++ -- 'MonadBaseControlPure' and 'MonadTransControlPure'+ , MonadBaseControlPure+ , unliftBase++ , MonadTransControlPure+ , unliftT+ ) where++import Control.Effect.Internal.Union+import Control.Monad.Trans.Control+import Control.Monad.Trans.Reader++class a ~ StM m a => Pure m a+instance a ~ StM m a => Pure m a++-- | A constraint synonym for @'MonadBaseControl' b m@ together+-- with that @StM m a ~ a@ for all @a@.+class ( MonadBaseControl b m+ , forall x. Pure m x+ )+ => MonadBaseControlPure b m++instance ( MonadBaseControl b m+ , forall x. Pure m x+ )+ => MonadBaseControlPure b m++class a ~ StT t a => PureT t a+instance a ~ StT t a => PureT t a++class ( MonadTransControl t+ , forall x. PureT t x+ )+ => MonadTransControlPure t++instance ( MonadTransControl t+ , forall x. PureT t x+ )+ => MonadTransControlPure t++unliftBase :: forall b m a+ . MonadBaseControlPure b m+ => ((forall x. m x -> b x) -> b a)+ -> m a+unliftBase main = liftBaseWith $ \lower ->+ main (lower :: Pure m x => m x -> b x)+{-# INLINE unliftBase #-}++unliftT :: forall t m a+ . (MonadTransControlPure t, Monad m)+ => ((forall n x. Monad n => t n x -> n x) -> m a)+ -> t m a+unliftT main = liftWith $ \lower ->+ main (lower :: (PureT t x, Monad n) => t n x -> n x)+{-# INLINE unliftT #-}++-- | A /helper primitive effect/ for unlifting to a base monad.+--+-- Helper primitive effects are effects that allow you to avoid interpreting one+-- of your own effects as a primitive if the power needed from direct access to+-- the underlying monad can instead be provided by the relevant helper primitive+-- effect. The reason why you'd want to do this is that helper primitive effects+-- already have 'ThreadsEff' instances defined for them, so you don't have to+-- define any for your own effect.+--+-- The helper primitive effects offered in this library are -- in order of+-- ascending power -- 'Control.Effect.Regional.Regional',+-- 'Control.Effect.Optional.Optional', 'Control.Effect.BaseControl.BaseControl'+-- and 'Control.Effect.Unlift.Unlift'.+--+-- __'Unlift' is typically used as a primitive effect.__+-- If you define a 'Control.Effect.Carrier' that relies on a novel+-- non-trivial monad transformer @t@, then you need to make+-- a @'ThreadsEff' t ('Unlift' b)@ instance (if possible).+-- 'threadUnliftViaClass' can help you with that.+--+-- The following threading constraints accept 'Unlift':+--+-- * 'Control.Effect.ReaderThreads'+data Unlift b m a where+ Unlift :: forall b m a. ((forall x. m x -> b x) -> b a) -> Unlift b m a++-- | A valid definition of 'threadEff' for a @'ThreadsEff' ('Unlift' b) t@ instance,+-- given that @t@ is a 'MonadTransControl' where @'StT' t a ~ a@ holds for all @a@.+threadUnliftViaClass :: forall b t m a+ . (MonadTransControlPure t, Monad m)+ => (forall x. Unlift b m x -> m x)+ -> Unlift b (t m) a -> t m a+threadUnliftViaClass alg (Unlift main) = unliftT $ \lowerT ->+ alg $ Unlift $ \lowerM -> main (lowerM . lowerT)+{-# INLINE threadUnliftViaClass #-}++instance ThreadsEff (ReaderT i) (Unlift b) where+ threadEff alg (Unlift main) = ReaderT $ \s ->+ alg $ Unlift $ \lower -> main (lower . (`runReaderT` s))+ {-# INLINE threadEff #-}
+ src/Control/Effect/Type/Unravel.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TupleSections #-} +module Control.Effect.Type.Unravel where + +import Control.Effect.Internal.Union +import Control.Monad.Trans +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.Except (ExceptT(..)) +-- import qualified Control.Monad.Trans.State.Strict as SSt +-- import qualified Control.Monad.Trans.State.Lazy as LSt +-- import qualified Control.Monad.Trans.Writer.Lazy as LWr +-- import qualified Control.Monad.Trans.Writer.Strict as SWr +-- import qualified Control.Monad.Trans.Writer.CPS as CPSWr + +-- | A primitive effect which allows you to break a computation into layers. +-- This is the primitive effect underlying +-- 'Control.Effect.Intercept.Intercept' and +-- 'Control.Effect.Intercept.InterceptCont'. +-- +-- Note: 'ThreadsEff' instances are not allowed to assume that @p@ is a functor. +-- +-- __'Unravel' is typically used as a primitive effect.__ +-- If you define a 'Control.Effect.Carrier' that relies on a novel +-- non-trivial monad transformer @t@, then you need to make +-- a @'ThreadsEff' t ('Unravel' p)@ instance (if possible). +-- +-- The following threading constraints accept 'Unravel': +-- +-- * 'Control.Effect.ReaderThreads' +-- * 'Control.Effect.Error.ErrorThreads' +-- * 'Control.Effect.NonDet.NonDetThreads' +-- * 'Control.Effect.Stepped.SteppedThreads' +-- * 'Control.Effect.Cont.ContThreads' +data Unravel p :: Effect where + Unravel :: p a -> (m a -> a) -> m a -> Unravel p m a + +instance ThreadsEff (ReaderT i) (Unravel p) where + threadEff alg (Unravel p cataM main) = ReaderT $ \i -> + alg $ Unravel p (cataM . lift) (runReaderT main i) + {-# INLINE threadEff #-} + +instance ThreadsEff (ExceptT e) (Unravel p) where + threadEff alg (Unravel p cataM (ExceptT main)) = lift $ + alg $ Unravel p (cataM . lift) (fmap (cataM . ExceptT . pure) main) + {-# INLINE threadEff #-} + +-- NOTE: These instances have very unintuitive semantics, so +-- we don't make them available. +{- +instance ThreadsEff (LSt.StateT s) (Unravel p) where + threadEff alg (Unravel p cataM main) = LSt.StateT $ \s -> + fmap (, s) $ + alg $ Unravel p + (cataM . lift) + ( (\t -> cataM (LSt.StateT $ \_ -> pure t)) + <$> LSt.runStateT main s + ) + {-# INLINE threadEff #-} + +instance ThreadsEff (SSt.StateT s) (Unravel p) where + threadEff alg (Unravel p cataM main) = SSt.StateT $ \s -> + fmap (, s) $ + alg $ Unravel p + (cataM . lift) + ( (\t -> cataM (SSt.StateT $ \_ -> pure t)) + <$> SSt.runStateT main s + ) + {-# INLINE threadEff #-} + +instance Monoid w => ThreadsEff (LWr.WriterT w) (Unravel p) where + threadEff alg (Unravel p cataM main) = lift $ + alg $ Unravel p + (cataM . lift) + ( (\t -> cataM (LWr.WriterT $ pure t)) + <$> LWr.runWriterT main + ) + {-# INLINE threadEff #-} + +instance Monoid w => ThreadsEff (SWr.WriterT w) (Unravel p) where + threadEff alg (Unravel p cataM main) = lift $ + alg $ Unravel p + (cataM . lift) + ( (\t -> cataM (SWr.WriterT $ pure t)) + <$> SWr.runWriterT main + ) + {-# INLINE threadEff #-} + +instance Monoid w => ThreadsEff (CPSWr.WriterT w) (Unravel p) where + threadEff alg (Unravel p cataM main) = lift $ + alg $ Unravel p + (cataM . lift) + ( (\t -> cataM (CPSWr.writerT $ pure t)) + <$> CPSWr.runWriterT main + ) + {-# INLINE threadEff #-} +-}
+ src/Control/Effect/Type/WriterPrim.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE CPP #-} +module Control.Effect.Type.WriterPrim + ( -- * Effects + WriterPrim(..) + + -- * Threading utilities + , threadWriterPrim + , threadWriterPrimViaClass + + -- * Combinators for 'Algebra's + -- Intended to be used for custom 'Control.Effect.Carrier' instances when + -- defining 'algPrims'. + , algListenPrimIntoWriterPrim + ) where + +import Control.Monad.Trans +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Except (ExceptT) +import qualified Control.Monad.Trans.State.Strict as SSt +import qualified Control.Monad.Trans.State.Lazy as LSt +import qualified Control.Monad.Trans.Writer.Lazy as LWr +import qualified Control.Monad.Trans.Writer.Strict as SWr +import qualified Control.Monad.Trans.Writer.CPS as CPSWr +import Control.Monad.Writer.Class +import Control.Effect.Internal.ViaAlg +import Control.Effect.Internal.Reflection +import Control.Effect.Internal.Union +import Control.Effect.Type.ListenPrim + +-- | A primitive effect that may be used for +-- interpreters of connected 'Control.Effect.Writer.Tell', +-- 'Control.Effect.Writer.Listen', and 'Control.Effect.Writer.Pass' effects. +-- +-- This combines 'Control.Effect.Writer.Tell' and +-- 'Control.Effect.Writer.Listen' and 'Control.Effect.Writer.Pass'. +-- This may be relevant if there are monad transformers that may only lift +-- 'Control.Effect.Writer.pass' if they also have access to +-- 'Control.Effect.Writer.listen' and 'Control.Effect.Writer.tell'. +-- +-- __'WriterPrim' is only used as a primitive effect.__ +-- If you define a 'Control.Effect.Carrier' that relies on a novel +-- non-trivial monad transformer @t@, then you need to make +-- a @'Monoid' w => 'ThreadsEff' t ('WriterPrim' w)@ instance (if possible). +-- 'threadWriterPrim' and 'threadWriterPrimViaClass' can help you with that. +-- +-- The following threading constraints accept 'WriterPrim': +-- +-- * 'Control.Effect.ReaderThreads' +-- * 'Control.Effect.State.StateThreads' +-- * 'Control.Effect.State.StateLazyThreads' +-- * 'Control.Effect.Error.ErrorThreads' +-- * 'Control.Effect.Writer.WriterThreads' +-- * 'Control.Effect.Writer.WriterLazyThreads' +-- * 'Control.Effect.NonDet.NonDetThreads' +data WriterPrim w m a where + WriterPrimTell :: w -> WriterPrim w m () + WriterPrimListen :: m a -> WriterPrim w m (w, a) + WriterPrimPass :: m (w -> w, a) -> WriterPrim w m a + +-- | Construct a valid definition of 'threadEff' for a +-- @'ThreadsEff' t ('WriterPrim' w)@ instance only be specifying how +-- 'WriterPrimPass' should be lifted. +-- +-- This relies on an existing @'ThreadsEff' t ('ListenPrim' w)@ instance. +threadWriterPrim :: forall w t m a + . ( MonadTrans t + , ThreadsEff t (ListenPrim w) + , Monad m + ) + => ( (forall x. WriterPrim w m x -> m x) + -> t m (w -> w, a) -> t m a + ) + -> (forall x. WriterPrim w m x -> m x) + -> WriterPrim w (t m) a -> t m a +threadWriterPrim h alg = \case + WriterPrimTell w -> lift (alg (WriterPrimTell w)) + WriterPrimListen m -> (`threadEff` (ListenPrimListen m)) $ \case + ListenPrimTell w -> alg (WriterPrimTell w) + ListenPrimListen m' -> alg (WriterPrimListen m') + WriterPrimPass m -> h alg m +{-# INLINE threadWriterPrim #-} + +instance ( Reifies s (ReifiedEffAlgebra (WriterPrim w) m) + , Monoid w + , Monad m + ) + => MonadWriter w (ViaAlg s (WriterPrim w) m) where + tell w = case reflect @s of + ReifiedEffAlgebra alg -> coerceAlg alg (WriterPrimTell w) + {-# INLINE tell #-} + + listen m = case reflect @s of + ReifiedEffAlgebra alg -> + fmap (\(s, a) -> (a, s)) $ coerceAlg alg (WriterPrimListen m) + {-# INLINE listen #-} + + pass m = case reflect @s of + ReifiedEffAlgebra alg -> + coerceAlg alg (WriterPrimPass (fmap (\(a,f) -> (f, a)) m)) + {-# INLINE pass #-} + +-- | A valid definition of 'threadEff' for a +-- @'Monoid' w => 'ThreadsEff' ('WriterPrim' w) t@ instance, +-- given that @t@ lifts @'MonadWriter' w@. +threadWriterPrimViaClass :: forall w t m a + . (Monoid w, MonadTrans t, Monad m) + => ( RepresentationalT t + , forall b. MonadWriter w b => MonadWriter w (t b) + ) + => (forall x. WriterPrim w m x -> m x) + -> WriterPrim w (t m) a -> t m a +threadWriterPrimViaClass alg = \case + WriterPrimTell w -> lift (alg (WriterPrimTell w)) + WriterPrimListen m -> + reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) -> + unViaAlgT + $ fmap (\(f, a) -> (a, f)) + $ listen + $ viaAlgT @s @(WriterPrim w) m + WriterPrimPass m -> + reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) -> + unViaAlgT + $ pass + $ fmap (\(f, a) -> (a, f)) + $ viaAlgT @s @(WriterPrim w) m +{-# INLINE threadWriterPrimViaClass #-} + +#define THREAD_WRITERPRIM(monadT) \ +instance Monoid threadedMonoid \ + => ThreadsEff (monadT) (WriterPrim threadedMonoid) where \ + threadEff = threadWriterPrimViaClass; \ + {-# INLINE threadEff #-} + +THREAD_WRITERPRIM(ReaderT i) +THREAD_WRITERPRIM(ExceptT e) +THREAD_WRITERPRIM(LSt.StateT s) +THREAD_WRITERPRIM(SSt.StateT s) + +instance Monoid s => ThreadsEff (LWr.WriterT s) (WriterPrim w) where + threadEff = threadWriterPrim $ \alg m -> + LWr.WriterT + $ alg + $ WriterPrimPass + $ fmap (\((f,a), s) -> (f, (a, s))) + $ LWr.runWriterT m + {-# INLINE threadEff #-} + +instance Monoid s => ThreadsEff (SWr.WriterT s) (WriterPrim w) where + threadEff = threadWriterPrim $ \alg m -> + SWr.WriterT + $ alg + $ WriterPrimPass + $ fmap (\((f,a), s) -> (f, (a, s))) + $ SWr.runWriterT m + {-# INLINE threadEff #-} + +instance Monoid s => ThreadsEff (CPSWr.WriterT s) (WriterPrim w) where + threadEff = threadWriterPrim $ \alg m -> + CPSWr.writerT + $ alg + $ WriterPrimPass + $ fmap (\((f,a), s) -> (f, (a, s))) + $ CPSWr.runWriterT m + {-# INLINE threadEff #-} + +-- | Rewrite an 'Algebra' where the topmost effect is 'ListenPrim' into +-- an 'Algebra' where the topmost effect is 'WriterPrim' by providing +-- an implementation of 'WriterPrimPass'. +algListenPrimIntoWriterPrim :: Algebra' (ListenPrim w ': p) m a + -> (m (w -> w, a) -> m a) + -> Algebra' (WriterPrim w ': p) m a +algListenPrimIntoWriterPrim alg h = powerAlg (weakenAlg alg) $ \case + WriterPrimTell w -> (alg . inj) (ListenPrimTell w) + WriterPrimListen m -> (alg . inj) (ListenPrimListen m) + WriterPrimPass m -> h m +{-# INLINE algListenPrimIntoWriterPrim #-}
+ src/Control/Effect/Union.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE DerivingVia #-}+module Control.Effect.Union+ ( -- * Effects+ Union(..)+ , ElemOf(..)++ -- * Actions+ , unionize++ , unionizeHead++ -- * Interpretations+ , runUnion++ -- * Utilities+ , inj+ , decomp+ , extract+ , weaken+ , absurdU+ , absurdMember+ , membership++ -- * Carriers+ , UnionizeC+ , UnionizeHeadC+ , UnionC+ ) where++import Data.Coerce++import Control.Effect++import Control.Effect.Internal+import Control.Effect.Internal.Utils+import Control.Effect.Internal.Union+import Control.Effect.Internal.Derive+import Control.Effect.Internal.Membership+import Control.Effect.Internal.KnownList++-- For coercion purposes+import Control.Monad.Trans.Identity+import Control.Effect.Carrier.Internal.Compose+import Control.Effect.Carrier.Internal.Intro+++newtype UnionC (l :: [Effect]) m a = UnionC { unUnionC :: m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b, MonadBaseControl b+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance ( KnownList l+ , HeadEffs l m+ )+ => Carrier (UnionC l m) where+ type Derivs (UnionC l m) = Union l ': StripPrefix l (Derivs m)+ type Prims (UnionC l m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINEABLE algPrims #-}++ reformulate (n :: forall x. UnionC l m x -> z x) alg =+ let+ algDerivs' :: Algebra (Derivs m) z+ algDerivs' = reformulate @m (n .# UnionC) alg+ in+ powerAlg (weakenAlgN (singList @l) algDerivs') $ \(Union pr e) ->+ algDerivs' (Union (lengthenMembership @(StripPrefix l (Derivs m)) pr) e)+ {-# INLINEABLE reformulate #-}++ algDerivs =+ let+ algD' :: Algebra (Derivs m) (UnionC l m)+ algD' = coerce (algDerivs @m)+ in+ powerAlg (weakenAlgN (singList @l) algD') $ \(Union pr e) ->+ algD' (Union (lengthenMembership @(StripPrefix l (Derivs m)) pr) e)+ {-# INLINEABLE algDerivs #-}++-- | Run an @'Union' b@ effect by placing the effects of @b@ on top of the+-- effect stack.+--+-- @'Derivs' ('UnionC' b m) = Union b ': 'StripPrefix' b ('Derivs' m)@+--+-- @'Prims' ('UnionC' b m) = 'Prims' m@+runUnion :: forall b m a+ . ( HeadEffs b m+ , KnownList b+ )+ => UnionC b m a+ -> m a+runUnion = unUnionC+{-# INLINE runUnion #-}++-- | Sends uses of effects in @b@ to a @'Union' b@ effect.+--+-- @'Derivs' (UnionizeC b m) = b ++ 'Derivs' m@+unionize :: ( Eff (Union b) m+ , KnownList b+ )+ => UnionizeC b m a+ -> m a+unionize = unUnionizeC+{-# INLINE unionize #-}++type UnionizeHeadC b = CompositionC+ '[ IntroC b '[Union b]+ , UnionizeC b+ ]+++-- | Rewrite uses of effects in @b@ into a @'Union' b@ effect on top of the effect stack.+--+-- @'Derivs' (UnionizeC b m) = b ++ StripPrefix '['Union' b] 'Derivs' m@+unionizeHead :: ( HeadEff (Union b) m+ , KnownList b+ )+ => UnionizeHeadC b m a+ -> m a+unionizeHead = coerce+{-# INLINE unionizeHead #-}+++newtype UnionizeC b m a = UnionizeC { unUnionizeC :: m a }+ deriving ( Functor, Applicative, Monad+ , Alternative, MonadPlus+ , MonadFix, MonadFail, MonadIO+ , MonadThrow, MonadCatch, MonadMask+ , MonadBase b', MonadBaseControl b'+ )+ deriving (MonadTrans, MonadTransControl) via IdentityT++instance ( KnownList b+ , Eff (Union b) m+ )+ => Carrier (UnionizeC b m) where+ type Derivs (UnionizeC b m) = Append b (Derivs m)+ type Prims (UnionizeC b m) = Prims m++ algPrims = coerce (algPrims @m)+ {-# INLINE algPrims #-}++ reformulate n alg (Union pr e) =+ case splitMembership @(Derivs m) (singList @b) pr of+ Left pr' -> reformulate (n .# UnionizeC) alg $ inj (Union pr' e)+ Right pr' -> reformulate (n .# UnionizeC) alg (Union pr' e)+ {-# INLINE reformulate #-}++ algDerivs (Union pr e) =+ case splitMembership @(Derivs m) (singList @b) pr of+ Left pr' -> UnionizeC $ algDerivs @m $ inj (Union pr' e)+ Right pr' -> UnionizeC $ algDerivs @m (Union pr' e)+ {-# INLINE algDerivs #-}
+ src/Control/Effect/Unlift.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DerivingVia #-}+module Control.Effect.Unlift+ ( -- * Effects+ Unlift(..)++ -- * Actions+ , unlift++ -- * Interpretations+ , MonadBaseControlPure+ , unliftToFinal++ , runUnlift++ -- * Threading utilities+ , threadUnliftViaClass++ -- * Combinators for 'Algebra's+ -- Intended to be used for custom 'Carrier' instances when+ -- defining 'algPrims'.+ , powerAlgUnlift+ , powerAlgUnliftFinal++ -- * Carriers+ , UnliftToFinalC+ , UnliftC+ ) where++import Control.Effect+import Control.Effect.Carrier+import Control.Effect.Internal.Unlift++import Control.Effect.Type.Unlift++unlift :: Eff (Unlift b) m => ((forall x. m x -> b x) -> b a) -> m a+unlift main = send (Unlift main)+{-# INLINE unlift #-}++-- | Run a @'Unlift' m@ effect, where the unlifted monad @m@ is the+-- current monad.+--+-- @'Derivs' ('UnliftC' m) = 'Unlift' m ': 'Derivs' m@+--+-- @'Prims' ('UnliftC' m) = 'Unlift' m ': 'Prims' m@+runUnlift :: Carrier m+ => UnliftC m a+ -> m a+runUnlift = unUnliftC+{-# INLINE runUnlift #-}++data UnliftToFinalH++instance ( MonadBaseControlPure b m+ , Carrier m+ )+ => PrimHandler UnliftToFinalH (Unlift b) m where+ effPrimHandler (Unlift main) = unliftBase main+ {-# INLINEABLE effPrimHandler #-}++type UnliftToFinalC b = InterpretPrimC UnliftToFinalH (Unlift b)++-- | Run a @'Unlift' b@ effect, where the unlifted monad @b@ is the+-- final base monad of @m@+--+-- @'Derivs' ('UnliftToFinalC' b m) = 'Unlift' b ': 'Derivs' m@+--+-- @'Prims' ('UnliftToFinalC' b m) = 'Unlift' b ': 'Prims' m@+unliftToFinal :: ( MonadBaseControlPure b m+ , Carrier m+ )+ => UnliftToFinalC b m a+ -> m a+unliftToFinal = interpretPrimViaHandler+{-# INLINE unliftToFinal #-}++-- | Strengthen an @'Algebra' p m@ by adding a @'Unlift' m@ handler+powerAlgUnlift :: forall m p a+ . Algebra' p m a+ -> Algebra' (Unlift m ': p) m a+powerAlgUnlift alg = powerAlg alg $ \case+ Unlift main -> main id+{-# INLINE powerAlgUnlift #-}++-- | Strengthen an @'Algebra' p m@ by adding a @'Unlift' b@ handler, where+-- @b@ is the final base monad.+powerAlgUnliftFinal :: forall b m p a+ . MonadBaseControlPure b m+ => Algebra' p m a+ -> Algebra' (Unlift b ': p) m a+powerAlgUnliftFinal alg = powerAlg alg $ \case+ Unlift main -> unliftBase main+{-# INLINE powerAlgUnliftFinal #-}
+ src/Control/Effect/Writer.hs view
@@ -0,0 +1,1035 @@+{-# LANGUAGE BlockArguments, DerivingVia #-}+module Control.Effect.Writer+ ( -- * Effects+ Tell(..)+ , Listen(..)+ , Pass(..)+ , Writer++ -- * Actions+ , tell+ , listen+ , pass+ , censor++ -- * Interpretations for 'Tell'+ , runTell++ , runTellLazy++ , runTellList++ , runTellListLazy++ , tellToIO+ , runTellIORef+ , runTellTVar++ , tellIntoEndoTell++ , tellToTell+ , tellIntoTell++ -- * Simple variants of interpretations for 'Tell'+ , tellToIOSimple+ , runTellIORefSimple+ , runTellTVarSimple++ , tellToTellSimple+ , tellIntoTellSimple++ -- * Interpretations for 'Tell' + 'Listen'+ , runListen++ , runListenLazy++ , listenToIO+ , runListenTVar++ , listenIntoEndoListen++ -- * Interpretations for 'Writer' ('Tell' + 'Listen' + 'Pass')+ , runWriter++ , runWriterLazy++ , writerToIO+ , runWriterTVar++ , writerToBracket+ , writerToBracketTVar++ , writerIntoEndoWriter++ -- * Other utilities+ , fromEndoWriter++ -- * Threading constraints+ , WriterThreads+ , WriterLazyThreads++ -- * MonadMask+ , C.MonadMask++ -- * Carriers+ , TellC+ , TellLazyC+ , TellListC+ , TellListLazyC+ , TellIntoEndoTellC+ , ListenC+ , ListenLazyC+ , ListenTVarC+ , ListenIntoEndoListenC+ , WriterC+ , WriterLazyC+ , WriterTVarC+ , WriterToBracketC+ , WriterIntoEndoWriterC+ ) where++import Data.Bifunctor+import Data.Semigroup+import Data.Tuple (swap)+import Data.IORef++import Control.Concurrent.STM++import Control.Monad++import Control.Effect+import Control.Effect.Reader+import Control.Effect.Bracket+import Control.Effect.Type.ListenPrim+import Control.Effect.Type.WriterPrim++import Control.Effect.Carrier+import Control.Effect.Internal.Writer++import qualified Control.Monad.Catch as C++import qualified Control.Monad.Trans.Writer.CPS as W+import qualified Control.Monad.Trans.Writer.Lazy as LW++-- For coercion purposes+import Control.Effect.Internal.Utils+import Control.Effect.Carrier.Internal.Interpret+import Control.Effect.Carrier.Internal.Compose+import Control.Effect.Carrier.Internal.Intro+import Control.Monad.Trans.Identity++-- | A pseudo-effect for connected @'Tell' s@, @'Listen' s@ and @'Pass' s@ effects.+--+-- @'Writer'@ should only ever be used inside of 'Eff' and 'Effs'+-- constraints. It is not a real effect! See 'Bundle'.+type Writer s = Bundle '[Tell s, Listen s, Pass s]++tell :: Eff (Tell s) m => s -> m ()+tell = send . Tell+{-# INLINE tell #-}++listen :: Eff (Listen s) m => m a -> m (s, a)+listen = send . Listen+{-# INLINE listen #-}++pass :: Eff (Pass s) m => m (s -> s, a) -> m a+pass = send . Pass+{-# INLINE pass #-}++censor :: Eff (Pass s) m => (s -> s) -> m a -> m a+censor f = pass . fmap ((,) f)+{-# INLINE censor #-}+++data TellListH++type TellListC s = CompositionC+ '[ ReinterpretC TellListH (Tell s) '[Tell (Dual [s])]+ , TellC (Dual [s])+ ]++instance Eff (Tell (Dual [s])) m+ => Handler TellListH (Tell s) m where+ effHandler (Tell s) = tell (Dual [s])+ {-# INLINEABLE effHandler #-}++-- | Run a @'Tell' s@ by gathering the 'tell's into a list.+--+-- The resulting list is produced strictly. See 'runTellListLazy' for a lazy+-- variant.+runTellList :: forall s m a p+ . ( Carrier m+ , Threaders '[WriterThreads] m p+ )+ => TellListC s m a+ -> m ([s], a)+runTellList =+ (fmap . first) (reverse .# getDual)+ . runTell+ .# reinterpretViaHandler+ .# runComposition+{-# INLINE runTellList #-}++data TellListLazyH++type TellListLazyC s = CompositionC+ '[ ReinterpretC TellListLazyH (Tell s) '[Tell (Endo [s])]+ , TellLazyC (Endo [s])+ ]++instance Eff (Tell (Endo [s])) m+ => Handler TellListLazyH (Tell s) m where+ effHandler (Tell s) = tell (Endo (s:))+ {-# INLINEABLE effHandler #-}++-- | Run a @'Tell' s@ by gathering the 'tell's into a list.+--+-- This is a variant of 'runTellList' that produces the+-- final list lazily. __Use this only if you need__+-- __the laziness, as this would otherwise incur an unneccesary space leak.__+runTellListLazy :: forall s m a p+ . ( Carrier m+ , Threaders '[WriterLazyThreads] m p+ )+ => TellListLazyC s m a+ -> m ([s], a)+runTellListLazy =+ fromEndoWriter+ . runTellLazy+ .# reinterpretViaHandler+ .# runComposition+{-# INLINE runTellListLazy #-}+++-- | Run a @'Tell' s@ effect, where @s@ is a 'Monoid', by accumulating+-- all the uses of 'tell'.+--+-- You may want to combine this with 'tellIntoTell'.+--+-- Unlike 'runListen' and 'runWriter', this does not provide the ability to+-- interact with the 'tell's through 'listen' and 'pass'; but also doesn't+-- impose any primitive effects, meaning 'runTell' doesn't restrict what+-- interpreters are run before it.+--+-- @'Derivs' ('TellC' s m) = 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('TellC' s m) = 'Prims' m@+--+-- This produces the final accumulation @s@ strictly. See 'runTellLazy' for a+-- lazy variant of this.+runTell :: forall s m a p+ . ( Monoid s+ , Carrier m+ , Threaders '[WriterThreads] m p+ )+ => TellC s m a+ -> m (s, a)+runTell (TellC m) = do+ (a, s) <- W.runWriterT m+ return (s, a)+{-# INLINE runTell #-}++-- | Run connected @'Listen' s@ and @'Tell' s@ effects, where @s@ is a 'Monoid',+-- by accumulating all the uses of 'tell'.+--+-- Unlike 'runWriter', this does not provide the power of 'pass'; but because+-- of that, it also doesn't impose 'Pass' as a primitive effect, meaning+-- a larger variety of interpreters may be run before 'runListen' compared to+-- 'runWriter'.+--+-- @'Derivs' ('ListenC' s m) = 'Listen' s ': 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('ListenC' s m) = 'ListenPrim' s ': 'Prims' m@+--+-- This produces the final accumulation strictly. See 'runListenLazy' for a+-- lazy variant of this.+runListen :: forall s m a p+ . ( Monoid s+ , Carrier m+ , Threaders '[WriterThreads] m p+ )+ => ListenC s m a+ -> m (s, a)+runListen (ListenC m) = do+ (a, s) <- W.runWriterT m+ return (s, a)+{-# INLINE runListen #-}++-- | Run connected @'Pass' s@, @'Listen' s@ and @'Tell' s@ effects,+-- -- i.e. @'Writer' s@ -- where @s@ is a 'Monoid', by accumulating all the+-- uses of 'tell'.+--+-- @'Pass' s@ is a fairly restrictive primitive effect. Notably,+-- 'Control.Effect.Cont.runCont' can't be used before 'runWriter'.+-- If you don't need 'pass', consider using 'runTell' or 'runListen' instead.+--+-- @'Derivs' ('WriterC' s m) = 'Pass' s ': 'Listen' s ': 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('WriterC' s m) = 'WriterPrim' s ': 'Prims' m@+--+-- This produces the final accumulation strictly. See 'runWriterLazy' for a+-- lazy variant of this.+runWriter :: forall s m a p+ . ( Monoid s+ , Carrier m+ , Threaders '[WriterThreads] m p+ )+ => WriterC s m a+ -> m (s, a)+runWriter (WriterC m) = do+ (a, s) <- W.runWriterT m+ return (s, a)+{-# INLINE runWriter #-}+++-- | Run a @'Tell' s@ effect, where @s@ is a 'Monoid', by accumulating all the+-- uses of 'tell' lazily.+--+-- @'Derivs' ('TellLazyC' s m) = 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('TellLazyC' s m) = 'Prims' m@+--+-- This is a variant of 'runTell' that produces the final accumulation+-- lazily. __Use this only if you need__+-- __the laziness, as this would otherwise incur an unneccesary space leak.__+runTellLazy :: forall s m a p+ . ( Monoid s+ , Carrier m+ , Threaders '[WriterLazyThreads] m p+ )+ => TellLazyC s m a+ -> m (s, a)+runTellLazy (TellLazyC m) = swap <$> LW.runWriterT m+{-# INLINE runTellLazy #-}++-- | Run connected @'Listen' s@ and @'Tell' s@ effects,+-- where @s@ is a 'Monoid', by accumulating all the uses of 'tell' lazily.+--+-- @'Derivs' ('ListenLazyC' s m) = 'Listen' s ': 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('ListenLazyC' s m) = 'ListenPrim' s ': 'Prims' m@+--+-- This is a variant of 'runListen' that produces the+-- final accumulation lazily. __Use this only if you need__+-- __the laziness, as this would otherwise incur an unneccesary space leak.__+runListenLazy :: forall s m a p+ . ( Monoid s+ , Carrier m+ , Threaders '[WriterThreads] m p+ )+ => ListenLazyC s m a+ -> m (s, a)+runListenLazy (ListenLazyC m) = swap <$> LW.runWriterT m+{-# INLINE runListenLazy #-}++-- | Run connected @'Pass' s@, @'Listen' s@ and @'Tell' s@ effects,+-- -- i.e. @'Writer' s@ -- where @s@ is a 'Monoid',+-- by accumulating all the uses of 'tell' lazily.+--+-- @'Derivs' ('ListenLazyC' s m) = 'Pass' s ': 'Listen' s ': 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('ListenLazyC' s m) = 'WriterPrim' s ': 'Prims' m@+--+-- This is a variant of 'runListen' that produces the+-- final accumulation lazily. __Use this only if you need__+-- __the laziness, as this would otherwise incur an unneccesary space leak.__+runWriterLazy :: forall s m a p+ . ( Monoid s+ , Carrier m+ , Threaders '[WriterLazyThreads] m p+ )+ => WriterLazyC s m a+ -> m (s, a)+runWriterLazy (WriterLazyC m) = swap <$> LW.runWriterT m+{-# INLINE runWriterLazy #-}++tellTVar :: ( Monoid s+ , Effs '[Reader (s -> STM ()), Embed IO] m+ )+ => s+ -> m ()+tellTVar o = do+ write <- ask+ embed $ atomically $ write o+{-# INLINE tellTVar #-}+++data WriterToEndoWriterH++instance (Monoid s, Eff (Tell (Endo s)) m)+ => Handler WriterToEndoWriterH (Tell s) m where+ effHandler (Tell s) = tell (Endo (s <>))+ {-# INLINEABLE effHandler #-}++instance (Monoid s, Eff (Listen (Endo s)) m)+ => Handler WriterToEndoWriterH (Listen s) m where+ effHandler (Listen m) =+ (fmap . first) (\(Endo f) -> f mempty) $ listen m+ {-# INLINEABLE effHandler #-}++instance (Monoid s, Eff (Pass (Endo s)) m)+ => Handler WriterToEndoWriterH (Pass s) m where+ effHandler (Pass m) =+ pass $+ (fmap . first)+ (\f (Endo ss) -> let !s' = f (ss mempty) in Endo (s' <>))+ m+ {-# INLINEABLE effHandler #-}++fromEndoWriter :: (Monoid s, Functor f)+ => f (Endo s, a)+ -> f (s, a)+fromEndoWriter = (fmap . first) (\(Endo f) -> f mempty)+{-# INLINE fromEndoWriter #-}++type TellIntoEndoTellC s =+ ReinterpretC WriterToEndoWriterH (Tell s) '[Tell (Endo s)]++-- | Rewrite a @'Tell' s@ effect into a @'Tell' ('Endo' s)@ effect.+--+-- This effectively right-associates all uses of 'tell', which+-- asymptotically improves performance if the time complexity of '<>' for the+-- 'Monoid' depends only on the size of the first argument.+-- In particular, you should use this (if you can be bothered) if the monoid+-- is a list, such as 'String'.+--+-- Usage is to combine this with the 'Tell' interpreter of your choice, followed+-- by 'fromEndoWriter', like this:+--+-- @+-- 'run'+-- $ ...+-- $ 'fromEndoWriter'+-- $ 'runTell'+-- $ 'tellIntoEndoTell' \@String -- The 'Monoid' must be specified+-- $ ...+-- @+tellIntoEndoTell :: ( Monoid s+ , HeadEff (Tell (Endo s)) m+ )+ => TellIntoEndoTellC s m a+ -> m a+tellIntoEndoTell = reinterpretViaHandler+{-# INLINE tellIntoEndoTell #-}++type ListenIntoEndoListenC s = CompositionC+ '[ IntroC '[Listen s, Tell s] '[Listen (Endo s), Tell (Endo s)]+ , InterpretC WriterToEndoWriterH (Listen s)+ , InterpretC WriterToEndoWriterH (Tell s)+ ]++-- | Rewrite connected @'Listen' s@ and @'Tell' s@ effects into+-- connected @'Listen' ('Endo' s)@ and @'Tell' ('Endo' s)@ effects.+--+-- This effectively right-associates all uses of 'tell', which+-- asymptotically improves performance if the time complexity of '<>' for the+-- 'Monoid' depends only on the size of the first argument.+-- In particular, you should use this (if you can be bothered) if the monoid+-- is a list, such as String.+--+-- Usage is to combine this with the 'Listen' interpreter of your choice,+-- followed by 'fromEndoWriter', like this:+--+-- @+-- 'run'+-- $ ...+-- $ 'fromEndoWriter'+-- $ 'runListen'+-- $ 'listenIntoEndoListen' \@String -- The 'Monoid' must be specified+-- $ ...+-- @+--+listenIntoEndoListen :: ( Monoid s+ , HeadEffs '[Listen (Endo s), Tell (Endo s)] m+ )+ => ListenIntoEndoListenC s m a+ -> m a+listenIntoEndoListen =+ interpretViaHandler+ .# interpretViaHandler+ .# introUnderMany+ .# runComposition+{-# INLINE listenIntoEndoListen #-}++type WriterIntoEndoWriterC s = CompositionC+ '[ IntroC '[Pass s, Listen s, Tell s]+ '[Pass (Endo s), Listen (Endo s), Tell (Endo s)]+ , InterpretC WriterToEndoWriterH (Pass s)+ , InterpretC WriterToEndoWriterH (Listen s)+ , InterpretC WriterToEndoWriterH (Tell s)+ ]++-- | Rewrite connected @'Pass' s@, @'Listen' s@ and @'Tell' s@ effects+-- -- i.e. @'Writer' s@ -- into connected @'Pass' ('Endo' s)@,+-- @'Listen' ('Endo' s)@ and @'Tell' (Endo s)@ effects on top of the effect+-- stack -- i.e. @'Writer' (Endo s)@.+--+-- This effectively right-associates all uses of 'tell', which+-- asymptotically improves performance if the time complexity of '<>' for the+-- 'Monoid' depends only on the size of the first argument.+-- In particular, you should use this (if you can be bothered) if the+-- monoid is a list, such as String.+--+-- Usage is to combine this with the 'Writer' interpreter of your choice,+-- followed by 'fromEndoWriter', like this:+--+-- @+-- 'run'+-- $ ...+-- $ 'fromEndoWriter'+-- $ 'runWriter'+-- $ 'writerIntoEndoWriter' \@String -- The 'Monoid' must be specified+-- $ ...+-- @+writerIntoEndoWriter :: ( Monoid s+ , HeadEffs+ '[Pass (Endo s), Listen (Endo s), Tell (Endo s)]+ m+ )+ => WriterIntoEndoWriterC s m a+ -> m a+writerIntoEndoWriter =+ interpretViaHandler+ .# interpretViaHandler+ .# interpretViaHandler+ .# introUnderMany+ .# runComposition+{-# INLINE writerIntoEndoWriter #-}++-- | Transform a 'Tell' effect into another 'Tell' effect by providing a function+-- to transform the type told.+--+-- This is useful to transform a @'Tell' s@ effect where @s@ isn't a 'Monoid'+-- into a @'Tell' t@ effect where @@ _is_ a 'Monoid', and thus can be+-- interpreted using the various 'Monoid'al 'Tell' interpreters.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'tellToTell' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'tellToTellSimple', which doesn't have a higher-rank type.+tellToTell :: forall s t m a+ . Eff (Tell t) m+ => (s -> t)+ -> InterpretReifiedC (Tell s) m a+ -> m a+tellToTell f = interpret $ \case+ Tell s -> tell (f s)+{-# INLINE tellToTell #-}++-- | Transform a 'Tell' effect into another 'Tell' effect by providing a function+-- to transform the type told.+--+-- This is useful to transform a @'Tell' s@ where @s@ isn't a 'Monoid' into a+-- @'Tell' t@ effect where @@ _is_ a 'Monoid', and thus can be interpreted using+-- the various 'Monoid'al 'Tell' interpreters.+--+-- This is a less performant version of 'tellToTell' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+tellToTellSimple :: forall s t m a p+ . ( Eff (Tell t) m+ , Threaders '[ReaderThreads] m p+ )+ => (s -> t)+ -> InterpretSimpleC (Tell s) m a+ -> m a+tellToTellSimple f = interpretSimple $ \case+ Tell s -> tell (f s)+{-# INLINE tellToTellSimple #-}++-- | Rewrite a 'Tell' effect into another 'Tell' effect on top of the effect+-- stack by providing a function to transform the type told.+--+-- This is useful to rewrite a @'Tell' s@ effect where @s@ isn't a 'Monoid'+-- into a @'Tell' t@ effect where @t@ _is_ a 'Monoid', and thus can be+-- interpreted using the various 'Monoid'al 'Tell' interpreters.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'tellToTell' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'tellIntoTellSimple', which doesn't have a higher-rank type.+tellIntoTell :: forall s t m a+ . HeadEff (Tell t) m+ => (s -> t)+ -> ReinterpretReifiedC (Tell s) '[Tell t] m a+ -> m a+tellIntoTell f = reinterpret $ \case+ Tell s -> tell (f s)+{-# INLINE tellIntoTell #-}++-- | Rewrite a 'Tell' effect into another 'Tell' effect on top of the effect+-- stack by providing a function to transform the type told.+--+-- This is useful to rewrite a @'Tell' s@ effect where @s@ isn't a 'Monoid'+-- into a @'Tell' t@ effect where @@ _is_ a 'Monoid', and thus can be+-- interpreted using the various 'Monoid'al 'Tell' interpreters.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'tellToTell' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'tellIntoTellSimple', which doesn't have a higher-rank type.+--+-- This is a less performant version of 'tellIntoTell' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+tellIntoTellSimple :: forall s t m a p+ . ( HeadEff (Tell t) m+ , Threaders '[ReaderThreads] m p+ )+ => (s -> t)+ -> ReinterpretSimpleC (Tell s) '[Tell t] m a+ -> m a+tellIntoTellSimple f = reinterpretSimple $ \case+ Tell s -> tell (f s)+{-# INLINE tellIntoTellSimple #-}++++listenTVar :: forall s m a+ . ( Monoid s+ , Effs '[Reader (s -> STM ()), Embed IO, Bracket] m+ )+ => m a+ -> m (s, a)+listenTVar main = do+ writeGlobal <- ask+ localVar <- embed $ newTVarIO mempty+ switch <- embed $ newTVarIO True+ let+ writeLocal :: s -> STM ()+ writeLocal o = do+ writeToLocal <- readTVar switch+ when writeToLocal $ do+ s <- readTVar localVar+ writeTVar localVar $! s <> o+ writeGlobal o+ a <- (local (\_ -> writeLocal) main)+ `finally`+ (embed $ atomically $ writeTVar switch False)+ s <- embed $ readTVarIO localVar+ return (s, a)++passTVar :: forall s m a+ . ( Monoid s+ , Effs '[Reader (s -> STM ()), Embed IO, Bracket] m+ )+ => m (s -> s, a)+ -> m a+passTVar main = do+ writeGlobal <- ask+ localVar <- embed $ newTVarIO mempty+ switch <- embed $ newTVarIO True+ let+ writeLocal :: s -> STM ()+ writeLocal o = do+ writeToLocal <- readTVar switch+ if writeToLocal then do+ s <- readTVar localVar+ writeTVar localVar $! s <> o+ else+ writeGlobal o++ commit :: (s -> s) -> IO ()+ commit f = atomically $ do+ notAlreadyCommited <- readTVar switch+ when notAlreadyCommited $ do+ s <- readTVar localVar+ writeGlobal (f s)+ writeTVar switch False++ ((_, a), _) <-+ generalBracket+ (pure ())+ (\_ -> \case+ ExitCaseSuccess (f, _) -> embed (commit f)+ _ -> embed (commit id)+ )+ (\_ -> local (\_ -> writeLocal) main)+ return a++data WriterToBracketH++type WriterToBracketC s = CompositionC+ '[ IntroC '[Pass s, Listen s, Tell s] '[Local (s -> STM ()), Ask (s -> STM ())]+ , InterpretC WriterToBracketH (Pass s)+ , InterpretC WriterToBracketH (Listen s)+ , InterpretC WriterTVarH (Tell s)+ , ReaderC (s -> STM ())+ ]++instance ( Monoid s+ , Effs '[Reader (s -> STM ()), Embed IO, Bracket] m+ )+ => Handler WriterToBracketH (Listen s) m where+ effHandler (Listen m) = listenTVar m+ {-# INLINEABLE effHandler #-}++instance ( Monoid s+ , Effs '[Reader (s -> STM ()), Embed IO, Bracket] m+ )+ => Handler WriterToBracketH (Pass s) m where+ effHandler (Pass m) = passTVar m+ {-# INLINEABLE effHandler #-}++-- | Run connected @'Pass' s@, @'Listen' s@ and @'Tell' s@ effects+-- -- i.e. @'Writer' s@ -- by accumulating uses of 'tell' through using atomic+-- operations in 'IO', relying on the provided protection of 'Bracket' for+-- the implementation.+--+-- @'Derivs' ('WriterToBracketC' s m) = 'Pass' s ': 'Listen' s : 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('WriterToBracketC' s m) = 'Control.Effect.Type.ReaderPrim.ReaderPrim' (s -> STM ()) ': 'Prims' m@+--+-- Note that unlike 'writerToIO', this does not have a higher-rank type.+writerToBracket :: forall s m a p+ . ( Monoid s+ , Effs [Embed IO, Bracket] m+ , Threaders '[ReaderThreads] m p+ )+ => WriterToBracketC s m a+ -> m (s, a)+writerToBracket m = do+ tvar <- embed $ newTVarIO mempty+ a <- writerToBracketTVar tvar m+ s <- embed $ readTVarIO tvar+ return (s, a)+{-# INLINE writerToBracket #-}++-- | Run connected @'Pass' s@, @'Listen' s@ and @'Tell' s@ effects+-- -- i.e. @'Writer' s@ -- by accumulating uses of 'tell' through using atomic+-- operations in 'IO' over a 'TVar', relying on the provided protection+-- of 'Bracket' for the implementation.+--+-- @'Derivs' ('WriterToBracketC' s m) = 'Pass' s ': 'Listen' s : 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('WriterToBracketC' s m) = 'Control.Effect.Type.ReaderPrim.ReaderPrim' (s -> STM ()) ': 'Prims' m@+--+-- Note that unlike 'runTellTVar', this does not have a higher-rank type.+writerToBracketTVar :: forall s m a p+ . ( Monoid s+ , Effs [Embed IO, Bracket] m+ , Threaders '[ReaderThreads] m p+ )+ => TVar s+ -> WriterToBracketC s m a+ -> m a+writerToBracketTVar tvar =+ runReader (\o -> do+ s <- readTVar tvar+ writeTVar tvar $! s <> o+ )+ .# interpretViaHandler+ .# interpretViaHandler+ .# interpretViaHandler+ .# introUnderMany+ .# runComposition+{-# INLINE writerToBracketTVar #-}++data WriterTVarH++type ListenTVarC s = CompositionC+ '[ IntroC '[Listen s, Tell s]+ '[ ListenPrim s+ , Local (s -> STM ())+ , Ask (s -> STM ())+ ]+ , InterpretC WriterTVarH (Listen s)+ , InterpretC WriterTVarH (Tell s)+ , InterpretPrimC WriterTVarH (ListenPrim s)+ , ReaderC (s -> STM ())+ ]++type WriterTVarC s = CompositionC+ '[ IntroC '[Pass s, Listen s, Tell s]+ '[ ListenPrim s+ , WriterPrim s+ , Local (s -> STM ())+ , Ask (s -> STM ())+ ]+ , InterpretC WriterTVarH (Pass s)+ , InterpretC WriterTVarH (Listen s)+ , InterpretC WriterTVarH (Tell s)+ , InterpretC WriterTVarH (ListenPrim s)+ , InterpretPrimC WriterTVarH (WriterPrim s)+ , ReaderC (s -> STM ())+ ]++instance ( Monoid s+ , Effs '[Reader (s -> STM ()), Embed IO] m+ )+ => Handler WriterTVarH (Tell s) m where+ effHandler (Tell o) = tellTVar o+ {-# INLINEABLE effHandler #-}++instance Eff (ListenPrim s) m+ => Handler WriterTVarH (Listen s) m where+ effHandler (Listen m) = send $ ListenPrimListen m+ {-# INLINEABLE effHandler #-}++instance Eff (WriterPrim s) m+ => Handler WriterTVarH (Pass s) m where+ effHandler (Pass m) = send $ WriterPrimPass m+ {-# INLINEABLE effHandler #-}++instance Eff (WriterPrim s) m+ => Handler WriterTVarH (ListenPrim s) m where+ effHandler = \case+ ListenPrimTell o -> send $ WriterPrimTell o+ ListenPrimListen m -> send $ WriterPrimListen m+ {-# INLINEABLE effHandler #-}++instance ( Monoid s+ , Effs '[Reader (s -> STM ()), Embed IO] m+ , C.MonadMask m+ )+ => PrimHandler WriterTVarH (ListenPrim s) m where+ effPrimHandler = \case+ ListenPrimTell o -> tellTVar o+ ListenPrimListen m -> bracketToIO (listenTVar (lift m))+ {-# INLINEABLE effPrimHandler #-}++instance ( Monoid s+ , Effs '[Reader (s -> STM ()), Embed IO] m+ , C.MonadMask m+ )+ => PrimHandler WriterTVarH (WriterPrim s) m where+ effPrimHandler = \case+ WriterPrimTell o -> tellTVar o+ WriterPrimListen m -> bracketToIO (listenTVar (lift m))+ WriterPrimPass m -> bracketToIO (passTVar (lift m))+ {-# INLINEABLE effPrimHandler #-}++-- | Run a @'Tell' s@ effect where @s@ is a 'Monoid' by accumulating uses of+-- 'tell' through atomic operations in 'IO'.+--+-- You may want to combine this with 'tellIntoTell'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'tellToIO' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'tellToIOSimple', which doesn't have a higher-rank type.+tellToIO :: forall s m a+ . ( Monoid s+ , Eff (Embed IO) m+ )+ => InterpretReifiedC (Tell s) m a+ -> m (s, a)+tellToIO m = do+ ref <- embed $ newIORef mempty+ a <- runTellIORef ref m+ s <- embed $ readIORef ref+ return (s, a)+{-# INLINE tellToIO #-}++-- | Run a @'Tell' s@ effect where @s@ is a 'Monoid' by accumulating uses of+-- 'tell' through using atomic operations in 'IO' over the provided 'IORef'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runTellIORef' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'runTellIORefSimple', which doesn't have a higher-rank type.+runTellIORef :: forall s m a+ . ( Monoid s+ , Eff (Embed IO) m+ )+ => IORef s+ -> InterpretReifiedC (Tell s) m a+ -> m a+runTellIORef ref = interpret $ \case+ Tell o -> embed $ atomicModifyIORef' ref (\s -> (s <> o, ()))+{-# INLINE runTellIORef #-}++-- | Run a @'Tell' s@ effect where @s@ is a 'Monoid' by accumulating uses of+-- 'tell' through using atomic operations in 'IO' over the provided 'TVar'.+--+-- This has a higher-rank type, as it makes use of 'InterpretReifiedC'.+-- __This makes 'runTellTVar' very difficult to use partially applied.__+-- __In particular, it can't be composed using @'.'@.__+--+-- If performance is secondary, consider using the slower+-- 'runTellTVarSimple', which doesn't have a higher-rank type.+runTellTVar :: forall s m a+ . ( Monoid s+ , Eff (Embed IO) m+ )+ => TVar s+ -> InterpretReifiedC (Tell s) m a+ -> m a+runTellTVar tvar = interpret $ \case+ Tell o -> embed $ atomically $ do+ s <- readTVar tvar+ writeTVar tvar $! s <> o+{-# INLINE runTellTVar #-}++-- | Run a @'Tell' s@ effect where @s@ is a 'Monoid' by accumulating uses of+-- 'tell' through atomic operations in 'IO'.+--+-- You may want to combine this with 'tellIntoTellSimple'.+--+-- This is a less performant version of 'tellToIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+tellToIOSimple :: forall s m a p+ . ( Monoid s+ , Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => InterpretSimpleC (Tell s) m a+ -> m (s, a)+tellToIOSimple m = do+ ref <- embed $ newIORef mempty+ a <- runTellIORefSimple ref m+ s <- embed $ readIORef ref+ return (s, a)+{-# INLINE tellToIOSimple #-}++-- | Run a @'Tell' s@ effect where @s@ is a 'Monoid' by accumulating uses of+-- 'tell' through using atomic operations in 'IO' over the provided 'IORef'.+--+-- This is a less performant version of 'tellToIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runTellIORefSimple :: forall s m a p+ . ( Monoid s+ , Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => IORef s+ -> InterpretSimpleC (Tell s) m a+ -> m a+runTellIORefSimple ref = interpretSimple $ \case+ Tell o -> embed $ atomicModifyIORef' ref (\s -> (s <> o, ()))+{-# INLINE runTellIORefSimple #-}++-- | Run a @'Tell' s@ effect where @s@ is a 'Monoid' by accumulating uses of+-- 'tell' through using atomic operations in 'IO' over the provided 'TVar'.+--+-- This is a less performant version of 'tellToIO' that doesn't have+-- a higher-rank type, making it much easier to use partially applied.+runTellTVarSimple :: forall s m a p+ . ( Monoid s+ , Eff (Embed IO) m+ , Threaders '[ReaderThreads] m p+ )+ => TVar s+ -> InterpretSimpleC (Tell s) m a+ -> m a+runTellTVarSimple tvar = interpretSimple $ \case+ Tell o -> embed $ atomically $ do+ s <- readTVar tvar+ writeTVar tvar $! s <> o+{-# INLINE runTellTVarSimple #-}++-- | Run connected @'Listen' s@ and @'Tell' s@ effects by accumulating uses of+-- 'tell' through using atomic operations in 'IO'.+--+-- @'Derivs' ('ListenTVarC' s m) = 'Listen' s ': 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('ListenTVarC' s m) = 'ListenPrim' s ': 'Control.Effect.Type.ReaderPrim.ReaderPrim' (s -> STM ()) ': 'Prims' m@+--+-- Note that unlike 'tellToIO', this does not have a higher-rank type.+listenToIO :: forall s m a p+ . ( Monoid s+ , Eff (Embed IO) m+ , C.MonadMask m+ , Threaders '[ReaderThreads] m p+ )+ => ListenTVarC s m a+ -> m (s, a)+listenToIO m = do+ tvar <- embed $ newTVarIO mempty+ a <- runListenTVar tvar m+ s <- embed $ readTVarIO tvar+ return (s, a)+{-# INLINE listenToIO #-}++-- | Run connected @'Listen' s@ and @'Tell' s@ effects by accumulating uses of+-- 'tell' through using atomic operations in 'IO' over the provided 'TVar'.+--+-- @'Derivs' ('ListenTVarC' s m) = 'Listen' s : 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('ListenTVarC' s m) = 'ListenPrim' s ': 'Control.Effect.Type.ReaderPrim.ReaderPrim' (s -> STM ()) ': 'Prims' m@+--+-- Note that unlike 'runTellTVar', this does not have a higher-rank type.+runListenTVar :: forall s m a p+ . ( Monoid s+ , Eff (Embed IO) m+ , C.MonadMask m+ , Threaders '[ReaderThreads] m p+ )+ => TVar s+ -> ListenTVarC s m a+ -> m a+runListenTVar tvar =+ runReader (\o -> do+ s <- readTVar tvar+ writeTVar tvar $! s <> o+ )+ .# interpretPrimViaHandler+ .# interpretViaHandler+ .# interpretViaHandler+ .# introUnderMany+ .# runComposition+{-# INLINE runListenTVar #-}++-- | Run connected @'Pass' s@, @'Listen' s@ and @'Tell' s@ effects+-- -- i.e. @'Writer' s@ -- by accumulating uses of 'tell' through using atomic+-- operations in 'IO'.+--+-- @'Derivs' ('WriterTVarC' s m) = 'Pass' s ': 'Listen' s : 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('WriterTVarC' s m) = 'WriterPrim' s ': 'Control.Effect.Type.ReaderPrim.ReaderPrim' (s -> STM ()) ': 'Prims' m@+--+-- Note that unlike 'tellToIO', this does not have a higher-rank type.+writerToIO :: forall s m a p+ . ( Monoid s+ , Eff (Embed IO) m+ , C.MonadMask m+ , Threaders '[ReaderThreads] m p+ )+ => WriterTVarC s m a+ -> m (s, a)+writerToIO m = do+ tvar <- embed $ newTVarIO mempty+ a <- runWriterTVar tvar m+ s <- embed $ readTVarIO tvar+ return (s, a)+{-# INLINE writerToIO #-}++-- | Run connected @'Pass' s@, @'Listen' s@ and @'Tell' s@ effects+-- -- i.e. @'Writer' s@ -- by accumulating uses of 'tell' through using atomic+-- operations in 'IO' over a 'TVar'.+--+-- @'Derivs' ('WriterTVarC' s m) = 'Pass' s ': 'Listen' s : 'Tell' s ': 'Derivs' m@+--+-- @'Prims' ('WriterTVarC' s m) = 'WriterPrim' s ': 'Control.Effect.Type.ReaderPrim.ReaderPrim' (s -> STM ()) ': 'Prims' m@+--+-- Note that unlike 'runTellTVar', this does not have a higher-rank type.+runWriterTVar :: forall s m a p+ . ( Monoid s+ , Eff (Embed IO) m+ , C.MonadMask m+ , Threaders '[ReaderThreads] m p+ )+ => TVar s+ -> WriterTVarC s m a+ -> m a+runWriterTVar tvar =+ runReader (\o -> do+ s <- readTVar tvar+ writeTVar tvar $! s <> o+ )+ .# interpretPrimViaHandler+ .# interpretViaHandler+ .# interpretViaHandler+ .# interpretViaHandler+ .# interpretViaHandler+ .# introUnderMany+ .# runComposition+{-# INLINE runWriterTVar #-}
+ src/Control/Monad/Trans/Free/Church/Alternate.hs view
@@ -0,0 +1,139 @@+module Control.Monad.Trans.Free.Church.Alternate where++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Base+import qualified Control.Monad.Fail as Fail+import Control.Effect.Internal.Union+import Control.Effect.Type.Unravel+import Control.Effect.Type.ListenPrim+import Control.Effect.Type.ReaderPrim+import Control.Effect.Type.Regional+import Control.Effect.Type.Optional+import Control.Monad.Catch hiding (handle)++newtype FreeT f m a = FreeT {+ unFreeT :: forall r+ . (forall x. m x -> (x -> r) -> r)+ -> (forall x. f x -> (x -> r) -> r)+ -> (a -> r) -> r+ }++class (forall f. Threads (FreeT f) p) => FreeThreads p+instance (forall f. Threads (FreeT f) p) => FreeThreads p++liftF :: f a -> FreeT f m a+liftF f = FreeT $ \_ handler c -> f `handler` c+{-# INLINE liftF #-}++foldFreeT :: Monad m+ => (a -> b)+ -> (forall x. (x -> m b) -> f x -> m b)+ -> FreeT f m a+ -> m b+foldFreeT b c free = unFreeT free (>>=) (flip c) (pure . b)+{-# INLINE foldFreeT #-}++instance Functor (FreeT f m) where+ fmap f cnt = FreeT $ \bind handler c ->+ unFreeT cnt bind handler (c . f)+ {-# INLINE fmap #-}++instance Applicative (FreeT f m) where+ pure a = FreeT $ \_ _ c -> c a+ {-# INLINE pure #-}++ ff <*> fa = FreeT $ \bind handler c ->+ unFreeT ff bind handler $ \f ->+ unFreeT fa bind handler (c . f)+ {-# INLINE (<*>) #-}++ liftA2 f fa fb = FreeT $ \bind handler c ->+ unFreeT fa bind handler $ \a ->+ unFreeT fb bind handler (c . f a)+ {-# INLINE liftA2 #-}++ fa *> fb = fa >>= \_ -> fb+ {-# INLINE (*>) #-}++instance Monad (FreeT f m) where+ m >>= f = FreeT $ \bind handler c ->+ unFreeT m bind handler $ \a ->+ unFreeT (f a) bind handler c+ {-# INLINE (>>=) #-}++instance MonadBase b m => MonadBase b (FreeT f m) where+ liftBase = lift . liftBase+ {-# INLINE liftBase #-}++instance Fail.MonadFail m => Fail.MonadFail (FreeT f m) where+ fail = lift . Fail.fail+ {-# INLINE fail #-}++instance MonadTrans (FreeT f) where+ lift m = FreeT $ \bind _ c -> m `bind` c+ {-# INLINE lift #-}++instance MonadIO m => MonadIO (FreeT f m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++instance MonadThrow m => MonadThrow (FreeT f m) where+ throwM = lift . throwM+ {-# INLINE throwM #-}++instance MonadCatch m => MonadCatch (FreeT f m) where+ catch main handle = FreeT $ \bind handler c ->+ unFreeT main+ (\m cn ->+ (`bind` id) $+ fmap cn m+ `catch`+ \e -> pure $ unFreeT (handle e) bind handler c+ )+ handler+ c+ {-# INLINE catch #-}++instance Monoid w => ThreadsEff (FreeT f) (ListenPrim w) where+ threadEff = threadListenPrim $ \alg main -> FreeT $ \bind handler c ->+ unFreeT main+ (\m cn acc ->+ alg (ListenPrimListen m) `bind` \(s, a) ->+ cn a $! acc <> s+ )+ (\eff cn acc -> handler eff (`cn` acc))+ (\a acc -> c (acc, a))+ mempty+ {-# INLINE threadEff #-}++instance ThreadsEff (FreeT f) (Regional s) where+ threadEff alg (Regionally s m) = FreeT $ \bind handler c ->+ unFreeT m (bind . alg . Regionally s) handler c+ {-# INLINE threadEff #-}++instance Functor s => ThreadsEff (FreeT f) (Optional s) where+ threadEff alg (Optionally sa main) = FreeT $ \bind handler c ->+ unFreeT main+ (\m cn ->+ (`bind` id) $ alg $ Optionally (fmap c sa) (fmap cn m)+ )+ handler+ c+ {-# INLINE threadEff #-}++instance ThreadsEff (FreeT f) (Unravel p) where+ threadEff alg (Unravel p cataM main) =+ unFreeT main+ (\m cn ->+ lift $ alg $ Unravel p+ (cataM . lift)+ (fmap (cataM . cn) m)+ )+ (\f c -> liftF f >>= c)+ return+ {-# INLINE threadEff #-}++instance ThreadsEff (FreeT f) (ReaderPrim i) where+ threadEff = threadReaderPrimViaRegional+ {-# INLINE threadEff #-}
+ src/Control/Monad/Trans/List/Church.hs view
@@ -0,0 +1,200 @@+module Control.Monad.Trans.List.Church where++import Control.Applicative+import Control.Monad.Base+import Control.Monad.Trans+import qualified Control.Monad.Catch as C+import qualified Control.Monad.Fail as Fail++import Control.Effect.Carrier++import Control.Effect.Type.ListenPrim+import Control.Effect.Type.WriterPrim+import Control.Effect.Type.Regional+import Control.Effect.Type.Optional+import Control.Effect.Type.Unravel+import Control.Effect.Type.ReaderPrim++newtype ListT m a = ListT {+ unListT :: forall r+ . (forall x. m x -> (x -> r) -> r)+ -> (a -> r -> r)+ -> r -- lose+ -> r -- cutfail+ -> r+ }++cons :: a -> ListT m a -> ListT m a+cons a m = ListT $ \bind c b t -> c a (unListT m bind c b t)++instance ThreadsEff ListT (Regional s) where+ threadEff alg (Regionally s m) = ListT $ \bind ->+ unListT m (bind . alg . Regionally s)+ {-# INLINE threadEff #-}++instance Functor s => ThreadsEff ListT (Optional s) where+ threadEff alg (Optionally s m) = ListT $ \bind c b ->+ unListT m (\mx cn ->+ (`bind` id) $ alg $+ fmap (`c` b) s+ `Optionally`+ fmap cn mx+ ) c b+ {-# INLINE threadEff #-}++instance ThreadsEff ListT (Unravel p) where+ threadEff alg (Unravel p cataM main) =+ unListT+ main+ (\mx cn -> lift $ alg $+ Unravel p (cataM . lift) (fmap (cataM . cn) mx)+ )+ cons+ lose+ cutfail+ {-# INLINE threadEff #-}++instance Monoid s => ThreadsEff ListT (ListenPrim s) where+ threadEff = threadListenPrim $ \alg main -> ListT $ \bind c b t ->+ unListT+ main+ (\mx cn acc -> alg (ListenPrimListen mx) `bind` \(s, a) ->+ let+ !acc' = acc <> s+ in+ cn a acc'+ )+ (\a r acc -> c (acc, a) (r mempty))+ (const b)+ (const t)+ mempty+ {-# INLINE threadEff #-}++instance Monoid s => ThreadsEff ListT (WriterPrim s) where+ threadEff = threadWriterPrim $ \alg main ->+ let+ go' m = m >>= \case+ Empty -> return (id, Empty)+ CutFail -> return (id, CutFail)+ Cons (f, a) r -> return (f, Cons a (go r))+ Embed mx cn -> go' (fmap cn mx)++ go Empty = Empty+ go CutFail = CutFail+ go (Cons (_, a) r) = Cons a (go r)+ go (Embed mx cn) = (`Embed` id) $ alg $ WriterPrimPass $ go' (fmap cn mx)+ in+ fromLayeredListT (go (toLayeredListT main))+ {-# INLINE threadEff #-}++instance ThreadsEff ListT (ReaderPrim i) where+ threadEff = threadReaderPrimViaRegional+ {-# INLINE threadEff #-}++instance MonadBase b m => MonadBase b (ListT m) where+ liftBase = lift . liftBase+ {-# INLINE liftBase #-}++instance Fail.MonadFail m => Fail.MonadFail (ListT m) where+ fail = lift . Fail.fail+ {-# INLINE fail #-}++instance MonadThrow m => MonadThrow (ListT m) where+ throwM = lift . C.throwM+ {-# INLINE throwM #-}++instance MonadCatch m => MonadCatch (ListT m) where+ catch m h = ListT $ \bind c b t ->+ unListT+ m+ (\mx cn -> (`bind` id) $+ fmap cn mx `C.catch` \e -> return $ unListT (h e) bind c b t+ )+ c b t+ {-# INLINE catch #-}++cull :: ListT m a -> ListT m a+cull m = ListT $ \bind c b t -> unListT m bind (\a _ -> c a b) b t++choose :: ListT m a -> ListT m a -> ListT m a+choose ma mb = ListT $ \bind c b t -> unListT ma bind c (unListT mb bind c b t) t++lose :: ListT m a+lose = ListT $ \_ _ b _ -> b++cutfail :: ListT m a+cutfail = ListT $ \_ _ _ t -> t++call :: ListT m a -> ListT m a+call m = ListT $ \bind c b _ -> unListT m bind c b b++data LayeredListT m a where+ Embed :: m x -> (x -> LayeredListT m a) -> LayeredListT m a+ Empty :: LayeredListT m a+ CutFail :: LayeredListT m a+ Cons :: a -> LayeredListT m a -> LayeredListT m a++toLayeredListT :: ListT m a -> LayeredListT m a+toLayeredListT m = unListT m Embed Cons Empty CutFail++split' :: LayeredListT m a -> LayeredListT m (Maybe (a, LayeredListT m a))+split' (Embed mx cn) = Embed mx (split' . cn)+split' Empty = Cons Nothing Empty+split' CutFail = CutFail+split' (Cons a r) = Cons (Just (a, r)) Empty++fromLayeredListT :: LayeredListT m a -> ListT m a+fromLayeredListT m = ListT $ \bind c b t ->+ let+ go (Embed mx cn) = mx `bind` (go . cn)+ go Empty = b+ go CutFail = t+ go (Cons a r) = c a (go r)+ in+ go m++-- split cutfail === cutfail+-- If you don't want that behaviour, instead of @split m@, do @split (call m)@+split :: ListT m a -> ListT m (Maybe (a, ListT m a))+split =+ (fmap . fmap . fmap) fromLayeredListT+ . fromLayeredListT+ . split'+ . toLayeredListT+{-# INLINE split #-}++instance Functor (ListT m) where+ fmap f m = ListT $ \bind c b t ->+ unListT m bind (c . f) b t+ {-# INLINE fmap #-}++instance Applicative (ListT m) where+ pure a = ListT $ \_ c b _ -> c a b+ liftA2 f fa fb = ListT $ \bind c b t ->+ unListT fa bind (\a r -> unListT fb bind (c . f a) r t) b t+ {-# INLINE liftA2 #-}++ ma *> mb = ma >>= \_ -> mb+ {-# INLINE (*>) #-}++instance Monad (ListT m) where+ m >>= f = ListT $ \bind c b t ->+ unListT m bind (\a r -> unListT (f a) bind c r t) b t+ {-# INLINE (>>=) #-}++instance MonadTrans ListT where+ lift m = ListT $ \bind c b _ -> m `bind` (`c` b)+ {-# INLINE lift #-}++instance MonadIO m => MonadIO (ListT m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++runListT :: (Alternative f, Monad m)+ => ListT m a+ -> m (f a)+runListT m =+ unListT m (>>=) (fmap . (<|>) . pure) (pure empty) (pure empty)+{-# INLINE runListT #-}++
+ test/BracketSpec.hs view
@@ -0,0 +1,66 @@+module BracketSpec where++import Test.Hspec++import Control.Concurrent.MVar++import Control.Effect+import Control.Effect.Mask+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Conc+import Control.Effect.Trace+++test1 :: IO ([String], Either () ())+test1 = runM $ runTraceListIO $ errorToIO @() $ bracketToIO $ do+ throw () `onError` trace "protected"++test2 :: IO [String]+test2 = runM $ fmap fst $ runTraceListIO $ maskToIO $ concToIO $ bracketToIO $ do+ a <- mask $ \restore -> async $ do+ restore (embed (newEmptyMVar @()) >>= embed . takeMVar) `onError` trace "protected"+ cancel a++test3 :: IO ([String], Either () ())+test3 = runM $ runTraceListIO $ bracketToIO $ runError $ do+ throw () `onError` trace "protected"++test4 :: IO (Either () [String])+test4 = runM $ runError $ fmap fst $ runTraceListIO $ bracketToIO $ do+ (throw () `onError` trace "protected") `catch` \() -> return ()++test5 :: ([String], Either () ())+test5 = run $ runTraceList $ runBracketLocally $ runError $ do+ throw () `onError` trace "protected"++test6 :: IO ([String], Either () ())+test6 = runM $ runTraceList $ runBracketLocally $ errorToIO $ do+ throw () `onError` trace "protected"++test7 :: Either () [String]+test7 = run $ runError $ fmap fst $ runTraceList $ runBracketLocally $ do+ (throw () `onError` trace "protected") `catch` \() -> return ()++spec :: Spec+spec = do+ describe "bracketToIO" $ do+ it "should protect against IO exceptions" $ do+ res <- test1+ res `shouldBe` (["protected"], Left ())+ it "should protect against asynchronous exceptions" $ do+ res <- test2+ res `shouldBe` ["protected"]+ it "should protect against pure exceptions" $ do+ res3 <- test3+ res3 `shouldBe` (["protected"], Left ())+ res4 <- test4+ res4 `shouldBe` Right ["protected"]++ describe "runBracketLocally" $ do+ it "should protect against pure exceptions of local effects" $ do+ test5 `shouldBe` (["protected"], Left ())+ it "should not protect against global effects" $ do+ res6 <- test6+ res6 `shouldBe` ([], Left ())+ test7 `shouldBe` Right []
+ test/ErrorSpec.hs view
@@ -0,0 +1,43 @@+module ErrorSpec where++import Test.Hspec++import Control.Effect+import Control.Effect.Error+import Control.Effect.Conc+++test1 :: IO (Either () (Either () ()))+test1 = runM $ errorToIO $ errorToIO $ do+ (intro1 . intro1) $ throw () `catch` \() -> return ()++test2 :: IO (Either () (Either () ()))+test2 = runM $ errorToIO $ errorToIO $ do+ (intro1 . intro1) (throw ()) `catch` \() -> return ()++test3 :: IO (Either () ())+test3 = runM $ errorToIO $ concToIO $ do+ a <- async $ throw ()+ wait a++test4 :: IO (Either () ())+test4 = runM $ errorToIO $ concToIO $ do+ a <- async $ throw ()+ wait a `catch` \() -> return ()++spec :: Spec+spec = do+ describe "errorToIO" $ do+ it "should catch/throw exceptions only belonging to \+ \the specific interpreted Error" $ do+ res1 <- test1+ res1 `shouldBe` Right (Right ())++ res2 <- test2+ res2 `shouldBe` Left ()+ it "should propagate exceptions thrown in 'async'ed exceptions" $ do+ res3 <- test3+ res3 `shouldBe` Left ()++ res4 <- test4+ res4 `shouldBe` Right ()
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/NonDetSpec.hs view
@@ -0,0 +1,36 @@+module NonDetSpec where++import Test.Hspec++import Control.Effect+import Control.Effect.Alt+import Control.Effect.NonDet+import Control.Effect.Trace+import Control.Effect.Reader++runAlt :: Alternative f => AltToNonDetC (NonDetC RunC) a -> f a+runAlt = run . runNonDet . altToNonDet++inHigherOrder :: Effs '[NonDet, Trace, Reader ()] m+ => m ()+inHigherOrder = altToNonDet $ do+ local (\_ -> ()) $ trace "1" <|> trace "2"+ trace "3"++spec :: Spec+spec = parallel $ do+ describe "runNonDet" $ do+ it "should choose the first branch" $ do+ runAlt (pure '1' <|> pure '2') `shouldBe` (Just '1')+ it "should failover" $ do+ runAlt (empty <|> pure '2') `shouldBe` (Just '2')+ runAlt (pure '1' <|> empty) `shouldBe` (Just '1')++ it "should NOT have terrible semantics when <|> is used within\+ \ a higher-order action of a later effect!" $ do+ (fst . run . runTraceList . runReader () . runNonDet @[]) inHigherOrder+ `shouldNotBe` ["1","2","3","3"]+ (fst . run . runTraceList . runReader () . runNonDet @[]) inHigherOrder+ `shouldBe` ["1","3","2","3"]+ (fst . run . runTraceList . runNonDet @[] . runReader ()) inHigherOrder+ `shouldBe` ["1","3","2","3"]
+ test/WriterSpec.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+module WriterSpec where++import Test.Hspec++import qualified Control.Concurrent.Async as A+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception (evaluate)++import Control.Effect+import Control.Effect.Conc+import Control.Effect.Error+import Control.Effect.Reader+import Control.Effect.Writer+import Control.Effect.Unlift++censor' :: forall e s a m+ . Effs '[Error e, Writer s] m+ => (s -> s)+ -> m a+ -> m a+censor' f m = do+ res <- censor f $ try m+ case res of+ Right res' -> return res'+ Left e -> throw (e :: e)++test1 :: (String, Either () ())+test1 =+ run+ $ runWriter+ $ runError $ do+ tell "censoring"+ censor @String+ (drop 4)+ (tell " not applied" *> throw ())+ `catch`+ (\(_ :: ()) -> pure ())++test2 :: (String, Either () ())+test2 =+ run+ $ runWriter+ $ runError $+ do+ tell "censoring"+ censor' @() @String+ (drop 4)+ (tell " not applied" *> throw ())+ `catch`+ (\(_ :: ()) -> pure ())++test3 :: (String, (String, ()))+test3 = run . runListen $ listen (tell "and hear")++test4 :: IO (String, String)+test4 = do+ tvar <- newTVarIO ""+ (listened, _) <- runM $ concToIO $ runWriterTVar tvar $ do+ tell "message "+ listen $ do+ tell "has been"+ a <- async $ tell " received"+ wait a+ end <- readTVarIO tvar+ return (end, listened)++test5 :: IO (String, String)+test5 = do+ tvar <- newTVarIO ""+ lock <- newEmptyMVar+ (listened, a) <- runM $ concToIO $ runWriterTVar tvar $ do+ tell "message "+ listen $ do+ tell "has been"+ a <- async $ do+ embed $ takeMVar lock+ tell " received"+ return a+ putMVar lock ()+ _ <- A.wait a+ end <- readTVarIO tvar+ return (end, listened)++test6 :: ( Effs '[Error (Async ()), Embed IO] m+ , Threaders '[ReaderThreads] m p+ , MonadMask m+ , MonadBaseControlPure IO m+ )+ => m String+test6 = do+ tvar <- embed $ newTVarIO ""+ lock <- embed $ newEmptyMVar+ let+ inner = do+ tell "message "+ fmap snd $ listen @String $ do+ tell "has been"+ a <- async $ do+ embed $ takeMVar lock+ tell " received"+ throw a+ concToIO (runWriterTVar tvar inner) `catch` \a ->+ embed $ do+ putMVar lock ()+ () <- A.wait a+ readTVarIO tvar++++spec :: Spec+spec = do+ describe "writer" $ do+ it "should not censor" $ do+ test1 `shouldBe` ("censoring not applied", Right ())++ it "should censor" $ do+ test2 `shouldBe` ("censoring applied", Right ())++ it "should have a proper listen" $ do+ test3 `shouldBe` ("and hear", ("and hear", ()))++ it "should be strict in the output" $+ let+ t1 :: (Carrier m, Threaders '[WriterThreads] m p) => m (String, ())+ t1 = runWriter @String $ do+ tell @String (error "strict")+ return ()++ t2 :: (Carrier m, Threaders '[WriterThreads] m p) => m (String, ())+ t2 = runWriter @String $ do+ _ <- listen @String (tell @String (error "strict"))+ return ()++ t3 :: (Carrier m, Threaders '[WriterThreads] m p) => m (String, ())+ t3 = runWriter @String $ do+ pass @String $ pure (\_ -> error "strict", ())+ return ()+ in do+ runM t1 `shouldThrow` errorCall "strict"+ evaluate (run t1) `shouldThrow` errorCall "strict"+ runM t2 `shouldThrow` errorCall "strict"+ evaluate (run t2) `shouldThrow` errorCall "strict"+ runM t3 `shouldThrow` errorCall "strict"+ evaluate (run t3) `shouldThrow` errorCall "strict"++ describe "runWriterTVar" $ do+ it "should listen and commit asyncs spawned and awaited upon in a listen \+ \block" $ do+ (end, listened) <- test4+ end `shouldBe` "message has been received"+ listened `shouldBe` "has been received"++ it "should commit writes of asyncs spawned inside a listen block even if \+ \the block has finished." $ do+ (end, listened) <- test5+ end `shouldBe` "message has been received"+ listened `shouldBe` "has been"+++ it "should commit writes of asyncs spawned inside a listen block even if \+ \the block failed for any reason." $ do+ Right end1 <- runM $ errorToIO @(Async ()) $ test6+ end1 `shouldBe` "message has been received"++ describe "runLazyWriter" $ do+ let+ runLazily = run . runAskConstSimple () . runWriterLazy @[Int]+ runSemiLazily = runLazily . runError @()+ runStrictly = run . runError @() . runWriterLazy @[Int]+ runStrictlyM = runM . runWriterLazy @[Int]++ act :: Eff (Writer [Int]) m => m ()+ act = do+ tell @[Int] [1]+ tell @[Int] [2]+ error "strict"++ it "should build the final output lazily, if the interpreters after \+ \runLazyWriter and the final monad are lazy" $ do+ (take 2 . fst . runLazily) act `shouldBe` [1,2]+ (take 2 . fst . runSemiLazily) act `shouldBe` [1,2]+ evaluate (runStrictly act) `shouldThrow` errorCall "strict"+ runStrictlyM act `shouldThrow` errorCall "strict"++ it "should listen lazily if all interpreters and final monad are lazy" $ do+ let+ listenAct :: Eff (Writer [Int]) m => m [Int]+ listenAct = do+ (end,_) <- listen @[Int] act+ return (take 2 end)+ (snd . runLazily) listenAct `shouldBe` [1,2]++ evaluate ((snd . runSemiLazily) listenAct) `shouldThrow` errorCall "strict"+ evaluate (runStrictly listenAct) `shouldThrow` errorCall "strict"+ runStrictlyM listenAct `shouldThrow` errorCall "strict"++ it "should censor lazily if all interpreters and final monad are lazy" $ do+ let+ censorAct :: Eff (Writer [Int]) m => m ()+ censorAct = censor @[Int] (\(_:y:_) -> [0,y]) act+ (fst . runLazily) censorAct `shouldBe` [0,2]+ evaluate ((fst . runSemiLazily) censorAct) `shouldThrow` errorCall "strict"+ evaluate (runStrictly censorAct) `shouldThrow` errorCall "strict"+ runStrictlyM censorAct `shouldThrow` errorCall "strict"