diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +# Changelog for `in-other-words` + +## 0.1.0.0 (2020-10-10) +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,278 @@ +# in-other-words +[![build GHC 8.6](https://github.com/KingoftheHomeless/in-other-words/workflows/build%20GHC%208.6/badge.svg)](https://github.com/KingoftheHomeless/in-other-words/actions?query=workflow%3A%22build+GHC+8.6%22) +[![build GHC 8.8](https://github.com/KingoftheHomeless/in-other-words/workflows/build%20GHC%208.8/badge.svg)](https://github.com/KingoftheHomeless/in-other-words/actions?query=workflow%3A%22build+GHC+8.8%22) +[![build GHC 8.10](https://github.com/KingoftheHomeless/in-other-words/workflows/build%20GHC%208.10/badge.svg)](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(n2)* 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.[1](#f1) 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!" + ] +``` + +Higher-order usage: +```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. + +*** +[1](#a1) 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`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/in-other-words.cabal b/in-other-words.cabal new file mode 100644 --- /dev/null +++ b/in-other-words.cabal @@ -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 diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect.hs @@ -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 diff --git a/src/Control/Effect/Alt.hs b/src/Control/Effect/Alt.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Alt.hs @@ -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 #-} diff --git a/src/Control/Effect/AtomicState.hs b/src/Control/Effect/AtomicState.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/AtomicState.hs @@ -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 #-} diff --git a/src/Control/Effect/BaseControl.hs b/src/Control/Effect/BaseControl.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/BaseControl.hs @@ -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 #-} diff --git a/src/Control/Effect/Bracket.hs b/src/Control/Effect/Bracket.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Bracket.hs @@ -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 #-} diff --git a/src/Control/Effect/Carrier.hs b/src/Control/Effect/Carrier.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Carrier.hs @@ -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 diff --git a/src/Control/Effect/Carrier/Internal/Compose.hs b/src/Control/Effect/Carrier/Internal/Compose.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Carrier/Internal/Compose.hs @@ -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 #-} diff --git a/src/Control/Effect/Carrier/Internal/Interpret.hs b/src/Control/Effect/Carrier/Internal/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Carrier/Internal/Interpret.hs @@ -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 #-} diff --git a/src/Control/Effect/Carrier/Internal/Intro.hs b/src/Control/Effect/Carrier/Internal/Intro.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Carrier/Internal/Intro.hs @@ -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 #-} diff --git a/src/Control/Effect/Carrier/Internal/Stepped.hs b/src/Control/Effect/Carrier/Internal/Stepped.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Carrier/Internal/Stepped.hs @@ -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 diff --git a/src/Control/Effect/Conc.hs b/src/Control/Effect/Conc.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Conc.hs @@ -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 #-} diff --git a/src/Control/Effect/Cont.hs b/src/Control/Effect/Cont.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Cont.hs @@ -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 #-} diff --git a/src/Control/Effect/Debug.hs b/src/Control/Effect/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Debug.hs @@ -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" diff --git a/src/Control/Effect/Embed.hs b/src/Control/Effect/Embed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Embed.hs @@ -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 #-} diff --git a/src/Control/Effect/Error.hs b/src/Control/Effect/Error.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Error.hs @@ -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 #-} diff --git a/src/Control/Effect/ErrorIO.hs b/src/Control/Effect/ErrorIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/ErrorIO.hs @@ -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 #-} diff --git a/src/Control/Effect/Exceptional.hs b/src/Control/Effect/Exceptional.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Exceptional.hs @@ -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 #-} diff --git a/src/Control/Effect/Fail.hs b/src/Control/Effect/Fail.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Fail.hs @@ -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 #-} diff --git a/src/Control/Effect/Fix.hs b/src/Control/Effect/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Fix.hs @@ -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 #-} diff --git a/src/Control/Effect/Fresh.hs b/src/Control/Effect/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Fresh.hs @@ -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 #-} diff --git a/src/Control/Effect/Intercept.hs b/src/Control/Effect/Intercept.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Intercept.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal.hs b/src/Control/Effect/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/BaseControl.hs b/src/Control/Effect/Internal/BaseControl.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/BaseControl.hs @@ -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) diff --git a/src/Control/Effect/Internal/Cont.hs b/src/Control/Effect/Internal/Cont.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Cont.hs @@ -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 diff --git a/src/Control/Effect/Internal/Derive.hs b/src/Control/Effect/Internal/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Derive.hs @@ -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 diff --git a/src/Control/Effect/Internal/Effly.hs b/src/Control/Effect/Internal/Effly.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Effly.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/Error.hs b/src/Control/Effect/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Error.hs @@ -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 diff --git a/src/Control/Effect/Internal/Intercept.hs b/src/Control/Effect/Internal/Intercept.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Intercept.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/Itself.hs b/src/Control/Effect/Internal/Itself.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Itself.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/KnownList.hs b/src/Control/Effect/Internal/KnownList.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/KnownList.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/Membership.hs b/src/Control/Effect/Internal/Membership.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Membership.hs @@ -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" diff --git a/src/Control/Effect/Internal/Newtype.hs b/src/Control/Effect/Internal/Newtype.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Newtype.hs @@ -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' diff --git a/src/Control/Effect/Internal/NonDet.hs b/src/Control/Effect/Internal/NonDet.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/NonDet.hs @@ -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 diff --git a/src/Control/Effect/Internal/Optional.hs b/src/Control/Effect/Internal/Optional.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Optional.hs @@ -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) diff --git a/src/Control/Effect/Internal/Reader.hs b/src/Control/Effect/Internal/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Reader.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/Reflection.hs b/src/Control/Effect/Internal/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Reflection.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/Regional.hs b/src/Control/Effect/Internal/Regional.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Regional.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/State.hs b/src/Control/Effect/Internal/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/State.hs @@ -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 diff --git a/src/Control/Effect/Internal/Union.hs b/src/Control/Effect/Internal/Union.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Union.hs @@ -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 diff --git a/src/Control/Effect/Internal/Unlift.hs b/src/Control/Effect/Internal/Unlift.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Unlift.hs @@ -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) diff --git a/src/Control/Effect/Internal/Utils.hs b/src/Control/Effect/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Utils.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/ViaAlg.hs b/src/Control/Effect/Internal/ViaAlg.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/ViaAlg.hs @@ -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 #-} diff --git a/src/Control/Effect/Internal/Writer.hs b/src/Control/Effect/Internal/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Writer.hs @@ -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 diff --git a/src/Control/Effect/Mask.hs b/src/Control/Effect/Mask.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Mask.hs @@ -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 #-} diff --git a/src/Control/Effect/Newtype.hs b/src/Control/Effect/Newtype.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Newtype.hs @@ -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 diff --git a/src/Control/Effect/NonDet.hs b/src/Control/Effect/NonDet.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/NonDet.hs @@ -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 #-} diff --git a/src/Control/Effect/Optional.hs b/src/Control/Effect/Optional.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Optional.hs @@ -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 #-} diff --git a/src/Control/Effect/Primitive.hs b/src/Control/Effect/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Primitive.hs @@ -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 diff --git a/src/Control/Effect/Reader.hs b/src/Control/Effect/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Reader.hs @@ -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 #-} diff --git a/src/Control/Effect/Regional.hs b/src/Control/Effect/Regional.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Regional.hs @@ -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 #-} diff --git a/src/Control/Effect/Select.hs b/src/Control/Effect/Select.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Select.hs @@ -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 #-} diff --git a/src/Control/Effect/State.hs b/src/Control/Effect/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/State.hs @@ -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 #-} diff --git a/src/Control/Effect/Stepped.hs b/src/Control/Effect/Stepped.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Stepped.hs @@ -0,0 +1,14 @@ +module Control.Effect.Stepped + ( SteppedC + , Steps(..) + , steps + , unsteps + , liftSteps + + , FirstOrder + + -- Threading constraints + , SteppedThreads + ) where + +import Control.Effect.Carrier.Internal.Stepped diff --git a/src/Control/Effect/Trace.hs b/src/Control/Effect/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Trace.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/Alt.hs b/src/Control/Effect/Type/Alt.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Alt.hs @@ -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 diff --git a/src/Control/Effect/Type/Bracket.hs b/src/Control/Effect/Type/Bracket.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Bracket.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/Catch.hs b/src/Control/Effect/Type/Catch.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Catch.hs @@ -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] diff --git a/src/Control/Effect/Type/Embed.hs b/src/Control/Effect/Type/Embed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Embed.hs @@ -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 diff --git a/src/Control/Effect/Type/ErrorIO.hs b/src/Control/Effect/Type/ErrorIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/ErrorIO.hs @@ -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 diff --git a/src/Control/Effect/Type/Fail.hs b/src/Control/Effect/Type/Fail.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Fail.hs @@ -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 diff --git a/src/Control/Effect/Type/Fix.hs b/src/Control/Effect/Type/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Fix.hs @@ -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) diff --git a/src/Control/Effect/Type/Internal/BaseControl.hs b/src/Control/Effect/Type/Internal/BaseControl.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Internal/BaseControl.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/ListenPrim.hs b/src/Control/Effect/Type/ListenPrim.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/ListenPrim.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/Mask.hs b/src/Control/Effect/Type/Mask.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Mask.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/Optional.hs b/src/Control/Effect/Type/Optional.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Optional.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/ReaderPrim.hs b/src/Control/Effect/Type/ReaderPrim.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/ReaderPrim.hs @@ -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) diff --git a/src/Control/Effect/Type/Regional.hs b/src/Control/Effect/Type/Regional.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Regional.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/Split.hs b/src/Control/Effect/Type/Split.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Split.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/Throw.hs b/src/Control/Effect/Type/Throw.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Throw.hs @@ -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 + diff --git a/src/Control/Effect/Type/Unlift.hs b/src/Control/Effect/Type/Unlift.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Unlift.hs @@ -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 #-} diff --git a/src/Control/Effect/Type/Unravel.hs b/src/Control/Effect/Type/Unravel.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/Unravel.hs @@ -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 #-} +-} diff --git a/src/Control/Effect/Type/WriterPrim.hs b/src/Control/Effect/Type/WriterPrim.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Type/WriterPrim.hs @@ -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 #-} diff --git a/src/Control/Effect/Union.hs b/src/Control/Effect/Union.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Union.hs @@ -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 #-} diff --git a/src/Control/Effect/Unlift.hs b/src/Control/Effect/Unlift.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Unlift.hs @@ -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 #-} diff --git a/src/Control/Effect/Writer.hs b/src/Control/Effect/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Writer.hs @@ -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 #-} diff --git a/src/Control/Monad/Trans/Free/Church/Alternate.hs b/src/Control/Monad/Trans/Free/Church/Alternate.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Free/Church/Alternate.hs @@ -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 #-} diff --git a/src/Control/Monad/Trans/List/Church.hs b/src/Control/Monad/Trans/List/Church.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/List/Church.hs @@ -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 #-} + + diff --git a/test/BracketSpec.hs b/test/BracketSpec.hs new file mode 100644 --- /dev/null +++ b/test/BracketSpec.hs @@ -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 [] diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/ErrorSpec.hs @@ -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 () diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/NonDetSpec.hs b/test/NonDetSpec.hs new file mode 100644 --- /dev/null +++ b/test/NonDetSpec.hs @@ -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"] diff --git a/test/WriterSpec.hs b/test/WriterSpec.hs new file mode 100644 --- /dev/null +++ b/test/WriterSpec.hs @@ -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"