effectful-core (empty) → 1.0.0.0
raw patch · 27 files changed
+4099/−0 lines, 27 filesdep +basedep +containersdep +effectful-core
Dependencies added: base, containers, effectful-core, exceptions, monad-control, primitive, transformers-base, unliftio-core
Files
- CHANGELOG.md +2/−0
- LICENSE +30/−0
- README.md +173/−0
- effectful-core.cabal +105/−0
- src/Effectful.hs +234/−0
- src/Effectful/Dispatch/Dynamic.hs +608/−0
- src/Effectful/Dispatch/Static.hs +219/−0
- src/Effectful/Dispatch/Static/Primitive.hs +40/−0
- src/Effectful/Dispatch/Static/Unsafe.hs +41/−0
- src/Effectful/Error/Dynamic.hs +90/−0
- src/Effectful/Error/Static.hs +221/−0
- src/Effectful/Fail.hs +24/−0
- src/Effectful/Internal/Effect.hs +77/−0
- src/Effectful/Internal/Env.hs +461/−0
- src/Effectful/Internal/Monad.hs +492/−0
- src/Effectful/Internal/Unlift.hs +320/−0
- src/Effectful/Prim.hs +10/−0
- src/Effectful/Reader/Dynamic.hs +64/−0
- src/Effectful/Reader/Static.hs +56/−0
- src/Effectful/State/Dynamic.hs +159/−0
- src/Effectful/State/Static/Local.hs +136/−0
- src/Effectful/State/Static/Shared.hs +157/−0
- src/Effectful/Writer/Dynamic.hs +112/−0
- src/Effectful/Writer/Static/Local.hs +100/−0
- src/Effectful/Writer/Static/Shared.hs +114/−0
- utils/Effectful/Internal/Utils.hs +49/−0
- utils/utils.c +5/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# effectful-core-1.0.0.0 (2022-07-13)+* Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021-2022, Andrzej Rybczak++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 Andrzej Rybczak nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,173 @@+# effectful++[](https://github.com/haskell-effectful/effectful/actions?query=branch%3Amaster)+[](https://hackage.haskell.org/package/effectful)+[](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net)+[](https://www.stackage.org/lts/package/effectful)+[](https://www.stackage.org/nightly/package/effectful)+++<img src="https://user-images.githubusercontent.com/387658/127747903-f728437f-2ee4-47b8-9f0c-5102fd44c8e4.png" width="128">++An easy to use, fast extensible effects library with seamless integration with+the existing Haskell ecosystem.++Main features:++1. Very fast+ ([benchmarks](https://github.com/haskell-effectful/effectful/tree/master/benchmarks/README.md)).++2. Easy to use API (comparable with usage of the [MonadUnliftIO](https://hackage.haskell.org/package/unliftio-core/docs/Control-Monad-IO-Unlift.html#t:MonadUnliftIO) class).++3. Correct semantics in presence of runtime exceptions (no more discarded state+ updates).++4. Seamless integration with the existing ecosystem (`exceptions`,+ `monad-control`, `unliftio-core`, `resourcet` etc.).++5. Support for thread local and shared state (e.g. `StateT` provides a thread+ local state, while `MVar` holds a shared state, both approaches have their+ merits).++6. Support for statically (implementation determined at compile time) and+ dynamically (implementation determined at run time) dispatched effects.++## Motivation++Do we really need yet another library for handling effects? There's+[freer-simple](https://hackage.haskell.org/package/freer-simple),+[fused-effects](https://hackage.haskell.org/package/fused-effects),+[polysemy](https://hackage.haskell.org/package/polysemy),+[eff](https://github.com/hasura/eff) and probably a few more.++Unfortunately, of all of them only `eff` is a promising proposition because of+reasonable performance characteristics (see the talk [Effects for+Less](https://www.youtube.com/watch?v=0jI-AlWEwYI) for more information) and+potential for good interoperability with the existing ecosystem.++The second point is arguably the most important, because it allows focusing on+things that matter instead of reinventing all kinds of wheels, hence being a+necessary condition for broader adoption of the library.++However, `eff` uses delimited continuations underneath, which:++- Are not yet supported by GHC (though [the+proposal](https://github.com/ghc-proposals/ghc-proposals/pull/313) for including+support for them has been accepted).++- Are quite hard to understand.++- Make the library "too powerful" in a sense as it faces+ [a](https://github.com/hasura/eff/issues/13)+ [few](https://github.com/hasura/eff/issues/7)+ [issues](https://github.com/hasura/eff/issues/12) with no clear path towards+ their resolution.++### What about `mtl`?++It's true that its "effects as classes" approach is widely known and used often.++However:++- `mtl` style effects are+ [slow](https://github.com/haskell-effectful/effectful/tree/master/benchmarks/README.md).++- The majority of popular monad transformers (except `ReaderT`) used for effect+ implementations are rife with [subtle+ issues](https://github.com/haskell-effectful/effectful/tree/master/transformers.md).++These are problematic enough that the [ReaderT design+pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/) was+invented. Its fundamentals are solid, but it's not an effect system.++A solution? Use the `ReaderT` pattern as a base and build around it to make an+extensible effects library! This is where `effectful` comes in. The `Eff` monad+it uses is essentially a `ReaderT` over `IO` on steroids, allowing us to extend+its environment with data types representing effects.++This concept is quite simple, so:++- It's reasonably easy to understand what is going on under the hood.++- The `Eff` monad being a reader allows for seamless interoperability with+ ubiquitous classes such as `MonadBaseControl` and `MonadUnliftIO` and solves+ [issues](https://github.com/haskell-effectful/effectful/tree/master/transformers.md)+ of monad transformers mentioned above.++What is more, the `Eff` monad is concrete, so GHC has many possibilities for+optimization, which results in a very fast code at a default optimization+level. There is no need to mark every function `INLINE` or enable additional+optimization passes, it just works.++### Any downsides?++As always, there's no free lunch. The `Eff` monad doesn't support `NonDet` nor+`Coroutine` effects. However, the `NonDet` effect in existing libraries is+[broken](https://github.com/lexi-lambda/eff/blob/8c4df4bf54faf22456354be18095b14825be5e85/notes/semantics-zoo.md)+and none of the ones with support for higher order effects provide the+`Coroutine` effect, so arguably it's not a big loss.++If you need such capability in your application, there are well established+libraries such as [conduit](https://hackage.haskell.org/package/conduit) or+[list-t](https://hackage.haskell.org/package/list-t) that can be used with+`effectful` without any issues.++### Summary++`effectful` is an extensible effects library that aims to replace "boring"+transformer stacks (which consist of a dozen of newtype'd `ExceptT`, `ReaderT`,+`StateT` and `WriterT` transformers) and their derivatives by providing+equivalent effects with improved semantics, performance and usability (it also+makes it easy to reuse them for your own effects). It doesn't try to make monad+transformers obsolete, so you're free to use it with `ConduitT`, `ContT`,+`ListT` etc. when necessary.++## Package structure++The effect system is split among several libraries:++- The [`effectful-core`](https://hackage.haskell.org/package/effectful-core)+ library contains the core of the effect system along with the basic+ effects. It aims for a small dependency footprint and provides building blocks+ for more advanced effects.++- The [`effectful-plugin`](https://hackage.haskell.org/package/effectful-plugin)+ library provides an optional GHC plugin for improving disambiguation of+ effects (see+ [here](https://github.com/haskell-effectful/effectful/blob/master/effectful-plugin/README.md)+ for more information).++- The [`effectful-th`](https://hackage.haskell.org/package/effectful-th) library+ provides utilities for generating bits of effect-related boilerplate via+ Template Haskell.++- The [`effectful`](https://hackage.haskell.org/package/effectful) library+ re-exports public modules of `effectful-core` and additionally provides most+ features of the `unliftio` library divided into appropriate effects.++## Example++A `Filesystem` effect with two handlers, one that runs in `IO` and another that+uses an in-memory virtual file system can be found+[here](https://github.com/haskell-effectful/effectful/blob/master/effectful/examples/FileSystem.hs).++## Resources++Resources that inspired the rise of this library and had a lot of impact on its+design.++Talks:++* [Effects for Less](https://www.youtube.com/watch?v=0jI-AlWEwYI) by Alexis King.++* [Monad Transformer State](https://www.youtube.com/watch?v=KZIN9f9rI34) by Michael Snoyman.++Blog posts:++* [ReaderT design pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/) by Michael Snoyman.++* [Exceptions Best Practices](https://www.fpcomplete.com/blog/2016/11/exceptions-best-practices-haskell/) by Michael Snoyman.++----------------------------------------++<div>Icons made by <a href="https://www.freepik.com" title="Freepik">Freepik</a> from <a href="https://www.flaticon.com/" title="Flaticon">www.flaticon.com</a></div>
+ effectful-core.cabal view
@@ -0,0 +1,105 @@+cabal-version: 2.4+build-type: Simple+name: effectful-core+version: 1.0.0.0+license: BSD-3-Clause+license-file: LICENSE+category: Control+maintainer: andrzej@rybczak.net+author: Andrzej Rybczak+synopsis: An easy to use, performant extensible effects library.++description: An easy to use, performant extensible effects library with seamless+ integration with the existing Haskell ecosystem.+ .+ This library provides core definitions with a minimal dependency+ footprint. See the @<https://hackage.haskell.org/package/effectful effectful>@+ package for the "batteries-included" variant.++extra-source-files:+ CHANGELOG.md+ README.md++tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.3 || ==9.4.1++bug-reports: https://github.com/haskell-effectful/effectful/issues+source-repository head+ type: git+ location: https://github.com/haskell-effectful/effectful.git++common language+ ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors++ default-language: Haskell2010++ default-extensions: BangPatterns+ ConstraintKinds+ DataKinds+ DeriveFunctor+ DeriveGeneric+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ NoStarIsType+ RankNTypes+ RoleAnnotations+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators++library effectful-internal-utils+ import: language++ build-depends: base++ hs-source-dirs: utils+ c-sources: utils/utils.c++ exposed-modules: Effectful.Internal.Utils++library+ import: language++ ghc-options: -O2++ build-depends: effectful-internal-utils++ build-depends: base >= 4.13 && < 5+ , containers >= 0.6+ , exceptions >= 0.10.4+ , monad-control >= 1.0.3+ , primitive >= 0.7.3.0+ , transformers-base >= 0.4.6+ , unliftio-core >= 0.2.0.1++ hs-source-dirs: src++ exposed-modules: Effectful+ Effectful.Dispatch.Dynamic+ Effectful.Dispatch.Static+ Effectful.Dispatch.Static.Primitive+ Effectful.Dispatch.Static.Unsafe+ Effectful.Error.Dynamic+ Effectful.Error.Static+ Effectful.Fail+ Effectful.Internal.Effect+ Effectful.Internal.Env+ Effectful.Internal.Monad+ Effectful.Internal.Unlift+ Effectful.Prim+ Effectful.Reader.Dynamic+ Effectful.Reader.Static+ Effectful.State.Dynamic+ Effectful.State.Static.Local+ Effectful.State.Static.Shared+ Effectful.Writer.Dynamic+ Effectful.Writer.Static.Local+ Effectful.Writer.Static.Shared++ reexported-modules: Effectful.Internal.Utils
+ src/Effectful.hs view
@@ -0,0 +1,234 @@+module Effectful+ ( -- * Introduction+ -- $intro++ -- ** Integration with existing libraries+ -- $integration++ -- *** Transformed monads+ -- $transformer++ -- *** Concrete monads++ -- **** IO+ -- $concrete_io++ -- **** Other+ -- $concrete_other++ -- *** Polymorphic monads+ -- $poly++ -- * The 'Eff' monad+ Eff++ -- ** Effect constraints+ , Effect+ , Dispatch(..)+ , DispatchOf+ , (:>)+ , (:>>)++ -- * Running the 'Eff' monad++ -- ** Pure computations+ , runPureEff++ -- ** Computations with side effects+ , runEff+ , IOE++ -- ** Unlifting+ , UnliftStrategy(..)+ , Persistence(..)+ , Limit(..)+ , unliftStrategy+ , withUnliftStrategy+ , withEffToIO++ -- ** Lifting+ , raise+ , subsume+ , inject+ , Subset++ -- * Re-exports+ , MonadIO(..)+ , MonadUnliftIO(..)+ ) where++import Control.Monad.IO.Class+import Control.Monad.IO.Unlift++import Effectful.Internal.Effect+import Effectful.Internal.Env+import Effectful.Internal.Monad++-- $intro+--+-- Haskell is one of the few programming languages that distinguishes between+-- pure functions and functions that might perform side effects. For example, a+-- function+--+-- @+-- f :: 'Int' -> 'String'+-- @+--+-- can't perform side effects at all, but a function+--+-- @+-- f :: 'Int' -> 'IO' 'String'+-- @+--+-- can perform any side effect. This "all or nothing" approach isn't very+-- satisfactory though, because the vast majority of time we would like to+-- signify that a function can perform /some/ side effects, e.g. only be able to+-- log messages.+--+-- This library provides support for expressing exactly that with its 'Eff'+-- monad:+--+-- @+-- f :: Log ':>' es => 'Int' -> 'Eff' es 'String'+-- @+--+-- It implements support for extensible effects with both dynamic and static+-- dispatch. For more information about each type consult the documentation in+-- "Effectful.Dispatch.Dynamic" and "Effectful.Dispatch.Static".+--+-- The library provides:+--+-- - The 'Eff' monad that tracks effects at the type level. This is going to be+-- the main monad of your application.+--+-- - A set of predefined, basic effects such as t'Effectful.Error.Static.Error',+-- t'Effectful.Reader.Static.Reader', t'Effectful.State.Static.Local.State' and+-- t'Effectful.Writer.Static.Local.Writer'.+--+-- - Utilities for defining new effects and interpreting them, possibly in terms+-- of already existing ones.+--+-- While basic effects can be used out of the box, it's usually recommended to+-- create your own that serve a more specific purpose.+--++-- $integration+--+-- Integration with most of existing libraries and frameworks can be done quite+-- easily. The main difference on how that looks like depends on the way a+-- library operates in a monadic context.+--+-- There are three main groups a library might fall into. It either operates:+--+-- 1) In a monad of your application transformed by a library specific monad+-- transformer.+--+-- 2) In its own, concrete monad, which is usually 'IO' or a couple of monad+-- transformers on top of 'IO'.+--+-- 3) In a polymorphic monad, which is constrained by a type class that+-- implements core operations of a library.+--+-- Each case needs a slightly different approach to integrate with the 'Eff'+-- monad.++-- $transformer+--+-- These are libraries that provide a custom transformer for the main monad of+-- your application and their operations make use of it for their+-- operations. Examples include @InputT@ from the+-- [haskeline](https://hackage.haskell.org/package/haskeline) package or+-- @ConduitT@ from the [conduit](https://hackage.haskell.org/package/conduit)+-- package.+--+-- These libraries can trivially be used with the 'Eff' monad since it provides+-- typical instances that these libraries require the underlying monad to have,+-- such as t'Control.Monad.Catch.MonadMask' or 'MonadUnliftIO'.+--+-- In case the 'Eff' monad doesn't provide a specific instance out of the box,+-- it can be supplied via a specific effect. As an example see how the instance+-- of @MonadResource@ for 'Eff' is implemented in the+-- [resourcet-effectful](https://hackage.haskell.org/package/resourcet-effectful)+-- package.+--++-- $concrete_io+--+-- If a library operates in 'IO', there are a couple of ways to integrate it.+--+-- The easiest way is to use its functions selectively in the 'Eff' monad with+-- the help of 'liftIO' or 'withEffToIO' / 'withRunInIO'. This is the easiest+-- way. However, it's not particularly robust, since it vastly broadens the+-- scope in which the 'IOE' effect is needed (not to mention that explicit+-- lifting is annoying).+--+-- A somewhat better approach is to create a dummy static effect with+-- lightweight wrappers of the library functions. As an example have a look at+-- the @Effectful.Concurrent.Async@ module from the+-- [effectful](https://hackage.haskell.org/package/effectful) package that wraps+-- the API of the [async](https://hackage.haskell.org/package/async)+-- package. Unfortunately, this requires the amount of work proportional to the+-- size of the library and might not be the best option, especially if you only+-- need to make use of a few functions.+--+-- Even better (though sometimes hard to do in practice) way is to consider,+-- what the library will be used for and then create a custom effect with high+-- level operations that the library in question will help us implement. The+-- advantage of this approach is that we're hiding implementation details from+-- the so-called "business logic" of our application and make it possible to+-- easily swap them in different environments or during future refactoring.+--++-- $concrete_other+--+-- Some libraries operate in a transformer stack over 'IO' or have its own+-- concrete monad that's a newtype over 'IO', e.g. @Handler@ from the+-- [servant-server](https://hackage.haskell.org/package/servant-server) package.+--+-- In such case it's best to mirror the monad in question by the 'Eff' monad+-- with appropriate effects (as tha majority of popular monad transformers have+-- [subtle+-- issues](https://github.com/haskell-effectful/effectful/blob/master/transformers.md)),+-- use it as soon as possible, then at the end feed the final state to the monad+-- of the library so it proceeds as if nothing unusual happened.+--+-- As an example, consider the following monad:+--+-- >>> import qualified Control.Monad.State as T+-- >>> import qualified Control.Monad.Except as T+--+-- >>> data HandlerState+-- >>> data HandlerError+--+-- >>> :{+-- newtype Handler a = Handler (T.ExceptT HandlerError (T.StateT HandlerState IO) a)+-- deriving ( Applicative, Functor, Monad, MonadIO+-- , T.MonadState HandlerState, T.MonadError HandlerError+-- )+-- :}+--+-- This is how you can execute 'Eff' actions in the @Handler@ monad:+--+-- >>> import Effectful.Error.Static+-- >>> import Effectful.State.Static.Local+--+-- >>> :{+-- effToHandler :: Eff [Error HandlerError, State HandlerState, IOE] a -> Handler a+-- effToHandler m = do+-- -- Retrieve the current state of the Handler.+-- s <- T.get+-- -- Run the Eff monad with effects mirroring the capabilities of @Handler@.+-- (er, s') <- liftIO . runEff . runState s . runErrorNoCallStack @HandlerError $ m+-- -- Update the state of the Handler and throw an error if appropriate.+-- T.put s'+-- either T.throwError pure er+-- :}+--++-- $poly+--+-- Libraries working in a polymorphic monad use @mtl@ style effects. Details+-- about their integration with the 'Eff' monad require familiarity with+-- dynamically dispatched effects and thus are available in the+-- "Effectful.Dispatch.Dynamic#g:integration" module.+--
+ src/Effectful/Dispatch/Dynamic.hs view
@@ -0,0 +1,608 @@+-- | Dynamically dispatched effects.+module Effectful.Dispatch.Dynamic+ ( -- * Introduction+ -- $intro++ -- ** An example+ -- $example++ -- ** First order and higher order effects+ -- $order++ -- ** Integration with @mtl@ style effects #integration#+ -- $integration++ -- * Sending operations to the handler+ send++ -- * Handling effects+ , EffectHandler+ , interpret+ , reinterpret+ , interpose+ , impose++ -- ** Handling local 'Eff' computations+ , LocalEnv++ -- *** Unlifts+ , localSeqUnlift+ , localSeqUnliftIO+ , localUnlift+ , localUnliftIO++ -- *** Lifts+ , withLiftMap+ , withLiftMapIO++ -- *** Bidirectional lifts+ , localLiftUnlift+ , localLiftUnliftIO++ -- *** Utils+ , SuffixOf++ -- * Re-exports+ , HasCallStack+ ) where++import Control.Exception (bracket)+import Control.Monad.IO.Unlift+import Data.Kind+import GHC.Stack (HasCallStack)++import Effectful.Internal.Effect+import Effectful.Internal.Env+import Effectful.Internal.Monad++-- $intro+--+-- A dynamically dispatched effect is a collection of operations that can be+-- interpreted in different ways at runtime, depending on the handler that is+-- used to run the effect.+--+-- This allows a programmer to separate the __what__ from the __how__,+-- i.e. define effects that model what the code should do, while providing+-- handlers that determine how it should do it later. Moreover, different+-- environments can use different handlers to change the behavior of specific+-- parts of the application if appropriate.+--++-- $example+--+-- Let's create an effect for basic file access, i.e. writing and reading files.+--+-- First, we need to define a generalized algebraic data type of kind 'Effect',+-- where each constructor corresponds to a specific operation of the effect in+-- question.+--+-- >>> :{+-- data FileSystem :: Effect where+-- ReadFile :: FilePath -> FileSystem m String+-- WriteFile :: FilePath -> String -> FileSystem m ()+-- :}+--+-- >>> type instance DispatchOf FileSystem = Dynamic+--+-- The @FileSystem@ effect has two operations:+--+-- - @ReadFile@, which takes a @FilePath@ and returns a @String@ in the monadic+-- context.+--+-- - @WriteFile@, which takes a @FilePath@, a @String@ and returns a @()@ in the+-- monadic context.+--+-- For people familiar with @mtl@ style effects, note that the syntax looks very+-- similar to defining an appropriate type class:+--+-- @+-- class FileSystem m where+-- readFile :: FilePath -> m String+-- writeFile :: FilePath -> String -> m ()+-- @+--+-- The biggest difference between these two is that the definition of a type+-- class gives us operations as functions, while the definition of an effect+-- gives us operations as data constructors. They can be turned into functions+-- with the help of 'send':+--+-- >>> :{+-- readFile :: (HasCallStack, FileSystem :> es) => FilePath -> Eff es String+-- readFile path = send (ReadFile path)+-- :}+--+-- >>> :{+-- writeFile :: (HasCallStack, FileSystem :> es) => FilePath -> String -> Eff es ()+-- writeFile path content = send (WriteFile path content)+-- :}+--+-- /Note:/ the above functions and the 'DispatchOf' instance can also be+-- automatically generated by the @makeEffect@ function from the @effectful-th@+-- library.+--+-- The following defines an 'EffectHandler' that reads and writes files from the+-- drive:+--+-- >>> import Control.Exception (IOException)+-- >>> import Control.Monad.Catch (catch)+-- >>> import qualified System.IO as IO+--+-- >>> import Effectful.Error.Static+--+-- >>> newtype FsError = FsError String deriving Show+--+-- >>> :{+-- runFileSystemIO+-- :: (IOE :> es, Error FsError :> es)+-- => Eff (FileSystem : es) a+-- -> Eff es a+-- runFileSystemIO = interpret $ \_ -> \case+-- ReadFile path -> adapt $ IO.readFile path+-- WriteFile path contents -> adapt $ IO.writeFile path contents+-- where+-- adapt m = liftIO m `catch` \(e::IOException) -> throwError . FsError $ show e+-- :}+--+-- Here, we use 'interpret' and simply execute corresponding 'IO' actions for+-- each operation, additionally doing a bit of error management.+--+-- On the other hand, maybe there is a situation in which instead of interacting+-- with the outside world, a pure, in-memory storage is preferred:+--+-- >>> import qualified Data.Map.Strict as M+--+-- >>> import Effectful.State.Static.Local+--+-- >>> :{+-- runFileSystemPure+-- :: Error FsError :> es+-- => M.Map FilePath String+-- -> Eff (FileSystem : es) a+-- -> Eff es a+-- runFileSystemPure fs0 = reinterpret (evalState fs0) $ \_ -> \case+-- ReadFile path -> gets (M.lookup path) >>= \case+-- Just contents -> pure contents+-- Nothing -> throwError . FsError $ "File not found: " ++ show path+-- WriteFile path contents -> modify $ M.insert path contents+-- :}+--+-- Here, we use 'reinterpret' and introduce a+-- t'Effectful.State.Static.Local.State' effect for the storage that is private+-- to the effect handler and cannot be accessed outside of it.+--+-- Let's compare how these differ.+--+-- >>> :{+-- action = do+-- file <- readFile "effectful-core.cabal"+-- pure $ length file > 0+-- :}+--+-- >>> :t action+-- action :: (FileSystem :> es) => Eff es Bool+--+-- >>> runEff . runError @FsError . runFileSystemIO $ action+-- Right True+--+-- >>> runPureEff . runErrorNoCallStack @FsError . runFileSystemPure M.empty $ action+-- Left (FsError "File not found: \"effectful-core.cabal\"")+--++-- $order+--+-- Note that the definition of the @FileSystem@ effect from the previous section+-- doesn't use the @m@ type parameter. What is more, when the effect is+-- interpreted, the 'LocalEnv' argument of the 'EffectHandler' is also not+-- used. Such effects are /first order/.+--+-- If an effect makes use of the @m@ parameter, it is a /higher order effect/.+--+-- Interpretation of higher order effects is slightly more involved. To see why,+-- let's consider the @Profiling@ effect for logging how much time a specific+-- action took to run:+--+-- >>> :{+-- data Profiling :: Effect where+-- Profile :: String -> m a -> Profiling m a+-- :}+--+-- >>> type instance DispatchOf Profiling = Dynamic+--+-- >>> :{+-- profile :: (HasCallStack, Profiling :> es) => String -> Eff es a -> Eff es a+-- profile label action = send (Profile label action)+-- :}+--+-- If we naively try to interpret it, we will run into trouble:+--+-- >>> import GHC.Clock (getMonotonicTime)+--+-- >>> :{+-- runProfiling :: IOE :> es => Eff (Profiling : es) a -> Eff es a+-- runProfiling = interpret $ \_ -> \case+-- Profile label action -> do+-- t1 <- liftIO getMonotonicTime+-- r <- action+-- t2 <- liftIO getMonotonicTime+-- liftIO . putStrLn $ "Action '" ++ label ++ "' took " ++ show (t2 - t1) ++ " seconds."+-- pure r+-- :}+-- ...+-- ... Couldn't match type ‘localEs’ with ‘es’+-- ...+--+-- The problem is that @action@ has a type @Eff localEs a@, while the monad of+-- the effect handler is @Eff es@. @localEs@ represents the /local environment/+-- in which the @Profile@ operation was called, which is opaque as the effect+-- handler cannot possibly know how it looks like.+--+-- The solution is to use the 'LocalEnv' that an 'EffectHandler' is given to run+-- the action using one of the functions from the 'localUnlift' family:+--+-- >>> :{+-- runProfiling :: IOE :> es => Eff (Profiling : es) a -> Eff es a+-- runProfiling = interpret $ \env -> \case+-- Profile label action -> localSeqUnliftIO env $ \unlift -> do+-- t1 <- getMonotonicTime+-- r <- unlift action+-- t2 <- getMonotonicTime+-- putStrLn $ "Action '" ++ label ++ "' took " ++ show (t2 - t1) ++ " seconds."+-- pure r+-- :}+--+-- In a similar way we can define a dummy interpreter that does no profiling:+--+-- >>> :{+-- runNoProfiling :: Eff (Profiling : es) a -> Eff es a+-- runNoProfiling = interpret $ \env -> \case+-- Profile label action -> localSeqUnlift env $ \unlift -> unlift action+-- :}+--+-- ...and it's done.+--+-- >>> action = profile "greet" . liftIO $ putStrLn "Hello!"+--+-- >>> :t action+-- action :: (Profiling :> es, IOE :> es) => Eff es ()+--+-- >>> runEff . runProfiling $ action+-- Hello!+-- Action 'greet' took ... seconds.+--+-- >>> runEff . runNoProfiling $ action+-- Hello!+--++-- $integration+--+-- There exists a lot of libraries that provide their functionality as an @mtl@+-- style effect, which generally speaking is a type class that contains core+-- operations of the library in question.+--+-- Such effects are quite easy to use with the 'Eff' monad. As an example,+-- consider the @mtl@ style effect for generation of random numbers:+--+-- >>> :{+-- class Monad m => MonadRNG m where+-- randomInt :: m Int+-- :}+--+-- Let's say the library also defines a helper function for generation of random+-- strings:+--+-- >>> import Control.Monad+-- >>> import Data.Char+--+-- >>> :{+-- randomString :: MonadRNG m => Int -> m String+-- randomString n = map chr <$> replicateM n randomInt+-- :}+--+-- To make it possible to use it with the 'Eff' monad, the first step is to+-- create an effect with operations that mirror the ones of a type class:+--+-- >>> :{+-- data RNG :: Effect where+-- RandomInt :: RNG m Int+-- :}+--+-- >>> type instance DispatchOf RNG = Dynamic+--+-- If we continued as in the example above, we'd now create top level helper+-- functions that execute effect operations using 'send', in this case+-- @randomInt@ tied to @RandomInt@. But this function is already declared by the+-- @MonadRNG@ type class! Therefore, what we do instead is provide an+-- __orphan__, __canonical__ instance of @MonadRNG@ for 'Eff' that delegates to+-- the @RNG@ effect:+--+-- >>> :set -XUndecidableInstances+--+-- >>> :{+-- instance RNG :> es => MonadRNG (Eff es) where+-- randomInt = send RandomInt+-- :}+--+-- Now we only need an interpreter:+--+-- >>> :{+-- runDummyRNG :: Eff (RNG : es) a -> Eff es a+-- runDummyRNG = interpret $ \_ -> \case+-- RandomInt -> pure 55+-- :}+--+-- and we can use any function that requires a @MonadRNG@ constraint with the+-- 'Eff' monad as long as the @RNG@ effect is in place:+--+-- >>> runEff . runDummyRNG $ randomString 3+-- "777"+--++----------------------------------------+-- Handling effects++-- | Interpret an effect.+interpret+ :: DispatchOf e ~ Dynamic+ => EffectHandler e es+ -- ^ The effect handler.+ -> Eff (e : es) a+ -> Eff es a+interpret handler m = unsafeEff $ \es -> do+ les <- forkEnv es+ (`unEff` es) $ runHandler (Handler les handler) m++-- | Interpret an effect using other, private effects.+--+-- @'interpret' ≡ 'reinterpret' 'id'@+reinterpret+ :: DispatchOf e ~ Dynamic+ => (Eff handlerEs a -> Eff es b)+ -- ^ Introduction of effects encapsulated within the handler.+ -> EffectHandler e handlerEs+ -- ^ The effect handler.+ -> Eff (e : es) a+ -> Eff es b+reinterpret runHandlerEs handler m = unsafeEff $ \es -> do+ les0 <- forkEnv es+ (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do+ (`unEff` es) $ runHandler (Handler les handler) m++-- | Replace the handler of an existing effect with a new one.+--+-- /Note:/ this function allows for augmenting handlers with a new functionality+-- as the new handler can send operations to the old one.+--+-- >>> :{+-- data E :: Effect where+-- Op :: E m ()+-- type instance DispatchOf E = Dynamic+-- :}+--+-- >>> :{+-- runE :: IOE :> es => Eff (E : es) a -> Eff es a+-- runE = interpret $ \_ Op -> liftIO (putStrLn "op")+-- :}+--+-- >>> runEff . runE $ send Op+-- op+--+-- >>> :{+-- augmentE :: (E :> es, IOE :> es) => Eff es a -> Eff es a+-- augmentE = interpose $ \_ Op -> liftIO (putStrLn "augmented op") >> send Op+-- :}+--+-- >>> runEff . runE . augmentE $ send Op+-- augmented op+-- op+--+interpose+ :: forall e es a. (DispatchOf e ~ Dynamic, e :> es)+ => EffectHandler e es+ -- ^ The effect handler.+ -> Eff es a+ -> Eff es a+interpose handler m = unsafeEff $ \es0 -> do+ les <- forkEnv es0+ bracket (replaceEnv (Handler les handler) relinkHandler es0)+ (unreplaceEnv @e)+ (\es -> unEff m es)++-- | Replace the handler of an existing effect with a new one that uses other,+-- private effects.+--+-- @'interpose' ≡ 'impose' 'id'@+impose+ :: forall e es handlerEs a b. (DispatchOf e ~ Dynamic, e :> es)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Introduction of effects encapsulated within the handler.+ -> EffectHandler e handlerEs+ -- ^ The effect handler.+ -> Eff es a+ -> Eff es b+impose runHandlerEs handler m = unsafeEff $ \es0 -> do+ les0 <- forkEnv es0+ (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do+ bracket (replaceEnv (Handler les handler) relinkHandler es0)+ (unreplaceEnv @e)+ (\es -> unEff m es)++----------------------------------------+-- Unlifts++-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the+-- general version see 'localUnlift'.+localSeqUnlift+ :: (HasCallStack, SuffixOf es handlerEs)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)+ -- ^ Continuation with the unlifting function in scope.+ -> Eff es a+localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do+ seqUnliftIO les $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift++-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the+-- general version see 'localUnliftIO'.+localSeqUnliftIO+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> ((forall r. Eff localEs r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ -> Eff es a+localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k++-- | Create a local unlifting function with the given strategy.+localUnlift+ :: (HasCallStack, SuffixOf es handlerEs)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> UnliftStrategy+ -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)+ -- ^ Continuation with the unlifting function in scope.+ -> Eff es a+localUnlift (LocalEnv les) strategy k = case strategy of+ SeqUnlift -> unsafeEff $ \es -> do+ seqUnliftIO les $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift+ ConcUnlift p l -> unsafeEff $ \es -> do+ concUnliftIO les p l $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift++-- | Create a local unlifting function with the given strategy.+localUnliftIO+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> UnliftStrategy+ -> ((forall r. Eff localEs r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ -> Eff es a+localUnliftIO (LocalEnv les) strategy k = case strategy of+ SeqUnlift -> liftIO $ seqUnliftIO les k+ ConcUnlift p l -> liftIO $ concUnliftIO les p l k++-- | Utility for lifting 'Eff' computations of type+--+-- @'Eff' es a -> 'Eff' es b@+--+-- to+--+-- @'Eff' localEs a -> 'Eff' localEs b@+--+-- /Note:/ the computation must not run its argument in a different thread,+-- attempting to do so will result in a runtime error.+withLiftMap+ :: (HasCallStack, SuffixOf es handlerEs)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> ((forall a b. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)+ -- ^ Continuation with the lifting function in scope.+ -> Eff es r+withLiftMap !_ k = unsafeEff $ \es -> do+ -- The LocalEnv parameter is not used, but we need it to constraint the+ -- localEs type variable. It's also strict so that callers don't cheat.+ (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do+ seqUnliftIO localEs $ \unlift -> do+ (`unEff` es) . mapEff . unsafeEff_ $ unlift m++-- | Utility for lifting 'IO' computations of type+--+-- @'IO' a -> 'IO' b@+--+-- to+--+-- @'Eff' localEs a -> 'Eff' localEs b@+--+-- /Note:/ the computation must not run its argument in a different thread,+-- attempting to do so will result in a runtime error.+--+-- Useful e.g. for lifting the unmasking function in+-- 'Control.Exception.mask'-like computations:+--+-- >>> :{+-- data Fork :: Effect where+-- ForkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> Fork m ThreadId+-- type instance DispatchOf Fork = Dynamic+-- :}+--+-- >>> :{+-- runFork :: IOE :> es => Eff (Fork : es) a -> Eff es a+-- runFork = interpret $ \env (ForkWithUnmask m) -> withLiftMapIO env $ \liftMap -> do+-- localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do+-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask+-- :}+withLiftMapIO+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)+ -- ^ Continuation with the lifting function in scope.+ -> Eff es r+withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do+ -- The LocalEnv parameter is not used, but we need it to constraint the+ -- localEs type variable. It's also strict so that callers don't cheat.+ seqUnliftIO es $ \unlift -> mapIO $ unlift m++----------------------------------------+-- Bidirectional lifts++-- | Create a local lifting and unlifting function with the given strategy.+--+-- Useful for lifting complicated 'Eff' computations where the monadic action+-- shows in both positive (as a result) and negative (as an argument) position.+--+-- /Note:/ depending on the computation you're lifting 'localUnlift' along with+-- 'withLiftMap' might be enough and is more efficient.+localLiftUnlift+ :: (HasCallStack, SuffixOf es handlerEs)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> UnliftStrategy+ -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a)+ -- ^ Continuation with the lifting and unlifting function in scope.+ -> Eff es a+localLiftUnlift (LocalEnv les) strategy k = case strategy of+ SeqUnlift -> unsafeEff $ \es -> do+ seqUnliftIO es $ \unliftEs -> do+ seqUnliftIO les $ \unliftLocalEs -> do+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)+ ConcUnlift p l -> unsafeEff $ \es -> do+ concUnliftIO es p l $ \unliftEs -> do+ concUnliftIO les p l $ \unliftLocalEs -> do+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)++-- | Create a local unlifting function with the given strategy along with an+-- unrestricted lifting function.+--+-- Useful for lifting complicated 'IO' computations where the monadic action+-- shows in both positive (as a result) and negative (as an argument) position.+--+-- /Note:/ depending on the computation you're lifting 'localUnliftIO' along+-- with 'withLiftMapIO' might be enough and is more efficient.+localLiftUnliftIO+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> UnliftStrategy+ -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a)+ -- ^ Continuation with the lifting and unlifting function in scope.+ -> Eff es a+localLiftUnliftIO (LocalEnv les) strategy k = case strategy of+ SeqUnlift -> liftIO $ seqUnliftIO les $ k unsafeEff_+ ConcUnlift p l -> liftIO $ concUnliftIO les p l $ k unsafeEff_++----------------------------------------+-- Utils++-- | Require that the second list of effects is a suffix of the first one.+--+-- In other words, 'SuffixOf' @es@ @baseEs@ means "a suffix of @es@ is+-- @baseEs@".+type family SuffixOf (es :: [Effect]) (baseEs :: [Effect]) :: Constraint where+ SuffixOf baseEs baseEs = ()+ SuffixOf (e : es) baseEs = SuffixOf es baseEs++-- $setup+-- >>> import Control.Concurrent (ThreadId, forkIOWithUnmask)
+ src/Effectful/Dispatch/Static.hs view
@@ -0,0 +1,219 @@+-- | Statically dispatched effects.+module Effectful.Dispatch.Static+ ( -- * Introduction+ -- $intro++ -- ** An example+ -- $example++ -- * Low level API+ StaticRep+ , SideEffects(..)+ , MaybeIOE++ -- ** Extending the environment+ , runStaticRep+ , evalStaticRep+ , execStaticRep++ -- ** Data retrieval and update+ , getStaticRep+ , putStaticRep+ , stateStaticRep+ , stateStaticRepM+ , localStaticRep++ -- ** Unlifts+ , seqUnliftIO+ , concUnliftIO+ , unsafeSeqUnliftIO+ , unsafeConcUnliftIO++ -- ** Utils+ , unEff+ , unsafeEff+ , unsafeEff_+ , unsafeLiftMapIO++ -- * Re-exports+ , HasCallStack+ ) where++import GHC.Stack (HasCallStack)++import Effectful.Internal.Env+import Effectful.Internal.Monad++-- $intro+--+-- Unlike dynamically dispatched effects, statically dispatched effects have a+-- single, set interpretation that cannot be changed at runtime, which makes+-- them useful in specific scenatios. For example:+--+-- * If you'd like to ensure that a specific effect will behave in a certain way+-- at all times, using a statically dispatched version is the only way to+-- ensure that.+--+-- * If the effect you're about to define has only one reasonable+-- implementation, it makes a lot of sense to make it statically dispatched.+--+-- Statically dispatched effects also perform slightly better than dynamically+-- dispatched ones, because their operations are implemented as standard top+-- level functions, so the compiler can apply more optimizations to them.+--++-- $example+--+-- Let's say that there exists a logging library whose functionality we'd like+-- to turn into an effect. Its @Logger@ data type (after simplification) is+-- represented in the following way:+--+-- >>> data Logger = Logger { logMessage :: String -> IO () }+--+-- Because the @Logger@ type itself allows customization of how messages are+-- logged, it is an excellent candidate to be turned into a statically+-- dispatched effect.+--+-- Such effect is represented by an empty data type of kind 'Effectful.Effect':+--+-- >>> data Log :: Effect+--+-- When it comes to the dispatch, we also need to signify whether core+-- operations of the effect will perform side effects. Since GHC is not a+-- polygraph, you can lie, though being truthful is recommended 🙂+--+-- >>> type instance DispatchOf Log = Static WithSideEffects+--+-- The environment of 'Eff' will hold the data type that represents the+-- effect. It is defined by the appropriate instance of the 'StaticRep' data+-- family:+--+-- >>> newtype instance StaticRep Log = Log Logger+--+-- /Note:/ all operations of a statically dispatched effect will have a+-- read/write access to this data type as long as they can see its constructors,+-- hence it's best not to export them from the module that defines the effect.+--+-- The logging operation can be defined as follows:+--+-- >>> :{+-- log :: (IOE :> es, Log :> es) => String -> Eff es ()+-- log msg = do+-- Log logger <- getStaticRep+-- liftIO $ logMessage logger msg+-- :}+--+-- That works, but has an unfortunate consequence: in order to use the @log@+-- operation the 'IOE' effect needs to be in scope! This is bad, because we're+-- trying to limit (ideally, fully eliminate) the need to have the full power of+-- 'IO' available in the application code. The solution is to use one of the+-- escape hatches that allow unrestricted access to the internal representation+-- of 'Eff':+--+-- >>> :{+-- log :: Log :> es => String -> Eff es ()+-- log msg = do+-- Log logger <- getStaticRep+-- unsafeEff_ $ logMessage logger msg+-- :}+--+-- However, since logging is most often an operation with side effects, in order+-- for this approach to be sound, the function that introduces the @Log@ effect+-- needs to require the 'IOE' effect.+--+-- If you forget to do that, don't worry. As long as the 'DispatchOf' instance+-- was correctly defined to be @'Static' 'WithSideEffects'@, you will get a+-- reminder:+--+-- >>> :{+-- runLog :: Logger -> Eff (Log : es) a -> Eff es a+-- runLog logger = evalStaticRep (Log logger)+-- :}+-- ...+-- ...No instance for (IOE :> es) arising from a use of ‘evalStaticRep’+-- ...+--+-- Including @'IOE' :> es@ in the context fixes the problem:+--+-- >>> :{+-- runLog :: IOE :> es => Logger -> Eff (Log : es) a -> Eff es a+-- runLog logger = evalStaticRep (Log logger)+-- :}+--+-- In general, whenever any operation of a statically dispatched effect performs+-- side effects using one of the unsafe functions, all functions that introduce+-- this effect need to require the 'IOE' effect (otherwise it would be possible+-- to run it via 'runPureEff').+--+-- Now we can use the newly defined effect to log messages:+--+-- >>> dummyLogger = Logger { logMessage = \_ -> pure () }+--+-- >>> stdoutLogger = Logger { logMessage = putStrLn }+--+-- >>> :{+-- action = do+-- log "Computing things..."+-- log "Sleeping..."+-- log "Computing more things..."+-- pure True+-- :}+--+-- >>> :t action+-- action :: (Log :> es) => Eff es Bool+--+-- >>> runEff . runLog stdoutLogger $ action+-- Computing things...+-- Sleeping...+-- Computing more things...+-- True+--+-- >>> runEff . runLog dummyLogger $ action+-- True+--++-- | Utility for lifting 'IO' computations of type+--+-- @'IO' a -> 'IO' b@+--+-- to+--+-- @'Eff' es a -> 'Eff' es b@+--+-- /Note:/ the computation must not run its argument in a separate thread,+-- attempting to do so will result in a runtime error.+--+-- This function is __unsafe__ because it can be used to introduce arbitrary+-- 'IO' actions into pure 'Eff' computations.+unsafeLiftMapIO :: HasCallStack => (IO a -> IO b) -> Eff es a -> Eff es b+unsafeLiftMapIO f m = unsafeEff $ \es -> do+ seqUnliftIO es $ \unlift -> f (unlift m)++-- | Create an unlifting function with the 'SeqUnlift' strategy.+--+-- This function is __unsafe__ because it can be used to introduce arbitrary+-- 'IO' actions into pure 'Eff' computations.+unsafeSeqUnliftIO+ :: HasCallStack+ => ((forall r. Eff es r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ -> Eff es a+unsafeSeqUnliftIO k = unsafeEff $ \es -> do+ seqUnliftIO es k++-- | Create an unlifting function with the 'ConcUnlift' strategy.+--+-- This function is __unsafe__ because it can be used to introduce arbitrary+-- 'IO' actions into pure 'Eff' computations.+unsafeConcUnliftIO+ :: HasCallStack+ => Persistence+ -> Limit+ -> ((forall r. Eff es r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ -> Eff es a+unsafeConcUnliftIO persistence limit k = unsafeEff $ \es -> do+ concUnliftIO es persistence limit k++-- $setup+-- >>> import Effectful
+ src/Effectful/Dispatch/Static/Primitive.hs view
@@ -0,0 +1,40 @@+-- | Primitive API for statically dispatched effects.+--+-- This module exposes internal implementation details of the 'Effectful.Eff'+-- monad. Most of the time functions from "Effectful.Dispatch.Static" are+-- sufficient.+--+-- /Warning:/ playing the so called "type tetris" with functions from this+-- module is not enough. Their misuse might lead to memory corruption or+-- segmentation faults, so make sure you understand what you're doing.+module Effectful.Dispatch.Static.Primitive+ ( -- * The environment+ Env++ -- ** Relinker+ , Relinker(..)+ , dummyRelinker++ -- ** Representation of effects+ , EffectRep++ -- ** Extending and shrinking+ , consEnv+ , unconsEnv++ -- ** Data retrieval and update+ , getEnv+ , putEnv+ , stateEnv+ , modifyEnv++ -- ** Utils+ , emptyEnv+ , cloneEnv+ , forkEnv+ , sizeEnv+ , checkSizeEnv+ , tailEnv+ ) where++import Effectful.Internal.Env
+ src/Effectful/Dispatch/Static/Unsafe.hs view
@@ -0,0 +1,41 @@+-- | Unsafe utilities for statically dispatched effects.+module Effectful.Dispatch.Static.Unsafe+ ( reallyUnsafeLiftMapIO+ , reallyUnsafeUnliftIO+ ) where++import Effectful.Internal.Monad++-- | Utility for lifting 'IO' computations of type+--+-- @'IO' a -> 'IO' b@+--+-- to+--+-- @'Eff' es a -> 'Eff' es b@+--+-- This function is __highly unsafe__ because:+--+-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'+-- computations.+--+-- - The 'IO' computation must not run its argument in a different thread, but+-- it's not checked anywhere.+--+-- __If you disregard the second point, segmentation faults await.__+reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b+reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)++-- | Create an unlifting function.+--+-- This function is __highly unsafe__ because:+--+-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'+-- computations.+--+-- - Unlifted 'Eff' computations must not be run in a thread distinct from the+-- caller of 'reallyUnsafeUnliftIO', but it's not checked anywhere.+--+-- __If you disregard the second point, segmentation faults await.__+reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a+reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es)
+ src/Effectful/Error/Dynamic.hs view
@@ -0,0 +1,90 @@+-- | The dynamically dispatched variant of the 'Error' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use the statically dispatched variant,+-- i.e. "Effectful.Error.Static".+module Effectful.Error.Dynamic+ ( -- * Effect+ Error(..)++ -- ** Handlers+ , runError+ , runErrorNoCallStack++ -- ** Operations+ , throwError+ , catchError+ , handleError+ , tryError++ -- * Re-exports+ , E.HasCallStack+ , E.CallStack+ , E.getCallStack+ , E.prettyCallStack+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import qualified Effectful.Error.Static as E++-- | Provide the ability to handle errors of type @e@.+data Error e :: Effect where+ ThrowError :: e -> Error e m a+ CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a++type instance DispatchOf (Error e) = Dynamic++-- | Handle errors of type @e@ (via "Effectful.Error.Static").+runError+ :: Eff (Error e : es) a+ -> Eff es (Either (E.CallStack, e) a)+runError = reinterpret E.runError $ \env -> \case+ ThrowError e -> E.throwError e+ CatchError m h -> localSeqUnlift env $ \unlift -> do+ E.catchError (unlift m) (\cs -> unlift . h cs)++-- | Handle errors of type @e@ (via "Effectful.Error.Static"). In case of an+-- error discard the 'E.CallStack'.+runErrorNoCallStack+ :: Eff (Error e : es) a+ -> Eff es (Either e a)+runErrorNoCallStack = fmap (either (Left . snd) Right) . runError++-- | Throw an error of type @e@.+throwError+ :: (HasCallStack, Error e :> es)+ => e+ -- ^ The error.+ -> Eff es a+throwError = send . ThrowError++-- | Handle an error of type @e@.+catchError+ :: (HasCallStack, Error e :> es)+ => Eff es a+ -- ^ The inner computation.+ -> (E.CallStack -> e -> Eff es a)+ -- ^ A handler for errors in the inner computation.+ -> Eff es a+catchError m = send . CatchError m++-- | The same as @'flip' 'catchError'@, which is useful in situations where the+-- code for the handler is shorter.+handleError+ :: Error e :> es+ => (E.CallStack -> e -> Eff es a)+ -- ^ A handler for errors in the inner computation.+ -> Eff es a+ -- ^ The inner computation.+ -> Eff es a+handleError = flip catchError++-- | Similar to 'catchError', but returns an 'Either' result which is a 'Right'+-- if no error was thrown and a 'Left' otherwise.+tryError+ :: (HasCallStack, Error e :> es)+ => Eff es a+ -- ^ The inner computation.+ -> Eff es (Either (E.CallStack, e) a)+tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
+ src/Effectful/Error/Static.hs view
@@ -0,0 +1,221 @@+-- | Support for handling errors of a particular type, i.e. checked exceptions.+--+-- The 'Error' effect is __not__ a general mechanism for handling regular+-- exceptions, that's what functions from the @exceptions@ library are for (see+-- "Control.Monad.Catch" for more information).+--+-- In particular, regular exceptions of type @e@ are distinct from errors of+-- type @e@ and will __not__ be caught by functions from this module:+--+-- >>> import qualified Control.Monad.Catch as E+--+-- >>> boom = error "BOOM!"+--+-- >>> runEff . runError @ErrorCall $ boom `catchError` \_ (_::ErrorCall) -> pure "caught"+-- *** Exception: BOOM!+-- ...+--+-- If you want to catch regular exceptions, you should use+-- 'Control.Monad.Catch.catch' (or a similar function):+--+-- >>> runEff $ boom `E.catch` \(_::ErrorCall) -> pure "caught"+-- "caught"+--+-- On the other hand, functions for safe finalization and management of+-- resources such as 'Control.Monad.Catch.finally' and+-- 'Control.Monad.Catch.bracket' work as expected:+--+-- >>> msg = liftIO . putStrLn+--+-- >>> :{+-- runEff . runErrorNoCallStack @String $ do+-- E.bracket_ (msg "Beginning.")+-- (msg "Cleaning up.")+-- (msg "Computing." >> throwError "oops" >> msg "More.")+-- :}+-- Beginning.+-- Computing.+-- Cleaning up.+-- Left "oops"+--+-- /Note:/ unlike the 'Control.Monad.Trans.Except.ExceptT' monad transformer+-- from the @transformers@ library, the order in which you handle the 'Error'+-- effect with regard to other stateful effects does not matter. Consider the+-- following:+--+-- >>> import qualified Control.Monad.State.Strict as T+-- >>> import qualified Control.Monad.Except as T+--+-- >>> m1 = (T.modify (++ " there!") >> T.throwError "oops") `T.catchError` \_ -> pure ()+--+-- >>> (`T.runStateT` "Hi") . T.runExceptT $ m1+-- (Right (),"Hi there!")+--+-- >>> T.runExceptT . (`T.runStateT` "Hi") $ m1+-- Right ((),"Hi")+--+-- Here, whether state updates within the 'catchError' block are discarded or+-- not depends on the shape of the monad transformer stack, which is surprising+-- and can be a source of subtle bugs. On the other hand:+--+-- >>> import Effectful.State.Static.Local+--+-- >>> m2 = (modify (++ " there!") >> throwError "oops") `catchError` \_ (_::String) -> pure ()+--+-- >>> runEff . runState "Hi" . runError @String $ m2+-- (Right (),"Hi there!")+--+-- >>> runEff . runError @String . runState "Hi" $ m2+-- Right ((),"Hi there!")+--+-- Here, no matter the order of effects, state updates made within the+-- @catchError@ block before the error happens always persist, giving+-- predictable behavior.+--+-- /Hint:/ if you'd like to reproduce the transactional behavior with the+-- 'Effectful.State.Static.Local.State' effect, appropriate usage of+-- 'Control.Monad.Catch.bracketOnError' will do the trick.+module Effectful.Error.Static+ ( -- * Effect+ Error++ -- ** Handlers+ , runError+ , runErrorNoCallStack++ -- ** Operations+ , throwError+ , catchError+ , handleError+ , tryError++ -- * Re-exports+ , HasCallStack+ , CallStack+ , getCallStack+ , prettyCallStack+ ) where++import Control.Exception+import Data.Unique+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide the ability to handle errors of type @e@.+data Error e :: Effect++type instance DispatchOf (Error e) = Static NoSideEffects+newtype instance StaticRep (Error e) = Error ErrorId++-- | Handle errors of type @e@.+runError+ :: forall e es a+ . Eff (Error e : es) a+ -> Eff es (Either (CallStack, e) a)+runError m = unsafeEff $ \es0 -> mask $ \unmask -> do+ eid <- newErrorId+ es <- consEnv (Error @e eid) dummyRelinker es0+ r <- tryErrorIO unmask eid es `onException` unconsEnv es+ unconsEnv es+ pure r+ where+ tryErrorIO unmask eid es = try (unmask $ unEff m es) >>= \case+ Right a -> pure $ Right a+ Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))+ $ throwIO ex++-- | Handle errors of type @e@. In case of an error discard the 'CallStack'.+runErrorNoCallStack+ :: forall e es a+ . Eff (Error e : es) a+ -> Eff es (Either e a)+runErrorNoCallStack = fmap (either (Left . snd) Right) . runError++-- | Throw an error of type @e@.+throwError+ :: forall e es a. (HasCallStack, Error e :> es)+ => e+ -- ^ The error.+ -> Eff es a+throwError e = unsafeEff $ \es -> do+ Error eid <- getEnv @(Error e) es+ throwIO $ ErrorWrapper eid callStack (toAny e)++-- | Handle an error of type @e@.+catchError+ :: forall e es a. Error e :> es+ => Eff es a+ -- ^ The inner computation.+ -> (CallStack -> e -> Eff es a)+ -- ^ A handler for errors in the inner computation.+ -> Eff es a+catchError m handler = unsafeEff $ \es -> do+ Error eid <- getEnv @(Error e) es+ catchErrorIO eid (unEff m es) $ \cs e -> do+ checkSizeEnv es+ unEff (handler cs e) es++-- | The same as @'flip' 'catchError'@, which is useful in situations where the+-- code for the handler is shorter.+handleError+ :: forall e es a. Error e :> es+ => (CallStack -> e -> Eff es a)+ -- ^ A handler for errors in the inner computation.+ -> Eff es a+ -- ^ The inner computation.+ -> Eff es a+handleError = flip catchError++-- | Similar to 'catchError', but returns an 'Either' result which is a 'Right'+-- if no error was thrown and a 'Left' otherwise.+tryError+ :: forall e es a. Error e :> es+ => Eff es a+ -- ^ The inner computation.+ -> Eff es (Either (CallStack, e) a)+tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)++----------------------------------------+-- Helpers++newtype ErrorId = ErrorId Unique+ deriving Eq++-- | A unique is picked so that distinct 'Error' handlers for the same type+-- don't catch each other's exceptions.+newErrorId :: IO ErrorId+newErrorId = ErrorId <$> newUnique++tryHandler+ :: SomeException+ -> ErrorId+ -> (CallStack -> e -> r)+ -> IO r+ -> IO r+tryHandler ex eid0 handler next = case fromException ex of+ Just (ErrorWrapper eid cs e)+ | eid0 == eid -> pure $ handler cs (fromAny e)+ | otherwise -> next+ Nothing -> next++data ErrorWrapper = ErrorWrapper !ErrorId CallStack Any+instance Show ErrorWrapper where+ showsPrec p (ErrorWrapper _ cs _)+ = ("Effectful.Error.Static.ErrorWrapper\n\n" ++)+ . ("If you see this, most likely there is a stray 'Async' action that\n" ++)+ . ("outlived the scope of the 'Error' effect, was interacted with and threw\n" ++)+ . ("an error to the parent thread. If that scenario sounds unlikely, please\n" ++)+ . ("file a ticket at https://github.com/haskell-effectful/effectful/issues.\n\n" ++)+ . showsPrec p (prettyCallStack cs)+instance Exception ErrorWrapper++catchErrorIO :: ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a+catchErrorIO eid m handler = do+ m `catch` \err@(ErrorWrapper etag cs e) -> do+ if eid == etag+ then handler cs (fromAny e)+ else throwIO err
+ src/Effectful/Fail.hs view
@@ -0,0 +1,24 @@+-- | Provider of the 'MonadFail' instance for 'Eff'.+module Effectful.Fail+ ( -- * Effect+ Fail(..)++ -- ** Handlers+ , runFail+ , runFailIO+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Error.Static+import Effectful.Internal.Monad (Fail(..))++-- | Run the 'Fail' effect via 'Error'.+runFail :: Eff (Fail : es) a -> Eff es (Either String a)+runFail = reinterpret runErrorNoCallStack $ \_ -> \case+ Fail msg -> throwError msg++-- | Run the 'Fail' effect via the 'MonadFail' instance for 'IO'.+runFailIO :: IOE :> es => Eff (Fail : es) a -> Eff es a+runFailIO = interpret $ \_ -> \case+ Fail msg -> liftIO $ fail msg
+ src/Effectful/Internal/Effect.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | Type-safe indexing for 'Effectful.Internal.Monad.Env'.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Effect+ ( Effect+ , (:>)(..)+ , (:>>)+ , Subset(..)++ -- * Re-exports+ , Type+ ) where++import Data.Kind+import GHC.TypeLits++-- | The kind of effects.+type Effect = (Type -> Type) -> Type -> Type++-- | A constraint that requires that a particular effect @e@ is a member of the+-- type-level list @es@. This is used to parameterize an 'Effectful.Eff'+-- computation over an arbitrary list of effects, so long as @e@ is /somewhere/+-- in the list.+--+-- For example, a computation that only needs access to a mutable value of type+-- 'Integer' would have the following type:+--+-- @+-- 'Effectful.State.Static.Local.State' 'Integer' ':>' es => 'Effectful.Eff' es ()+-- @+class (e :: Effect) :> (es :: [Effect]) where+ -- | Get the position of @e@ in @es@.+ --+ -- /Note:/ GHC is kind enough to cache these values as they're top level CAFs,+ -- so the lookup is amortized @O(1)@ without any language level tricks.+ reifyIndex :: Int+ reifyIndex = -- Don't show "minimal complete definition" in haddock.+ error "unimplemented"++instance TypeError+ ( Text "There is no handler for '" :<>: ShowType e :<>: Text "' in the context"+ ) => e :> '[] where+ reifyIndex = error "unreachable"++instance {-# OVERLAPPING #-} e :> (e : es) where+ reifyIndex = 0++instance e :> es => e :> (x : es) where+ reifyIndex = 1 + reifyIndex @e @es++----------------------------------------++-- | Convenience operator for expressing that a function uses multiple effects+-- in a more concise way than enumerating them all with '(:>)'.+--+-- @[E1, E2, ..., En] ':>>' es ≡ (E1 ':>' es, E2 ':>' es, ..., En :> es)@+type family xs :>> es :: Constraint where+ '[] :>> es = ()+ (x : xs) :>> es = (x :> es, xs :>> es)++----------------------------------------++-- | Provide evidence that @xs@ is a subset of @es@.+class Subset (xs :: [Effect]) (es :: [Effect]) where+ reifyIndices :: [Int]+ reifyIndices = -- Don't show "minimal complete definition" in haddock.+ error "unimplemented"++instance Subset '[] es where+ reifyIndices = []++instance (e :> es, Subset xs es) => Subset (e : xs) es where+ reifyIndices = reifyIndex @e @es : reifyIndices @xs @es
+ src/Effectful/Internal/Env.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_HADDOCK not-home #-}+module Effectful.Internal.Env+ ( -- * The environment+ Env(..)+ , References(..)+ , Storage(..)++ -- ** Relinker+ , Relinker(..)+ , dummyRelinker++ -- * Dispatch+ , Dispatch(..)+ , SideEffects(..)+ , DispatchOf+ , EffectRep++ -- * Operations+ , emptyEnv+ , cloneEnv+ , forkEnv+ , sizeEnv+ , checkSizeEnv+ , tailEnv++ -- ** Modification of the effect stack+ , consEnv+ , unconsEnv+ , replaceEnv+ , unreplaceEnv+ , subsumeEnv+ , unsubsumeEnv+ , injectEnv++ -- ** Data retrieval and update+ , getEnv+ , putEnv+ , stateEnv+ , modifyEnv+ ) where++import Control.Monad+import Control.Monad.Primitive+import Data.IORef+import Data.Primitive.PrimArray+import Data.Primitive.SmallArray+import GHC.Stack (HasCallStack)++import Effectful.Internal.Effect+import Effectful.Internal.Utils++type role Env nominal++-- | A strict (WHNF), __thread local__, mutable, extensible record indexed by types+-- of kind 'Effect'.+--+-- Supports forking, i.e. introduction of local branches for encapsulation of+-- effects specific to effect handlers.+--+-- __Warning: the environment is a mutable data structure and cannot be simultaneously used from multiple threads under any circumstances.__+--+-- In order to pass it to a different thread, you need to perform a deep copy+-- with the 'cloneEnv' funtion.+--+-- Offers very good performance characteristics for most often performed+-- operations:+--+-- - Extending: /@O(1)@/ (amortized).+--+-- - Shrinking: /@O(1)@/.+--+-- - Indexing via '(:>)': /@O(1)@/+--+-- - Modification of a specific element: /@O(1)@/.+--+-- - Forking: /@O(n)@/, where @n@ is the size of the effect stack.+--+-- - Cloning: /@O(N + Σ(n_i))@/, where @N@ is the size of the 'Storage', while+-- @i@ ranges over handlers of dynamically dispatched effects in the 'Storage'+-- and @n_i@ is the size of the effect stack of @i@-th handler.+--+data Env (es :: [Effect]) = Env+ { envSize :: !Int+ , envRefs :: !(IORef References)+ , envStorage :: !(IORef Storage)+ }++-- | An array of references to effects in the 'Storage'.+data References = References+ { refSize :: !Int+ , refIndices :: !(MutablePrimArray RealWorld Int)+ }++-- | A storage of effects.+--+-- Shared between all forks of the environment within the same thread.+data Storage = Storage+ { stSize :: !Int+ , stEffects :: !(SmallMutableArray RealWorld Any)+ , stRelinkers :: !(SmallMutableArray RealWorld Any)+ }++----------------------------------------+-- Relinker++-- | A function for relinking 'Env' objects stored in the handlers and/or making+-- a deep copy of the representation of the effect when cloning the environment.+newtype Relinker :: (Effect -> Type) -> Effect -> Type where+ Relinker+ :: ((forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e))+ -> Relinker rep e++-- | A dummy 'Relinker'.+dummyRelinker :: Relinker rep e+dummyRelinker = Relinker $ \_ -> pure++----------------------------------------+-- Dispatch++-- | A type of dispatch. For more information consult the documentation in+-- "Effectful.Dispatch.Dynamic" and "Effectful.Dispatch.Static".+data Dispatch = Dynamic | Static SideEffects++-- | Signifies whether core operations of a statically dispatched effect perform+-- side effects. If an effect is marked as such, the+-- 'Effectful.Dispatch.Static.runStaticRep' family of functions will require the+-- 'Effectful.IOE' effect to be in context via the+-- 'Effectful.Dispatch.Static.MaybeIOE' type family.+data SideEffects = NoSideEffects | WithSideEffects++-- | Dispatch types of effects.+type family DispatchOf (e :: Effect) :: Dispatch++-- | Internal representations of effects.+type family EffectRep (d :: Dispatch) :: Effect -> Type++----------------------------------------+-- Operations++-- | Create an empty environment.+emptyEnv :: IO (Env '[])+emptyEnv = Env <$> pure 0+ <*> (newIORef . References 0 =<< newPrimArray 0)+ <*> (newIORef =<< emptyStorage)++-- | Clone the environment to use it in a different thread.+cloneEnv :: Env es -> IO (Env es)+cloneEnv (Env size mrefs0 storage0) = do+ References n refs0 <- readIORef mrefs0+ errorWhenDifferent size n+ mrefs <- newIORef . References n+ =<< cloneMutablePrimArray refs0 0 (sizeofMutablePrimArray refs0)+ Storage storageSize es0 fs0 <- readIORef storage0+ let esSize = sizeofSmallMutableArray es0+ fsSize = sizeofSmallMutableArray fs0+ when (esSize /= fsSize) $ do+ error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")"+ es <- cloneSmallMutableArray es0 0 esSize+ fs <- cloneSmallMutableArray fs0 0 esSize+ storage <- newIORef $ Storage storageSize es fs+ let relinkEffects = \case+ 0 -> pure ()+ k -> do+ let i = k - 1+ Relinker f <- fromAny <$> readSmallArray fs i+ readSmallArray es i+ >>= f (relinkEnv storage) . fromAny+ >>= writeSmallArray es i . toAny+ relinkEffects i+ relinkEffects storageSize+ pure $ Env size mrefs storage+{-# NOINLINE cloneEnv #-}++-- | Create a fork of the environment.+--+-- Forked environment can be updated independently of the original one within+-- the same thread.+forkEnv :: Env es -> IO (Env es)+forkEnv (Env size mrefs0 storage) = do+ References n refs0 <- readIORef mrefs0+ errorWhenDifferent size n+ mrefs <- newIORef . References size+ =<< cloneMutablePrimArray refs0 0 (sizeofMutablePrimArray refs0)+ pure $ Env size mrefs storage+{-# NOINLINE forkEnv #-}++-- | Check that the size of the environment is internally consistent.+checkSizeEnv :: Env es -> IO ()+checkSizeEnv (Env size mrefs _) = do+ References n _ <- readIORef mrefs+ errorWhenDifferent size n+{-# NOINLINE checkSizeEnv #-}++-- | Get the current size of the environment.+sizeEnv :: Env es -> IO Int+sizeEnv env = pure $ envSize env++-- | Access the tail of the environment.+tailEnv :: Env (e : es) -> IO (Env es)+tailEnv (Env size mrefs0 storage) = do+ References n refs0 <- readIORef mrefs0+ errorWhenDifferent size n+ mrefs <- newIORef . References (size - 1)+ =<< cloneMutablePrimArray refs0 0 (sizeofMutablePrimArray refs0)+ pure $ Env (size - 1) mrefs storage+{-# NOINLINE tailEnv #-}++----------------------------------------+-- Extending and shrinking++-- | Extend the environment with a new data type (in place).+consEnv+ :: EffectRep (DispatchOf e) e+ -- ^ The representation of the effect.+ -> Relinker (EffectRep (DispatchOf e)) e+ -> Env es+ -> IO (Env (e : es))+consEnv e f (Env size mrefs storage) = do+ References n refs0 <- readIORef mrefs+ errorWhenDifferent size n+ len0 <- getSizeofMutablePrimArray refs0+ refs <- case size `compare` len0 of+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"+ LT -> pure refs0+ EQ -> resizeMutablePrimArray refs0 (doubleCapacity len0)+ ref <- insertEffect storage e f+ writePrimArray refs size ref+ writeIORef mrefs $! References (size + 1) refs+ pure $ Env (size + 1) mrefs storage+{-# NOINLINE consEnv #-}++-- | Shrink the environment by one data type (in place).+--+-- /Note:/ after calling this function the input environment is no longer+-- usable.+unconsEnv :: Env (e : es) -> IO ()+unconsEnv (Env size mrefs storage) = do+ References n refs <- readIORef mrefs+ errorWhenDifferent size n+ ref <- readPrimArray refs (size - 1)+ deleteEffect storage ref+ writeIORef mrefs $! References (size - 1) refs+{-# NOINLINE unconsEnv #-}++----------------------------------------++-- | Replace a specific effect in the stack with a new value.+replaceEnv+ :: forall e es. e :> es+ => EffectRep (DispatchOf e) e+ -- ^ The representation of the effect.+ -> Relinker (EffectRep (DispatchOf e)) e+ -> Env es+ -> IO (Env es)+replaceEnv e f (Env size mrefs0 storage) = do+ References n refs0 <- readIORef mrefs0+ errorWhenDifferent size n+ len0 <- getSizeofMutablePrimArray refs0+ when (size > len0) $ do+ error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"+ refs <- cloneMutablePrimArray refs0 0 len0+ ref <- insertEffect storage e f+ writePrimArray refs (mkIndex (reifyIndex @e @es) size) ref+ mrefs <- newIORef $ References n refs+ pure $ Env size mrefs storage+{-# NOINLINE replaceEnv #-}++-- | Remove a reference to the replaced effect.+--+-- /Note:/ after calling this function the input environment is no longer+-- usable.+unreplaceEnv :: forall e es. e :> es => Env es -> IO ()+unreplaceEnv (Env size mrefs storage) = do+ References n refs <- readIORef mrefs+ errorWhenDifferent size n+ ref <- readPrimArray refs $ mkIndex (reifyIndex @e @es) size+ deleteEffect storage ref+{-# NOINLINE unreplaceEnv #-}++----------------------------------------++-- | Reference an existing effect from the top of the stack (in place).+subsumeEnv :: forall e es. e :> es => Env es -> IO (Env (e : es))+subsumeEnv (Env size mrefs storage) = do+ References n refs0 <- readIORef mrefs+ errorWhenDifferent size n+ len0 <- getSizeofMutablePrimArray refs0+ refs <- case size `compare` len0 of+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"+ LT -> pure refs0+ EQ -> resizeMutablePrimArray refs0 (doubleCapacity len0)+ ref <- readPrimArray refs $ mkIndex (reifyIndex @e @es) size+ writePrimArray refs size ref+ writeIORef mrefs $! References (size + 1) refs+ pure $ Env (size + 1) mrefs storage+{-# NOINLINE subsumeEnv #-}++-- | Remove a reference to an existing effect from the top of the stack.+--+-- /Note:/ after calling this function the input environment is no longer+-- usable.+unsubsumeEnv :: e :> es => Env (e : es) -> IO ()+unsubsumeEnv (Env size mrefs _) = do+ References n refs <- readIORef mrefs+ errorWhenDifferent size n+ writeIORef mrefs $! References (size - 1) refs+{-# NOINLINE unsubsumeEnv #-}++----------------------------------------++-- | Construct an environment containing a permutation (with possible+-- duplicates) of a subset of effects from the input environment.+injectEnv :: forall xs es. Subset xs es => Env es -> IO (Env xs)+injectEnv (Env size0 mrefs0 storage) = do+ References n0 refs0 <- readIORef mrefs0+ errorWhenDifferent size0 n0+ let makeRefs k acc = \case+ [] -> unsafeThawPrimArray $ primArrayFromListN k acc+ (e : es) -> do+ i <- readPrimArray refs0 $ mkIndex e size0+ makeRefs (k + 1) (i : acc) es+ refs <- makeRefs 0 [] (reifyIndices @xs @es)+ size <- getSizeofMutablePrimArray refs+ mrefs <- newIORef $ References size refs+ pure $ Env size mrefs storage+{-# NOINLINE injectEnv #-}++----------------------------------------+-- Data retrieval and update++-- | Extract a specific data type from the environment.+getEnv+ :: forall e es. e :> es+ => Env es -- ^ The environment.+ -> IO (EffectRep (DispatchOf e) e)+getEnv env = do+ (i, es) <- getLocation @e env+ fromAny <$> readSmallArray es i++-- | Replace the data type in the environment with a new value (in place).+putEnv+ :: forall e es. e :> es+ => Env es -- ^ The environment.+ -> EffectRep (DispatchOf e) e+ -> IO ()+putEnv env e = do+ (i, es) <- getLocation @e env+ e `seq` writeSmallArray es i (toAny e)++-- | Modify the data type in the environment (in place) and return a value.+stateEnv+ :: forall e es a. e :> es+ => Env es -- ^ The environment.+ -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))+ -> IO a+stateEnv env f = do+ (i, es) <- getLocation @e env+ (a, e) <- f . fromAny <$> readSmallArray es i+ e `seq` writeSmallArray es i (toAny e)+ pure a++-- | Modify the data type in the environment (in place).+modifyEnv+ :: forall e es. e :> es+ => Env es -- ^ The environment.+ -> (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e)+ -> IO ()+modifyEnv env f = do+ (i, es) <- getLocation @e env+ e <- f . fromAny <$> readSmallArray es i+ e `seq` writeSmallArray es i (toAny e)++-- | Determine location of the effect in the environment.+getLocation+ :: forall e es. e :> es+ => Env es+ -> IO (Int, SmallMutableArray RealWorld Any)+getLocation (Env size mrefs storage) = do+ refs <- refIndices <$> readIORef mrefs+ i <- readPrimArray refs $ mkIndex (reifyIndex @e @es) size+ es <- stEffects <$> readIORef storage+ pure (i, es)++-- | Get the index of a reference to an effect.+mkIndex :: Int -> Int -> Int+mkIndex ix size = size - ix - 1++----------------------------------------+-- Internal helpers++-- | Create an empty storage.+emptyStorage :: IO Storage+emptyStorage = Storage+ <$> pure 0+ <*> newSmallArray 0 undefinedData+ <*> newSmallArray 0 undefinedData++-- | Insert an effect into the storage and return its reference.+insertEffect+ :: IORef Storage+ -> EffectRep (DispatchOf e) e+ -- ^ The representation of the effect.+ -> Relinker (EffectRep (DispatchOf e)) e+ -> IO Int+insertEffect storage e f = do+ Storage size es0 fs0 <- readIORef storage+ let len0 = sizeofSmallMutableArray es0+ case size `compare` len0 of+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"+ LT -> do+ e `seq` writeSmallArray es0 size (toAny e)+ f `seq` writeSmallArray fs0 size (toAny f)+ writeIORef storage $! Storage (size + 1) es0 fs0+ pure size+ EQ -> do+ let len = doubleCapacity len0+ es <- newSmallArray len undefinedData+ fs <- newSmallArray len undefinedData+ copySmallMutableArray es 0 es0 0 size+ copySmallMutableArray fs 0 fs0 0 size+ e `seq` writeSmallArray es size (toAny e)+ f `seq` writeSmallArray fs size (toAny f)+ writeIORef storage $! Storage (size + 1) es fs+ pure size++-- | Given a reference to an effect, delete it from the storage.+--+-- /Note:/ the reference needs to point to the end of the storage. Normally it's+-- not a problem as it turns out effects are put and taken from the storage in+-- the same order across all forks, unless someone tries to do something+-- unexpected.+deleteEffect :: IORef Storage -> Int -> IO ()+deleteEffect storage ref = do+ Storage size es fs <- readIORef storage+ when (ref /= size - 1) $ do+ error $ "ref (" ++ show ref ++ ") /= size - 1 (" ++ show (size - 1) ++ ")"+ writeSmallArray es ref undefinedData+ writeSmallArray fs ref undefinedData+ writeIORef storage $! Storage (size - 1) es fs++-- | Relink the environment to use the new storage.+relinkEnv :: IORef Storage -> Env es -> IO (Env es)+relinkEnv storage (Env size mrefs0 _) = do+ References n refs0 <- readIORef mrefs0+ mrefs <- newIORef . References n+ =<< cloneMutablePrimArray refs0 0 (sizeofMutablePrimArray refs0)+ pure $ Env size mrefs storage++-- | Throw an error if array sizes do not agree.+errorWhenDifferent :: HasCallStack => Int -> Int -> IO ()+errorWhenDifferent size n+ | size /= n = error $ "size (" ++ show size ++ ") /= n (" ++ show n ++ ")"+ | otherwise = pure ()++-- | Double the capacity of an array.+doubleCapacity :: Int -> Int+doubleCapacity n = max 1 n * 2++undefinedData :: HasCallStack => a+undefinedData = error "undefined data"
+ src/Effectful/Internal/Monad.hs view
@@ -0,0 +1,492 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | The 'Eff' monad.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Monad+ ( -- * The 'Eff' monad+ Eff+ , runPureEff++ -- ** Access to the internal representation+ , unEff+ , unsafeEff+ , unsafeEff_++ -- * Fail+ , Fail(..)++ -- * IO+ , IOE+ , runEff++ -- * Prim+ , Prim+ , runPrim++ -- * Lifting+ , raise+ , subsume+ , inject++ -- * Unlifting+ , UnliftStrategy(..)+ , Persistence(..)+ , Limit(..)+ , unliftStrategy+ , withUnliftStrategy+ , withEffToIO++ -- ** Low-level unlifts+ , seqUnliftIO+ , concUnliftIO++ -- * Dispatch++ -- ** Dynamic dispatch+ , EffectHandler+ , LocalEnv(..)+ , Handler(..)+ , relinkHandler+ , runHandler+ , send++ -- ** Static dispatch+ , StaticRep+ , MaybeIOE+ , runStaticRep+ , evalStaticRep+ , execStaticRep+ , getStaticRep+ , putStaticRep+ , stateStaticRep+ , stateStaticRepM+ , localStaticRep++ -- *** Primitive operations+ , consEnv+ , getEnv+ , putEnv+ , stateEnv+ , modifyEnv+ ) where++import Control.Applicative (liftA2)+import Control.Monad.Base+import Control.Monad.Fix+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Primitive+import Control.Monad.Trans.Control+import Data.Kind (Constraint)+import GHC.Exts (oneShot)+import GHC.IO (IO(..))+import GHC.Stack (HasCallStack)+import System.IO.Unsafe (unsafeDupablePerformIO)+import qualified Control.Exception as E+import qualified Control.Monad.Catch as C++import Effectful.Internal.Effect+import Effectful.Internal.Env+import Effectful.Internal.Unlift++type role Eff nominal representational++-- | The 'Eff' monad provides the implementation of a computation that performs+-- an arbitrary set of effects. In @'Eff' es a@, @es@ is a type-level list that+-- contains all the effects that the computation may perform. For example, a+-- computation that produces an 'Integer' by consuming a 'String' from the+-- global environment and acting upon a single mutable value of type 'Bool'+-- would have the following type:+--+-- @+-- ('Effectful.Reader.Static.Reader' 'String' ':>' es, 'Effectful.State.Static.Local.State' 'Bool' ':>' es) => 'Eff' es 'Integer'+-- @+--+-- Abstracting over the list of effects with '(:>)':+--+-- - Allows the computation to be used in functions that may perform other+-- effects.+--+-- - Allows the effects to be handled in any order.+newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a)+ deriving (Monoid, Semigroup)++-- | Run a pure 'Eff' computation.+--+-- For running computations with side effects see 'runEff'.+runPureEff :: Eff '[] a -> a+runPureEff (Eff m) =+ -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no+ -- IO with side effects was performed (unless someone sneakily introduced side+ -- effects with unsafeEff, but then all bets are off).+ --+ -- Moreover, internals don't allocate any resources that require explicit+ -- cleanup actions to run.+ unsafeDupablePerformIO $ m =<< emptyEnv++----------------------------------------+-- Access to the internal representation++-- | Peel off the constructor of 'Eff'.+unEff :: Eff es a -> Env es -> IO a+unEff = \(Eff m) -> m++-- | Access the underlying 'IO' monad along with the environment.+--+-- This function is __unsafe__ because it can be used to introduce arbitrary+-- 'IO' actions into pure 'Eff' computations.+unsafeEff :: (Env es -> IO a) -> Eff es a+unsafeEff m = Eff (oneShot m)++-- | Access the underlying 'IO' monad.+--+-- This function is __unsafe__ because it can be used to introduce arbitrary+-- 'IO' actions into pure 'Eff' computations.+unsafeEff_ :: IO a -> Eff es a+unsafeEff_ m = unsafeEff $ \_ -> m++----------------------------------------+-- Unlifting IO++-- | Get the current 'UnliftStrategy'.+unliftStrategy :: IOE :> es => Eff es UnliftStrategy+unliftStrategy = do+ IOE unlift <- getStaticRep+ pure unlift++-- | Locally override the 'UnliftStrategy' with the given value.+withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a+withUnliftStrategy unlift = localStaticRep $ \_ -> IOE unlift++-- | Create an unlifting function with the current 'UnliftStrategy'.+--+-- This function is equivalent to 'Effectful.withRunInIO', but has a+-- 'HasCallStack' constraint for accurate stack traces in case an insufficiently+-- powerful 'UnliftStrategy' is used and the unlifting function fails.+withEffToIO+ :: (HasCallStack, IOE :> es)+ => ((forall r. Eff es r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ --+ -- /Note:/ the strategy is reset to 'SeqUnlift' inside the continuation.+ -> Eff es a+withEffToIO f = unliftStrategy >>= \case+ SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do+ unsafeEff $ \es -> concUnliftIO es p b f++-- | Create an unlifting function with the 'SeqUnlift' strategy.+seqUnliftIO+ :: HasCallStack+ => Env es+ -- ^ The environment.+ -> ((forall r. Eff es r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ -> IO a+seqUnliftIO es k = seqUnlift k es unEff++-- | Create an unlifting function with the 'ConcUnlift' strategy.+concUnliftIO+ :: HasCallStack+ => Env es+ -- ^ The environment.+ -> Persistence+ -> Limit+ -> ((forall r. Eff es r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ -> IO a+concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff++----------------------------------------+-- Base++instance Functor (Eff es) where+ fmap f (Eff m) = unsafeEff $ \es -> f <$> m es+ a <$ Eff fb = unsafeEff $ \es -> a <$ fb es++instance Applicative (Eff es) where+ pure = unsafeEff_ . pure+ Eff mf <*> Eff mx = unsafeEff $ \es -> mf es <*> mx es+ Eff ma *> Eff mb = unsafeEff $ \es -> ma es *> mb es+ Eff ma <* Eff mb = unsafeEff $ \es -> ma es <* mb es+ liftA2 f (Eff ma) (Eff mb) = unsafeEff $ \es -> liftA2 f (ma es) (mb es)++instance Monad (Eff es) where+ return = unsafeEff_ . pure+ Eff m >>= k = unsafeEff $ \es -> m es >>= \a -> unEff (k a) es+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/20008+ Eff ma >> Eff mb = unsafeEff $ \es -> ma es >> mb es++instance MonadFix (Eff es) where+ mfix f = unsafeEff $ \es -> mfix $ \a -> unEff (f a) es++----------------------------------------+-- Exception++instance C.MonadThrow (Eff es) where+ throwM = unsafeEff_ . E.throwIO++instance C.MonadCatch (Eff es) where+ catch m handler = unsafeEff $ \es -> do+ unEff m es `E.catch` \e -> do+ checkSizeEnv es+ unEff (handler e) es++instance C.MonadMask (Eff es) where+ mask k = unsafeEff $ \es -> E.mask $ \unmask ->+ unEff (k $ \m -> unsafeEff $ unmask . unEff m) es++ uninterruptibleMask k = unsafeEff $ \es -> E.uninterruptibleMask $ \unmask ->+ unEff (k $ \m -> unsafeEff $ unmask . unEff m) es++ generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \unmask -> do+ resource <- unEff acquire es+ b <- unmask (unEff (use resource) es) `E.catch` \e -> do+ checkSizeEnv es+ _ <- unEff (release resource $ C.ExitCaseException e) es+ E.throwIO e+ c <- unEff (release resource $ C.ExitCaseSuccess b) es+ pure (b, c)++----------------------------------------+-- Fail++-- | Provide the ability to use the 'MonadFail' instance of 'Eff'.+data Fail :: Effect where+ Fail :: String -> Fail m a++type instance DispatchOf Fail = Dynamic++instance Fail :> es => MonadFail (Eff es) where+ fail = send . Fail++----------------------------------------+-- IO++-- | Run arbitrary 'IO' computations via 'MonadIO' or 'MonadUnliftIO'.+--+-- /Note:/ it is not recommended to use this effect in application code as it is+-- too liberal. Ideally, this is only used in handlers of more fine-grained+-- effects.+data IOE :: Effect++type instance DispatchOf IOE = Static WithSideEffects+newtype instance StaticRep IOE = IOE UnliftStrategy++-- | Run an 'Eff' computation with side effects.+--+-- For running pure computations see 'runPureEff'.+runEff :: Eff '[IOE] a -> IO a+runEff m = unEff m =<< consEnv (IOE SeqUnlift) dummyRelinker =<< emptyEnv++instance IOE :> es => MonadIO (Eff es) where+ liftIO = unsafeEff_++-- | Use 'withEffToIO' if you want accurate stack traces on errors.+instance IOE :> es => MonadUnliftIO (Eff es) where+ withRunInIO = withEffToIO++-- | Instance included for compatibility with existing code, usage of 'liftIO'+-- is preferrable.+instance IOE :> es => MonadBase IO (Eff es) where+ liftBase = unsafeEff_++-- | Instance included for compatibility with existing code, usage of+-- 'Effectful.withRunInIO' is preferrable.+instance IOE :> es => MonadBaseControl IO (Eff es) where+ type StM (Eff es) a = a+ liftBaseWith = withEffToIO+ restoreM = pure++----------------------------------------+-- Primitive++-- | Provide the ability to perform primitive state-transformer actions.+data Prim :: Effect++type instance DispatchOf Prim = Static WithSideEffects+data instance StaticRep Prim = Prim++-- | Run an 'Eff' computation with primitive state-transformer actions.+runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a+runPrim = evalStaticRep Prim++instance Prim :> es => PrimMonad (Eff es) where+ type PrimState (Eff es) = RealWorld+ primitive = unsafeEff_ . IO++----------------------------------------+-- Lifting++-- | Lift an 'Eff' computation into an effect stack with one more effect.+--+-- /Note:/ unless you need this function rarely, you're most likely working with+-- monomorphic effect stacks, which is not recommended (see 'Eff' for more+-- information).+raise :: Eff es a -> Eff (e : es) a+raise m = unsafeEff $ \es -> unEff m =<< tailEnv es++-- | Eliminate a duplicate effect from the top of the effect stack.+subsume :: e :> es => Eff (e : es) a -> Eff es a+subsume m = unsafeEff $ \es0 -> do+ E.bracket (subsumeEnv es0)+ unsubsumeEnv+ (\es -> unEff m es)++-- | Allow for running an effect stack @xs@ within @es@ as long as @xs@ is a+-- permutation (with possible duplicates) of a subset of @es@.+--+-- Generalizes 'raise' and 'subsume'.+--+-- /Note:/ this function should be needed rarely, usually when you have to cross+-- API boundaries and monomorphic effect stacks are involved. Using monomorphic+-- stacks is discouraged (see 'Eff'), but sometimes might be necessary due to+-- external constraints.+inject :: Subset xs es => Eff xs a -> Eff es a+inject m = unsafeEff $ \es -> unEff m =<< injectEnv es++----------------------------------------+-- Dynamic dispatch++type role LocalEnv nominal nominal++-- | Opaque representation of the 'Eff' environment at the point of calling the+-- 'send' function, i.e. right before the control is passed to the effect+-- handler.+--+-- The second type variable represents effects of a handler and is needed for+-- technical reasons to guarantee soundness.+newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env localEs)++-- | Type signature of the effect handler.+type EffectHandler e es+ = forall a localEs. HasCallStack+ => LocalEnv localEs es+ -- ^ Capture of the local environment for handling local 'Eff' computations+ -- when @e@ is a higher order effect.+ -> e (Eff localEs) a+ -- ^ The effect performed in the local environment.+ -> Eff es a++-- | An internal representation of dynamically dispatched effects, i.e. the+-- effect handler bundled with its environment.+data Handler :: Effect -> Type where+ Handler :: !(Env es) -> !(EffectHandler e es) -> Handler e+type instance EffectRep Dynamic = Handler++relinkHandler :: Relinker Handler e+relinkHandler = Relinker $ \relink (Handler handlerEs handle) -> do+ newHandlerEs <- relink handlerEs+ pure $ Handler newHandlerEs handle++-- | Run a dynamically dispatched effect with the given handler.+runHandler :: DispatchOf e ~ Dynamic => Handler e -> Eff (e : es) a -> Eff es a+runHandler e m = unsafeEff $ \es0 -> do+ E.bracket (consEnv e relinkHandler es0)+ unconsEnv+ (\es -> unEff m es)++-- | Send an operation of the given effect to its handler for execution.+send+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => e (Eff es) a+ -- ^ The effect.+ -> Eff es a+send op = unsafeEff $ \es -> do+ Handler handlerEs handle <- getEnv es+ unEff (handle (LocalEnv es) op) handlerEs+{-# NOINLINE send #-}++----------------------------------------+-- Static dispatch++-- | Require the 'IOE' effect for running statically dispatched effects whose+-- operations perform side effects.+type family MaybeIOE (sideEffects :: SideEffects) (es :: [Effect]) :: Constraint where+ MaybeIOE NoSideEffects _ = ()+ MaybeIOE WithSideEffects es = IOE :> es++-- | Internal representations of statically dispatched effects.+data family StaticRep (e :: Effect) :: Type+type instance EffectRep (Static sideEffects) = StaticRep++-- | Run a statically dispatched effect with the given initial representation+-- and return the final value along with the final representation.+runStaticRep+ :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+ => StaticRep e -- ^ The initial representation.+ -> Eff (e : es) a+ -> Eff es (a, StaticRep e)+runStaticRep e0 m = unsafeEff $ \es0 -> do+ E.bracket (consEnv e0 dummyRelinker es0)+ unconsEnv+ (\es -> (,) <$> unEff m es <*> getEnv es)++-- | Run a statically dispatched effect with the given initial representation+-- and return the final value, discarding the final representation.+evalStaticRep+ :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+ => StaticRep e -- ^ The initial representation.+ -> Eff (e : es) a+ -> Eff es a+evalStaticRep e m = unsafeEff $ \es0 -> do+ E.bracket (consEnv e dummyRelinker es0)+ unconsEnv+ (\es -> unEff m es)++-- | Run a statically dispatched effect with the given initial representation+-- and return the final representation, discarding the final value.+execStaticRep+ :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+ => StaticRep e -- ^ The initial representation.+ -> Eff (e : es) a+ -> Eff es (StaticRep e)+execStaticRep e0 m = unsafeEff $ \es0 -> do+ E.bracket (consEnv e0 dummyRelinker es0)+ unconsEnv+ (\es -> unEff m es *> getEnv es)++-- | Fetch the current representation of the effect.+getStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => Eff es (StaticRep e)+getStaticRep = unsafeEff $ \es -> getEnv es++-- | Set the current representation of the effect to the given value.+putStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => StaticRep e -> Eff es ()+putStaticRep s = unsafeEff $ \es -> putEnv es s++-- | Apply the function to the current representation of the effect and return a+-- value.+stateStaticRep+ :: (DispatchOf e ~ Static sideEffects, e :> es)+ => (StaticRep e -> (a, StaticRep e))+ -- ^ The function to modify the representation.+ -> Eff es a+stateStaticRep f = unsafeEff $ \es -> stateEnv es f++-- | Apply the monadic function to the current representation of the effect and+-- return a value.+stateStaticRepM+ :: (DispatchOf e ~ Static sideEffects, e :> es)+ => (StaticRep e -> Eff es (a, StaticRep e))+ -- ^ The function to modify the representation.+ -> Eff es a+stateStaticRepM f = unsafeEff $ \es -> E.mask $ \unmask -> do+ (a, s) <- (\s0 -> unmask $ unEff (f s0) es) =<< getEnv es+ putEnv es s+ pure a++-- | Execute a computation with a temporarily modified representation of the+-- effect.+localStaticRep+ :: (DispatchOf e ~ Static sideEffects, e :> es)+ => (StaticRep e -> StaticRep e)+ -- ^ The function to temporarily modify the representation.+ -> Eff es a+ -> Eff es a+localStaticRep f m = unsafeEff $ \es -> do+ E.bracket (stateEnv es $ \s -> (s, f s))+ (\s -> putEnv es s)+ (\_ -> unEff m es)
+ src/Effectful/Internal/Unlift.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | Implementation of sequential and concurrent unlifts.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Unlift+ ( -- * Unlifting strategies+ UnliftStrategy(..)+ , Persistence(..)+ , Limit(..)++ -- * Unlifting functions+ , seqUnlift+ , concUnlift+ , ephemeralConcUnlift+ , persistentConcUnlift+ ) where++import Control.Concurrent+import Control.Monad+import GHC.Conc.Sync (ThreadId(..))+import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)+import GHC.Generics (Generic)+import GHC.IO (IO(..))+import GHC.Stack (HasCallStack)+import GHC.Weak (Weak(..))+import System.Mem.Weak (deRefWeak)+import qualified Data.IntMap.Strict as IM++import Effectful.Internal.Env+import Effectful.Internal.Utils++----------------------------------------+-- Unlift strategies++-- | The strategy to use when unlifting 'Effectful.Eff' computations via+-- 'Effectful.withEffToIO', 'Effectful.withRunInIO' or the+-- 'Effectful.Dispatch.Dynamic.localUnlift' family.+--+-- /Warning:/ unlifting functions should not be used outside of continuations+-- that brought them into scope. __The behavior when doing so is undefined.__+data UnliftStrategy+ = SeqUnlift+ -- ^ The fastest strategy and a default setting for t'Effectful.IOE'. An+ -- attempt to call the unlifting function in threads distinct from its creator+ -- will result in a runtime error.+ | ConcUnlift !Persistence !Limit+ -- ^ A strategy that makes it possible for the unlifting function to be called+ -- in threads distinct from its creator. See 'Persistence' and 'Limit'+ -- settings for more information.+ deriving (Eq, Generic, Ord, Show)++-- | Persistence setting for the 'ConcUnlift' strategy.+--+-- Different functions require different persistence strategies. Examples:+--+-- - Lifting 'pooledMapConcurrentlyN' from the @unliftio@ library requires the+-- 'Ephemeral' strategy as we don't want jobs to share environment changes+-- made by previous jobs run in the same worker thread.+--+-- - Lifting 'Control.Concurrent.forkIOWithUnmask' requires the 'Persistent'+-- strategy, otherwise the unmasking function would start with a fresh+-- environment each time it's called.+data Persistence+ = Ephemeral+ -- ^ Don't persist the environment between calls to the unlifting function in+ -- threads distinct from its creator.+ | Persistent+ -- ^ Persist the environment between calls to the unlifting function within a+ -- particular thread.+ deriving (Eq, Generic, Ord, Show)++-- | Limit setting for the 'ConcUnlift' strategy.+data Limit+ = Limited !Int+ -- ^ Behavior dependent on the 'Persistence' setting.+ --+ -- For 'Ephemeral', it limits the amount of uses of the unlifting function in+ -- threads distinct from its creator to @N@. The unlifting function will+ -- create @N@ copies of the environment when called @N@ times and @K+1@ copies+ -- when called @K < N@ times.+ --+ -- For 'Persistent', it limits the amount of threads, distinct from the+ -- creator of the unlifting function, it can be called in to @N@. The amount+ -- of calls to the unlifting function within a particular threads is+ -- unlimited. The unlifting function will create @N@ copies of the environment+ -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads.+ | Unlimited+ -- ^ Unlimited use of the unlifting function.+ deriving (Eq, Generic, Ord, Show)++----------------------------------------+-- Unlift functions++-- | Sequential unlift.+seqUnlift+ :: HasCallStack+ => ((forall r. m r -> IO r) -> IO a)+ -> Env es+ -> (forall r. m r -> Env es -> IO r)+ -> IO a+seqUnlift k es unEff = do+ tid0 <- myThreadId+ k $ \m -> do+ tid <- myThreadId+ if tid `eqThreadId` tid0+ then unEff m es+ else error+ $ "If you want to use the unlifting function to run Eff computations "+ ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)."++-- | Concurrent unlift for various strategies and limits.+concUnlift+ :: HasCallStack+ => Persistence+ -> Limit+ -> ((forall r. m r -> IO r) -> IO a)+ -> Env es+ -> (forall r. m r -> Env es -> IO r)+ -> IO a+concUnlift Ephemeral (Limited uses) k =+ ephemeralConcUnlift uses k+concUnlift Ephemeral Unlimited k =+ ephemeralConcUnlift maxBound k+concUnlift Persistent (Limited threads) k =+ persistentConcUnlift False threads k+concUnlift Persistent Unlimited k =+ persistentConcUnlift True maxBound k++-- | Concurrent unlift that doesn't preserve the environment between calls to+-- the unlifting function in threads other than its creator.+ephemeralConcUnlift+ :: HasCallStack+ => Int+ -- ^ Number of permitted uses of the unlift function.+ -> ((forall r. m r -> IO r) -> IO a)+ -> Env es+ -> (forall r. m r -> Env es -> IO r)+ -> IO a+ephemeralConcUnlift uses k es0 unEff = do+ unless (uses > 0) $ do+ error $ "Invalid number of uses: " ++ show uses+ tid0 <- myThreadId+ -- Create a copy of the environment as a template for the other threads to+ -- use. This can't be done from inside the callback as the environment might+ -- have already changed by then.+ esTemplate <- cloneEnv es0+ mvUses <- newMVar uses+ k $ \m -> do+ es <- myThreadId >>= \case+ tid | tid0 `eqThreadId` tid -> pure es0+ _ -> modifyMVar mvUses $ \case+ 0 -> error+ $ "Number of permitted calls (" ++ show uses ++ ") to the unlifting "+ ++ "function in other threads was exceeded. Please increase the limit "+ ++ "or use the unlimited variant."+ 1 -> pure (0, esTemplate)+ n -> do+ let newUses = n - 1+ es <- cloneEnv esTemplate+ newUses `seq` pure (newUses, es)+ unEff m es++-- | Concurrent unlift that preserves the environment between calls to the+-- unlifting function within a particular thread.+persistentConcUnlift+ :: HasCallStack+ => Bool+ -> Int+ -- ^ Number of threads that are allowed to use the unlift function.+ -> ((forall r. m r -> IO r) -> IO a)+ -> Env es+ -> (forall r. m r -> Env es -> IO r)+ -> IO a+persistentConcUnlift cleanUp threads k es0 unEff = do+ unless (threads > 0) $ do+ error $ "Invalid number of threads: " ++ show threads+ tid0 <- myThreadId+ -- Create a copy of the environment as a template for the other threads to+ -- use. This can't be done from inside the callback as the environment might+ -- have already changed by then.+ esTemplate <- cloneEnv es0+ mvEntries <- newMVar $ ThreadEntries threads IM.empty+ k $ \m -> do+ es <- myThreadId >>= \case+ tid | tid0 `eqThreadId` tid -> pure es0+ tid -> modifyMVar mvEntries $ \te -> do+ let wkTid = weakThreadId tid+ (mes, i) <- case wkTid `IM.lookup` teEntries te of+ Just (ThreadEntry i td) -> (, i) <$> lookupEnv tid td+ Nothing -> pure (Nothing, newEntryId)+ case mes of+ Just es -> pure (te, es)+ Nothing -> case teCapacity te of+ 0 -> error+ $ "Number of other threads (" ++ show threads ++ ") permitted to "+ ++ "use the unlifting function was exceeded. Please increase the "+ ++ "limit or use the unlimited variant."+ 1 -> do+ wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp+ let newEntries = ThreadEntries+ { teCapacity = teCapacity te - 1+ , teEntries = addThreadData wkTid i wkTidEs $ teEntries te+ }+ newEntries `seq` pure (newEntries, esTemplate)+ _ -> do+ es <- cloneEnv esTemplate+ wkTidEs <- mkWeakThreadIdEnv tid es wkTid i mvEntries cleanUp+ let newEntries = ThreadEntries+ { teCapacity = teCapacity te - 1+ , teEntries = addThreadData wkTid i wkTidEs $ teEntries te+ }+ newEntries `seq` pure (newEntries, es)+ unEff m es++----------------------------------------+-- Data types++newtype EntryId = EntryId Int+ deriving Eq++newEntryId :: EntryId+newEntryId = EntryId 0++nextEntryId :: EntryId -> EntryId+nextEntryId (EntryId i) = EntryId (i + 1)++data ThreadEntries es = ThreadEntries+ { teCapacity :: !Int+ , teEntries :: !(IM.IntMap (ThreadEntry es))+ }++-- | In GHC < 9 weak thread ids are 32bit long, while ThreadIdS are 64bit long,+-- so there is potential for collisions. This is solved by keeping, for a+-- particular weak thread id, a list of ThreadIdS with unique EntryIdS.+data ThreadEntry es = ThreadEntry !EntryId !(ThreadData es)++data ThreadData es+ = ThreadData !EntryId !(Weak (ThreadId, Env es)) (ThreadData es)+ | NoThreadData++----------------------------------------+-- Weak references to threads++mkWeakThreadIdEnv+ :: ThreadId+ -> Env es+ -> Int+ -> EntryId+ -> MVar (ThreadEntries es)+ -> Bool+ -> IO (Weak (ThreadId, Env es))+mkWeakThreadIdEnv t@(ThreadId t#) es wkTid i v = \case+ True -> IO $ \s0 ->+ case mkWeak# t# (t, es) finalizer s0 of+ (# s1, w #) -> (# s1, Weak w #)+ False -> IO $ \s0 ->+ case mkWeakNoFinalizer# t# (t, es) s0 of+ (# s1, w #) -> (# s1, Weak w #)+ where+ IO finalizer = deleteThreadData wkTid i v++----------------------------------------+-- Manipulation of ThreadEntries++lookupEnv :: ThreadId -> ThreadData es -> IO (Maybe (Env es))+lookupEnv tid0 = \case+ NoThreadData -> pure Nothing+ ThreadData _ wkTidEs td -> deRefWeak wkTidEs >>= \case+ Nothing -> lookupEnv tid0 td+ Just (tid, es)+ | tid0 `eqThreadId` tid -> pure $ Just es+ | otherwise -> lookupEnv tid0 td++----------------------------------------++addThreadData+ :: Int+ -> EntryId+ -> Weak (ThreadId, Env es)+ -> IM.IntMap (ThreadEntry es)+ -> IM.IntMap (ThreadEntry es)+addThreadData wkTid i w teMap+ | i == newEntryId = IM.insert wkTid (newThreadEntry i w) teMap+ | otherwise = IM.adjust (consThreadData w) wkTid teMap++newThreadEntry :: EntryId -> Weak (ThreadId, Env es) -> ThreadEntry es+newThreadEntry i w = ThreadEntry (nextEntryId i) $ ThreadData i w NoThreadData++consThreadData :: Weak (ThreadId, Env es) -> ThreadEntry es -> ThreadEntry es+consThreadData w (ThreadEntry i td) =+ ThreadEntry (nextEntryId i) $ ThreadData i w td++----------------------------------------++deleteThreadData :: Int -> EntryId -> MVar (ThreadEntries es) -> IO ()+deleteThreadData wkTid i v = modifyMVar_ v $ \te -> do+ let newEntries = ThreadEntries+ { teCapacity = case teCapacity te of+ -- If the template copy of the environment hasn't been consumed+ -- yet, the capacity can be restored.+ 0 -> 0+ n -> n + 1+ , teEntries = IM.update (cleanThreadEntry i) wkTid $ teEntries te+ }+ newEntries `seq` pure newEntries++cleanThreadEntry :: EntryId -> ThreadEntry es -> Maybe (ThreadEntry es)+cleanThreadEntry i0 (ThreadEntry i td0) = case cleanThreadData i0 td0 of+ NoThreadData -> Nothing+ td -> Just (ThreadEntry i td)++cleanThreadData :: EntryId -> ThreadData es -> ThreadData es+cleanThreadData i0 = \case+ NoThreadData -> NoThreadData+ ThreadData i w td+ | i0 == i -> td+ | otherwise -> ThreadData i w (cleanThreadData i0 td)
+ src/Effectful/Prim.hs view
@@ -0,0 +1,10 @@+-- | Provider of the 'MonadPrim' instance for 'Eff'.+module Effectful.Prim+ ( -- * Effect+ Prim++ -- ** Handlers+ , runPrim+ ) where++import Effectful.Internal.Monad
+ src/Effectful/Reader/Dynamic.hs view
@@ -0,0 +1,64 @@+-- | The dynamically dispatched variant of the 'Reader' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use the statically dispatched variant,+-- i.e. "Effectful.Reader.Static".+module Effectful.Reader.Dynamic+ ( -- * Effect+ Reader(..)++ -- ** Handlers+ , runReader++ -- ** Operations+ , ask+ , asks+ , local+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import qualified Effectful.Reader.Static as R++data Reader r :: Effect where+ Ask :: Reader r m r+ Local :: (r -> r) -> m a -> Reader r m a++type instance DispatchOf (Reader r) = Dynamic++-- | Run the 'Reader' effect with the given initial environment (via+-- "Effectful.Reader.Static").+runReader+ :: r -- ^ The initial environment.+ -> Eff (Reader r : es) a+ -> Eff es a+runReader r = reinterpret (R.runReader r) $ \env -> \case+ Ask -> R.ask+ Local f m -> localSeqUnlift env $ \unlift -> R.local f (unlift m)++----------------------------------------+-- Operations++-- | Fetch the value of the environment.+ask :: (HasCallStack, Reader r :> es) => Eff es r+ask = send Ask++-- | Retrieve a function of the current environment.+--+-- @'asks' f ≡ f '<$>' 'ask'@+asks+ :: (HasCallStack, Reader r :> es)+ => (r -> a) -- ^ The function to apply to the environment.+ -> Eff es a+asks f = f <$> ask++-- | Execute a computation in a modified environment.+--+-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@+--+local+ :: (HasCallStack, Reader r :> es)+ => (r -> r) -- ^ The function to modify the environment.+ -> Eff es a+ -> Eff es a+local f = send . Local f
+ src/Effectful/Reader/Static.hs view
@@ -0,0 +1,56 @@+-- | Support for access to a read only value of a particular type.+module Effectful.Reader.Static+ ( -- * Effect+ Reader++ -- ** Handlers+ , runReader++ -- ** Operations+ , ask+ , asks+ , local+ ) where++import Effectful+import Effectful.Dispatch.Static++-- | Provide access to a strict (WHNF), thread local, read only value of type+-- @r@.+data Reader r :: Effect++type instance DispatchOf (Reader r) = Static NoSideEffects+newtype instance StaticRep (Reader r) = Reader r++-- | Run a 'Reader' effect with the given initial environment.+runReader+ :: r -- ^ The initial environment.+ -> Eff (Reader r : es) a+ -> Eff es a+runReader r = evalStaticRep (Reader r)++-- | Fetch the value of the environment.+ask :: Reader r :> es => Eff es r+ask = do+ Reader r <- getStaticRep+ pure r++-- | Retrieve a function of the current environment.+--+-- @'asks' f ≡ f '<$>' 'ask'@+asks+ :: Reader r :> es+ => (r -> a) -- ^ The function to apply to the environment.+ -> Eff es a+asks f = f <$> ask++-- | Execute a computation in a modified environment.+--+-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@+--+local+ :: Reader r :> es+ => (r -> r) -- ^ The function to modify the environment.+ -> Eff es a+ -> Eff es a+local f = localStaticRep $ \(Reader r) -> Reader (f r)
+ src/Effectful/State/Dynamic.hs view
@@ -0,0 +1,159 @@+-- | The dynamically dispatched variant of the 'State' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use one of the statically dispatched variants,+-- i.e. "Effectful.State.Static.Local" or "Effectful.State.Static.Shared".+module Effectful.State.Dynamic+ ( -- * Effect+ State(..)++ -- ** Handlers++ -- *** Local+ , runStateLocal+ , evalStateLocal+ , execStateLocal++ -- *** Shared+ , runStateShared+ , evalStateShared+ , execStateShared++ -- ** Operations+ , get+ , gets+ , put+ , state+ , modify+ , stateM+ , modifyM+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import qualified Effectful.State.Static.Local as L+import qualified Effectful.State.Static.Shared as S++-- | Provide access to a mutable value of type @s@.+data State s :: Effect where+ Get :: State s m s+ Put :: s -> State s m ()+ State :: (s -> (a, s)) -> State s m a+ StateM :: (s -> m (a, s)) -> State s m a++type instance DispatchOf (State s) = Dynamic++----------------------------------------+-- Local++-- | Run the 'State' effect with the given initial state and return the final+-- value along with the final state (via "Effectful.State.Static.Local").+runStateLocal :: s -> Eff (State s : es) a -> Eff es (a, s)+runStateLocal s0 = reinterpret (L.runState s0) localState++-- | Run the 'State' effect with the given initial state and return the final+-- value, discarding the final state (via "Effectful.State.Static.Local").+evalStateLocal :: s -> Eff (State s : es) a -> Eff es a+evalStateLocal s0 = reinterpret (L.evalState s0) localState++-- | Run the 'State' effect with the given initial state and return the final+-- state, discarding the final value (via "Effectful.State.Static.Local").+execStateLocal :: s -> Eff (State s : es) a -> Eff es s+execStateLocal s0 = reinterpret (L.execState s0) localState++localState+ :: L.State s :> es+ => LocalEnv localEs es+ -> State s (Eff localEs) a+ -> Eff es a+localState env = \case+ Get -> L.get+ Put s -> L.put s+ State f -> L.state f+ StateM f -> localSeqUnlift env $ \unlift -> L.stateM (unlift . f)++----------------------------------------+-- Shared++-- | Run the 'State' effect with the given initial state and return the final+-- value along with the final state (via "Effectful.State.Static.Shared").+runStateShared :: s -> Eff (State s : es) a -> Eff es (a, s)+runStateShared s0 = reinterpret (S.runState s0) sharedState++-- | Run the 'State' effect with the given initial state and return the final+-- value, discarding the final state (via "Effectful.State.Static.Shared").+evalStateShared :: s -> Eff (State s : es) a -> Eff es a+evalStateShared s0 = reinterpret (S.evalState s0) sharedState++-- | Run the 'State' effect with the given initial state and return the final+-- state, discarding the final value (via "Effectful.State.Static.Shared").+execStateShared :: s -> Eff (State s : es) a -> Eff es s+execStateShared s0 = reinterpret (S.execState s0) sharedState++sharedState+ :: S.State s :> es+ => LocalEnv localEs es+ -> State s (Eff localEs) a+ -> Eff es a+sharedState env = \case+ Get -> S.get+ Put s -> S.put s+ State f -> S.state f+ StateM f -> localSeqUnlift env $ \unlift -> S.stateM (unlift . f)++----------------------------------------+-- Operations++-- | Fetch the current value of the state.+get+ :: (HasCallStack, State s :> es)+ => Eff es s+get = send Get++-- | Get a function of the current state.+--+-- @'gets' f ≡ f '<$>' 'get'@+gets+ :: (HasCallStack, State s :> es)+ => (s -> a)+ -> Eff es a+gets f = f <$> get++-- | Set the current state to the given value.+put+ :: (HasCallStack, State s :> es)+ => s+ -> Eff es ()+put = send . Put++-- | Apply the function to the current state and return a value.+state+ :: (HasCallStack, State s :> es)+ => (s -> (a, s))+ -> Eff es a+state = send . State++-- | Apply the function to the current state.+--+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@+modify+ :: (HasCallStack, State s :> es)+ => (s -> s)+ -> Eff es ()+modify f = state (\s -> ((), f s))++-- | Apply the monadic function to the current state and return a value.+stateM+ :: (HasCallStack, State s :> es)+ => (s -> Eff es (a, s))+ -> Eff es a+stateM = send . StateM++-- | Apply the monadic function to the current state.+--+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@+modifyM+ :: (HasCallStack, State s :> es)+ => (s -> Eff es s)+ -> Eff es ()+modifyM f = stateM (\s -> ((), ) <$> f s)
+ src/Effectful/State/Static/Local.hs view
@@ -0,0 +1,136 @@+-- | Support for access to a mutable value of a particular type.+--+-- The value is thread local. If you want it to be shared between threads, use+-- "Effectful.State.Static.Shared".+--+-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from+-- the @transformers@ library, the 'State' effect doesn't discard state updates+-- when an exception is received:+--+-- >>> import qualified Control.Monad.Trans.State.Strict as S+--+-- >>> :{+-- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do+-- S.modify (++ " there!")+-- error "oops"+-- :}+-- "Hi"+--+-- >>> :{+-- runEff . execState "Hi" . handle (\(_::ErrorCall) -> pure ()) $ do+-- modify (++ " there!")+-- error "oops"+-- :}+-- "Hi there!"+module Effectful.State.Static.Local+ ( -- * Effect+ State++ -- ** Handlers+ , runState+ , evalState+ , execState++ -- ** Operations+ , get+ , gets+ , put+ , state+ , modify+ , stateM+ , modifyM+ ) where++import Effectful+import Effectful.Dispatch.Static++-- | Provide access to a strict (WHNF), thread local, mutable value of type @s@.+data State s :: Effect++type instance DispatchOf (State s) = Static NoSideEffects+newtype instance StaticRep (State s) = State s++-- | Run the 'State' effect with the given initial state and return the final+-- value along with the final state.+runState+ :: s -- ^ The initial state.+ -> Eff (State s : es) a+ -> Eff es (a, s)+runState s0 m = do+ (a, State s) <- runStaticRep (State s0) m+ pure (a, s)++-- | Run the 'State' effect with the given initial state and return the final+-- value, discarding the final state.+evalState+ :: s -- ^ The initial state.+ -> Eff (State s : es) a+ -> Eff es a+evalState s = evalStaticRep (State s)++-- | Run the 'State' effect with the given initial state and return the final+-- state, discarding the final value.+execState+ :: s -- ^ The initial state.+ -> Eff (State s : es) a+ -> Eff es s+execState s0 m = do+ State s <- execStaticRep (State s0) m+ pure s++-- | Fetch the current value of the state.+get :: State s :> es => Eff es s+get = do+ State s <- getStaticRep+ pure s++-- | Get a function of the current state.+--+-- @'gets' f ≡ f '<$>' 'get'@+gets+ :: State s :> es+ => (s -> a) -- ^ The function to apply to the state.+ -> Eff es a+gets f = f <$> get++-- | Set the current state to the given value.+put :: State s :> es => s -> Eff es ()+put s = putStaticRep (State s)++-- | Apply the function to the current state and return a value.+state+ :: State s :> es+ => (s -> (a, s)) -- ^ The function to modify the state.+ -> Eff es a+state f = stateStaticRep $ \(State s0) -> let (a, s) = f s0 in (a, State s)++-- | Apply the function to the current state.+--+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@+modify+ :: State s :> es+ => (s -> s) -- ^ The function to modify the state.+ -> Eff es ()+modify f = state $ \s -> ((), f s)++-- | Apply the monadic function to the current state and return a value.+stateM+ :: State s :> es+ => (s -> Eff es (a, s)) -- ^ The function to modify the state.+ -> Eff es a+stateM f = stateStaticRepM $ \(State s0) -> do+ (a, s) <- f s0+ pure (a, State s)++-- | Apply the monadic function to the current state.+--+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@+modifyM+ :: State s :> es+ => (s -> Eff es s) -- ^ The monadic function to modify the state.+ -> Eff es ()+modifyM f = stateM (\s -> ((), ) <$> f s)++-- $setup+-- >>> import Control.Exception (ErrorCall)+-- >>> import Control.Monad.Catch
@@ -0,0 +1,157 @@+-- | Support for access to a shared, mutable value of a particular type.+--+-- The value is shared between multiple threads. If you want each thead to+-- manage its own version of the value, use "Effectful.State.Static.Local".+--+-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from+-- the @transformers@ library, the 'State' effect doesn't discard state updates+-- when an exception is received:+--+-- >>> import qualified Control.Monad.Trans.State.Strict as S+--+-- >>> :{+-- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do+-- S.modify (++ " there!")+-- error "oops"+-- :}+-- "Hi"+--+-- >>> :{+-- runEff . execState "Hi" . handle (\(_::ErrorCall) -> pure ()) $ do+-- modify (++ " there!")+-- error "oops"+-- :}+-- "Hi there!"+module Effectful.State.Static.Shared+ ( -- * Effect+ State++ -- ** Handlers+ , runState+ , evalState+ , execState++ , runStateMVar+ , evalStateMVar+ , execStateMVar++ -- ** Operations+ , get+ , gets+ , put+ , state+ , modify+ , stateM+ , modifyM+ ) where++import Control.Concurrent.MVar++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive++-- | Provide access to a strict (WHNF), shared, mutable value of type @s@.+data State s :: Effect++type instance DispatchOf (State s) = Static NoSideEffects+newtype instance StaticRep (State s) = State (MVar s)++-- | Run the 'State' effect with the given initial state and return the final+-- value along with the final state.+runState :: s -> Eff (State s : es) a -> Eff es (a, s)+runState s m = do+ v <- unsafeEff_ $ newMVar s+ a <- evalStaticRep (State v) m+ (a, ) <$> unsafeEff_ (readMVar v)++-- | Run the 'State' effect with the given initial state and return the final+-- value, discarding the final state.+evalState :: s -> Eff (State s : es) a -> Eff es a+evalState s m = do+ v <- unsafeEff_ $ newMVar s+ evalStaticRep (State v) m++-- | Run the 'State' effect with the given initial state and return the final+-- state, discarding the final value.+execState :: s -> Eff (State s : es) a -> Eff es s+execState s m = do+ v <- unsafeEff_ $ newMVar s+ _ <- evalStaticRep (State v) m+ unsafeEff_ $ readMVar v++-- | Run the 'State' effect with the given initial state 'MVar' and return the+-- final value along with the final state.+runStateMVar :: MVar s -> Eff (State s : es) a -> Eff es (a, s)+runStateMVar v m = do+ a <- evalStaticRep (State v) m+ (a, ) <$> unsafeEff_ (readMVar v)++-- | Run the 'State' effect with the given initial state 'MVar' and return the+-- final value, discarding the final state.+evalStateMVar :: MVar s -> Eff (State s : es) a -> Eff es a+evalStateMVar v m = do+ evalStaticRep (State v) m++-- | Run the 'State' effect with the given initial state 'MVar' and return the+-- final state, discarding the final value.+execStateMVar :: MVar s -> Eff (State s : es) a -> Eff es s+execStateMVar v m = do+ _ <- evalStaticRep (State v) m+ unsafeEff_ $ readMVar v++-- | Fetch the current value of the state.+get :: State s :> es => Eff es s+get = unsafeEff $ \es -> do+ State v <- getEnv es+ readMVar v++-- | Get a function of the current state.+--+-- @'gets' f ≡ f '<$>' 'get'@+gets :: State s :> es => (s -> a) -> Eff es a+gets f = f <$> get++-- | Set the current state to the given value.+put :: State s :> es => s -> Eff es ()+put s = unsafeEff $ \es -> do+ State v <- getEnv es+ modifyMVar_ v $ \_ -> s `seq` pure s++-- | Apply the function to the current state and return a value.+--+-- /Note:/ this function gets an exclusive access to the state for its duration.+state :: State s :> es => (s -> (a, s)) -> Eff es a+state f = unsafeEff $ \es -> do+ State v <- getEnv es+ modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)++-- | Apply the function to the current state.+--+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@+--+-- /Note:/ this function gets an exclusive access to the state for its duration.+modify :: State s :> es => (s -> s) -> Eff es ()+modify f = state (\s -> ((), f s))++-- | Apply the monadic function to the current state and return a value.+--+-- /Note:/ this function gets an exclusive access to the state for its duration.+stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a+stateM f = unsafeEff $ \es -> do+ State v <- getEnv es+ modifyMVar v $ \s0 -> do+ (a, s) <- unEff (f s0) es+ s `seq` pure (s, a)++-- | Apply the monadic function to the current state.+--+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@+--+-- /Note:/ this function gets an exclusive access to the state for its duration.+modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()+modifyM f = stateM (\s -> ((), ) <$> f s)++-- $setup+-- >>> import Control.Exception (ErrorCall)+-- >>> import Control.Monad.Catch
+ src/Effectful/Writer/Dynamic.hs view
@@ -0,0 +1,112 @@+-- | The dynamically dispatched variant of the 'Writer' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use one of the statically dispatched variants,+-- i.e. "Effectful.Writer.Static.Local" or "Effectful.Writer.Static.Shared".+module Effectful.Writer.Dynamic+ ( -- * Effect+ Writer(..)++ -- ** Handlers++ -- *** Local+ , runWriterLocal+ , execWriterLocal++ -- *** Shared+ , runWriterShared+ , execWriterShared++ -- * Operations+ , tell+ , listen+ , listens+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import qualified Effectful.Writer.Static.Local as L+import qualified Effectful.Writer.Static.Shared as S++-- | Provide access to a write only value of type @w@.+data Writer w :: Effect where+ Tell :: w -> Writer w m ()+ Listen :: m a -> Writer w m (a, w)++type instance DispatchOf (Writer w) = Dynamic++----------------------------------------+-- Local++-- | Run the 'Writer' effect and return the final value along with the final+-- output (via "Effectful.Writer.Static.Local").+runWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriterLocal = reinterpret L.runWriter localWriter++-- | Run a 'Writer' effect and return the final output, discarding the final+-- value (via "Effectful.Writer.Static.Local").+execWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriterLocal = reinterpret L.execWriter localWriter++localWriter+ :: (L.Writer w :> es, Monoid w)+ => LocalEnv localEs es+ -> Writer w (Eff localEs) a+ -> Eff es a+localWriter env = \case+ Tell w -> L.tell w+ Listen m -> localSeqUnlift env $ \unlift -> L.listen (unlift m)++----------------------------------------+-- Shared++-- | Run the 'Writer' effect and return the final value along with the final+-- output (via "Effectful.Writer.Static.Shared").+runWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriterShared = reinterpret S.runWriter sharedWriter++-- | Run the 'Writer' effect and return the final output, discarding the final+-- value (via "Effectful.Writer.Static.Shared").+execWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriterShared = reinterpret S.execWriter sharedWriter++sharedWriter+ :: (S.Writer w :> es, Monoid w)+ => LocalEnv localEs es+ -> Writer w (Eff localEs) a+ -> Eff es a+sharedWriter env = \case+ Tell w -> S.tell w+ Listen m -> localSeqUnlift env $ \unlift -> S.listen (unlift m)++----------------------------------------+-- Operations++-- | Append the given output to the overall output of the 'Writer'.+tell+ :: (HasCallStack, Writer w :> es)+ => w+ -> Eff es ()+tell = send . Tell++-- | Execute an action and append its output to the overall output of the+-- 'Writer'.+listen+ :: (HasCallStack, Writer w :> es)+ => Eff es a+ -> Eff es (a, w)+listen = send . Listen++-- | Execute an action and append its output to the overall output of the+-- 'Writer', then return the final value along with a function of the recorded+-- output.+--+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@+listens+ :: (HasCallStack, Writer w :> es)+ => (w -> b)+ -> Eff es a+ -> Eff es (a, b)+listens f m = do+ (a, w) <- listen m+ pure (a, f w)
+ src/Effectful/Writer/Static/Local.hs view
@@ -0,0 +1,100 @@+-- | Support for access to a write only value of a particular type.+--+-- The value is thread local. If you want it to be shared between threads, use+-- "Effectful.Writer.Static.Shared".+--+-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses+-- of '<>', which makes it unsuitable for use with types for which such pattern+-- is inefficient. __This applies, in particular, to the standard list type__,+-- which makes the 'Writer' effect pretty niche.+--+-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the+-- @transformers@ package includes additional operations+-- 'Control.Monad.Trans.Writer.Strict.pass' and+-- 'Control.Monad.Trans.Writer.Strict.censor', they don't cooperate with runtime+-- exceptions very well, so they're deliberately omitted here.+module Effectful.Writer.Static.Local+ ( -- * Effect+ Writer++ -- ** Handlers+ , runWriter+ , execWriter++ -- ** Operations+ , tell+ , listen+ , listens+ ) where++import Control.Exception (onException, mask)++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive++-- | Provide access to a strict (WHNF), thread local, write only value of type+-- @w@.+data Writer w :: Effect++type instance DispatchOf (Writer w) = Static NoSideEffects+newtype instance StaticRep (Writer w) = Writer w++-- | Run a 'Writer' effect and return the final value along with the final+-- output.+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriter m = do+ (a, Writer w) <- runStaticRep (Writer mempty) m+ pure (a, w)++-- | Run a 'Writer' effect and return the final output, discarding the final+-- value.+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriter m = do+ Writer w <- execStaticRep (Writer mempty) m+ pure w++-- | Append the given output to the overall output of the 'Writer'.+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()+tell w = stateStaticRep $ \(Writer w0) -> ((), Writer (w0 <> w))++-- | Execute an action and append its output to the overall output of the+-- 'Writer'.+--+-- /Note:/ if an exception is received while the action is executed, the partial+-- output of the action will still be appended to the overall output of the+-- 'Writer':+--+-- >>> :{+-- runEff . execWriter @String $ do+-- tell "Hi"+-- handle (\(_::ErrorCall) -> pure ((), "")) $ do+-- tell " there"+-- listen $ do+-- tell "!"+-- error "oops"+-- :}+-- "Hi there!"+listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)+listen m = unsafeEff $ \es -> mask $ \unmask -> do+ w0 <- stateEnv es $ \(Writer w) -> (w, Writer mempty)+ a <- unmask (unEff m es) `onException` merge es w0+ (a, ) <$> merge es w0+ where+ merge es w0 =+ -- If an exception is thrown, restore w0 and keep parts of w1.+ stateEnv es $ \(Writer w1) -> (w1, Writer (w0 <> w1))++-- | Execute an action and append its output to the overall output of the+-- 'Writer', then return the final value along with a function of the recorded+-- output.+--+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@+listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)+listens f m = do+ (a, w) <- listen m+ pure (a, f w)++-- $setup+-- >>> import Control.Exception (ErrorCall)+-- >>> import Control.Monad.Catch
@@ -0,0 +1,114 @@+-- | Support for access to a write only value of a particular type.+--+-- The value is shared between multiple threads. If you want each thead to+-- manage its own version of the value, use "Effectful.Writer.Static.Local".+--+-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses+-- of '<>', which makes it unsuitable for use with types for which such pattern+-- is inefficient. __This applies, in particular, to the standard list type__,+-- which makes the 'Writer' effect pretty niche.+--+-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the+-- @transformers@ package includes additional operations+-- 'Control.Monad.Trans.Writer.Strict.pass' and+-- 'Control.Monad.Trans.Writer.Strict.censor', they don't cooperate with runtime+-- exceptions very well, so they're deliberately omitted here.+module Effectful.Writer.Static.Shared+ ( -- * Effect+ Writer++ -- ** Handlers+ , runWriter+ , execWriter++ -- ** Operations+ , tell+ , listen+ , listens+ ) where++import Control.Concurrent.MVar+import Control.Exception (onException, uninterruptibleMask)++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive++-- | Provide access to a strict (WHNF), shared, write only value of type @w@.+data Writer w :: Effect++type instance DispatchOf (Writer w) = Static NoSideEffects+newtype instance StaticRep (Writer w) = Writer (MVar w)++-- | Run a 'Writer' effect and return the final value along with the final+-- output.+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriter m = do+ v <- unsafeEff_ $ newMVar mempty+ a <- evalStaticRep (Writer v) m+ (a, ) <$> unsafeEff_ (readMVar v)++-- | Run a 'Writer' effect and return the final output, discarding the final+-- value.+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriter m = do+ v <- unsafeEff_ $ newMVar mempty+ _ <- evalStaticRep (Writer v) m+ unsafeEff_ $ readMVar v++-- | Append the given output to the overall output of the 'Writer'.+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()+tell w1 = unsafeEff $ \es -> do+ Writer v <- getEnv es+ modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w++-- | Execute an action and append its output to the overall output of the+-- 'Writer'.+--+-- /Note:/ if an exception is received while the action is executed, the partial+-- output of the action will still be appended to the overall output of the+-- 'Writer':+--+-- >>> :{+-- runEff . execWriter @String $ do+-- tell "Hi"+-- handle (\(_::ErrorCall) -> pure ((), "")) $ do+-- tell " there"+-- listen $ do+-- tell "!"+-- error "oops"+-- :}+-- "Hi there!"+listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)+listen m = unsafeEff $ \es -> do+ -- The mask is uninterruptible because modifyMVar_ v0 in the merge function+ -- might block and if an async exception is received while waiting, w1 will be+ -- lost.+ uninterruptibleMask $ \unmask -> do+ v1 <- newMVar mempty+ -- Replace thread local MVar with a fresh one for isolated listening.+ v0 <- stateEnv es $ \(Writer v) -> (v, Writer v1)+ a <- unmask (unEff m es) `onException` merge es v0 v1+ (a, ) <$> merge es v0 v1+ where+ -- Merge results accumulated in the local MVar with the mainline. If an+ -- exception was received while listening, merge results recorded so far.+ merge es v0 v1 = do+ putEnv es $ Writer v0+ w1 <- readMVar v1+ modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w+ pure w1++-- | Execute an action and append its output to the overall output of the+-- 'Writer', then return the final value along with a function of the recorded+-- output.+--+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@+listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)+listens f m = do+ (a, w) <- listen m+ pure (a, f w)++-- $setup+-- >>> import Control.Exception (ErrorCall)+-- >>> import Control.Monad.Catch
+ utils/Effectful/Internal/Utils.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# OPTIONS_HADDOCK not-home #-}+module Effectful.Internal.Utils+ ( weakThreadId+ , eqThreadId++ -- * Utils for 'Any'+ , Any+ , toAny+ , fromAny+ ) where++import Foreign.C.Types+import GHC.Conc.Sync (ThreadId(..))+import GHC.Exts (Any, ThreadId#)+import Unsafe.Coerce (unsafeCoerce)++-- | Get an id of a thread that doesn't prevent its garbage collection.+weakThreadId :: ThreadId -> Int+weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId t#++foreign import ccall unsafe "rts_getThreadId"+#if __GLASGOW_HASKELL__ >= 903+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163+ rts_getThreadId :: ThreadId# -> CULLong+#elif __GLASGOW_HASKELL__ >= 900+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1254+ rts_getThreadId :: ThreadId# -> CLong+#else+ rts_getThreadId :: ThreadId# -> CInt+#endif++-- | 'Eq' instance for 'ThreadId' is broken in GHC < 9, see+-- https://gitlab.haskell.org/ghc/ghc/-/issues/16761 for more info.+eqThreadId :: ThreadId -> ThreadId -> Bool+eqThreadId (ThreadId t1#) (ThreadId t2#) = eq_thread t1# t2# == 1++foreign import ccall unsafe "effectful_eq_thread"+ eq_thread :: ThreadId# -> ThreadId# -> CLong++----------------------------------------++toAny :: a -> Any+toAny = unsafeCoerce++fromAny :: Any -> a+fromAny = unsafeCoerce
+ utils/utils.c view
@@ -0,0 +1,5 @@+// Correct implementation of ThreadId# equality for GHC < 9.+long effectful_eq_thread(void *tso1, void *tso2)+{+ return tso1 == tso2;+}