├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── cabal.project ├── cabal.project.travis ├── eff ├── Setup.hs ├── eff.cabal ├── src │ └── Control │ │ ├── Effect.hs │ │ └── Effect │ │ ├── Base.hs │ │ ├── Coroutine.hs │ │ ├── Error.hs │ │ ├── Internal.hs │ │ ├── Internal │ │ ├── Debug.hs │ │ └── SmallArray.hs │ │ ├── NonDet.hs │ │ ├── Reader.hs │ │ ├── State.hs │ │ ├── State │ │ └── Strict.hs │ │ ├── Writer.hs │ │ └── Writer │ │ └── Strict.hs └── test │ ├── Control │ ├── Effect │ │ └── Examples │ │ │ └── FileSystemSpec.hs │ └── EffectSpec.hs │ └── Main.hs └── notes └── semantics-zoo.md /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle 2 | /cabal.project.local 3 | /stack.yaml 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | addons: 4 | apt: 5 | sources: [hvr-ghc] 6 | packages: [cabal-install-3.2] 7 | env: 8 | - GHC_VERSION: 8.11.0.20200620 9 | GHC_BINDIST: https://gitlab.haskell.org/lexi.lambda/ghc/raw/continuations-bindist-8.11.0.20200620-x86_64-xenial/ghc.tar.xz 10 | 11 | cache: 12 | directories: 13 | - $HOME/.ghc/$GHC_VERSION 14 | - $HOME/.cabal/bin 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_install: 19 | - GHC_HOME=$HOME/.ghc/$GHC_VERSION 20 | - | 21 | if [[ ! -f $GHC_HOME/bin/ghc ]]; then 22 | wget "$GHC_BINDIST" && \ 23 | tar -xf ghc.tar.xz && \ 24 | pushd ghc-$GHC_VERSION-*-linux && \ 25 | ./configure --prefix="$GHC_HOME" && \ 26 | make install && \ 27 | popd 28 | fi 29 | - export PATH=$HOME/.cabal/bin:/opt/cabal/bin:$GHC_HOME/bin:$PATH 30 | 31 | install: 32 | - cp cabal.project.travis cabal.project.local 33 | - cabal v2-update 34 | - cabal v2-build all --only-dependencies 35 | script: 36 | - cabal v2-test all --test-show-details=direct 37 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Hasura, Alexis King, and contributors 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee 4 | is hereby granted, provided that the above copyright notice and this permission notice appear in all 5 | copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS 8 | SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 9 | AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 10 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE 11 | OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 12 | SOFTWARE. 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `eff` — screaming fast extensible effects for less [![Build Status](https://travis-ci.org/hasura/eff.svg?branch=master)](https://travis-ci.org/hasura/eff) [![Documentation](https://img.shields.io/static/v1?label=docs&message=0.0.0.0&color=informational)][docs] 2 | 3 | **🚧 This library is currently under construction. 🚧** 4 | 5 | `eff` is a work-in-progress implementation of an *extensible effect system* for Haskell, a general-purpose solution for tracking effects at the type level and handling them in flexible ways. Compared to other effect systems currently available, `eff` differentiates itself in the following respects: 6 | 7 | - `eff` is **really fast**. Built on top of [low-level primitives added to the GHC RTS][gh:proposal] to support capturing slices of the call stack, `eff` is performant by design. Using a direct implementation of delimited control allows it to be fast without relying on fickle compiler optimizations to eliminate indirection. 8 | 9 | Traditional effect system microbenchmarks fail to capture the performance of real code, as they are so small that GHC often ends up inlining everything. In real programs, GHC compiles most effect-polymorphic code via dictionary passing, not specialization, causing the performance of other effect systems to degrade beyond what microbenchmarks would imply. `eff` takes care to allow GHC to generate efficient code without the need for whole-program specialization. 10 | 11 | - `eff` is **low-boilerplate** and **easy to use**, even without Template Haskell or any generic programming. `eff`’s interface is comparable to `freer-simple` and `polysemy`, but writing new effect handlers is made even simpler thanks to a small set of highly expressive core operations. 12 | 13 | - `eff` is **expressive**, providing support for both first-order/algebraic effects and higher-order/scoped effects, like `fused-effects` and `polysemy` (but unlike `freer-simple`). 14 | 15 | - `eff`’s semantics is **precise** and **easy to reason about**, based on models of delimited control. Other approaches to scoped operations (including those taken in `mtl`, `fused-effects`, and `polysemy`) have behavior that changes depending on handler order, and some combinations can lead to nonsensical results. `eff`’s semantics is consistent regardless of handler order, and scoped operations compose in predictable ways. 16 | 17 | ## `eff` in action 18 | 19 | To illustrate just how easy it is to define and handle effects in `eff`, the following code example includes 100% of the code necessary to define a custom `FileSystem` effect and two handlers, one that runs in `IO` and another that uses an in-memory virtual file system: 20 | 21 | ```haskell 22 | import qualified System.IO as IO 23 | import Prelude hiding (readFile, writeFile) 24 | import Control.Effect 25 | 26 | -- ----------------------------------------------------------------------------- 27 | -- effect definition 28 | 29 | data FileSystem :: Effect where 30 | ReadFile :: FilePath -> FileSystem m String 31 | WriteFile :: FilePath -> String -> FileSystem m () 32 | 33 | readFile :: FileSystem :< effs => FilePath -> Eff effs String 34 | readFile = send . ReadFile 35 | 36 | writeFile :: FileSystem :< effs => FilePath -> String -> Eff effs () 37 | writeFile a b = send $ WriteFile a b 38 | 39 | -- ----------------------------------------------------------------------------- 40 | -- IO handler 41 | 42 | runFileSystemIO :: IOE :< effs => Eff (FileSystem ': effs) a -> Eff effs a 43 | runFileSystemIO = interpret \case 44 | ReadFile path -> liftIO $ IO.readFile path 45 | WriteFile path contents -> liftIO $ IO.writeFile path contents 46 | 47 | -- ----------------------------------------------------------------------------- 48 | -- pure handler 49 | 50 | runFileSystemPure :: Error String :< effs => Eff (FileSystem ': effs) a -> Eff effs a 51 | runFileSystemPure = lift 52 | >>> interpret \case 53 | ReadFile path -> do 54 | fileSystem <- get 55 | case lookup path fileSystem of 56 | Just contents -> pure contents 57 | Nothing -> throw ("readFile: no such file " <> path) 58 | WriteFile path contents -> do 59 | fileSystem <- get 60 | -- add the new file and remove an old file with the same name, if it exists 61 | put ((path, contents) : filter ((/= path) . fst) fileSystem) 62 | >>> evalState @[(FilePath, String)] [] 63 | ``` 64 | 65 | That’s it. For a thorough explanation of how the above example works, [see the `eff` documentation][docs]. 66 | 67 | ## Implementation status 68 | 69 | `eff` is a work in progress, and since it requires changes to the GHC RTS, you cannot use it yet on any released version of GHC. If there is interest, I can try to provide builds of GHC with the necessary changes to use `eff`, but otherwise you will need to wait for them to be merged into GHC proper before using `eff` yourself. There is currently [an open GHC proposal][gh:proposal] to add the necessary operations, and [the work-in-progress implementation branch is available here][gl:continuations]. 70 | 71 | Looking beyond that, many things are still not yet implemented. More work needs to be done to properly interoperate with `IO` exceptions, and the set of built-in effects currently provided is very small. However, all the existing functionality works, and it has been designed to support extensions, so I do not anticipate any difficulty supporting them. 72 | 73 | This library is also sorely lacking a benchmark suite. I have a small set of microbenchmarks I have been using to test out various scenarios and edge cases of different effect libraries, but they need to be cleaned up and added to this repository, and a set of less synthetic benchmarks are also important to assess real-world performance. **If you have a small but non-trivial program where differences in effect system performance are significant, I would be much obliged if you could share it to build a more realistic set of effect system benchmarks.** 74 | 75 | ## Acknowledgements, citations, and related work 76 | 77 | All code in `eff` is original in the sense that it was not taken directly from other libraries, but much of it is directly inspired by the existing work of many others. The following is a non-exhaustive list of people and works that have had a significant impact, directly or indirectly, on `eff`’s design and implementation: 78 | 79 | - Oleg Kiselyov, Amr Sabry, and Cameron Swords — [Extensible Effects: An alternative to monad transfomers][oleg:exteff] 80 | - Oleg Kiselyov and Hiromi Ishii — [Freer Monads, More Extensible Effects][oleg:more] 81 | - Rob Rix, Patrick Thomson, and other contributors — [`fused-effects`][gh:fused-effects] 82 | - Sandy Maguire and other contributors — [`polysemy`][gh:polysemy] 83 | 84 | [docs]: https://hasura.github.io/eff/Control-Effect.html 85 | [gh:fused-effects]: https://github.com/fused-effects/fused-effects 86 | [gh:polysemy]: https://github.com/polysemy-research/polysemy 87 | [gh:proposal]: https://github.com/ghc-proposals/ghc-proposals/pull/313 88 | [gl:continuations]: https://gitlab.haskell.org/lexi.lambda/ghc/-/commits/first-class-continuations 89 | [oleg:exteff]: http://okmij.org/ftp/Haskell/extensible/exteff.pdf 90 | [oleg:more]: http://okmij.org/ftp/Haskell/extensible/more.pdf 91 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: eff 2 | jobs: $ncpus 3 | 4 | repository head.hackage.ghc.haskell.org 5 | url: https://ghc.gitlab.haskell.org/head.hackage/ 6 | secure: True 7 | key-threshold: 3 8 | root-keys: 9 | f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89 10 | 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329 11 | 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d 12 | 13 | allow-newer: 14 | primitive-0.7.0.1:base 15 | splitmix-0.0.5:base 16 | 17 | constraints: 18 | primitive ==0.7.0.1, 19 | QuickCheck ==2.13.2 || ==2.14 20 | 21 | package * 22 | optimization: 2 23 | 24 | haddock-html: true 25 | haddock-hoogle: true 26 | haddock-hyperlink-source: true 27 | haddock-quickjump: true 28 | 29 | package eff 30 | ghc-options: -j 31 | haddock-options: "--optghc=-Wno-unused-imports" 32 | -------------------------------------------------------------------------------- /cabal.project.travis: -------------------------------------------------------------------------------- 1 | documentation: true 2 | tests: true 3 | 4 | package eff 5 | -- Disabled temporarily: 6 | -- ghc-options: -Werror 7 | -------------------------------------------------------------------------------- /eff/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /eff/eff.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: eff 3 | version: 0.0.0.0 4 | category: Control 5 | build-type: Simple 6 | 7 | author: Alexis King 8 | maintainer: Alexis King 9 | homepage: https://github.com/hasura/eff 10 | bug-reports: https://github.com/hasura/eff/issues 11 | 12 | license: ISC 13 | copyright: 2019 Hasura, Alexis King 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/hasura/eff 18 | 19 | flag debug 20 | description: 21 | Enables some additional internal consistency checking at the cost of a small performance 22 | overhead. This may be useful if you find yourself getting segfaults or similarly dire badness, 23 | but is otherwise unlikely to be helpful. 24 | default: False 25 | manual: True 26 | 27 | common common 28 | ghc-options: 29 | -fdicts-strict 30 | -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints 31 | 32 | if flag(debug) 33 | ghc-options: -fno-ignore-asserts -falignment-sanitisation -fcatch-bottoms 34 | cpp-options: -DEFF_DEBUG 35 | 36 | build-depends: 37 | , base >=4.14 && <5 38 | , ghc-prim 39 | , primitive >=0.6.2 && <0.8 40 | 41 | default-language: Haskell2010 42 | default-extensions: 43 | BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures 44 | DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift 45 | DeriveTraversable DerivingStrategies DerivingVia EmptyCase 46 | ExistentialQuantification FlexibleContexts FlexibleInstances 47 | FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs 48 | KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns 49 | OverloadedStrings PatternSynonyms QuantifiedConstraints RankNTypes 50 | RoleAnnotations ScopedTypeVariables StandaloneDeriving 51 | StandaloneKindSignatures TupleSections TypeApplications TypeFamilies 52 | TypeFamilyDependencies TypeOperators UnliftedNewtypes ViewPatterns 53 | 54 | library 55 | import: common 56 | hs-source-dirs: src 57 | exposed-modules: 58 | Control.Effect 59 | Control.Effect.Base 60 | Control.Effect.Coroutine 61 | Control.Effect.Error 62 | Control.Effect.Internal 63 | Control.Effect.Internal.Debug 64 | Control.Effect.Internal.SmallArray 65 | Control.Effect.NonDet 66 | Control.Effect.Reader 67 | Control.Effect.State 68 | Control.Effect.State.Strict 69 | Control.Effect.Writer 70 | Control.Effect.Writer.Strict 71 | 72 | test-suite eff-tests 73 | import: common 74 | type: exitcode-stdio-1.0 75 | hs-source-dirs: test 76 | main-is: Main.hs 77 | other-modules: 78 | Control.EffectSpec 79 | Control.Effect.Examples.FileSystemSpec 80 | 81 | if flag(debug) 82 | ghc-options: -debug -with-rtsopts=-DS 83 | 84 | build-depends: 85 | , eff 86 | , hspec >=2 && <3 87 | build-tool-depends: 88 | , hspec-discover:hspec-discover >=2 && <3 89 | -------------------------------------------------------------------------------- /eff/src/Control/Effect.hs: -------------------------------------------------------------------------------- 1 | {-| @eff@ is a fast, flexible, easy to use effect system for Haskell. @eff@ 2 | makes it easy to write composable, modular effects and effect handlers without 3 | sacrificing performance. Broadly speaking, @eff@ provides the following 4 | features: 5 | 6 | * The 'Eff' monad, which provides an extremely flexible set of control 7 | operations that can be used to implement a variety of effects. 8 | 9 | * A standard library of built-in effects and effect handlers, including common 10 | effects like 'Reader', 'State', and 'Error'. 11 | 12 | * A framework for defining your own effects and effect handlers, which can 13 | either be built from scratch using the 'Eff' primitives or by delegating to 14 | an existing handler. 15 | 16 | @eff@ is far from the first effect system for Haskell, but it differentiates 17 | itself from existing libraries in the following respects: 18 | 19 | * @eff@ is built atop a direct, low-level implementation of delimited 20 | continuations to provide the best performance possible. 21 | 22 | * @eff@ provides a simpler, more streamlined API for handling effects. 23 | 24 | * Like @polysemy@ and @fused-effects@ (but unlike @freer-simple@), @eff@ 25 | supports so called “scoped” effect operations like 'local' and 'catch', but 26 | unlike @polysemy@ and @fused-effects@ (and also unlike 27 | @transformers@/@mtl@), @eff@ provides a consistent semantics for such 28 | operations regardless of handler order. 29 | 30 | @eff@ aspires to be a turnkey replacement for most traditional uses of monad 31 | transformers. @eff@ provides comparable performance to @transformers@ and @mtl@ 32 | with less complexity, less boilerplate, and a simpler semantics. -} 33 | module Control.Effect ( 34 | -- * The @Eff@ monad 35 | Eff 36 | , run 37 | , lift 38 | , lift1 39 | 40 | -- * Defining new effects 41 | , Effect 42 | , send 43 | , (:<) 44 | , (:<<) 45 | 46 | -- * Handling effects 47 | -- ** Simple effect handlers 48 | , interpret 49 | -- ** Advanced effect handlers 50 | , Handle 51 | , handle 52 | , liftH 53 | , abort 54 | , control 55 | , control0 56 | , locally 57 | 58 | -- * Performing I/O 59 | , IOE(..) 60 | , MonadIO(..) 61 | , runIO 62 | 63 | -- * Re-exports 64 | , (&) 65 | , (>>>) 66 | -- ** Built-in effects 67 | , module Control.Effect.Coroutine 68 | , module Control.Effect.Error 69 | , module Control.Effect.NonDet 70 | , module Control.Effect.Reader 71 | , module Control.Effect.State.Strict 72 | , module Control.Effect.Writer.Strict 73 | ) where 74 | 75 | import Control.Applicative 76 | import Control.Category ((>>>)) 77 | import Control.Monad.IO.Class 78 | import Data.Function 79 | 80 | import Control.Effect.Base 81 | import Control.Effect.Coroutine 82 | import Control.Effect.Error 83 | import Control.Effect.Internal 84 | import Control.Effect.NonDet 85 | import Control.Effect.Reader 86 | import Control.Effect.State.Strict 87 | import Control.Effect.Writer.Strict 88 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Base.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | This module exports the core functionality @eff@ without any of the 4 | -- built-in effects or effect handlers. You can import this module if you don’t 5 | -- want to import the built-in effects, but otherwise you probably want to 6 | -- import "Control.Effect" instead. 7 | module Control.Effect.Base ( 8 | -- * The @Eff@ monad 9 | Eff 10 | , run 11 | , lift 12 | , lift1 13 | 14 | -- * Defining new effects 15 | , Effect 16 | , send 17 | , (:<) 18 | , (:<<) 19 | 20 | -- * Handling effects 21 | -- ** Simple effect handlers 22 | , interpret 23 | -- ** Advanced effect handlers 24 | , Handle 25 | , handle 26 | , liftH 27 | , abort 28 | , control 29 | , control0 30 | , locally 31 | 32 | -- * Performing I/O 33 | , IOE(..) 34 | , MonadIO(..) 35 | , runIO 36 | ) where 37 | 38 | import Control.Monad.IO.Class 39 | 40 | import Control.Effect.Internal 41 | 42 | -- | The simplest way to handle an effect. Each use of 'send' for the handled 43 | -- effect dispatches to the handler function, which provides an interpretation 44 | -- for the operation. The handler function may handle the operation directly, or 45 | -- it may defer to other effects currently in scope. 46 | -- 47 | -- Most effect handlers should be implemented using 'interpret', possibly with 48 | -- the help of additional 'Control.Effect.Error.Error' or 'State' effects. 49 | -- Especially complex handlers can be defined via the more general 'handle', 50 | -- which 'interpret' is defined in terms of: 51 | -- 52 | -- @ 53 | -- 'interpret' f = 'handle' ('liftH' '.' f) 54 | -- @ 55 | interpret 56 | :: forall eff a effs 57 | . (forall m b. eff m b -> Eff (eff ': effs) b) 58 | -- ^ The handler function. 59 | -> Eff (eff ': effs) a 60 | -- ^ The action to handle. 61 | -> Eff effs a 62 | interpret f = handle pure (liftH . f) 63 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Coroutine.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect.Coroutine 2 | ( Coroutine(..) 3 | , yield 4 | , Status(..) 5 | , runCoroutine 6 | ) where 7 | 8 | import Control.Effect.Base 9 | 10 | data Coroutine a b :: Effect where 11 | Yield :: a -> Coroutine a b m b 12 | 13 | yield :: Coroutine a b :< effs => a -> Eff effs b 14 | yield = send . Yield 15 | 16 | data Status effs a b c 17 | = Done c 18 | | Yielded a !(b -> Eff (Coroutine a b ': effs) c) 19 | 20 | runCoroutine :: Eff (Coroutine a b ': effs) c -> Eff effs (Status effs a b c) 21 | runCoroutine = handle (pure . Done) \case 22 | Yield a -> control0 \k -> pure $! Yielded a k 23 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Error.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect.Error 2 | ( Error(..) 3 | , throw 4 | , catch 5 | , runError 6 | ) where 7 | 8 | import Control.Effect.Base 9 | 10 | -- | The @'Error' e@ effect allows throwing and catching errors of type @e@. 11 | -- 12 | -- Handlers should obey the law @'catch' ('throw' /x/) /f/@ ≡ @'pure' (/f/ /x/)@. 13 | data Error e :: Effect where 14 | Throw :: e -> Error e m a 15 | Catch :: Eff (Error e ': effs) a -> (e -> Eff effs a) -> Error e (Eff effs) a 16 | 17 | -- | Raises an error of type @e@. 18 | throw :: Error e :< effs => e -> Eff effs a 19 | throw = send . Throw 20 | 21 | -- | @'catch' /m/ /f/@ executes @/m/@. If it raises an error @/e/@, the 22 | -- computation aborts to the point of the call to 'catch', and it resumes by 23 | -- executing @/f/ /e/@. 24 | catch :: Error e :< effs => Eff (Error e ': effs) a -> (e -> Eff effs a) -> Eff effs a 25 | catch a b = send $ Catch a b 26 | 27 | -- | Handles an 'Error' effect. Returns 'Left' if the computation raised an 28 | -- uncaught error, otherwise returns 'Right'. 29 | runError :: forall e a effs. Eff (Error e ': effs) a -> Eff effs (Either e a) 30 | runError = handle (pure . Right) \case 31 | Throw e -> abort $ Left e 32 | Catch m f -> locally (either f pure =<< runError m) 33 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE StrictData #-} 7 | {-# LANGUAGE UnboxedTuples #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Control.Effect.Internal where 11 | 12 | import qualified Control.Exception as IO 13 | import qualified Data.Type.Coercion as Coercion 14 | 15 | import Control.Applicative 16 | import Control.Exception (Exception) 17 | import Control.Monad 18 | import Control.Monad.IO.Class 19 | import Data.Bool (bool) 20 | import Data.Coerce 21 | import Data.Functor 22 | import Data.IORef 23 | import Data.Kind (Constraint, Type) 24 | import Data.Type.Coercion (Coercion(..), gcoerceWith) 25 | import Data.Type.Equality ((:~:)(..), gcastWith) 26 | import GHC.Exts (Any, Int(..), Int#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, prompt#, control0#) 27 | import GHC.Types (IO(..)) 28 | import System.IO.Unsafe (unsafeDupablePerformIO) 29 | import Unsafe.Coerce (unsafeCoerce) 30 | 31 | import Control.Effect.Internal.Debug 32 | import Control.Effect.Internal.SmallArray 33 | 34 | -- ----------------------------------------------------------------------------- 35 | 36 | axiom :: a :~: b 37 | axiom = unsafeCoerce Refl 38 | {-# INLINE axiom #-} 39 | 40 | -- | A restricted form of 'unsafeCoerce' that only works for converting to/from 41 | -- 'Any'. Still just as unsafe, but makes it slightly more difficult to 42 | -- accidentally misuse. 43 | pattern Any :: forall a. a -> Any 44 | pattern Any a <- (unsafeCoerce -> a) 45 | where Any = unsafeCoerce 46 | {-# COMPLETE Any #-} 47 | 48 | anyCo :: forall a. Coercion a Any 49 | anyCo = unsafeCoerce (Coercion @a @a) 50 | {-# INLINE anyCo #-} 51 | 52 | -- | Used to explicitly overwrite references to values that should not be 53 | -- retained by the GC. 54 | null# :: Any 55 | null# = Any () 56 | 57 | unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #) 58 | unIO (IO m) = m 59 | {-# INLINE unIO #-} 60 | 61 | -- ----------------------------------------------------------------------------- 62 | 63 | data Dict c = c => Dict 64 | 65 | type DictRep :: Constraint -> Type 66 | type family DictRep c 67 | 68 | type WithDict :: Constraint -> Type -> Type 69 | newtype WithDict c r = WithDict { unWithDict :: c => r } 70 | 71 | reflectDict :: forall c r. DictRep c -> (c => r) -> r 72 | reflectDict !d x = unsafeCoerce (WithDict @c @r x) d 73 | {-# INLINE reflectDict #-} 74 | 75 | -- ----------------------------------------------------------------------------- 76 | 77 | -- | The kind of effects. 78 | type Effect = (Type -> Type) -> Type -> Type 79 | 80 | type (:<) :: Effect -> [Effect] -> Constraint 81 | class eff :< effs where 82 | reifyIndex :: Int 83 | instance {-# OVERLAPPING #-} eff :< (eff ': effs) where 84 | reifyIndex = 0 85 | {-# INLINE reifyIndex #-} 86 | instance eff :< effs => eff :< (eff' ': effs) where 87 | reifyIndex = reifyIndex @eff @effs + 1 88 | {-# INLINE reifyIndex #-} 89 | 90 | type (:<<) :: [Effect] -> [Effect] -> Constraint 91 | class effs1 :<< effs2 where 92 | reifySubIndex :: Int 93 | instance {-# OVERLAPPING #-} effs :<< effs where 94 | reifySubIndex = 0 95 | {-# INLINE reifySubIndex #-} 96 | instance (effs2 ~ (eff ': effs3), effs1 :<< effs3) => effs1 :<< effs2 where 97 | reifySubIndex = reifySubIndex @effs1 @effs3 + 1 98 | {-# INLINE reifySubIndex #-} 99 | 100 | type instance DictRep (eff :< effs) = Int 101 | type instance DictRep (effs1 :<< effs2) = Int 102 | 103 | type (:<#) :: Effect -> [Effect] -> TYPE 'IntRep 104 | -- see Note [Manual worker/wrapper] 105 | newtype eff :<# effs = ReflectIndex# { reifyIndex# :: Int# } 106 | pattern IndexDict# :: forall eff effs. () => eff :< effs => eff :<# effs 107 | pattern IndexDict# <- ReflectIndex# ((\idx -> reflectDict @(eff :< effs) (I# idx) (Dict @(eff :< effs))) -> Dict) 108 | where IndexDict# = case reifyIndex @eff @effs of I# idx -> ReflectIndex# idx 109 | {-# COMPLETE IndexDict# #-} 110 | 111 | {- ----------------------------------------------------------------------------- 112 | -- Note [The Eff Machine] 113 | ~~~~~~~~~~~~~~~~~~~~~~~~~ 114 | The Eff monad is best thought of as a “embedded virtual machine.” Given 115 | primitive support for continuation manipulation from the host, Eff efficiently 116 | implements a complement of complex control operations. 117 | 118 | At any time, the Eff machine conceptually manages two pieces of state: 119 | 120 | 1. The /metacontinuation stack/, which holds metacontinuation frames. 121 | Metacontinuation frames correspond to things like effect handlers, 122 | “thread-local” state, and dynamic winders. 123 | 124 | 2. The /targets vector/, which maps a list of effects to the corresponding 125 | metacontinuation frames that handle them. (See Note [The targets vector].) 126 | 127 | However, the representation of the metacontinuation stack is not explicit: it is 128 | implicitly encoded as stack frames on the ordinary GHC RTS stack that cooperate 129 | using a particular calling convention. 130 | 131 | Note [Manual worker/wrapper] 132 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 133 | GHC performs an optimization called the /worker-wrapper transformation/, which 134 | is used to propagate strictness information, unboxing, and more. The idea is 135 | simple: if a function strictly operates on a boxed value, like 136 | 137 | f :: Int -> Foo 138 | f !n = ... 139 | 140 | then GHC will internally rewrite it into a pair of definitions, a /worker/ and a 141 | /wrapper/: 142 | 143 | $wf :: Int# -> Foo 144 | $wf n = ... 145 | 146 | f :: Int -> Foo 147 | f (I# n) = $wf n 148 | {-# INLINE f #-} 149 | 150 | If some other code uses f, the wrapper will be inlined at the call site, and the 151 | exposed unfolding allows GHC to make a direct call to $wf passing an unboxed 152 | Int#. 153 | 154 | This is great, but the automatic transformation can only do so much. The 155 | worker/wrapper transformation relies on inlining, so it only works for known 156 | calls. This means it can be advantageous to /manually/ perform this kind of 157 | transformation to ensure unboxing happens, especially on datatypes (where the 158 | “worker” is the datatype definition itself and the “wrapper” is a pattern 159 | synonym.) -} 160 | 161 | -- | All @eff@ computations operate in the 'Eff' monad. 'Eff' computations are 162 | -- parameterized by a type-level list that specifies which effects they are 163 | -- allowed to perform. For example, a computation of type 164 | -- @'Eff' '['Control.Effect.Error' e, 'Control.Effect.Reader' r, 'Control.Effect.State' s] a@ 165 | -- can raise exceptions of type @e@, can access a global environment of type 166 | -- @r@, and can read and modify a single cell of mutable state of type @s@. 167 | -- 168 | -- To run an 'Eff' computation that performs effects, the effects must be 169 | -- explicitly /handled/. Functions that handle effects are called 170 | -- /effect handlers/, and they usually have types like the following: 171 | -- 172 | -- @ 173 | -- runX :: 'Eff' (X ': effs) a -> 'Eff' effs a 174 | -- @ 175 | -- 176 | -- Note that the argument to @runX@ can perform the @X@ effect, but the result 177 | -- cannot! Any @X@ operations have been handled by @runX@, which interprets 178 | -- their meaning. Examples of effect handlers include 179 | -- 'Control.Effect.Error.runError', 'Control.Effect.Reader.runReader', and 180 | -- 'Control.Effect.State.Strict.runState'. 181 | -- 182 | -- After all effects have been handled, the resulting computation will have type 183 | -- @'Eff' '[] a@, a computation that performs no effects. A computation with 184 | -- this type is pure, so it can be converted to an ordinary value using 'run'. 185 | -- 186 | -- Some effects cannot be handled locally, but instead require performing I/O. 187 | -- These effects will delegate to the 'IOE' effect, which provides low-level 188 | -- interop with Haskell’s built-in 'IO' monad. After all other effects have been 189 | -- handled, a computation of type @'Eff' '['IOE'] a@ can be converted to an 190 | -- ordinary @'IO' a@ computation using 'runIO'. 191 | type Eff :: [Effect] -> Type -> Type 192 | type role Eff nominal representational 193 | newtype Eff effs a = Eff# { unEff# :: EVM a } 194 | deriving (Functor, Applicative, Monad) 195 | 196 | pattern Eff :: (Registers -> IO (Registers, a)) -> Eff effs a 197 | pattern Eff{unEff} = Eff# (EVM unEff) -- see Note [Manual worker/wrapper] 198 | {-# COMPLETE Eff #-} 199 | 200 | newtype EVM a = EVM# { unEVM# :: Registers# -> IO (Result a) } 201 | data Result a = Result Registers# ~a 202 | 203 | pattern EVM :: (Registers -> IO (Registers, a)) -> EVM a 204 | -- see Note [Manual worker/wrapper] 205 | pattern EVM{unEVM} <- EVM# ((\m (BoxRegisters rs1) -> m rs1 <&> \(Result rs2 a) -> (BoxRegisters rs2, a)) -> unEVM) 206 | where EVM m = EVM# \rs1 -> m (BoxRegisters rs1) <&> \(BoxRegisters rs2, a) -> Result rs2 a 207 | {-# COMPLETE EVM #-} 208 | 209 | packIOResult :: IO (Registers, a) -> IO (Result a) 210 | -- see Note [Manual worker/wrapper] 211 | packIOResult m = m >>= \(BoxRegisters rs, a) -> pure $! Result rs a 212 | {-# INLINE packIOResult #-} 213 | 214 | -- ----------------------------------------------------------------------------- 215 | 216 | newtype Registers# = Registers# (# PromptId, Targets# #) 217 | data Registers = BoxRegisters { unboxRegisters :: Registers# } 218 | pattern Registers :: PromptId -> Targets -> Registers 219 | -- see Note [Manual worker/wrapper] 220 | pattern Registers pid ts <- BoxRegisters (Registers# (# pid, (BoxTargets -> ts) #)) 221 | where Registers pid (BoxTargets ts) = BoxRegisters (Registers# (# pid, ts #)) 222 | {-# COMPLETE Registers #-} 223 | 224 | initialRegisters :: Registers 225 | initialRegisters = Registers (PromptId 0) noTargets 226 | 227 | newtype PromptId = PromptId# Int# 228 | pattern PromptId :: Int -> PromptId 229 | -- see Note [Manual worker/wrapper] 230 | pattern PromptId{unPromptId} <- PromptId# (I# -> unPromptId) 231 | where PromptId (I# n) = PromptId# n 232 | {-# COMPLETE PromptId #-} 233 | 234 | data Unwind 235 | = UnwindAbort PromptId ~Any 236 | | UnwindControl (Capture Any) 237 | 238 | instance Show Unwind where 239 | show (UnwindAbort (PromptId pid) _) 240 | = "<>" 241 | show (UnwindControl (Capture (PromptId pid) _ _ _)) 242 | = "<>" 243 | instance Exception Unwind 244 | 245 | data Capture a where 246 | Capture 247 | :: PromptId 248 | -- ^ The prompt to capture up to. 249 | -> CaptureMode 250 | -> ((b -> EVM c) -> EVM d) 251 | -- ^ The replacement continuation passed by the user to the original call to 252 | -- 'control'. This should be invoked with the fully-composed continuation 253 | -- after capturing is complete. 254 | -> (b -> EVM a) 255 | -- ^ The composed continuation captured so far. 256 | -> Capture a 257 | 258 | data CaptureMode 259 | -- | The captured continuation should include the prompt being captured up to. 260 | -- This mode corresponds to the 'control' operator. 261 | = IncludePrompt 262 | -- | The captured continuation should include frames up to the the prompt, but 263 | -- not the prompt itself. This mode corresponds to the 'control0' operator. 264 | | ExcludePrompt 265 | 266 | captureVM :: forall a b. Capture a -> IO b 267 | captureVM a = gcoerceWith (Coercion.sym $ anyCo @a) $ 268 | IO.throwIO $! UnwindControl (coerce a) 269 | {-# INLINE captureVM #-} 270 | 271 | -- | Runs an 'EVM' action with a new prompt installed. The arguments specify 272 | -- what happens when control exits the action. 273 | promptVM 274 | :: forall a b 275 | . IO (Registers, a) 276 | -> (a -> IO b) 277 | -- ^ return handler 278 | -> (PromptId -> Any -> IO b) 279 | -- ^ abort handler 280 | -> (Capture a -> IO b) 281 | -- ^ capture handler 282 | -> IO b 283 | promptVM m onReturn onAbort onControl = IO.handle handleUnwind do 284 | -- TODO: Explain why it is crucial that the exception handler is installed 285 | -- outside of the frame where we replace the registers! 286 | Result _ a <- IO (prompt# (unIO (packIOResult m))) 287 | onReturn a 288 | where 289 | handleUnwind (UnwindAbort pid a) = onAbort pid a 290 | handleUnwind (UnwindControl cap) = gcoerceWith (anyCo @a) $ onControl (coerce cap) 291 | {-# INLINE promptVM #-} 292 | 293 | -- | Like 'promptVM', but for prompts that cannot be the target of a capture or 294 | -- abort (that is, prompts that only install winders/unwinders). 295 | promptVM_ 296 | :: forall a 297 | . IO (Registers, a) 298 | -> Registers 299 | -- ^ registers to restore on normal return 300 | -> (Capture a -> IO (Registers, a)) 301 | -- ^ capture handler 302 | -> IO (Registers, a) 303 | promptVM_ m rs onCapture = promptVM m onReturn rethrowAbort onCapture where 304 | onReturn a = pure (rs, a) 305 | -- TODO: Check if this unwrapping/rewrapping is eliminated at the STG level. 306 | rethrowAbort pid a = IO.throwIO $! UnwindAbort pid a 307 | {-# INLINE promptVM_ #-} 308 | 309 | controlVM :: ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a) 310 | controlVM f = IO (control0# f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where 311 | f# k# = unIO (f k <&> \(BoxRegisters rs, a) -> Result rs a) where 312 | k a = EVM# \rs -> IO $ k# \s -> (# s, Result rs a #) 313 | {-# INLINE controlVM #-} 314 | 315 | -- TODO: Share some code between `parameterizeVM` and `handle`. 316 | parameterizeVM :: (Registers -> Registers) -> EVM a -> EVM a 317 | parameterizeVM adjust (EVM m0) = EVM \rs -> do 318 | promptVM_ (m0 (adjust rs)) rs \(Capture target mode f k1) -> 319 | controlVM \k2 -> captureVM $! handleCapture target mode f k1 k2 320 | where 321 | handleCapture 322 | :: PromptId 323 | -> CaptureMode 324 | -> ((a -> EVM d) -> EVM e) 325 | -> (a -> EVM b) 326 | -> (b -> EVM c) 327 | -> Capture c 328 | handleCapture target1 mode1 f1 k1 k2 = 329 | let k3 a = EVM \rs1 -> do 330 | let m = unEVM (k1 a) (adjust rs1) 331 | (rs2, b) <- promptVM_ m rs1 \(Capture target2 mode2 f2 k4) -> 332 | captureVM $! handleCapture target2 mode2 f2 k4 k2 333 | unEVM (k2 b) rs2 334 | in Capture target1 mode1 f1 k3 335 | {-# INLINE parameterizeVM #-} 336 | 337 | {- ----------------------------------------------------------------------------- 338 | -- Note [The targets vector] 339 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 340 | In most implementations of delimited control or algebraic effects, handling an 341 | effect involves walking the prompt/handler stack looking for a frame with the 342 | right tag. This is a little unfortunate, as in the large majority of use cases, 343 | the handler stack changes infrequently relative to the number of effectful 344 | operations that are performed. Therefore, we take a slightly different approach, 345 | and we cache which effects are handled by which handlers at any given time. 346 | 347 | This cache is stored in the /targets vector/ (represented by type `Targets`), an 348 | immutable SmallArray that contains pointers to `Handler`s. Each effect is mapped 349 | to a handler using its index in the type-level list. For example, if we have a 350 | computation of type 351 | 352 | Eff '[Reader Int, NonDet, Error String] a 353 | 354 | then the targets vector will be three elements long. Index 0 will point to a 355 | handler for `Reader Int`, index 1 will point to a handler for `NonDet`, and 356 | index 2 will point to a handler for `Error String`. 357 | 358 | The targets vector makes `send` a constant-time operation, regardless of the 359 | number of effects. The `:<` class provides the effect’s index, so `send` need 360 | only look up the index in the targets vector and invoke the handler. This is a 361 | particularly good tradeoff in situations where the following conditions hold: 362 | 363 | 1. Most effects are handled at the top-level of the program and changed 364 | infrequently during runtime. 365 | 366 | 2. Most calls to `send` do not need to capture the continuation. 367 | 368 | In practice, these conditions seem usually true. However, if they aren’t, 369 | maintaining the targets vector has a cost: it needs to be recomputed on every 370 | use of `handle` or `lift`, and continuation restore requires recomputing the 371 | vector for every `handle` or `lift` frame in the captured continuation! In most 372 | cases, the vector is very small, so this isn’t a big deal. 373 | 374 | If the overhead of maintaining the targets vector ever turns out to be 375 | significant, there are a variety of potential optimizations that we currently 376 | don’t do. Here are a couple possibilities: 377 | 378 | * Most continuations are restored in the same context where they’re captured, 379 | so there’s no need to recompute the targets vectors upon restore. Skipping 380 | is the recomputation in that case is likely a particularly easy win. 381 | 382 | * If the list of effects grows very large, the cost of copying the whole 383 | vector could become prohibitive. In those situations, we could switch to a 384 | more sophisticated representation that allows more sharing while still 385 | providing decent access time, avoiding the need for unbounded copying. -} 386 | 387 | newtype Targets# = Targets# (SmallArray# Any) 388 | newtype Targets = Targets (SmallArray Any) 389 | pattern BoxTargets :: Targets# -> Targets 390 | pattern BoxTargets ts <- Targets (SmallArray (Targets# -> ts)) 391 | where BoxTargets (Targets# ts) = Targets (SmallArray ts) 392 | {-# COMPLETE BoxTargets #-} 393 | 394 | noTargets :: Targets 395 | noTargets = Targets mempty 396 | 397 | lookupTarget :: forall effs eff. (DebugCallStack, eff :< effs) => Targets -> Handler eff 398 | lookupTarget (Targets ts) = case indexSmallArray ts (reifyIndex @eff @effs) of (# Any h #) -> h 399 | 400 | pushTarget :: Handler eff -> Targets -> Targets 401 | pushTarget h (Targets ts1) = Targets $ runSmallArray do 402 | let len = sizeofSmallArray ts1 403 | ts2 <- newSmallArray (len + 1) null# 404 | writeSmallArray ts2 0 (Any h) 405 | copySmallArray ts2 1 ts1 0 len 406 | pure ts2 407 | 408 | dropTargets :: DebugCallStack => Int -> Targets -> Targets 409 | dropTargets idx (Targets ts) = Targets $ cloneSmallArray ts idx (sizeofSmallArray ts - idx) 410 | 411 | -- ----------------------------------------------------------------------------- 412 | 413 | instance Functor EVM where 414 | fmap f m = m >>= pure . f 415 | {-# INLINE fmap #-} 416 | 417 | instance Applicative EVM where 418 | pure a = EVM# \rs -> pure $ Result rs a 419 | {-# INLINE pure #-} 420 | (<*>) = ap 421 | {-# INLINE (<*>) #-} 422 | 423 | instance Monad EVM where 424 | EVM# m >>= f = EVM# \rs1 -> m rs1 >>= \(Result rs2 a) -> unEVM# (f a) rs2 425 | {-# INLINE (>>=) #-} 426 | 427 | instance MonadIO EVM where 428 | liftIO m = EVM# \rs -> Result rs <$> m 429 | {-# INLINE liftIO #-} 430 | 431 | -- | Runs a pure 'Eff' computation to produce a value. 432 | -- 433 | -- @ 434 | -- >>> 'run' '$' 'pure' 42 435 | -- 42 436 | -- >>> 'run' '$' 'Control.Effect.Error.runError' '$' 'Control.Effect.Error.throw' "bang" 437 | -- 'Left' "bang" 438 | -- @ 439 | run :: Eff '[] a -> a 440 | run (Eff m) = unsafeDupablePerformIO (snd <$> m initialRegisters) 441 | 442 | -- ----------------------------------------------------------------------------- 443 | 444 | -- | The monad that effect handlers run in. 445 | -- 446 | -- * The @eff@ parameter is the effect being handled, and the @effs@ parameter 447 | -- includes the other effects in scope at the point of the 'handle' call 448 | -- (used by 'liftH'). 449 | -- 450 | -- * The @i@ parameter is the return type of the handled computation before 451 | -- the exit handler has been applied (used by 'control0'). 452 | -- 453 | -- * The @r@ parameter is the final return type of the handled computation 454 | -- (used by 'abort', 'control', and 'control0'). 455 | -- 456 | -- * The @effs'@ parameter is the list of effects in scope at the point of the 457 | -- originating 'send' call (used by 'locally'). 458 | -- 459 | -- See 'handle' for more details. 460 | type Handle :: Effect -> [Effect] -> Type -> Type -> [Effect] -> Type -> Type 461 | type role Handle nominal nominal representational representational nominal representational 462 | newtype Handle eff effs i r effs' a = Handle# { runHandle# :: Registers# -> Eff effs' a } 463 | pattern Handle :: (Registers -> Eff effs' a) -> Handle eff effs i r effs' a 464 | -- see Note [Manual worker/wrapper] 465 | pattern Handle{runHandle} <- Handle# ((\f (BoxRegisters rs) -> f rs) -> runHandle) 466 | where Handle f = Handle# \rs -> f (BoxRegisters rs) 467 | {-# COMPLETE Handle #-} 468 | 469 | instance Functor (Handle eff effs i r effs') where 470 | fmap f (Handle# m) = Handle# \rs -> f <$> m rs 471 | {-# INLINE fmap #-} 472 | 473 | {- Note [Explicitly unbox Handler results] 474 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 475 | Normally, EVM returns results via the lifted Result type. This is necessary, 476 | since prompt# is not levity-polymorphic, and the wrapping/unwrapping that would 477 | be required if we returned the results in an unlifted type would leak 478 | continuation frames (TODO: write a Note that explains this!). 479 | 480 | Normally that is okay, since the optimizer will get rid of almost all of the 481 | intermediate Result values automatically. However, it can’t do that when calling 482 | an effect handler, those are unknown calls. Fortunately, in this situation, 483 | there is no obstacle to doing the unboxing explicitly, as we have control over 484 | the way we store handlers in the targets vector. 485 | 486 | The idea is simple enough. In `handle`, we accept an Eff value, but we eagerly 487 | adapt it to return an unboxed value: 488 | 489 | handle (Eff# (EVM# m)) = 490 | ... case result of { (# s, Result a b #) -> (# s, a, b #) } ... 491 | 492 | We arrange for that case expression to appear in a minimal unfolding that can be 493 | aggressively inlined at use sites, as described in Note [Manual worker/wrapper]. 494 | At each use site, GHC can see both the wrapping and unwrapping, so it will 495 | eliminate the Result constructor altogether. 496 | 497 | Dually, on the other side, we do the inverse transformation in `send`: 498 | 499 | send e = ... case f e rs s of { (# s, a, b #) -> (# s, Result a b #) } ... 500 | 501 | In exactly the same fashion, GHC can inline `send` at its use site (since its 502 | definition is very small), and the wrapping will be fused with any local 503 | unwrapping. Voilà, we have eliminated the constructor even across unknown calls! 504 | 505 | In reality, this wrapping/unwrapping is handled via the Handler pattern synonym, 506 | just as for all the other types we do this manual transformation for. -} 507 | 508 | newtype Handler eff = Handler# { runHandler# 509 | -- see Note [Explicitly unbox Handler results] 510 | :: forall effs a 511 | . eff :<# effs 512 | -> eff (Eff effs) a 513 | -> Registers# 514 | -> State# RealWorld 515 | -> (# State# RealWorld, Registers#, a #) 516 | } 517 | 518 | newtype WrappedHandler eff 519 | -- Unfortunately necessary to avoid the need for impredicative polymorphism in 520 | -- the definition of the Handler pattern synonym. 521 | = WrapHandler (forall effs a. eff :< effs => eff (Eff effs) a -> Eff effs a) 522 | 523 | pattern Handler :: (forall effs a. eff :< effs => eff (Eff effs) a -> Eff effs a) -> Handler eff 524 | -- see Note [Explicitly unbox Handler results] and Note [Manual worker/wrapper] 525 | pattern Handler{runHandler} <- ((\(Handler# f) -> 526 | WrapHandler \e -> Eff# (EVM# \rs1 -> IO \s1 -> 527 | case f IndexDict# e rs1 s1 of 528 | (# s2, rs2, a #) -> (# s2, Result rs2 a #) 529 | )) -> WrapHandler runHandler) 530 | where Handler f = Handler# \IndexDict# e rs1 s1 -> 531 | case unIO (unEVM# (unEff# (f e)) rs1) s1 of 532 | (# s2, Result rs2 a #) -> (# s2, rs2, a #) 533 | {-# COMPLETE Handler #-} 534 | 535 | -- ----------------------------------------------------------------------------- 536 | 537 | send :: forall eff a effs. eff :< effs => eff (Eff effs) a -> Eff effs a 538 | send !e = Eff \rs@(Registers _ ts) -> unEff (runHandler (lookupTarget @effs ts) e) rs 539 | 540 | -- | Handles the topmost effect in an 'Eff' computation. The given handler 541 | -- function must provide an interpretation for each effectful operation. The 542 | -- handler runs in the restrictive 'Handle' monad, which generally uses one of 543 | -- the following core 'Handle' operations: 544 | -- 545 | -- * 'liftH' — Runs an action in the context of the original 'handle' call. 546 | -- This is the most common way to handle an effect. 547 | -- 548 | -- * 'abort' — Aborts the computation to the 'handle' call and returns a value 549 | -- directly. This is usually used to implement exception-like operations. 550 | -- 551 | -- * 'control' — Captures the current continuation up to and including the 552 | -- 'handle' call and aborts, passing the captured continuation to the 553 | -- handler. This can be used to implement complex control operators such as 554 | -- coroutines or resumable exceptions. 555 | -- 556 | -- * 'control0' — Like 'control', but does not include the 'handle' call 557 | -- itself in the captured continuation, so a different handler may be 558 | -- installed before resuming the computation. 559 | -- 560 | -- * 'locally' — Runs an action directly in the context of the originating 561 | -- 'send' call. This can be used to implement “scoped” operations like 562 | -- 'Control.Effect.local' and 'Control.Effect.catch'. 563 | -- 564 | -- See the documentation for each of the above functions for examples and more 565 | -- details. 566 | handle 567 | :: forall eff a r effs 568 | . (a -> Eff effs r) 569 | -- ^ The exit handler, aka the action to take on normal returns (often just 'pure'). 570 | -> (forall effs' b. eff :< effs' => eff (Eff effs') b -> Handle eff effs a r effs' b) 571 | -- ^ The handler function. 572 | -> Eff (eff ': effs) a 573 | -- ^ The action to handle. 574 | -> Eff effs r 575 | handle onReturn f = handleVM onReturn \rs -> Handler \e -> runHandle# (f e) rs 576 | {-# INLINE handle #-} 577 | 578 | handleVM 579 | :: forall eff a r effs 580 | . (a -> Eff effs r) 581 | -> (Registers# -> Handler eff) 582 | -> Eff (eff ': effs) a 583 | -> Eff effs r 584 | handleVM onReturn f (Eff m1) = Eff# (withHandler m1) 585 | where 586 | withHandler :: (Registers -> IO (Registers, a)) -> EVM r 587 | -- GHC can’t figure out how to pull this small bit of unboxing out of the 588 | -- recursive knot we’re tying, so we do it manually here 589 | withHandler g = withHandler# (unEVM# (EVM g)) 590 | {-# INLINE withHandler #-} 591 | 592 | withHandler# :: (Registers# -> IO (Result a)) -> EVM r 593 | withHandler# m2 = EVM \rs -> do 594 | resetPrompt (EVM# m2) rs \(Capture target mode g k1) -> 595 | controlVM \k2 -> captureVM $! handleCaptureElsewhere target mode g k1 k2 596 | 597 | pushPrompt (Registers pid1 ts1) = 598 | let pid2 = PromptId (unPromptId pid1 + 1) 599 | ts2 = pushTarget (f (unboxRegisters rs2)) ts1 600 | rs2 = Registers pid2 ts2 601 | in rs2 602 | 603 | resetPrompt 604 | :: EVM a 605 | -> Registers 606 | -> (Capture a -> IO (Registers, r)) 607 | -> IO (Registers, r) 608 | resetPrompt m rs1 onCaptureElsewhere = 609 | promptVM (unEVM m rs2) handleReturn handleAbort handleCapture 610 | where 611 | !rs2@(Registers pid _) = pushPrompt rs1 612 | 613 | handleReturn a = unEff (onReturn a) rs1 614 | 615 | handleAbort target a 616 | | unPromptId target == unPromptId pid = case a of { Any b -> pure (rs1, b) } 617 | | otherwise = IO.throwIO $! UnwindAbort target a 618 | 619 | handleCapture = \case 620 | Capture target mode (g :: (b -> EVM c) -> EVM d) k1 621 | | unPromptId target == unPromptId pid -> 622 | -- We’re capturing up to this prompt, so the new continuation’s 623 | -- result type must be this function’s result type. 624 | gcastWith (axiom @r @d) case mode of 625 | -- If we’re capturing the prompt, then the captured 626 | -- continuation include onReturn, so its result type is the 627 | -- final result type. 628 | IncludePrompt -> gcastWith (axiom @r @c) $ unEVM (g (withHandler . unEVM . k1)) rs1 629 | -- If we’re not capturing the prompt, the captured 630 | -- continuation does NOT include onReturn, so its result type 631 | -- is the intermediate result type. 632 | ExcludePrompt -> gcastWith (axiom @a @c) $ unEVM (g k1) rs1 633 | cap -> onCaptureElsewhere cap 634 | 635 | handleCaptureElsewhere 636 | :: PromptId 637 | -> CaptureMode 638 | -> ((b -> EVM d) -> EVM e) 639 | -> (b -> EVM a) 640 | -> (r -> EVM c) 641 | -> Capture c 642 | handleCaptureElsewhere target1 mode1 f1 k1 k2 = 643 | let k3 a = EVM \rs1 -> do 644 | (rs2, b) <- resetPrompt (k1 a) rs1 \(Capture target2 mode2 g k4) -> 645 | captureVM $! handleCaptureElsewhere target2 mode2 g k4 k2 646 | unEVM (k2 b) rs2 647 | in Capture target1 mode1 f1 k3 648 | 649 | locally :: Eff effs' a -> Handle eff effs i r effs' a 650 | locally m = Handle \_ -> m 651 | 652 | liftH :: Eff (eff ': effs) a -> Handle eff effs i r effs' a 653 | liftH (Eff# m) = Handle \(Registers _ ts) -> 654 | Eff# (parameterizeVM (\(Registers pid _) -> Registers pid ts) m) 655 | 656 | abort :: r -> Handle eff effs i r effs' a 657 | abort a = Handle \(Registers pid _) -> Eff \_ -> IO.throwIO $! UnwindAbort pid (Any a) 658 | 659 | control :: ((a -> Eff effs r) -> Eff effs r) -> Handle eff effs i r effs' a 660 | control (f :: (a -> Eff effs r) -> Eff effs r) = 661 | controlWithMode @r IncludePrompt (coerce f) 662 | 663 | control0 :: ((a -> Eff (eff ': effs) i) -> Eff effs r) -> Handle eff effs i r effs' a 664 | control0 (f :: (a -> Eff (eff ': effs) i) -> Eff effs r) = 665 | controlWithMode @i ExcludePrompt (coerce f) 666 | 667 | controlWithMode 668 | :: forall b eff effs i r effs' a 669 | . CaptureMode 670 | -> ((a -> EVM b) -> EVM r) 671 | -> Handle eff effs i r effs' a 672 | controlWithMode mode f = Handle \(Registers pid _) -> Eff \_ -> 673 | controlVM \k -> captureVM $! Capture pid mode f k 674 | 675 | -- ----------------------------------------------------------------------------- 676 | 677 | -- TODO: Fuse uses of liftTargets using RULES. 678 | type Lift :: [Effect] -> [Effect] -> Constraint 679 | class Lift effs1 effs2 where 680 | liftTargets :: Targets -> Targets 681 | instance {-# INCOHERENT #-} effs1 :<< effs2 => Lift effs1 effs2 where 682 | liftTargets = dropTargets (reifySubIndex @effs1 @effs2) 683 | {-# INLINE liftTargets #-} 684 | instance Lift '[] effs where 685 | liftTargets _ = noTargets 686 | {-# INLINE liftTargets #-} 687 | instance (eff :< effs2, Lift effs1 effs2) => Lift (eff ': effs1) effs2 where 688 | liftTargets ts = pushTarget (lookupTarget @effs2 @eff ts) $! liftTargets @effs1 @effs2 ts 689 | 690 | -- | Lifts an 'Eff' computation into one that performs all the same effects, and 691 | -- possibly more. For example, if you have a computation 692 | -- 693 | -- @ 694 | -- m :: 'Eff' '[Foo, Bar] () 695 | -- @ 696 | -- 697 | -- then 'lift' will transform it into a polymorphic computation with the 698 | -- following type: 699 | -- 700 | -- @ 701 | -- 'lift' m :: (Foo ':<' effs, Bar ':<' effs) => 'Eff' effs () 702 | -- @ 703 | -- 704 | -- This type is much more general, and @effs@ can now be instantiated at many 705 | -- different types. Generally, 'lift' can manipulate the list of effects in any 706 | -- of the following ways: 707 | -- 708 | -- * Effects can be reordered. 709 | -- * New effects can be inserted anywhere in the list. 710 | -- * Duplicate effects can be collapsed. 711 | -- 712 | -- More generally, the list of effects doesn’t need to be entirely concrete in 713 | -- order for 'lift' to work. For example, if you have a computation 714 | -- 715 | -- @ 716 | -- n :: 'Eff' (Foo ': Bar ': effs1) () 717 | -- @ 718 | -- 719 | -- then @'lift' n@ will have the following type: 720 | -- 721 | -- @ 722 | -- 'lift' n :: (Foo ':<' effs2, Bar ':<' effs2, effs1 ':<<' effs2) => 'Eff' effs2 () 723 | -- @ 724 | -- 725 | -- This type is extremely general, and it allows 'lift' to manipulate the /head/ 726 | -- of the effects list even if the entire list is not completely known. 727 | -- 728 | -- The 'Lift' typeclass provides some type-level programming machinery to 729 | -- implement 'lift', but it should be treated as an implementation detail. In 730 | -- most situations, the machinery should “just work,” but if it doesn’t, the 731 | -- type errors can be somewhat inscrutable. In those situations, adding some 732 | -- explicit type annotations (or using @TypeApplications@) can improve the type 733 | -- errors significantly. 734 | lift :: forall effs1 effs2 a. Lift effs1 effs2 => Eff effs1 a -> Eff effs2 a 735 | lift = Eff# . parameterizeVM liftRegisters . unEff# where 736 | liftRegisters (Registers pid ts) = Registers pid (liftTargets @effs1 @effs2 ts) 737 | 738 | -- | Like 'lift', but restricted to introducing a single additional effect in the result. This is 739 | -- behaviorally identical to just using 'lift', but the restricted type can produce better type 740 | -- inference. 741 | lift1 :: forall eff effs a. Eff effs a -> Eff (eff ': effs) a 742 | lift1 = lift 743 | {-# INLINE lift1 #-} 744 | 745 | -- ----------------------------------------------------------------------------- 746 | 747 | -- | An effect used to run 'IO' operations via 'liftIO'. Handled by the special 748 | -- 'runIO' handler. 749 | data IOE :: Effect where 750 | LiftIO :: IO a -> IOE m a 751 | 752 | unsafeIOToEff :: IO a -> Eff effs a 753 | unsafeIOToEff = Eff# . liftIO 754 | {-# INLINE unsafeIOToEff #-} 755 | 756 | -- | Converts an 'Eff' computation to 'IO'. Unlike most handlers, 'IOE' must be 757 | -- the final effect handled, and 'runIO' completely replaces the call to 'run'. 758 | runIO :: Eff '[IOE] a -> IO a 759 | runIO m0 = snd <$> unEff (handleIO m0) initialRegisters where 760 | handleIO = handle pure \case 761 | LiftIO m -> locally (unsafeIOToEff m) 762 | 763 | instance IOE :< effs => MonadIO (Eff effs) where 764 | liftIO = send . LiftIO 765 | {-# INLINE liftIO #-} 766 | 767 | -- ----------------------------------------------------------------------------- 768 | 769 | -- | The @'State' s@ effect provides access to a single cell of mutable state of 770 | -- type @s@. 771 | data State s :: Effect where 772 | Get :: State s m s 773 | Put :: ~s -> State s m () 774 | 775 | evalState :: s -> Eff (State s ': effs) a -> Eff effs a 776 | evalState (s0 :: s) (Eff m0) = Eff \rs -> do 777 | ref <- newIORef s0 778 | promptVM_ (m0 (pushHandler ref rs)) rs \(Capture target mode f k1) -> 779 | controlVM \k2 -> handleCapture ref target mode f k1 k2 780 | where 781 | pushHandler :: IORef s -> Registers -> Registers 782 | pushHandler ref (Registers pid ts) = 783 | let h :: Handler (State s) 784 | h = Handler \case 785 | Get -> Eff# $ liftIO $ readIORef ref 786 | Put !s -> Eff# $ liftIO $ writeIORef ref s 787 | in Registers pid (pushTarget h ts) 788 | 789 | handleCapture 790 | :: IORef s 791 | -> PromptId 792 | -> CaptureMode 793 | -> ((a -> EVM d) -> EVM e) 794 | -> (a -> EVM b) 795 | -> (b -> EVM c) 796 | -> IO (Registers, b) 797 | handleCapture ref1 target1 mode1 f1 k1 k2 = do 798 | s <- readIORef ref1 799 | let k3 a = EVM \rs1 -> do 800 | ref2 <- newIORef s 801 | let m = unEVM (k1 a) (pushHandler ref2 rs1) 802 | (rs2, b) <- promptVM_ m rs1 \(Capture target2 mode2 f2 k4) -> 803 | handleCapture ref2 target2 mode2 f2 k4 k2 804 | unEVM (k2 b) rs2 805 | captureVM $! Capture target1 mode1 f1 k3 806 | 807 | -- ----------------------------------------------------------------------------- 808 | 809 | -- | The 'NonDet' effect provides so-called /nondeterministic execution/, which 810 | -- runs all branches of a computation and collects some or all of their results. 811 | -- Actual execution is not usually truly nondeterministic in the sense that it 812 | -- is somehow random; rather, 'NonDet' models nondeterministic binary choice by 813 | -- executing /both/ possibilities rather than choosing just one. 814 | data NonDet :: Effect where 815 | Empty :: NonDet m a 816 | Choose :: NonDet m Bool 817 | 818 | instance NonDet :< effs => Alternative (Eff effs) where 819 | empty = send Empty 820 | {-# INLINE empty #-} 821 | a <|> b = send Choose >>= bool b a 822 | {-# INLINE (<|>) #-} 823 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Internal/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Control.Effect.Internal.Debug where 4 | 5 | import Control.Exception (assert) 6 | 7 | #ifdef EFF_DEBUG 8 | import GHC.Stack (HasCallStack) 9 | #else 10 | import Data.Kind (Constraint) 11 | #endif 12 | 13 | debugEnabled :: Bool 14 | #ifdef EFF_DEBUG 15 | debugEnabled = True 16 | #else 17 | debugEnabled = False 18 | #endif 19 | {-# INLINE debugEnabled #-} 20 | 21 | #ifdef EFF_DEBUG 22 | type DebugCallStack = HasCallStack 23 | #else 24 | type DebugCallStack = () :: Constraint 25 | #endif 26 | 27 | assertM :: (DebugCallStack, Applicative m) => Bool -> m () 28 | assertM b = assert b $ pure () 29 | {-# INLINE assertM #-} 30 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Internal/SmallArray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | 4 | module Control.Effect.Internal.SmallArray 5 | ( SmallArray(..) 6 | , SmallMutableArray(..) 7 | , newSmallArray 8 | , P.runSmallArray 9 | , P.unsafeFreezeSmallArray 10 | , P.unsafeThawSmallArray 11 | , sizeofSmallArray 12 | , sizeofSmallMutableArray 13 | , indexSmallArray 14 | , readSmallArray 15 | , writeSmallArray 16 | , copySmallArray 17 | , cloneSmallArray 18 | , copySmallMutableArray 19 | , cloneSmallMutableArray 20 | ) where 21 | 22 | import qualified Data.Primitive.SmallArray as P 23 | 24 | import Control.Exception (assert) 25 | import Control.Monad.Primitive 26 | import Data.Primitive.SmallArray (SmallArray(..), SmallMutableArray(..)) 27 | import GHC.Exts (Int(..), indexSmallArray#) 28 | 29 | import Control.Effect.Internal.Debug 30 | 31 | newSmallArray :: (DebugCallStack, PrimMonad m) => Int -> a -> m (SmallMutableArray (PrimState m) a) 32 | newSmallArray len x = assert (len >= 0) $ P.newSmallArray len x 33 | {-# INLINE newSmallArray #-} 34 | 35 | sizeofSmallArray :: DebugCallStack => SmallArray a -> Int 36 | sizeofSmallArray arr = let len = P.sizeofSmallArray arr in assert (len >= 0) len 37 | {-# INLINE sizeofSmallArray #-} 38 | 39 | sizeofSmallMutableArray :: DebugCallStack => SmallMutableArray s a -> Int 40 | sizeofSmallMutableArray arr = let len = P.sizeofSmallMutableArray arr in assert (len >= 0) len 41 | {-# INLINE sizeofSmallMutableArray #-} 42 | 43 | indexSmallArray :: DebugCallStack => SmallArray a -> Int -> (# a #) 44 | indexSmallArray arr idx = 45 | -- We have to put the assertions in a pointless strict binding because `assert` can’t accept an 46 | -- unlifted argument. 47 | let !() = assert (idx >= 0) $ assert (idx < sizeofSmallArray arr) () 48 | !(SmallArray arr#) = arr 49 | !(I# idx#) = idx 50 | in indexSmallArray# arr# idx# 51 | {-# INLINE indexSmallArray #-} 52 | 53 | readSmallArray :: (DebugCallStack, PrimMonad m) => SmallMutableArray (PrimState m) a -> Int -> m a 54 | readSmallArray arr idx = 55 | assert (idx >= 0) $ assert (idx < sizeofSmallMutableArray arr) $ P.readSmallArray arr idx 56 | {-# INLINE readSmallArray #-} 57 | 58 | writeSmallArray 59 | :: (DebugCallStack, PrimMonad m) => SmallMutableArray (PrimState m) a -> Int -> a -> m () 60 | writeSmallArray arr idx x = do 61 | assertM $ idx >= 0 62 | assertM $ idx < sizeofSmallMutableArray arr 63 | P.writeSmallArray arr idx x 64 | {-# INLINE writeSmallArray #-} 65 | 66 | copySmallArray 67 | :: (DebugCallStack, PrimMonad m) 68 | => SmallMutableArray (PrimState m) a -> Int -> SmallArray a -> Int -> Int -> m () 69 | copySmallArray dst idx_dst src idx_src len = do 70 | assertM $ len >= 0 71 | assertM $ idx_dst >= 0 72 | assertM $ idx_dst + len <= sizeofSmallMutableArray dst 73 | assertM $ idx_src >= 0 74 | assertM $ idx_src + len <= sizeofSmallArray src 75 | P.copySmallArray dst idx_dst src idx_src len 76 | {-# INLINE copySmallArray #-} 77 | 78 | cloneSmallArray :: DebugCallStack => SmallArray a -> Int -> Int -> SmallArray a 79 | cloneSmallArray src idx len = 80 | assert (len >= 0) $ 81 | assert (idx >= 0) $ 82 | assert (idx + len <= sizeofSmallArray src) $ 83 | P.cloneSmallArray src idx len 84 | {-# INLINE cloneSmallArray #-} 85 | 86 | copySmallMutableArray 87 | :: (DebugCallStack, PrimMonad m) 88 | => SmallMutableArray (PrimState m) a -> Int -> SmallMutableArray (PrimState m) a -> Int -> Int -> m () 89 | copySmallMutableArray dst idx_dst src idx_src len = do 90 | assertM $ len >= 0 91 | assertM $ idx_dst >= 0 92 | assertM $ idx_dst + len <= sizeofSmallMutableArray dst 93 | assertM $ idx_src >= 0 94 | assertM $ idx_src + len <= sizeofSmallMutableArray src 95 | P.copySmallMutableArray dst idx_dst src idx_src len 96 | {-# INLINE copySmallMutableArray #-} 97 | 98 | cloneSmallMutableArray 99 | :: (DebugCallStack, PrimMonad m) 100 | => SmallMutableArray (PrimState m) a -> Int -> Int -> m (SmallMutableArray (PrimState m) a) 101 | cloneSmallMutableArray src idx len = do 102 | assertM $ len >= 0 103 | assertM $ idx >= 0 104 | assertM $ idx + len <= sizeofSmallMutableArray src 105 | P.cloneSmallMutableArray src idx len 106 | {-# INLINE cloneSmallMutableArray #-} 107 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/NonDet.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect.NonDet 2 | ( NonDet(..) 3 | , Alternative(..) 4 | , runNonDetAll 5 | ) where 6 | 7 | import Control.Applicative 8 | import Control.Effect.Base 9 | import Control.Effect.Internal (NonDet(..)) 10 | 11 | -- | Handles a 'NonDet' effect, collecting the results of all branches of the 12 | -- computation. The results are collected __strictly__, which means that /all/ 13 | -- effects are evaluated (even if using an 'Alternative' that ignores subsequent 14 | -- results, such as 'Maybe'). 15 | -- 16 | -- The result is also built using a __left-associated__ sequence of '<|>' calls, 17 | -- which allows the result to be constructed in constant space if an appropriate 18 | -- 'Alternative' instance is used, but can lead to very poor performance for 19 | -- types with inefficient append operations, such as @[]@. Consider using a data 20 | -- structure that supports efficient appends, such as @Data.Sequence.Seq@. 21 | runNonDetAll :: Alternative f => Eff (NonDet ': effs) a -> Eff effs (f a) 22 | runNonDetAll = handle (pure . pure) \case 23 | Empty -> abort empty 24 | Choose -> control \k -> liftA2 (<|>) (k True) (k False) 25 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Reader.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect.Reader 2 | ( Reader(..) 3 | , ask 4 | , local 5 | , runReader 6 | ) where 7 | 8 | import Control.Effect.Base 9 | 10 | -- | The @'Reader' r@ effect provides access to a global environment of type @r@. 11 | -- 12 | -- Handlers should obey the law @/f/ '<$>' 'ask'@ ≡ @'local' /f/ 'ask'@. 13 | data Reader r :: Effect where 14 | Ask :: Reader r m r 15 | Local :: (r1 -> r2) -> Eff (Reader r2 ': effs) a -> Reader r1 (Eff effs) a 16 | 17 | -- | Retrieves a value from the environment. 18 | ask :: Reader r :< effs => Eff effs r 19 | ask = send Ask 20 | 21 | -- | Runs a subcomputation in an environment modified by the given function. 22 | local :: Reader r1 :< effs => (r1 -> r2) -> Eff (Reader r2 ': effs) a -> Eff effs a 23 | local a b = send $ Local a b 24 | 25 | -- | Handles a @'Reader'@ effect by supplying a value for the environment. 26 | runReader :: r -> Eff (Reader r ': effs) a -> Eff effs a 27 | runReader r = handle pure \case 28 | Ask -> liftH $ pure r 29 | Local f m -> locally let !r' = f r in runReader r' m 30 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/State.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect.State 2 | ( State(..) 3 | , get 4 | , put 5 | , modify 6 | ) where 7 | 8 | import Control.Effect.Base 9 | import Control.Effect.Internal (State(..)) 10 | 11 | -- | Retrieves the current value of the state. 12 | get :: State s :< effs => Eff effs s 13 | get = send Get 14 | 15 | -- | Replaces the current state with the given value. 16 | put :: State s :< effs => s -> Eff effs () 17 | put = send . Put 18 | 19 | -- | Modifies the current state by applying the given function to it. 20 | modify :: State s :< effs => (s -> s) -> Eff effs () 21 | modify f = get >>= put . f 22 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/State/Strict.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect.State.Strict 2 | ( module Control.Effect.State 3 | , runState 4 | , evalState 5 | , execState 6 | ) where 7 | 8 | import Control.Effect.Base 9 | import Control.Effect.State 10 | import Control.Effect.Internal (evalState) 11 | import Data.Tuple (swap) 12 | 13 | -- | Handles a @'State'@ effect using a strict cell of mutable state—each use 14 | -- of 'put' or 'modify' eagerly forces the new value. The state is initialized 15 | -- to the given value, and the final state is returned alongside the 16 | -- computation’s result. 17 | runState :: s -> Eff (State s ': effs) a -> Eff effs (s, a) 18 | runState s m = evalState s (curry swap <$> m <*> get) 19 | 20 | execState :: s -> Eff (State s ': effs) a -> Eff effs s 21 | execState s m = evalState s (m *> get) 22 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Writer.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect.Writer 2 | ( Writer(..) 3 | , tell 4 | , listen 5 | , censor 6 | ) where 7 | 8 | import Control.Effect.Base 9 | 10 | -- | The @'Writer' w@ effect allows the accumulation of monoidal values of type 11 | -- @w@. 12 | -- 13 | -- Instances should obey the following laws: 14 | -- 15 | -- * @'tell' /x/ '*>' 'tell' /y/@ ≡ @'tell' (/x/ '<>' /y/)@ 16 | -- * @'listen' ('tell' /x/)@ ≡ @(/x/,) '<$>' 'tell' /x/@ 17 | -- * @'censor' /f/ ('tell' /x/)@ ≡ @'tell' (/f/ /x/)@ 18 | data Writer w :: Effect where 19 | Tell :: w -> Writer w m () 20 | Listen :: Eff (Writer w ': effs) a -> Writer w (Eff effs) (w, a) 21 | Censor :: (w -> w) -> Eff (Writer w ': effs) a -> Writer w (Eff effs) a 22 | 23 | -- | Appends the given value to the current output. 24 | tell :: Writer w :< effs => w -> Eff effs () 25 | tell = send . Tell 26 | 27 | -- | Executes the given action and includes its output in the result. 28 | listen :: Writer w :< effs => Eff (Writer w ': effs) a -> Eff effs (w, a) 29 | listen = send . Listen 30 | 31 | -- | Executes the given action and modifies its output by applying the given 32 | -- function. 33 | censor :: Writer w :< effs => (w -> w) -> Eff (Writer w ': effs) a -> Eff effs a 34 | censor a b = send $ Censor a b 35 | -------------------------------------------------------------------------------- /eff/src/Control/Effect/Writer/Strict.hs: -------------------------------------------------------------------------------- 1 | module Control.Effect.Writer.Strict 2 | ( module Control.Effect.Writer 3 | , runWriter 4 | , evalWriter 5 | , execWriter 6 | ) where 7 | 8 | import Control.Category ((>>>)) 9 | import Control.Effect.Base 10 | import Control.Effect.State.Strict 11 | import Control.Effect.Writer 12 | import Data.Function 13 | 14 | -- | Handles a @'Writer'@ effect, strictly accumulating the monoidal state. 15 | -- 16 | -- Note that the state will be accumulated via __left-associated__ uses of '<>'. 17 | -- This is necessary to be strict, but it can be catastrophically slow on 18 | -- certain monoids, most notably @[]@. To avoid pathological performance, use a 19 | -- data structure that supports efficient appends, such as @Data.Sequence.Seq@, 20 | -- or use 'Data.Semigroup.Dual' to flip the argument order of '<>' (but beware 21 | -- that this will cause the elements to be accumulated in reverse order). 22 | runWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs (w, a) 23 | runWriter (m0 :: Eff (Writer w ': effs) a) = lift m0 24 | & handle pure \case 25 | Tell w -> liftH $ tellS w 26 | Listen m -> locally $ runListen m 27 | Censor f m -> locally $ runCensor f m 28 | & runState mempty 29 | where 30 | tellS :: State w :< effs' => w -> Eff effs' () 31 | tellS w = get >>= \ws -> put $! (ws <> w) 32 | 33 | runListen :: Writer w :< effs' => Eff (Writer w ': effs') b -> Eff effs' (w, b) 34 | runListen = lift 35 | >>> handle pure \case 36 | Tell w -> liftH do 37 | tellS w 38 | lift1 $ tell w 39 | Listen m -> locally $ runListen m 40 | Censor f m -> locally $ runCensor f m 41 | >>> runState mempty 42 | 43 | runCensor :: Writer w :< effs' => (w -> w) -> Eff (Writer w ': effs') b -> Eff effs' b 44 | runCensor f = handle pure \case 45 | Tell w -> liftH $ lift1 (tell $! f w) 46 | Listen m -> locally $ runListen m 47 | Censor g m -> locally $ runCensor g m 48 | 49 | evalWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs a 50 | evalWriter = fmap snd . runWriter 51 | 52 | execWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs w 53 | execWriter = fmap fst . runWriter 54 | -------------------------------------------------------------------------------- /eff/test/Control/Effect/Examples/FileSystemSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoOverloadedStrings #-} 2 | 3 | module Control.Effect.Examples.FileSystemSpec where 4 | 5 | import Prelude hiding (readFile, writeFile) 6 | 7 | import qualified System.IO as IO 8 | 9 | import Control.Effect 10 | import Test.Hspec 11 | 12 | -- ----------------------------------------------------------------------------- 13 | -- effect definition 14 | 15 | data FileSystem :: Effect where 16 | ReadFile :: FilePath -> FileSystem m String 17 | WriteFile :: FilePath -> String -> FileSystem m () 18 | 19 | readFile :: FileSystem :< effs => FilePath -> Eff effs String 20 | readFile = send . ReadFile 21 | 22 | writeFile :: FileSystem :< effs => FilePath -> String -> Eff effs () 23 | writeFile a b = send $ WriteFile a b 24 | 25 | -- ----------------------------------------------------------------------------- 26 | -- IO handler 27 | 28 | runFileSystemIO :: IOE :< effs => Eff (FileSystem ': effs) a -> Eff effs a 29 | runFileSystemIO = interpret \case 30 | ReadFile path -> liftIO $ IO.readFile path 31 | WriteFile path contents -> liftIO $ IO.writeFile path contents 32 | 33 | -- ----------------------------------------------------------------------------- 34 | -- pure handler 35 | 36 | runFileSystemPure :: Error String :< effs => Eff (FileSystem ': effs) a -> Eff effs a 37 | runFileSystemPure = lift 38 | >>> interpret \case 39 | ReadFile path -> do 40 | fileSystem <- get 41 | case lookup path fileSystem of 42 | Just contents -> pure contents 43 | Nothing -> throw ("readFile: no such file " <> path) 44 | WriteFile path contents -> do 45 | fileSystem <- get 46 | -- add the new file and remove an old file with the same name, if it exists 47 | put ((path, contents) : filter ((/= path) . fst) fileSystem) 48 | >>> evalState @[(FilePath, String)] [] 49 | 50 | -- ----------------------------------------------------------------------------- 51 | 52 | copyFile :: FileSystem :< effs => FilePath -> FilePath -> Eff effs () 53 | copyFile inPath outPath = do 54 | contents <- readFile inPath 55 | writeFile outPath contents 56 | 57 | spec :: Spec 58 | spec = describe "runFileSystemPure" do 59 | let runPure = run . runError . runFileSystemPure 60 | 61 | it "raises an error if a file does not exist" do 62 | runPure (copyFile "in.txt" "out.txt") `shouldBe` Left "readFile: no such file in.txt" 63 | 64 | it "copies a file if it exists" do 65 | let go = do 66 | writeFile "in.txt" "Hello, world!" 67 | copyFile "in.txt" "out.txt" 68 | readFile "out.txt" 69 | runPure go `shouldBe` Right "Hello, world!" 70 | -------------------------------------------------------------------------------- /eff/test/Control/EffectSpec.hs: -------------------------------------------------------------------------------- 1 | module Control.EffectSpec (spec) where 2 | 3 | import Control.Applicative 4 | import Control.Monad 5 | import Data.Foldable 6 | import Data.Functor 7 | import Data.Monoid (Sum(..)) 8 | import Test.Hspec 9 | 10 | import Control.Effect 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "local" do 15 | it "locally modifies the context" do 16 | let action :: Reader Integer :< effs => Eff effs (Integer, Integer, Integer, Integer) 17 | action = do 18 | a <- ask @Integer 19 | (b, c, d) <- local @Integer (+ 5) do 20 | b <- ask @Integer 21 | c <- local @Integer (* 3) $ ask @Integer 22 | d <- ask @Integer 23 | pure (b, c, d) 24 | pure (a, b, c, d) 25 | 26 | run (runReader @Integer 10 action) `shouldBe` (10, 15, 45, 15) 27 | 28 | describe "catch" do 29 | it "applies a function to a thrown exception" do 30 | let action :: Error String :< effs => Eff effs String 31 | action = throw @String "bang" `catch` \err -> pure $ "caught: " <> err 32 | run (runError @String action) `shouldBe` Right "caught: bang" 33 | 34 | specify "Error + Reader" do 35 | let action :: (Error String :< effs, Reader Integer :< effs) => Eff effs () 36 | action = do 37 | n <- ask @Integer 38 | unless (n > 0) do 39 | throw $ "value must be positive; given " <> show n 40 | 41 | go :: Integer -> Either String () 42 | go n = run $ runReader n $ runError action 43 | 44 | go 42 `shouldBe` Right () 45 | go (-10) `shouldBe` Left "value must be positive; given -10" 46 | 47 | describe "Error + State" do 48 | it "yields the same state regardless of handler order" do 49 | let action :: (Error () :< effs, State Integer :< effs) => Eff effs () 50 | action = do 51 | modify @Integer (+ 1) 52 | (modify @Integer (+ 1) *> throw ()) `catch` \() -> pure () 53 | modify @Integer (+ 1) 54 | 55 | run (execState @Integer 0 $ runError @() action) `shouldBe` 3 56 | run (runError @() $ execState @Integer 0 action) `shouldBe` Right 3 57 | 58 | describe "NonDet" do 59 | describe "runNonDetAll" do 60 | it "collects the results of all branches" do 61 | let action :: NonDet :< effs => Eff effs (Integer, Integer) 62 | action = do 63 | a <- asum $ map pure [1, 2, 3] 64 | b <- asum $ map pure [4, 5, 6] 65 | pure (a, b) 66 | run (runNonDetAll action) `shouldBe` [(a, b) | a <- [1, 2, 3], b <- [4, 5, 6]] 67 | 68 | specify "choice + catch with exit" do 69 | let results = run $ runError @() $ runNonDetAll do 70 | b <- (pure True <|> throw ()) `catch` \() -> pure False 71 | pure $ not b 72 | results `shouldBe` Right [False, True] 73 | 74 | specify "choice + catch with early exit" do 75 | let results = run $ runError @() $ runNonDetAll do 76 | b <- (throw () <|> pure True) `catch` \() -> pure False 77 | pure $ not b 78 | results `shouldBe` Right [True, False] 79 | 80 | describe "listen over (<|>)" $ do 81 | let go :: (NonDet :< effs, Writer (Sum Integer) :< effs) => Eff effs ((Sum Integer), Bool) 82 | go = listen (add 1 *> (add 2 $> True <|> add 3 $> False)) 83 | where add = tell . Sum @Integer 84 | 85 | context "Writer is handled before Alternative" $ do 86 | it "returns output from each choice" $ do 87 | let results = run $ runNonDetAll $ runWriter @(Sum Integer) go 88 | results `shouldBe` [(Sum 3, (Sum 3, True)), (Sum 4, (Sum 4, False))] 89 | 90 | context "Writer is handled after Alternative" $ do 91 | it "returns output from each choice and sums the result" $ do 92 | let results = run $ runWriter @(Sum Integer) $ runNonDetAll go 93 | results `shouldBe` (Sum 6, [(Sum 3, True), (Sum 4, False)]) 94 | 95 | describe "Coroutine" do 96 | let feed :: forall a b effs c. [b] -> Eff (Coroutine a b ': effs) c -> Eff effs [a] 97 | feed as0 m = go as0 =<< runCoroutine m where 98 | go (a:as) (Yielded b k) = (b:) <$> (feed as (k a)) 99 | go [] (Yielded b _) = pure [b] 100 | go _ (Done _) = pure [] 101 | 102 | it "allows suspending and resuming a computation" do 103 | let squares :: Coroutine Integer Integer :< effs => Integer -> Eff effs () 104 | squares n = yield (n * n) >>= squares 105 | run (feed @Integer @Integer [1..5] (squares 0)) 106 | `shouldBe` [0, 1, 4, 9, 16, 25] 107 | -------------------------------------------------------------------------------- /eff/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /notes/semantics-zoo.md: -------------------------------------------------------------------------------- 1 | # The effect semantics zoo 2 | 3 | Not all effect systems implement the same semantics, particularly when so-called “scoping operators” are involved. This document collects examples that serve as useful “acid tests” for distinguishing a given effect system’s semantics. 4 | 5 | Code examples are given using an `eff`-style API. Unless otherwise noted, these can be mechanically translated to the APIs of other libraries, so only the results are listed. 6 | 7 | ## `State` + `Error` 8 | 9 | This is the classic example of differing behavior under effect reordering. Here is our test program: 10 | 11 | ```haskell 12 | action :: (State Bool :< es, Error () :< es) => Eff es Bool 13 | action = do 14 | (put True *> throw ()) `catch` \() -> pure () 15 | get 16 | 17 | main :: IO () 18 | main = do 19 | print $ run (evalState False $ runError @() action) 20 | print $ run (runError @() $ evalState False action) 21 | ``` 22 | 23 | Here are the results: 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 |
ImplementationError innerState inner
mtlRight TrueRight False
fused-effects
polysemy
effRight True
47 | 48 | ### Discussion 49 | 50 | All implementations agree when the `Error` handler is inside the `State` handler, but `eff` disagrees with the other implementations when the reverse is true. When the `State` handler is innermost, `mtl`-family libraries provide so-called “transactional state semantics”, which results in modifications to the state within the scope of a `catch` being discarded if an exception is raised. 51 | 52 | The transactional semantics is sometimes useful, so this is sometimes provided as an example of why the `mtl`-family semantics is a feature, not a bug. However, it is really just a specific instance of a more general class of interactions that cause `mtl`-family libraries discard state, and other instances are more difficult to justify. For that reason, my perspective is that this behavior constitutes a bug, and `eff` breaks rank accordingly. 53 | 54 | ## `NonDet` + `Error` 55 | 56 | Let’s modify the previous test program to use `NonDet` instead of `State`: 57 | 58 | ```haskell 59 | action1, action2 :: (NonDet :< es, Error () :< es) => Eff es Bool 60 | action1 = (pure True <|> throw ()) `catch` \() -> pure False 61 | action2 = (throw () <|> pure True) `catch` \() -> pure False 62 | 63 | main :: IO () 64 | main = do 65 | print $ run (runNonDetAll @[] $ runError @() action1) 66 | print $ run (runError @() $ runNonDetAll @[] action1) 67 | print $ run (runNonDetAll @[] $ runError @() action2) 68 | print $ run (runError @() $ runNonDetAll @[] action2) 69 | ``` 70 | 71 | And the results: 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 |
Implementationaction1, Error inneraction1, NonDet inneraction2, Error inneraction2, NonDet inner
mtl + list-t[Right True]Left ()[Right True]Right [False]
mtl + pipesRight [True, False]
fused-effects[Right True, Right False]Right [False][Right False, Right True]
polysemy
effRight [True, False]Right [False, True]
111 | 112 | ### Discussion 113 | 114 | The results in this case are much more interesting, as there is significantly more disagreement! Let’s go over the different libraries one by one: 115 | 116 | * In the case of `list-t`, I think its `MonadError` instance is unfortunately just plain broken, as it makes no attempt to install the `catch` handler on branch of execution other than the first. For that reason, I think its behavior can be mostly disregarded. 117 | 118 | * `pipes` does somewhat better, getting at least the “`action1`, `NonDet` inner” case right, but the behavior when the `Error` handler is innermost is frankly mystifying to me. I haven’t investigated what exactly causes that. 119 | 120 | * `fused-effects` and `polysemy` agree on all counts. This is closest to the behavior I would expect from the `mtl`-family libraries, so I consider the `list-t` and `pipes` behavior somewhat anomalous. 121 | 122 | * `eff` agrees with `fused-effects` and `polysemy` in cases where the `Error` handler is innermost, but it disagrees when `NonDet` is innermost. This mirrors its disagreement on the `State` + `Error` test above. 123 | 124 | Such extreme disagreement naturally leads us to ask: who is right? Unfortunately, without any well-defined laws or underlying semantics, there is no definitive answer. Barring that, the best we can do is appeal to our intuitions. 125 | 126 | As the author of `eff`, it is probably unsurprising that I believe `eff`’s behavior is the right one. However, whether you agree or disagree with me, I can at least outline my reasoning: 127 | 128 | * For starters, I think we can immediately throw out `list-t`’s answer on the “`action1`, `NonDet` inner” case. There is absolutely no way to justify any of these results being `Left`, as the only `throw` always appears inside a `catch`. 129 | 130 | * Similarly, I think we can throw out the `list-t` and `pipes` answers for the “`Error` inner” cases. In those cases, the throw exceptions *are* caught, as evidenced by no `Left` results appearing in the output, but there’s no `Right` result, either—the branch of execution seems to “vanish into thin air”, like a ship mysteriously lost in the Bermuda triangle. 131 | 132 | If you accept that argument, the remaining libraries—`fused-effects`, `polysemy`, and `eff`—all agree on those cases, producing the answer I think one would intuitively expect. 133 | 134 | * This leaves only the “`NonDet` inner” cases. `fused-effects` and `polysemy` produce `Right [False]` in both cases, while `eff` produces `Right [True, False]` and `Right [False, True]`, respectively. 135 | 136 | I think the `Right [False]` answer is hard to justify in the case of `action1`, where the exception is only raised in the second branch of execution. What happened to the first branch? It seems as though it’s vanished into the Bermuda triangle, too. 137 | 138 | Interestingly, `pipes` agrees with `eff` in the case of `action1`, but it disagrees in the case of `action2`. I think this actually makes dramatically more sense than the `fused-effects` and `polysemy` behavior: it suggests a `throw` discards all *local* branches up to the nearest enclosing `catch`, mirroring the transactional state semantics described above. 139 | 140 | `eff` is, in contrast, unwaveringly consistent: it always adheres to its continuation-based semantics, so `<|>` always forks the computation up to its handler, which duplicates the `catch` frame regardless of handler order, resulting in consistent results and no discarding of state. 141 | 142 | To summarize, I think there are really only two justifiable semantics here: 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 |
Semanticsaction1, Error inneraction1, NonDet inneraction2, Error inneraction2, NonDet inner
local[Right True, Right False]Right [True, False][Right False, Right True]Right [False]
globalRight [False, True]
168 | 169 | `eff`’s continuation-based semantics is consistent with the “global” row, but *none* of the libraries tested are consistent with the “local” row. I think this makes it difficult to argue that any of them are correct: I consider all libraries but `eff` broken on this example. 170 | 171 | ## `NonDet` + `Writer` 172 | 173 | `catch` is usually the go-to example of a scoping operator, but the `Writer` effect also includes one in the form of `listen`. Here’s a test case that exercises `listen` in combination with `NonDet`: 174 | 175 | ```haskell 176 | action :: (NonDet :< es, Writer (Sum Int) :< es) => Eff es ((Sum Int), Bool) 177 | action = listen (add 1 *> (add 2 $> True <|> add 3 $> False)) 178 | where add = tell . Sum @Int 179 | 180 | main :: IO () 181 | main = do 182 | print $ run (runNonDetAll @[] $ runWriter @(Sum Int) action) 183 | print $ run (runWriter @(Sum Int) $ runNonDetAll @[] action) 184 | ``` 185 | 186 | Here are the results (omitting the wrapping `Sum` constructors in the output for the sake of brevity and clarity): 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 |
ImplementationWriter innerNonDet inner
mtl + list-t[(3, (3, True)), (4, (4, False))]N/A — no MonadWriter instance
mtl + pipes(6, [(3, True), (6, False)])
fused-effects(6, [(6, True), (6, False)])
polysemy
eff(6, [(3, True), (4, False)])
217 | 218 | ### Discussion 219 | 220 | The results of the `NonDet` + `Writer` test are less shocking than they were for `NonDet` + `Error`, but there is still significant disagreement when the `NonDet` handler is innermost. Fortunately, when the `Writer` handler is innermost, there is no disagreement, as in the `State` + `Error` test. 221 | 222 | Let’s start this time by considering `eff`’s semantics. As always, `eff` adheres to a continuation-based model, where `<|>` forks the continuation delimited by the `NonDet` handler. In this case, that duplicates the `listen` frame, which means `listen` distributes over `<|>` once the `<|>` becomes the redex. Working through the reduction using those rules neatly explains both of its results. 223 | 224 | `pipes`, `fused-effects`, and `polysemy` disagree with this semantics. The answer given by `fused-effects` and `polysemy` makes some sense: we can interpret `listen` in the “`NonDet` inner” scenario as being “transactional” in that it observes `tell` output from all computational branches within its scope. It does, however, make the meaning of `NonDet` somewhat less intuitive, as if you interpret `NonDet` as a way of “splitting the world” nondeterministically, `listen` must somehow implicitly span across *all* worlds, despite knowing nothing about `NonDet`. 225 | 226 | The behavior of `pipes` is even more unusual, as `listen` still spans across multiple worlds, but each branch only sees the state accumulated from the current world and previous ones. This means `listen` also observes the *order* in which the worlds are executed, so changing the order in which branches are taken could result in meaningfully different results. 227 | 228 | All three interpretations of `listen` are interesting, and one can imagine situations in which all of them might be useful. However, it’s worth contemplating which behavior is most intuitive to offer *by default*, as well as what the programmer would have to do to obtain a behavior other than the default one. In `eff`, the answer is fairly simple: to allow `listen` to span multiple worlds, its handler must somehow be in cahoots with the `NonDet` handler, and otherwise it should be oblivious to the `NonDet` handler’s presence. In the other systems, it’s less clear how to recover `eff`’s behavior other than to replace `listen` with the local introduction of a separate `runWriter` handler that explicitly relays to the enclosing one. 229 | --------------------------------------------------------------------------------