diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +# effectful-core-1.0.0.0 (2022-07-13) +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,173 @@ +# effectful + +[![Build Status](https://github.com/haskell-effectful/effectful/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/haskell-effectful/effectful/actions?query=branch%3Amaster) +[![Hackage](https://img.shields.io/hackage/v/effectful.svg)](https://hackage.haskell.org/package/effectful) +[![Dependencies](https://img.shields.io/hackage-deps/v/effectful.svg)](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net) +[![Stackage LTS](https://www.stackage.org/package/effectful/badge/lts)](https://www.stackage.org/lts/package/effectful) +[![Stackage Nightly](https://www.stackage.org/package/effectful/badge/nightly)](https://www.stackage.org/nightly/package/effectful) + + + + +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. + +---------------------------------------- + +
Icons made by Freepik from www.flaticon.com
diff --git a/effectful-core.cabal b/effectful-core.cabal new file mode 100644 --- /dev/null +++ b/effectful-core.cabal @@ -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 @@ + 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 diff --git a/src/Effectful.hs b/src/Effectful.hs new file mode 100644 --- /dev/null +++ b/src/Effectful.hs @@ -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. +-- diff --git a/src/Effectful/Dispatch/Dynamic.hs b/src/Effectful/Dispatch/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Dispatch/Dynamic.hs @@ -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) diff --git a/src/Effectful/Dispatch/Static.hs b/src/Effectful/Dispatch/Static.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Dispatch/Static.hs @@ -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 diff --git a/src/Effectful/Dispatch/Static/Primitive.hs b/src/Effectful/Dispatch/Static/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Dispatch/Static/Primitive.hs @@ -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 diff --git a/src/Effectful/Dispatch/Static/Unsafe.hs b/src/Effectful/Dispatch/Static/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Dispatch/Static/Unsafe.hs @@ -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) diff --git a/src/Effectful/Error/Dynamic.hs b/src/Effectful/Error/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Error/Dynamic.hs @@ -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) diff --git a/src/Effectful/Error/Static.hs b/src/Effectful/Error/Static.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Error/Static.hs @@ -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 diff --git a/src/Effectful/Fail.hs b/src/Effectful/Fail.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Fail.hs @@ -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 diff --git a/src/Effectful/Internal/Effect.hs b/src/Effectful/Internal/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Internal/Effect.hs @@ -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 diff --git a/src/Effectful/Internal/Env.hs b/src/Effectful/Internal/Env.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Internal/Env.hs @@ -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" diff --git a/src/Effectful/Internal/Monad.hs b/src/Effectful/Internal/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Internal/Monad.hs @@ -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) diff --git a/src/Effectful/Internal/Unlift.hs b/src/Effectful/Internal/Unlift.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Internal/Unlift.hs @@ -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) diff --git a/src/Effectful/Prim.hs b/src/Effectful/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Prim.hs @@ -0,0 +1,10 @@ +-- | Provider of the 'MonadPrim' instance for 'Eff'. +module Effectful.Prim + ( -- * Effect + Prim + + -- ** Handlers + , runPrim + ) where + +import Effectful.Internal.Monad diff --git a/src/Effectful/Reader/Dynamic.hs b/src/Effectful/Reader/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Reader/Dynamic.hs @@ -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 diff --git a/src/Effectful/Reader/Static.hs b/src/Effectful/Reader/Static.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Reader/Static.hs @@ -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) diff --git a/src/Effectful/State/Dynamic.hs b/src/Effectful/State/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/State/Dynamic.hs @@ -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) diff --git a/src/Effectful/State/Static/Local.hs b/src/Effectful/State/Static/Local.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/State/Static/Local.hs @@ -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 diff --git a/src/Effectful/State/Static/Shared.hs b/src/Effectful/State/Static/Shared.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/State/Static/Shared.hs @@ -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 diff --git a/src/Effectful/Writer/Dynamic.hs b/src/Effectful/Writer/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Writer/Dynamic.hs @@ -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) diff --git a/src/Effectful/Writer/Static/Local.hs b/src/Effectful/Writer/Static/Local.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Writer/Static/Local.hs @@ -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 diff --git a/src/Effectful/Writer/Static/Shared.hs b/src/Effectful/Writer/Static/Shared.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Writer/Static/Shared.hs @@ -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 diff --git a/utils/Effectful/Internal/Utils.hs b/utils/Effectful/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/utils/Effectful/Internal/Utils.hs @@ -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 diff --git a/utils/utils.c b/utils/utils.c new file mode 100644 --- /dev/null +++ b/utils/utils.c @@ -0,0 +1,5 @@ +// Correct implementation of ThreadId# equality for GHC < 9. +long effectful_eq_thread(void *tso1, void *tso2) +{ + return tso1 == tso2; +}