on master help sign in
55 files changed+2984−811
since splitsnapshots
unifiedsplit
.github/workflows/haskell-ci.yml+30−37 README.md+10−3 cabal.haskell-ci+1−3 doctest.sh+2−2 effectful-core/effectful-core.cabal+20−17 effectful/src/Effectful.hs → effectful-core/src/Effectful.hs+8−4 effectful-core/src/Effectful/Handler.hs → effectful-core/src/Effectful/Dispatch/Dynamic.hs+81−104 effectful-core/src/Effectful/Dispatch/Static.hs+82 effectful-core/src/Effectful/Error.hs+99−30 effectful-core/src/Effectful/Error/Dynamic.hs+1−1 effectful-core/src/Effectful/Fail.hs+11−1 effectful-core/src/Effectful/Internal/Effect.hs+10−12 effectful-core/src/Effectful/Internal/Env.hs+103−84 effectful-core/src/Effectful/Internal/Monad.hs+207−242 effectful-core/src/Effectful/Internal/Unlift.hs+119−14 effectful-core/src/Effectful/Monad.hs+7−4 effectful-core/src/Effectful/Prim.hs+7 effectful-core/src/Effectful/Reader.hs+29−12 effectful-core/src/Effectful/Reader/Dynamic.hs+1−1 effectful-core/src/Effectful/State/Dynamic.hs+5−16 effectful-core/src/Effectful/State/Local.hs+88−24 effectful-core/src/Effectful/State/Shared.hs+63−15 effectful-core/src/Effectful/Writer/Dynamic.hs+7−7 effectful-core/src/Effectful/Writer/Local.hs+56−10 effectful-core/src/Effectful/Writer/Shared.hs+57−10 effectful/bench/Concurrency.hs+8−9 effectful/bench/Main.hs+3−3 effectful/bench/Unlift.hs+14−14 effectful/effectful.cabal+44−25 effectful/examples/FileSystem.hs−1 effectful/src/Effectful/Concurrent.hs+218 effectful/src/Effectful/Async.hs → effectful/src/Effectful/Concurrent/Async.hs+72−89 effectful/src/Effectful/Concurrent/Chan.hs+45 effectful/src/Effectful/Concurrent/Effect.hs+79 effectful/src/Effectful/Concurrent/MVar.hs+108 effectful/src/Effectful/Concurrent/QSem.hs+30 effectful/src/Effectful/Concurrent/QSemN.hs+30 effectful/src/Effectful/Concurrent/STM.hs+146 effectful/src/Effectful/Environment.hs+71 effectful/src/Effectful/FileSystem.hs+347 effectful/src/Effectful/FileSystem/Effect.hs+15 effectful/src/Effectful/FileSystem/IO.hs+143 effectful/src/Effectful/Process.hs+182 effectful/src/Effectful/Resource.hs+31−7 effectful/src/Effectful/Temporary.hs+70 effectful/src/Effectful/Timeout.hs+28 effectful/tests/AsyncTests.hs+6−7 effectful/tests/ConcurrencyTests.hs−1 effectful/tests/EnvironmentTests.hs+48 effectful/tests/ErrorTests.hs−1 effectful/tests/Main.hs+6 effectful/tests/StateTests.hs+1 effectful/tests/TimeoutTests.hs+25 effectful/tests/UnliftTests.hs+93 effectful/tests/Utils.hs+17−1
.github/workflows/haskell-ci.yml+30−37
@@ -8,9 +8,9 @@
88#
99# For more information, see https://github.com/haskell-CI/haskell-ci
1010#
11−# version: 0.13.20210621
11+# version: 0.13.20211116
1212#
13−# REGENDATA ("0.13.20210621",["github","--config=cabal.haskell-ci","cabal.project"])
13+# REGENDATA ("0.13.20211116",["github","--config=cabal.haskell-ci","cabal.project"])
1414#
1515name: Haskell-CI
1616on:
@@ -24,26 +24,23 @@ jobs:
2424 linux:
2525 name: Haskell-CI - Linux - ${{ matrix.compiler }}
2626 runs-on: ubuntu-18.04
27+ timeout-minutes:
28+ 60
2729 container:
2830 image: buildpack-deps:bionic
2931 continue-on-error: ${{ matrix.allow-failure }}
3032 strategy:
3133 matrix:
3234 include:
33− - compiler: ghc-9.2.0.20210422
35+ - compiler: ghc-9.2.1
3436 compilerKind: ghc
35− compilerVersion: 9.2.0.20210422
37+ compilerVersion: 9.2.1
3638 setup-method: ghcup
37− allow-failure: true
38− - compiler: ghc-9.0.1
39− compilerKind: ghc
40− compilerVersion: 9.0.1
41− setup-method: hvr-ppa
4239 allow-failure: false
43− - compiler: ghc-8.10.4
40+ - compiler: ghc-8.10.7
4441 compilerKind: ghc
45− compilerVersion: 8.10.4
46− setup-method: hvr-ppa
42+ compilerVersion: 8.10.7
43+ setup-method: ghcup
4744 allow-failure: false
4845 - compiler: ghc-8.8.4
4946 compilerKind: ghc
@@ -58,14 +55,18 @@ jobs:
5855 apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
5956 if [ "${{ matrix.setup-method }}" = ghcup ]; then
6057 mkdir -p "$HOME/.ghcup/bin"
61− curl -sL https://downloads.haskell.org/ghcup/0.1.14.1/x86_64-linux-ghcup-0.1.14.1 > "$HOME/.ghcup/bin/ghcup"
58+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
6259 chmod a+x "$HOME/.ghcup/bin/ghcup"
6360 "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
64− "$HOME/.ghcup/bin/ghcup" install cabal 3.4.0.0
61+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
6562 else
6663 apt-add-repository -y 'ppa:hvr/ghc'
6764 apt-get update
68− apt-get install -y "$HCNAME" cabal-install-3.4
65+ apt-get install -y "$HCNAME"
66+ mkdir -p "$HOME/.ghcup/bin"
67+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
68+ chmod a+x "$HOME/.ghcup/bin/ghcup"
69+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
6970 fi
7071 env:
7172 HCKIND: ${{ matrix.compilerKind }}
@@ -83,20 +84,20 @@ jobs:
8384 echo "HC=$HC" >> "$GITHUB_ENV"
8485 echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
8586 echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
86− echo "CABAL=$HOME/.ghcup/bin/cabal-3.4.0.0 -vnormal+nowrap" >> "$GITHUB_ENV"
87+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
8788 else
8889 HC=$HCDIR/bin/$HCKIND
8990 echo "HC=$HC" >> "$GITHUB_ENV"
9091 echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
9192 echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
92− echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> "$GITHUB_ENV"
93+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
9394 fi
9495
9596 HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
9697 echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
9798 echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
9899 echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
99− if [ $((HCNUMVER >= 90200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
100+ echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
100101 echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
101102 echo "GHCJSARITH=0" >> "$GITHUB_ENV"
102103 env:
@@ -125,17 +126,10 @@ jobs:
125126 repository hackage.haskell.org
126127 url: http://hackage.haskell.org/
127128 EOF
128− if $HEADHACKAGE; then
129129 cat >> $CABAL_CONFIG <<EOF
130− repository head.hackage.ghc.haskell.org
131− url: https://ghc.gitlab.haskell.org/head.hackage/
132− secure: True
133− root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
134− 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
135− f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
136− key-threshold: 3
130+ program-default-options
131+ ghc-options: $GHCJOBS +RTS -M3G -RTS
137132 EOF
138− fi
139133 cat $CABAL_CONFIG
140134 - name: versions
141135 run: |
@@ -148,7 +142,7 @@ jobs:
148142 - name: cache (tools)
149143 uses: actions/cache@v2
150144 with:
151− key: ${{ runner.os }}-${{ matrix.compiler }}-tools-b692a344
145+ key: ${{ runner.os }}-${{ matrix.compiler }}-tools-16fe7d6d
152146 path: ~/.haskell-ci-tools
153147 - name: install cabal-plan
154148 run: |
@@ -161,8 +155,8 @@ jobs:
161155 cabal-plan --version
162156 - name: install doctest
163157 run: |
164− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.18' ; fi
165− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest --version ; fi
158+ $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
159+ doctest --version
166160 - name: checkout
167161 uses: actions/checkout@v2
168162 with:
@@ -200,9 +194,6 @@ jobs:
200194 package effectful
201195 flags: +benchmark-foreign-libraries
202196 EOF
203− if $HEADHACKAGE; then
204− echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project
205− fi
206197 $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(effectful|effectful-core)$/; }' >> cabal.project.local
207198 cat cabal.project
208199 cat cabal.project.local
@@ -231,10 +222,12 @@ jobs:
231222 $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
232223 - name: doctest
233224 run: |
234− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful} || false ; fi
235− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XStrictData -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi
236− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful_core} || false ; fi
237− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XStrictData -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi
225+ cd ${PKGDIR_effectful} || false
226+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
227+ cd ${PKGDIR_effectful_core} || false
228+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
229+ cd ${PKGDIR_effectful_core} || false
230+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators utils
238231 - name: cabal check
239232 run: |
240233 cd ${PKGDIR_effectful} || false
README.md+10−3
@@ -1,7 +1,10 @@
11# effectful
22
33[![Build Status](https://github.com/arybczak/effectful/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/arybczak/effectful/actions?query=branch%3Amaster)
4−[![Documentation](https://img.shields.io/static/v1?label=docs&message=0.0.0.0&color=informational)](https://rybczak.net/files/effectful/effectful-0.0.0.0-docs)
4+[![Documentation](https://img.shields.io/static/v1?label=docs&message=effectful-core-0.1&color=informational)](https://rybczak.net/files/effectful/effectful-core-0.1-docs)
5+[![Documentation](https://img.shields.io/static/v1?label=docs&message=effectful-0.1&color=informational)](https://rybczak.net/files/effectful/effectful-0.1-docs)
6+
7+<img src="https://user-images.githubusercontent.com/387658/127747903-f728437f-2ee4-47b8-9f0c-5102fd44c8e4.png" width="128">
58
69*Note:* this is a pre-release.
710
@@ -17,8 +20,8 @@ Main features:
1720
18212. Easy to use API (no boilerplate code and dealing with arcane types).
1922
20−3. Correct semantics in presence of runtime exceptions (no more lost or
21− discarded state).
23+3. Correct semantics in presence of runtime exceptions (no more lost state
24+ modifications).
2225
23264. Seamless integration with the existing ecosystem (`exceptions`,
2427 `monad-control`, `unliftio-core`, `resourcet` etc.).
@@ -136,3 +139,7 @@ Blog posts:
136139* [ReaderT design pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/) by Michael Snoyman.
137140
138141* [Exceptions Best Practices](https://www.fpcomplete.com/blog/2016/11/exceptions-best-practices-haskell/) by Michael Snoyman.
142+
143+----------------------------------------
144+
145+<div>Icons made by <a href="https://www.freepik.com" title="Freepik">Freepik</a> from <a href="https://www.flaticon.com/" title="Flaticon">www.flaticon.com</a></div>
cabal.haskell-ci+1−3
@@ -1,11 +1,9 @@
11branches: master
22
3−doctest: <9.2
3+doctest: <9.3
44tests: True
55benchmarks: True
66
7−ghcup-jobs: >=9.2
8−
97raw-project
108 package effectful
119 flags: +benchmark-foreign-libraries
doctest.sh+2−2
@@ -17,6 +17,7 @@ run_doctest() {
1717 -XConstraintKinds \
1818 -XDataKinds \
1919 -XDeriveFunctor \
20+ -XDeriveGeneric \
2021 -XFlexibleContexts \
2122 -XFlexibleInstances \
2223 -XGADTs \
@@ -29,7 +30,6 @@ run_doctest() {
2930 -XRoleAnnotations \
3031 -XScopedTypeVariables \
3132 -XStandaloneDeriving \
32− -XStrictData \
3333 -XTupleSections \
3434 -XTypeApplications \
3535 -XTypeFamilies \
@@ -37,5 +37,5 @@ run_doctest() {
3737 popd
3838}
3939
40−run_doctest effectful src
4140run_doctest effectful-core src
41+run_doctest effectful src
effectful-core/effectful-core.cabal+20−17
@@ -1,7 +1,7 @@
11cabal-version: 2.4
22build-type: Simple
33name: effectful-core
4−version: 0.0.0.0
4+version: 0.1
55license: BSD-3-Clause
66license-file: LICENSE
77category: Control
@@ -12,14 +12,13 @@ synopsis: An easy to use, performant extensible effects library.
1212description: An easy to use, performant extensible effects library with seamless
1313 integration with the existing Haskell ecosystem.
1414 .
15− This library provides the core of the effect system and is quiet
16− minimal. If you look for something more sophisticated have a look
17− at the @<https://hackage.haskell.org/package/effectful effectful>@
18− package.
15+ This library provides core definitions with a minimal dependency
16+ footprint. See the @<https://hackage.haskell.org/package/effectful effectful>@
17+ package for documentation and the "batteries-included" variant.
1918
2019extra-source-files: CHANGELOG.md
2120
22−tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210422
21+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1
2322
2423bug-reports: https://github.com/arybczak/effectful/issues
2524source-repository head
@@ -35,6 +34,7 @@ common language
3534 ConstraintKinds
3635 DataKinds
3736 DeriveFunctor
37+ DeriveGeneric
3838 FlexibleContexts
3939 FlexibleInstances
4040 GADTs
@@ -47,7 +47,6 @@ common language
4747 RoleAnnotations
4848 ScopedTypeVariables
4949 StandaloneDeriving
50− StrictData
5150 TupleSections
5251 TypeApplications
5352 TypeFamilies
@@ -68,26 +67,30 @@ library
6867
6968 ghc-options: -O2
7069
71− build-depends: base >= 4.13 && <5
72− , containers
73− , effectful-internal-utils
74− , exceptions
75− , monad-control
76− , primitive
77− , transformers-base
78− , unliftio-core
70+ build-depends: effectful-internal-utils
71+
72+ build-depends: base >= 4.13 && < 5
73+ , containers >= 0.6
74+ , exceptions >= 0.10.4
75+ , monad-control >= 1.0.3
76+ , primitive >= 0.7.3.0
77+ , transformers-base >= 0.4.6
78+ , unliftio-core >= 0.2.0.1
7979
8080 hs-source-dirs: src
8181
82− exposed-modules: Effectful.Error
82+ exposed-modules: Effectful
83+ Effectful.Dispatch.Dynamic
84+ Effectful.Dispatch.Static
85+ Effectful.Error
8386 Effectful.Error.Dynamic
8487 Effectful.Fail
85− Effectful.Handler
8688 Effectful.Internal.Effect
8789 Effectful.Internal.Env
8890 Effectful.Internal.Monad
8991 Effectful.Internal.Unlift
9092 Effectful.Monad
93+ Effectful.Prim
9194 Effectful.Reader
9295 Effectful.Reader.Dynamic
9396 Effectful.State.Dynamic
effectful/src/Effectful.hs → effectful-core/src/Effectful.hsrenamed+8−4
@@ -8,10 +8,10 @@ module Effectful
88
99 -- * Running the 'Eff' monad
1010
11− -- ** Pure operations
11+ -- ** Pure computations
1212 , runPureEff
1313
14− -- ** Operations with side effects
14+ -- ** Computations with side effects
1515 , IOE
1616 , runEff
1717
@@ -32,7 +32,7 @@ module Effectful
3232 , interpret
3333 , reinterpret
3434
35− -- ** Handling local 'Eff' operations
35+ -- ** Handling local 'Eff' computations
3636 , LocalEnv
3737
3838 -- *** Unlifts
@@ -48,7 +48,11 @@ module Effectful
4848 -- *** Bidirectional lifts
4949 , localLiftUnlift
5050 , localLiftUnliftIO
51+
52+ -- * Re-exports
53+ , MonadIO(..)
54+ , MonadUnliftIO(..)
5155 ) where
5256
53−import Effectful.Handler
57+import Effectful.Dispatch.Dynamic
5458import Effectful.Monad
effectful-core/src/Effectful/Handler.hs → effectful-core/src/Effectful/Dispatch/Dynamic.hsrenamed+81−104
@@ -1,12 +1,13 @@
1−module Effectful.Handler
1+module Effectful.Dispatch.Dynamic
22 ( -- * Sending operations to the handler
33 send
44
55 -- * Handling effects
6+ , EffectHandler
67 , interpret
78 , reinterpret
89
9− -- ** Handling local 'Eff' operations
10+ -- ** Handling local 'Eff' computations
1011 , LocalEnv
1112
1213 -- *** Unlifts
@@ -23,89 +24,46 @@ module Effectful.Handler
2324 , localLiftUnlift
2425 , localLiftUnliftIO
2526
27+ -- *** Utils
28+ , SuffixOf
29+
2630 -- * Re-exports
2731 , HasCallStack
2832 ) where
2933
3034import Control.Monad.IO.Unlift
31−import GHC.Stack
32−import qualified Control.Exception as E
35+import Data.Kind
36+import GHC.Stack (HasCallStack)
3337
3438import Effectful.Internal.Effect
3539import Effectful.Internal.Env
3640import Effectful.Internal.Monad
3741
3842----------------------------------------
39−-- Handler
40−
41−-- | Opaque representation of the 'Eff' environment at the point of calling the
42−-- 'send' function, i.e. right before the control is passed to the effect
43−-- handler.
44−newtype LocalEnv es = LocalEnv (Env es)
45−
46−data Handler (e :: Effect) = forall handlerEs. Handler
47− { _env :: Env handlerEs
48− , _handle :: forall a localEs. HasCallStack
49− => LocalEnv localEs
50− -> e (Eff localEs) a
51− -> Eff handlerEs a
52− }
53−
54−runHandler :: Env es -> Handler e -> Eff (e : es) a -> IO a
55−runHandler es0 e m = do
56− size0 <- sizeEnv es0
57− E.bracket (unsafeConsEnv e relinker es0)
58− (unsafeTailEnv size0)
59− (\es -> unEff m es)
60− where
61− relinker :: Relinker Handler e
62− relinker = Relinker $ \relink Handler{..} -> do
63− env <- relink _env
64− pure Handler { _env = env, .. }
65−
66−----------------------------------------
67−-- Sending operations
68−
69−-- | Send an operation of a given effect to its handler for execution.
70−send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
71−send op = unsafeEff $ \es -> do
72− Handler{..} <- getEnv es
73− unEff (_handle (LocalEnv es) op) _env
74−
75−----------------------------------------
76−-- Interpretation
43+-- Handling effects
7744
7845-- | Interpret an effect.
79−--
80−-- /Note:/ 'LocalEnv' is for handling local 'Eff' operations using a function
81−-- from the 'localUnlift' family.
8246interpret
83− :: (forall r localEs. HasCallStack => LocalEnv localEs -> e (Eff localEs) r -> Eff es r)
47+ :: EffectHandler e es
8448 -- ^ The effect handler.
8549 -> Eff (e : es) a
8650 -> Eff es a
8751interpret handler m = unsafeEff $ \es -> do
8852 les <- forkEnv es
89− runHandler es (Handler les handler) m
90−
91−----------------------------------------
92−-- Reinterpretation
53+ (`unEff` es) $ runHandler (HandlerA les handler) m
9354
9455-- | Interpret an effect using other effects.
95−--
96−-- /Note:/ 'LocalEnv' is for handling local 'Eff' operations using a function
97−-- from the 'localUnlift' family.
9856reinterpret
9957 :: (Eff handlerEs a -> Eff es b)
10058 -- ^ Introduction of effects encapsulated within the handler.
101− -> (forall r localEs. HasCallStack => LocalEnv localEs -> e (Eff localEs) r -> Eff handlerEs r)
59+ -> EffectHandler e handlerEs
10260 -- ^ The effect handler.
10361 -> Eff (e : es) a
10462 -> Eff es b
10563reinterpret runHandlerEs handler m = unsafeEff $ \es -> do
10664 les0 <- forkEnv es
10765 (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do
108− runHandler es (Handler les handler) m
66+ (`unEff` es) $ runHandler (HandlerA les handler) m
10967
11068----------------------------------------
11169-- Unlifts
@@ -113,31 +71,31 @@ reinterpret runHandlerEs handler m = unsafeEff $ \es -> do
11371-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
11472-- general version see 'localUnlift'.
11573localSeqUnlift
116− :: HasCallStack
117− => LocalEnv localEs
74+ :: (HasCallStack, SuffixOf es handlerEs)
75+ => LocalEnv localEs handlerEs
11876 -- ^ Local environment.
11977 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
12078 -- ^ Continuation with the unlifting function in scope.
12179 -> Eff es a
12280localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do
123− unsafeSeqUnliftEff les $ \unlift -> do
81+ seqUnliftIO les $ \unlift -> do
12482 (`unEff` es) $ k $ unsafeEff_ . unlift
12583
12684-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
12785-- general version see 'localUnliftIO'.
12886localSeqUnliftIO
129− :: (HasCallStack, IOE :> es)
130− => LocalEnv localEs
87+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
88+ => LocalEnv localEs handlerEs
13189 -- ^ Local environment.
13290 -> ((forall r. Eff localEs r -> IO r) -> IO a)
13391 -- ^ Continuation with the unlifting function in scope.
13492 -> Eff es a
135−localSeqUnliftIO (LocalEnv les) k = liftIO $ unsafeSeqUnliftEff les k
93+localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k
13694
13795-- | Create a local unlifting function with the given strategy.
13896localUnlift
139− :: HasCallStack
140− => LocalEnv localEs
97+ :: (HasCallStack, SuffixOf es handlerEs)
98+ => LocalEnv localEs handlerEs
14199 -- ^ Local environment.
142100 -> UnliftStrategy
143101 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
@@ -145,58 +103,62 @@ localUnlift
145103 -> Eff es a
146104localUnlift (LocalEnv les) strategy k = case strategy of
147105 SeqUnlift -> unsafeEff $ \es -> do
148− unsafeSeqUnliftEff les $ \unlift -> do
106+ seqUnliftIO les $ \unlift -> do
149107 (`unEff` es) $ k $ unsafeEff_ . unlift
150108 ConcUnlift p l -> unsafeEff $ \es -> do
151− unsafeConcUnliftEff les p l $ \unlift -> do
109+ concUnliftIO les p l $ \unlift -> do
152110 (`unEff` es) $ k $ unsafeEff_ . unlift
153111
154112-- | Create a local unlifting function with the given strategy.
155113localUnliftIO
156− :: (HasCallStack, IOE :> es)
157− => LocalEnv localEs
114+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
115+ => LocalEnv localEs handlerEs
158116 -- ^ Local environment.
159117 -> UnliftStrategy
160118 -> ((forall r. Eff localEs r -> IO r) -> IO a)
161119 -- ^ Continuation with the unlifting function in scope.
162120 -> Eff es a
163121localUnliftIO (LocalEnv les) strategy k = case strategy of
164− SeqUnlift -> liftIO $ unsafeSeqUnliftEff les k
165− ConcUnlift p l -> liftIO $ unsafeConcUnliftEff les p l k
122+ SeqUnlift -> liftIO $ seqUnliftIO les k
123+ ConcUnlift p l -> liftIO $ concUnliftIO les p l k
166124
167−-- | Utility for lifting 'Eff' operations of type
125+-- | Utility for lifting 'Eff' computations of type
168126--
169127-- @'Eff' es a -> 'Eff' es b@
170128--
171129-- to
172130--
173−-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@
131+-- @'Eff' localEs a -> 'Eff' localEs b@
174132--
175−-- /Note:/ the operation must not run its argument in a separate thread,
133+-- /Note:/ the computation must not run its argument in a separate thread,
176134-- attempting to do so will result in a runtime error.
177135withLiftMap
178− :: (HasCallStack, IOE :> es)
179− => ((forall a b localEs. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
136+ :: (HasCallStack, SuffixOf es handlerEs)
137+ => LocalEnv localEs handlerEs
138+ -- ^ Local environment.
139+ -> ((forall a b. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
180140 -- ^ Continuation with the lifting function in scope.
181141 -> Eff es r
182−withLiftMap k = unsafeEff $ \es -> do
142+withLiftMap !_ k = unsafeEff $ \es -> do
143+ -- The LocalEnv parameter is not used, but we need it to constraint the
144+ -- localEs type variable. It's also strict so that callers don't cheat.
183145 (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do
184− unsafeSeqUnliftEff localEs $ \unlift -> do
185− (`unEff` es) . mapEff . liftIO $ unlift m
146+ seqUnliftIO localEs $ \unlift -> do
147+ (`unEff` es) . mapEff . unsafeEff_ $ unlift m
186148
187−-- | Utility for lifting 'IO' operations of type
149+-- | Utility for lifting 'IO' computations of type
188150--
189151-- @'IO' a -> 'IO' b@
190152--
191153-- to
192154--
193−-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@
155+-- @'Eff' localEs a -> 'Eff' localEs b@
194156--
195−-- /Note:/ the operation must not run its argument in a separate thread,
157+-- /Note:/ the computation must not run its argument in a separate thread,
196158-- attempting to do so will result in a runtime error.
197159--
198160-- Useful e.g. for lifting the unmasking function in
199−-- 'Control.Exception.mask'-like operations:
161+-- 'Control.Exception.mask'-like computations:
200162--
201163-- >>> :{
202164-- data Fork :: Effect where
@@ -205,31 +167,35 @@ withLiftMap k = unsafeEff $ \es -> do
205167--
206168-- >>> :{
207169-- runFork :: IOE :> es => Eff (Fork : es) a -> Eff es a
208−-- runFork = interpret $ \env (ForkWithUnmask m) -> withLiftMapIO $ \liftMap -> do
170+-- runFork = interpret $ \env (ForkWithUnmask m) -> withLiftMapIO env $ \liftMap -> do
209171-- localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
210172-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
211173-- :}
212174withLiftMapIO
213− :: (HasCallStack, IOE :> es)
214− => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
175+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
176+ => LocalEnv localEs handlerEs
177+ -- ^ Local environment.
178+ -> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
215179 -- ^ Continuation with the lifting function in scope.
216180 -> Eff es r
217−withLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
218− unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
181+withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do
182+ -- The LocalEnv parameter is not used, but we need it to constraint the
183+ -- localEs type variable. It's also strict so that callers don't cheat.
184+ seqUnliftIO es $ \unlift -> mapIO $ unlift m
219185
220186----------------------------------------
221187-- Bidirectional lifts
222188
223189-- | Create a local lifting and unlifting function with the given strategy.
224190--
225−-- Useful for lifting complicated 'Eff' operations where the monadic action
191+-- Useful for lifting complicated 'Eff' computations where the monadic action
226192-- shows in both positive (as a result) and negative (as an argument) position.
227193--
228−-- /Note:/ depending on the operation you're lifting 'localUnlift' along with
194+-- /Note:/ depending on the computation you're lifting 'localUnlift' along with
229195-- 'withLiftMap' might be enough and is more efficient.
230196localLiftUnlift
231− :: (HasCallStack, IOE :> es)
232− => LocalEnv localEs
197+ :: (HasCallStack, SuffixOf es handlerEs)
198+ => LocalEnv localEs handlerEs
233199 -- ^ Local environment.
234200 -> UnliftStrategy
235201 -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a)
@@ -237,33 +203,44 @@ localLiftUnlift
237203 -> Eff es a
238204localLiftUnlift (LocalEnv les) strategy k = case strategy of
239205 SeqUnlift -> unsafeEff $ \es -> do
240− unsafeSeqUnliftEff es $ \unliftEs -> do
241− unsafeSeqUnliftEff les $ \unliftLocalEs -> do
242− (`unEff` es) $ k (unsafeEff_ . unliftEs) (liftIO . unliftLocalEs)
206+ seqUnliftIO es $ \unliftEs -> do
207+ seqUnliftIO les $ \unliftLocalEs -> do
208+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)
243209 ConcUnlift p l -> unsafeEff $ \es -> do
244− unsafeConcUnliftEff es p l $ \unliftEs -> do
245− unsafeConcUnliftEff les p l $ \unliftLocalEs -> do
246− (`unEff` es) $ k (unsafeEff_ . unliftEs) (liftIO . unliftLocalEs)
210+ concUnliftIO es p l $ \unliftEs -> do
211+ concUnliftIO les p l $ \unliftLocalEs -> do
212+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)
247213
248214-- | Create a local unlifting function with the given strategy along with an
249215-- unrestricted lifting function.
250216--
251−-- Useful for lifting complicated 'IO' operations where the monadic action shows
252−-- in both positive (as a result) and negative (as an argument) position.
217+-- Useful for lifting complicated 'IO' computations where the monadic action
218+-- shows in both positive (as a result) and negative (as an argument) position.
253219--
254−-- /Note:/ depending on the operation you're lifting 'localUnliftIO' along with
255−-- 'withLiftMapIO' might be enough and is more efficient.
220+-- /Note:/ depending on the computation you're lifting 'localUnliftIO' along
221+-- with 'withLiftMapIO' might be enough and is more efficient.
256222localLiftUnliftIO
257− :: (HasCallStack, IOE :> es)
258− => LocalEnv localEs
223+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
224+ => LocalEnv localEs handlerEs
259225 -- ^ Local environment.
260226 -> UnliftStrategy
261227 -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a)
262228 -- ^ Continuation with the lifting and unlifting function in scope.
263229 -> Eff es a
264230localLiftUnliftIO (LocalEnv les) strategy k = case strategy of
265− SeqUnlift -> liftIO $ unsafeSeqUnliftEff les $ k unsafeEff_
266− ConcUnlift p l -> liftIO $ unsafeConcUnliftEff les p l $ k unsafeEff_
231+ SeqUnlift -> liftIO $ seqUnliftIO les $ k unsafeEff_
232+ ConcUnlift p l -> liftIO $ concUnliftIO les p l $ k unsafeEff_
233+
234+----------------------------------------
235+-- Utils
236+
237+-- | Require that the second list of effects is a suffix of the first one.
238+--
239+-- In other words, 'SuffixOf' @es@ @baseEs@ means "a suffix of @es@ is
240+-- @baseEs@".
241+type family SuffixOf (es :: [Effect]) (baseEs :: [Effect]) :: Constraint where
242+ SuffixOf baseEs baseEs = ()
243+ SuffixOf (e : es) baseEs = SuffixOf es baseEs
267244
268245-- $setup
269246-- >>> import Control.Concurrent
effectful-core/src/Effectful/Dispatch/Static.hsnew file+82
@@ -0,0 +1,82 @@
1+module Effectful.Dispatch.Static
2+ ( -- * Low level API
3+ DataA(..)
4+
5+ -- ** Extending the environment
6+ , runData
7+ , evalData
8+ , execData
9+
10+ -- ** Data retrieval and update
11+ , getData
12+ , putData
13+ , stateData
14+ , stateDataM
15+ , localData
16+
17+ -- ** Unlifts
18+ , seqUnliftIO
19+ , concUnliftIO
20+
21+ -- ** Utils
22+ , unEff
23+ , unsafeEff
24+ , unsafeEff_
25+ , unsafeLiftMapIO
26+ , unsafeUnliftIO
27+
28+ -- * Primitive API
29+ , Env
30+ , Relinker(..)
31+ , noRelinker
32+
33+ -- ** Operations
34+ , emptyEnv
35+ , cloneEnv
36+ , forkEnv
37+ , sizeEnv
38+ , checkSizeEnv
39+
40+ -- ** Extending and shrinking
41+ , unsafeConsEnv
42+ , unsafeTailEnv
43+
44+ -- ** Data retrieval and update
45+ , getEnv
46+ , putEnv
47+ , stateEnv
48+ , modifyEnv
49+ ) where
50+
51+import Effectful.Internal.Env
52+import Effectful.Internal.Monad
53+
54+-- | Utility for lifting 'IO' computations of type
55+--
56+-- @'IO' a -> 'IO' b@
57+--
58+-- to
59+--
60+-- @'Eff' es a -> 'Eff' es b@
61+--
62+-- This function is __unsafe__ because:
63+--
64+-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'
65+-- computations.
66+--
67+-- - The 'IO' computation must not run its argument in a separate thread, but
68+-- it's not checked anywhere.
69+unsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b
70+unsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)
71+
72+-- | Utility for running 'Eff' computations locally in the 'IO' monad.
73+--
74+-- This function is __unsafe__ because:
75+--
76+-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'
77+-- computations.
78+--
79+-- - Unlifted 'Eff' computations must not be run in a thread distinct from the
80+-- caller of 'unsafeUnliftIO', but it's not checked anywhere.
81+unsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
82+unsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es)
effectful-core/src/Effectful/Error.hs+99−30
@@ -1,29 +1,78 @@
1−{- | Support for checked exceptions.
2−
3−The 'Error' effect provided by this module is a suitable replacement for the
4−'Control.Monad.Except.ExceptT' monad transformer found in the @mtl@ library. It
5−is __not__ intended to be a general mechanism for catching errors, that's what
6−functions from the "Control.Monad.Catch" module are for.
7−
8−For example, if you want to catch an unchecked exception like
9−'Control.Exception.SomeException' or 'Control.Exception.ErrorCall' you could use
10−'Control.Monad.Catch.catch':
11−
12−>>> import qualified Control.Monad.Catch as E
13−>>> :{
14− let boom :: Eff es String
15− boom = error "BOOM!"
16− in
17− runEff $ boom `E.catch` \(e :: ErrorCall) -> pure "caught some error"
18−:}
19−"caught some error"
20−
21−-}
1+-- | Support for handling errors of a particular type, i.e. checked exceptions.
2+--
3+-- The 'Error' effect is __not__ a general mechanism for handling regular
4+-- exceptions, that's what functions from the @exceptions@ library are for (see
5+-- "Control.Monad.Catch" for more information).
6+--
7+-- In particular, regular exceptions of type @e@ are distinct from errors of
8+-- type @e@ and will __not__ be caught by functions from this module:
9+--
10+-- >>> import qualified Control.Monad.Catch as E
11+-- >>> let boom = error "BOOM!"
12+-- >>> runEff . runError @ErrorCall $ boom `catchError` \_ (_::ErrorCall) -> pure "caught"
13+-- *** Exception: BOOM!
14+-- ...
15+--
16+-- If you want to catch regular exceptions, you should use
17+-- 'Control.Monad.Catch.catch' (or a similar function):
18+--
19+-- >>> runEff $ boom `E.catch` \(_::ErrorCall) -> pure "caught"
20+-- "caught"
21+--
22+-- On the other hand, functions for safe finalization and management of
23+-- resources such as 'Control.Monad.Catch.finally' and
24+-- 'Control.Monad.Catch.bracket' work as expected:
25+--
26+-- >>> let msg = liftIO . putStrLn
27+-- >>> :{
28+-- runEff . fmap (either (Left . snd) Right) . runError @String $ do
29+-- E.bracket_ (msg "Beginning.")
30+-- (msg "Cleaning up.")
31+-- (msg "Computing." >> throwError "oops" >> msg "More.")
32+-- :}
33+-- Beginning.
34+-- Computing.
35+-- Cleaning up.
36+-- Left "oops"
37+--
38+-- /Note:/ unlike the 'Control.Monad.Trans.Except.ExceptT' monad transformer
39+-- from the @transformers@ library, the order in which you handle the 'Error'
40+-- effect with regard to other stateful effects does not matter. Consider the
41+-- following:
42+--
43+-- >>> import qualified Control.Monad.State.Strict as T
44+-- >>> import qualified Control.Monad.Except as T
45+--
46+-- >>> let m1 = (T.modify (++ " there!") >> T.throwError "oops") `T.catchError` \_ -> pure ()
47+--
48+-- >>> (`T.runStateT` "Hi") . T.runExceptT $ m1
49+-- (Right (),"Hi there!")
50+--
51+-- >>> T.runExceptT . (`T.runStateT` "Hi") $ m1
52+-- Right ((),"Hi")
53+--
54+-- Here, whether state modifications within the @catchError@ block are lost or
55+-- not depends on the shape of the monad transformer stack, which is surprising
56+-- and can be a source of subtle bugs. On the other hand:
57+--
58+-- >>> import Effectful.State.Local
59+--
60+-- >>> let m2 = (modify (++ " there!") >> throwError "oops") `catchError` \_ (_::String) -> pure ()
61+--
62+-- >>> runEff . runState "Hi" . runError @String $ m2
63+-- (Right (),"Hi there!")
64+--
65+-- >>> runEff . runError @String . runState "Hi" $ m2
66+-- Right ((),"Hi there!")
67+--
68+-- Here, no matter the order of effects, state modifications within the
69+-- @catchError@ block always persist, giving predictable behavior.
2270module Effectful.Error
2371 ( Error
2472 , runError
2573 , throwError
2674 , catchError
75+ , handleError
2776 , tryError
2877
2978 -- * Re-exports
@@ -38,13 +87,14 @@ import Data.Typeable
3887import Data.Unique
3988import GHC.Stack
4089
41−import Effectful.Internal.Effect
42−import Effectful.Internal.Env
43−import Effectful.Internal.Monad
90+import Effectful.Dispatch.Static
91+import Effectful.Monad
4492
45−data Error e :: Effect where
93+-- | Provide the ability to handle errors of type @e@.
94+newtype Error e :: Effect where
4695 Error :: ErrorId -> Error e m r
4796
97+-- | Handle errors of type @e@.
4898runError
4999 :: forall e es a. Typeable e
50100 => Eff (Error e : es) a
@@ -52,9 +102,9 @@ runError
52102runError m = unsafeEff $ \es0 -> mask $ \release -> do
53103 eid <- newErrorId
54104 size0 <- sizeEnv es0
55− es <- unsafeConsEnv (IdE (Error @e eid)) noRelinker es0
105+ es <- unsafeConsEnv (DataA (Error @e eid)) noRelinker es0
56106 r <- tryErrorIO release eid es `onException` unsafeTailEnv size0 es
57− _ <- unsafeTailEnv size0 es
107+ unsafeTailEnv size0 es
58108 pure r
59109 where
60110 tryErrorIO release eid es = try (release $ unEff m es) >>= \case
@@ -62,29 +112,48 @@ runError m = unsafeEff $ \es0 -> mask $ \release -> do
62112 Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))
63113 $ throwIO ex
64114
115+-- | Throw an error of type @e@.
65116throwError
66117 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
67118 => e
119+ -- ^ The error.
68120 -> Eff es a
69121throwError e = unsafeEff $ \es -> do
70− IdE (Error eid) <- getEnv @(Error e) es
122+ DataA (Error eid) <- getEnv @(Error e) es
71123 throwIO $ ErrorEx eid callStack e
72124
125+-- | Handle an error of type @e@.
73126catchError
74127 :: forall e es a. (Typeable e, Error e :> es)
75128 => Eff es a
129+ -- ^ The inner computation.
76130 -> (CallStack -> e -> Eff es a)
131+ -- ^ A handler for errors in the inner computation.
77132 -> Eff es a
78133catchError m handler = unsafeEff $ \es -> do
79− IdE (Error eid) <- getEnv @(Error e) es
134+ DataA (Error eid) <- getEnv @(Error e) es
80135 size <- sizeEnv es
81136 catchErrorIO eid (unEff m es) $ \cs e -> do
82137 checkSizeEnv size es
83138 unEff (handler cs e) es
84139
140+-- | The same as @'flip' 'catchError'@, which is useful in situations where the
141+-- code for the handler is shorter.
142+handleError
143+ :: forall e es a. (Typeable e, Error e :> es)
144+ => (CallStack -> e -> Eff es a)
145+ -- ^ A handler for errors in the inner computation.
146+ -> Eff es a
147+ -- ^ The inner computation.
148+ -> Eff es a
149+handleError = flip catchError
150+
151+-- | Similar to 'catchError', but returns an 'Either' result which is a 'Right'
152+-- if no error was thrown and a 'Left' otherwise.
85153tryError
86154 :: forall e es a. (Typeable e, Error e :> es)
87155 => Eff es a
156+ -- ^ The inner computation.
88157 -> Eff es (Either (CallStack, e) a)
89158tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
90159
@@ -112,7 +181,7 @@ tryHandler ex eid0 handler next = case fromException ex of
112181 | otherwise -> next
113182 Nothing -> next
114183
115−data ErrorEx e = ErrorEx ErrorId CallStack e
184+data ErrorEx e = ErrorEx !ErrorId CallStack e
116185instance Typeable e => Show (ErrorEx e) where
117186 showsPrec p (ErrorEx _ cs e)
118187 = ("Effectful.Error.ErrorEx (" ++)
effectful-core/src/Effectful/Error/Dynamic.hs+1−1
@@ -8,7 +8,7 @@ module Effectful.Error.Dynamic
88
99import Data.Typeable
1010
11−import Effectful.Handler
11+import Effectful.Dispatch.Dynamic
1212import Effectful.Monad
1313import qualified Effectful.Error as E
1414
effectful-core/src/Effectful/Fail.hs+11−1
@@ -1,6 +1,16 @@
1+-- | Provider of the 'MonadFail' instance for 'Eff'.
12module Effectful.Fail
2− ( Fail
3+ ( Fail(..)
34 , runFail
45 ) where
56
7+import Effectful.Dispatch.Dynamic
8+import Effectful.Error
69import Effectful.Internal.Monad
10+
11+-- | Run the 'Fail' effect via 'Error'.
12+runFail :: Eff (Fail : es) a -> Eff es (Either String a)
13+runFail = reinterpret eff $ \_ -> \case
14+ Fail msg -> throwError msg
15+ where
16+ eff = fmap (either (Left . snd) Right) . runError
effectful-core/src/Effectful/Internal/Effect.hs+10−12
@@ -8,7 +8,9 @@
88module Effectful.Internal.Effect
99 ( Effect
1010 , (:>)(..)
11− , IdE(..)
11+
12+ -- * Re-exports
13+ , Type
1214 ) where
1315
1416import Data.Kind
@@ -17,20 +19,16 @@ import GHC.TypeLits
1719-- | The kind of effects.
1820type Effect = (Type -> Type) -> Type -> Type
1921
20−-- | Adapter for statically dispatched effects.
21−newtype IdE :: Effect -> Type where
22− IdE :: (forall m r. e m r) -> IdE e
23−
24−-- | A constraint that requires that a particular effect, @e@, is a member of
25−-- the type-level list @es@. This is used to parameterize an
26−-- 'Effectful.Monad.Eff' operation over an arbitrary list of effects, so long as
27−-- @e@ is /somewhere/ in the list.
22+-- | A constraint that requires that a particular effect @e@ is a member of the
23+-- type-level list @es@. This is used to parameterize an 'Effectful.Monad.Eff'
24+-- computation over an arbitrary list of effects, so long as @e@ is /somewhere/
25+-- in the list.
2826--
29−-- For example, an operation that only needs access to a cell of mutable state
30−-- containing an 'Integer' would likely use the following type:
27+-- For example, a computation that only needs access to a mutable value of type
28+-- 'Integer' would likely use the following type:
3129--
3230-- @
33−-- 'Effectful.State.State' 'Integer' ':>' es => 'Effectful.Monad.Eff' es ()
31+-- 'Effectful.State.Local.State' 'Integer' ':>' es => 'Effectful.Monad.Eff' es ()
3432-- @
3533class (e :: Effect) :> (es :: [Effect]) where
3634 -- | Get the position of @e@ in @es@.
effectful-core/src/Effectful/Internal/Env.hs+103−84
@@ -1,26 +1,38 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE MagicHash #-}
22{-# OPTIONS_HADDOCK not-home #-}
33-- | The environment for the 'Effectful.Internal.Monad.Eff' monad.
44--
55-- This module is intended for internal use only, and may change without warning
66-- in subsequent releases.
77module Effectful.Internal.Env
8− ( Env
8+ ( -- * The environment
9+ Env(..)
10+ , Forks(..)
11+ , EnvRef(..)
12+
13+ -- ** ForkId
14+ , ForkId(..)
15+ , ForkIdGen(..)
16+ , newForkIdGen
17+ , cloneForkIdGen
18+ , newForkId
19+
20+ -- ** Relinker
921 , Relinker(..)
1022 , noRelinker
1123
12− -- * Operations
24+ -- * Operations
1325 , emptyEnv
1426 , cloneEnv
1527 , forkEnv
1628 , sizeEnv
1729 , checkSizeEnv
1830
19− -- ** Extending and shrinking
31+ -- ** Extending and shrinking
2032 , unsafeConsEnv
2133 , unsafeTailEnv
2234
23− -- ** Data retrieval and update
35+ -- ** Data retrieval and update
2436 , getEnv
2537 , putEnv
2638 , stateEnv
@@ -30,9 +42,8 @@ module Effectful.Internal.Env
3042import Control.Monad
3143import Control.Monad.Primitive
3244import Data.IORef
33−import Data.Kind
3445import Data.Primitive.SmallArray
35−import GHC.Exts (Any)
46+import GHC.Exts (Any, SmallMutableArray#)
3647import GHC.Stack (HasCallStack)
3748import Unsafe.Coerce
3849import qualified Data.IntMap.Strict as IM
@@ -70,17 +81,17 @@ type role Env nominal
7081-- @
7182--
7283-- The point of execution is currently at (*), i.e. the mainline. Moreover,
73−-- currently:
84+-- currently (brackets represent forks):
7485--
7586-- - Mainline sees @[e00, e01, e05, e07]@.
7687--
77−-- - @e01@ is an interpreted effect, its handler sees @[e00, e02, e03]@.
88+-- - @e01@ is an interpreted effect, its handler sees @[e00][e02, e03]@.
7889--
79−-- - @e03@ is an interpreted effect, its handler sees @[e00, e02, e04]@.
90+-- - @e03@ is an interpreted effect, its handler sees @[e00][e02][e04]@.
8091--
81−-- - @e05@ is an interpreted effect, its handler sees @[e00, e01, e06]@.
92+-- - @e05@ is an interpreted effect, its handler sees @[e00, e01][e06]@.
8293--
83−-- - @e07@ is an interpreted effect, its handler sees @[e00, e01, e05, e08,
94+-- - @e07@ is an interpreted effect, its handler sees @[e00, e01, e05][e08,
8495-- e09]@.
8596--
8697-- If an operation from @e01@ is invoked, the environment in the middle of
@@ -103,30 +114,32 @@ type role Env nominal
103114-- introduced @e12@), so its local environment was temporarily extended with
104115-- it. Moreover, currently:
105116--
106−-- - Handler of @e01@ sees @[e00, e02, e03, e10]@.
117+-- - Handler of @e01@ sees @[e00][e02, e03, e10]@.
107118--
108−-- - Handler of @e10@ sees @[e00, e02, e03, e11]@.
119+-- - Handler of @e10@ sees @[e00][e02, e03][e11]@.
109120--
110−-- - Handler of @e11@ sees @[e00, e02, e03, e12]@.
121+-- - Handler of @e11@ sees @[e00][e02, e03][e12]@.
111122--
112123data Env (es :: [Effect]) = Env
113− { _forks :: Forks
114− , _globalRef :: IORef EnvRef
115− , _forkIdGen :: ForkIdGen
124+ { _forks :: !Forks
125+ , _globalRef :: !(IORef EnvRef)
126+ , _forkIdGen :: !ForkIdGen
116127 }
117128
118129-- | Local forks of the environment.
119−data Forks = Forks ForkId Int (IORef EnvRef) Forks | NoFork
130+data Forks = Forks !ForkId !Int !(IORef EnvRef) Forks | NoFork
120131
132+-- | Data held in the environment.
121133data EnvRef = EnvRef
122− { _size :: Int
123− , _data :: SmallMutableArray RealWorld Any
124− , _relinkers :: SmallMutableArray RealWorld Any
134+ { _size :: !Int
135+ , _data :: !(SmallMutableArray RealWorld Any)
136+ , _relinkers :: !(SmallMutableArray RealWorld Any)
125137 }
126138
127139----------------------------------------
128140-- ForkId
129141
142+-- | Internal id of the fork.
130143newtype ForkId = ForkId { unForkId :: Int }
131144
132145-- | 'ForkId' generation.
@@ -150,12 +163,15 @@ newForkId (ForkIdGen ref) = do
150163----------------------------------------
151164-- Relinker
152165
166+-- | A function for relinking 'Env' objects stored in the handlers when cloning
167+-- the environment.
153168newtype Relinker :: (Effect -> Type) -> Effect -> Type where
154169 Relinker
155− :: ((forall es. Env es -> IO (Env es)) -> handler e -> IO (handler e))
156− -> Relinker handler e
170+ :: ((forall es. Env es -> IO (Env es)) -> adapter e -> IO (adapter e))
171+ -> Relinker adapter e
157172
158−noRelinker :: Relinker handler e
173+-- | A dummy 'Relinker' that does nothing.
174+noRelinker :: Relinker adapter e
159175noRelinker = Relinker $ \_ -> pure
160176
161177----------------------------------------
@@ -173,8 +189,8 @@ cloneEnv (Env NoFork gref0 gen0) = do
173189 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)
174190 gen <- cloneForkIdGen gen0
175191 gref <- newIORef $ EnvRef n es fs
176− cache <- newIORef IM.empty
177− relinkData gref gen cache es fs n
192+ store <- newIORef IM.empty
193+ relinkData gref gen store es fs n
178194 pure $ Env NoFork gref gen
179195cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do
180196 EnvRef _ es0 fs0 <- readIORef gref0
@@ -187,8 +203,8 @@ cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do
187203 copySmallMutableArray fs 0 fs0 0 baseN
188204 gen <- cloneForkIdGen gen0
189205 gref <- newIORef $ EnvRef len es fs
190− cache <- newIORef IM.empty
191− relinkData gref gen cache es fs n
206+ store <- newIORef IM.empty
207+ relinkData gref gen store es fs n
192208 -- The forked environment is flattened and becomes the global one.
193209 pure $ Env NoFork gref gen
194210{-# NOINLINE cloneEnv #-}
@@ -238,18 +254,18 @@ copyForks es fs len = \case
238254 copySmallMutableArray fs baseIx fs0 0 n
239255 copyForks es fs baseIx forks
240256
241−type EnvRefCache = IORef (IM.IntMap (IORef EnvRef))
257+type EnvRefStore = IORef (IM.IntMap (IORef EnvRef))
242258
243259-- | Relink local environments hiding in the handlers.
244260relinkData
245261 :: IORef EnvRef
246262 -> ForkIdGen
247− -> EnvRefCache
263+ -> EnvRefStore
248264 -> SmallMutableArray RealWorld Any
249265 -> SmallMutableArray RealWorld Any
250266 -> Int
251267 -> IO ()
252−relinkData gref gen cache es fs = \case
268+relinkData gref gen store es fs = \case
253269 0 -> pure ()
254270 n -> do
255271 let i = n - 1
@@ -257,41 +273,41 @@ relinkData gref gen cache es fs = \case
257273 readSmallArray es i
258274 >>= f relinkEnv . fromAny
259275 >>= writeSmallArray es i . toAny
260− relinkData gref gen cache es fs i
276+ relinkData gref gen store es fs i
261277 where
262278 relinkEnv :: Env es -> IO (Env es)
263− relinkEnv (Env forks _ _) = Env <$> relinkForks gref gen cache forks
279+ relinkEnv (Env forks _ _) = Env <$> relinkForks gref gen store forks
264280 <*> pure gref
265281 <*> pure gen
266282
267−relinkForks :: IORef EnvRef -> ForkIdGen -> EnvRefCache -> Forks -> IO Forks
268−relinkForks gref gen cache = \case
283+relinkForks :: IORef EnvRef -> ForkIdGen -> EnvRefStore -> Forks -> IO Forks
284+relinkForks gref gen store = \case
269285 NoFork -> pure NoFork
270286 Forks fid baseIx lref0 forks -> do
271287 -- A specific IORef EnvRef can be held by more than one local environment
272288 -- and we need to replace all its occurences with the same, new value
273289 -- containing its clone.
274− readIORef cache >>= pure . IM.lookup (unForkId fid) >>= \case
290+ readIORef store >>= pure . IM.lookup (unForkId fid) >>= \case
275291 Just lref -> Forks fid baseIx <$> pure lref
276− <*> relinkForks gref gen cache forks
277− Nothing -> Forks fid baseIx <$> cloneEnvRef gref gen cache fid lref0
278− <*> relinkForks gref gen cache forks
292+ <*> relinkForks gref gen store forks
293+ Nothing -> Forks fid baseIx <$> cloneEnvRef gref gen store fid lref0
294+ <*> relinkForks gref gen store forks
279295
280−-- | Clone the local 'EnvRef' and put it in a cache.
296+-- | Clone the local 'EnvRef' and put it in a store.
281297cloneEnvRef
282298 :: IORef EnvRef
283299 -> ForkIdGen
284− -> EnvRefCache
300+ -> EnvRefStore
285301 -> ForkId
286302 -> IORef EnvRef
287303 -> IO (IORef EnvRef)
288−cloneEnvRef gref gen cache fid lref0 = do
304+cloneEnvRef gref gen store fid lref0 = do
289305 EnvRef n es0 fs0 <- readIORef lref0
290306 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)
291307 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)
292308 ref <- newIORef $ EnvRef n es fs
293− modifyIORef' cache $ IM.insert (unForkId fid) ref
294− relinkData gref gen cache es fs n
309+ modifyIORef' store $ IM.insert (unForkId fid) ref
310+ relinkData gref gen store es fs n
295311 pure ref
296312
297313----------------------------------------
@@ -340,10 +356,10 @@ checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do
340356
341357-- | Extend the environment with a new data type (in place).
342358--
343−-- /Note:/ this function is __unsafe__ because it renders the input 'Env'
344−-- unusable until the corresponding 'unsafeTailEnv' call, but it's not checked
345−-- anywhere.
346−unsafeConsEnv :: handler e -> Relinker handler e -> Env es -> IO (Env (e : es))
359+-- This function is __highly unsafe__ because it renders the input 'Env'
360+-- unusable until the corresponding 'unsafeTailEnv' call is made, but it's not
361+-- checked anywhere.
362+unsafeConsEnv :: adapter e -> Relinker adapter e -> Env es -> IO (Env (e : es))
347363unsafeConsEnv e f (Env fork gref gen) = case fork of
348364 NoFork -> do
349365 extendEnvRef gref
@@ -379,16 +395,12 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of
379395-- | Shrink the environment by one data type (in place). Makes sure the size of
380396-- the environment is as expected.
381397--
382−-- /Note:/ this function is __unsafe__ because it renders the input 'Env'
398+-- This function is __highly unsafe__ because it renders the input 'Env'
383399-- unusable, but it's not checked anywhere.
384−unsafeTailEnv :: Int -> Env (e : es) -> IO (Env es)
385−unsafeTailEnv len (Env fork gref gen) = case fork of
386− NoFork -> do
387− shrinkEnvRef len gref
388− pure $ Env NoFork gref gen
389− Forks _ baseIx lref _ -> do
390− shrinkEnvRef (len - baseIx) lref
391− pure $ Env fork gref gen
400+unsafeTailEnv :: Int -> Env (e : es) -> IO ()
401+unsafeTailEnv len (Env fork gref _) = case fork of
402+ NoFork -> shrinkEnvRef len gref
403+ Forks _ baseIx lref _ -> shrinkEnvRef (len - baseIx) lref
392404 where
393405 shrinkEnvRef :: Int -> IORef EnvRef -> IO ()
394406 shrinkEnvRef k ref = do
@@ -405,41 +417,44 @@ unsafeTailEnv len (Env fork gref gen) = case fork of
405417-- Data retrieval and update
406418
407419-- | Extract a specific data type from the environment.
408−getEnv :: forall e es handler. e :> es => Env es -> IO (handler e)
420+getEnv
421+ :: forall e adapter es. e :> es
422+ => Env es
423+ -> IO (adapter e)
409424getEnv env = do
410− (i, es) <- getLocation @e env
425+ Location i es <- getLocation (reifyIndex @e @es) env
411426 fromAny <$> readSmallArray es i
412427
413428-- | Replace the data type in the environment with a new value (in place).
414429putEnv
415− :: forall e es handler. e :> es
430+ :: forall e adapter es. e :> es
416431 => Env es
417− -> handler e
432+ -> adapter e
418433 -> IO ()
419434putEnv env e = do
420− (i, es) <- getLocation @e env
435+ Location i es <- getLocation (reifyIndex @e @es) env
421436 e `seq` writeSmallArray es i (toAny e)
422437
423438-- | Modify the data type in the environment (in place) and return a value.
424439stateEnv
425− :: forall e es handler a. e :> es
440+ :: forall e adapter es a. e :> es
426441 => Env es
427− -> (handler e -> (a, handler e))
442+ -> (adapter e -> (a, adapter e))
428443 -> IO a
429444stateEnv env f = do
430− (i, es) <- getLocation @e env
445+ Location i es <- getLocation (reifyIndex @e @es) env
431446 (a, e) <- f . fromAny <$> readSmallArray es i
432447 e `seq` writeSmallArray es i (toAny e)
433448 pure a
434449
435450-- | Modify the data type in the environment (in place).
436451modifyEnv
437− :: forall e es handler. e :> es
452+ :: forall e adapter es. e :> es
438453 => Env es
439− -> (handler e -> handler e)
454+ -> (adapter e -> adapter e)
440455 -> IO ()
441456modifyEnv env f = do
442− (i, es) <- getLocation @e env
457+ Location i es <- getLocation (reifyIndex @e @es) env
443458 e <- f . fromAny <$> readSmallArray es i
444459 e `seq` writeSmallArray es i (toAny e)
445460
@@ -455,13 +470,17 @@ emptyEnvRef = do
455470 fs <- newSmallArray 0 undefinedData
456471 newIORef $ EnvRef 0 es fs
457472
473+-- | Location with unboxed fields to make GHC generate Core without unnecessary
474+-- reboxing around the local 'go' function from 'getLocation'.
475+data Location = Location !Int !(SmallMutableArray RealWorld Any)
476+
458477-- | Determine location of the data type in the environment.
459478getLocation
460− :: forall e es. e :> es
461− => Env es
462− -> IO (Int, SmallMutableArray RealWorld Any)
463−getLocation (Env fork ref _) = do
464− EnvRef n es _ <- readIORef ref
479+ :: Int
480+ -> Env es
481+ -> IO Location
482+getLocation ixE (Env fork ref _) = do
483+ EnvRef n es@(SmallMutableArray es#) _ <- readIORef ref
465484 -- Optimized for the common access pattern:
466485 --
467486 -- - Most application code has no access to forks, in which case we look at
@@ -470,28 +489,28 @@ getLocation (Env fork ref _) = do
470489 -- - Effect handlers will most likely access the newest fork with handler
471490 -- specific effects for reinterpretation.
472491 case fork of
473− NoFork -> pure (ix n, es)
492+ NoFork -> pure $ Location (ix n) es
474493 Forks _ baseIx lref forks -> do
475494 EnvRef ln les _ <- readIORef lref
476495 let i = ix (baseIx + ln)
477496 if i >= baseIx
478− then pure (i - baseIx, les)
479− else go es i forks
497+ then pure $ Location (i - baseIx) les
498+ else go es# i forks
480499 where
481− go :: SmallMutableArray RealWorld Any
500+ go :: SmallMutableArray# RealWorld Any
482501 -> Int
483502 -> Forks
484− -> IO (Int, SmallMutableArray RealWorld Any)
485− go es i = \case
486− NoFork -> pure (i, es)
503+ -> IO Location
504+ go es# i = \case
505+ NoFork -> pure $ Location i (SmallMutableArray es#)
487506 Forks _ baseIx lref forks -> do
488507 EnvRef _ les _ <- readIORef lref
489508 if i >= baseIx
490− then pure (i - baseIx, les)
491− else go es i forks
509+ then pure $ Location (i - baseIx) les
510+ else go es# i forks
492511
493512 ix :: Int -> Int
494− ix n = n - reifyIndex @e @es - 1
513+ ix n = n - ixE - 1
495514
496515toAny :: a -> Any
497516toAny = unsafeCoerce
effectful-core/src/Effectful/Internal/Monad.hs+207−242
@@ -6,7 +6,7 @@
66-- This module is intended for internal use only, and may change without warning
77-- in subsequent releases.
88module Effectful.Internal.Monad
9− ( -- * Monad
9+ ( -- * The 'Eff' monad
1010 Eff
1111 , runPureEff
1212
@@ -16,18 +16,17 @@ module Effectful.Internal.Monad
1616 , unsafeEff_
1717
1818 -- * Fail
19− , Fail
20− , runFail
19+ , Fail(..)
2120
2221 -- * IO
2322 , IOE
2423 , runEff
2524
26− -- * Primitive
25+ -- * Prim
2726 , Prim
2827 , runPrim
2928
30− -- ** Unlift strategies
29+ -- * Unlift strategies
3130 , UnliftStrategy(..)
3231 , Persistence(..)
3332 , Limit(..)
@@ -35,87 +34,88 @@ module Effectful.Internal.Monad
3534 , withUnliftStrategy
3635 , withEffToIO
3736
38− --- *** Low-level helpers
39− , unsafeWithLiftMapIO
40− , unsafeSeqUnliftEff
41− , unsafeConcUnliftEff
42−
43− -- * Primitive effects
44−
45− -- ** Running
46− , runEffect
47− , evalEffect
48− , execEffect
49−
50− -- ** Modification
51− , getEffect
52− , putEffect
53− , stateEffect
54− , stateEffectM
55− , localEffect
37+ -- ** Low-level unlifts
38+ , seqUnliftIO
39+ , concUnliftIO
40+
41+ -- * Effects
42+
43+ -- ** Dynamic dispatch
44+ , EffectHandler
45+ , LocalEnv(..)
46+ , HandlerA(..)
47+ , runHandler
48+ , send
49+
50+ -- ** Static dispatch
51+ , DataA(..)
52+ , runData
53+ , evalData
54+ , execData
55+ , getData
56+ , putData
57+ , stateData
58+ , stateDataM
59+ , localData
5660 ) where
5761
5862import Control.Applicative (liftA2)
59−import Control.Concurrent (myThreadId)
60−import Control.Exception
6163import Control.Monad.Base
6264import Control.Monad.Fix
6365import Control.Monad.IO.Class
6466import Control.Monad.IO.Unlift
6567import Control.Monad.Primitive
6668import Control.Monad.Trans.Control
67−import Data.Unique
6869import GHC.Exts (oneShot)
6970import GHC.IO (IO(..))
7071import GHC.Stack (HasCallStack)
7172import System.IO.Unsafe (unsafeDupablePerformIO)
72−import qualified Control.Monad.Catch as E
73+import qualified Control.Exception as E
74+import qualified Control.Monad.Catch as C
7375
7476import Effectful.Internal.Effect
7577import Effectful.Internal.Env
7678import Effectful.Internal.Unlift
77−import Effectful.Internal.Utils
7879
7980type role Eff nominal representational
8081
81−-- | The 'Eff' monad provides the implementation of an operation that performs
82+-- | The 'Eff' monad provides the implementation of a computation that performs
8283-- an arbitrary set of effects. In @'Eff' es a@, @es@ is a type-level list that
83−-- contains all the effects that the operation may perform. For example, an
84−-- operation that produces an 'Integer' by consuming a 'String' from the global
85−-- environment and acting upon a single mutable cell containing a 'Bool' would
86−-- have the following type:
84+-- contains all the effects that the computation may perform. For example, a
85+-- computation that produces an 'Integer' by consuming a 'String' from the
86+-- global environment and acting upon a single mutable value of type 'Bool'
87+-- would have the following type:
8788--
8889-- @
89−-- 'Eff' '['Effectful.Reader.Reader' 'String', 'Effectful.State.State' 'Bool'] 'Integer'
90+-- 'Eff' '['Effectful.Reader.Reader' 'String', 'Effectful.State.Local.State' 'Bool'] 'Integer'
9091-- @
9192--
9293-- Normally, a concrete list of effects is not used to parameterize 'Eff'.
9394-- Instead, the '(:>)' type class is used to express constraints on the list of
94−-- effects without coupling an operation to a concrete list of effects. For
95−-- example, the above example would more commonly be expressed with the
96−-- following type:
95+-- effects without coupling a computation to a concrete list of effects. For
96+-- example, the above example would be expressed with the following type:
9797--
9898-- @
99−-- ('Effectful.Reader.Reader' 'String' ':>' es, 'Effectful.State.State' 'Bool' ':>' es) => 'Eff' es 'Integer'
99+-- ('Effectful.Reader.Reader' 'String' ':>' es, 'Effectful.State.Local.State' 'Bool' ':>' es) => 'Eff' es 'Integer'
100100-- @
101101--
102−-- This abstraction allows the operation to be used in functions that may
102+-- This abstraction allows the computation to be used in functions that may
103103-- perform other effects, and it also allows the effects to be handled in any
104104-- order.
105105newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a)
106106 deriving (Monoid, Semigroup)
107107
108−-- | Run a pure 'Eff' operation.
108+-- | Run a pure 'Eff' computation.
109109--
110−-- For running operations with side effects see 'runEff'.
110+-- For running computations with side effects see 'runEff'.
111111runPureEff :: Eff '[] a -> a
112112runPureEff (Eff m) =
113− -- unsafePerformIO is safe here since IOE was not on the stack, so no IO with
114− -- side effects was performed (unless someone sneakily introduced side effects
115− -- with unsafeEff, but then all bets are off).
113+ -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no
114+ -- IO with side effects was performed (unless someone sneakily introduced side
115+ -- effects with unsafeEff, but then all bets are off).
116116 --
117117 -- Moreover, internals don't allocate any resources that require explicit
118− -- cleanup actions to run, so the "Dupable" part should also be just fine.
118+ -- cleanup actions to run.
119119 unsafeDupablePerformIO $ m =<< emptyEnv
120120
121121----------------------------------------
@@ -126,62 +126,70 @@ unEff :: Eff es a -> Env es -> IO a
126126unEff (Eff m) = m
127127
128128-- | Access the underlying 'IO' monad along with the environment.
129+--
130+-- This function is __unsafe__ because it can be used to introduce arbitrary
131+-- 'IO' actions into pure 'Eff' computations.
129132unsafeEff :: (Env es -> IO a) -> Eff es a
130133unsafeEff m = Eff (oneShot m)
131134
132135-- | Access the underlying 'IO' monad.
136+--
137+-- This function is __unsafe__ because it can be used to introduce arbitrary
138+-- 'IO' actions into pure 'Eff' computations.
133139unsafeEff_ :: IO a -> Eff es a
134140unsafeEff_ m = unsafeEff $ \_ -> m
135141
136−-- | Utility for lifting 'IO' operations of type
137−--
138−-- @'IO' a -> 'IO' b@
139−--
140−-- to
142+----------------------------------------
143+-- Unlifting IO
144+
145+-- | Get the current 'UnliftStrategy'.
146+unliftStrategy :: IOE :> es => Eff es UnliftStrategy
147+unliftStrategy = do
148+ DataA (IOE unlift) <- getData
149+ pure unlift
150+
151+-- | Locally override the 'UnliftStrategy' with the given value.
152+withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
153+withUnliftStrategy unlift = localData $ \_ -> DataA (IOE unlift)
154+
155+-- | Create an unlifting function with the current 'UnliftStrategy'.
141156--
142−-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@
157+-- This function is equivalent to 'withRunInIO', but has a 'HasCallStack'
158+-- constraint for accurate stack traces in case an insufficiently powerful
159+-- 'UnliftStrategy' is used and the unlifting function fails.
143160--
144−-- /Note:/ the 'IO' operation must not run its argument in a separate thread,
145−-- attempting to do so will result in a runtime error.
146−unsafeWithLiftMapIO
147− :: HasCallStack
148− => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
149− -> Eff es r
150−unsafeWithLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
151− unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
161+-- /Note:/ the strategy is reset to 'SeqUnlift' inside the continuation.
162+withEffToIO
163+ :: (HasCallStack, IOE :> es)
164+ => ((forall r. Eff es r -> IO r) -> IO a)
165+ -- ^ Continuation with the unlifting function in scope.
166+ -> Eff es a
167+withEffToIO f = unliftStrategy >>= \case
168+ SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f
169+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
170+ unsafeEff $ \es -> concUnliftIO es p b f
152171
153−-- | Lower 'Eff' operations into 'IO' ('SeqUnlift').
154−unsafeSeqUnliftEff
172+-- | Create an unlifting function with the 'SeqUnlift' strategy.
173+seqUnliftIO
155174 :: HasCallStack
156175 => Env es
176+ -- ^ The environment.
157177 -> ((forall r. Eff es r -> IO r) -> IO a)
178+ -- ^ Continuation with the unlifting function in scope.
158179 -> IO a
159−unsafeSeqUnliftEff es k = do
160− tid0 <- myThreadId
161− k $ \m -> do
162− tid <- myThreadId
163− if tid `eqThreadId` tid0
164− then unEff m es
165− else error
166− $ "If you want to use the unlifting function to run Eff operations "
167− ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)."
168−
169−-- | Lower 'Eff' operations into 'IO' ('ConcUnlift').
170−unsafeConcUnliftEff
180+seqUnliftIO es k = seqUnlift k es unEff
181+
182+-- | Create an unlifting function with the 'ConcUnlift' strategy.
183+concUnliftIO
171184 :: HasCallStack
172185 => Env es
186+ -- ^ The environment.
173187 -> Persistence
174188 -> Limit
175189 -> ((forall r. Eff es r -> IO r) -> IO a)
190+ -- ^ Continuation with the unlifting function in scope.
176191 -> IO a
177−unsafeConcUnliftEff es Ephemeral (Limited uses) k =
178− unsafeEphemeralConcUnliftIO uses k es unEff
179−unsafeConcUnliftEff es Ephemeral Unlimited k =
180− unsafeEphemeralConcUnliftIO maxBound k es unEff
181−unsafeConcUnliftEff es Persistent (Limited threads) k =
182− unsafePersistentConcUnliftIO False threads k es unEff
183−unsafeConcUnliftEff es Persistent Unlimited k =
184− unsafePersistentConcUnliftIO True maxBound k es unEff
192+concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff
185193
186194----------------------------------------
187195-- Base
@@ -209,84 +217,56 @@ instance MonadFix (Eff es) where
209217----------------------------------------
210218-- Exception
211219
212−instance E.MonadThrow (Eff es) where
213− throwM = unsafeEff_ . throwIO
220+instance C.MonadThrow (Eff es) where
221+ throwM = unsafeEff_ . E.throwIO
214222
215−instance E.MonadCatch (Eff es) where
223+instance C.MonadCatch (Eff es) where
216224 catch m handler = unsafeEff $ \es -> do
217225 size <- sizeEnv es
218− unEff m es `catch` \e -> do
226+ unEff m es `E.catch` \e -> do
219227 checkSizeEnv size es
220228 unEff (handler e) es
221229
222−instance E.MonadMask (Eff es) where
223− mask k = unsafeEff $ \es -> mask $ \restore ->
230+instance C.MonadMask (Eff es) where
231+ mask k = unsafeEff $ \es -> E.mask $ \restore ->
224232 unEff (k $ \m -> unsafeEff $ restore . unEff m) es
225233
226− uninterruptibleMask k = unsafeEff $ \es -> uninterruptibleMask $ \restore ->
234+ uninterruptibleMask k = unsafeEff $ \es -> E.uninterruptibleMask $ \restore ->
227235 unEff (k $ \m -> unsafeEff $ restore . unEff m) es
228236
229− generalBracket acquire release use = unsafeEff $ \es -> mask $ \restore -> do
237+ generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \restore -> do
230238 size <- sizeEnv es
231239 resource <- unEff acquire es
232− b <- restore (unEff (use resource) es) `catch` \e -> do
240+ b <- restore (unEff (use resource) es) `E.catch` \e -> do
233241 checkSizeEnv size es
234− _ <- unEff (release resource $ E.ExitCaseException e) es
235− throwIO e
242+ _ <- unEff (release resource $ C.ExitCaseException e) es
243+ E.throwIO e
236244 checkSizeEnv size es
237− c <- unEff (release resource $ E.ExitCaseSuccess b) es
245+ c <- unEff (release resource $ C.ExitCaseSuccess b) es
238246 pure (b, c)
239247
240248----------------------------------------
241249-- Fail
242250
251+-- | Provide the ability to use the 'MonadFail' instance of 'Eff'.
243252data Fail :: Effect where
244− Fail :: Unique -> Fail m r
245−
246−runFail :: Eff (Fail : es) a -> Eff es (Either String a)
247−runFail m = unsafeEff $ \es0 -> mask $ \release -> do
248− -- A unique tag is picked so that different runFail handlers don't catch each
249− -- other's exceptions.
250− tag <- newUnique
251− size0 <- sizeEnv es0
252− es <- unsafeConsEnv (IdE (Fail tag)) noRelinker es0
253− r <- tryFailIO tag (release $ unEff m es) `onException` unsafeTailEnv size0 es
254− _ <- unsafeTailEnv size0 es
255− pure r
253+ Fail :: String -> Fail m a
256254
257255instance Fail :> es => MonadFail (Eff es) where
258− fail msg = do
259− IdE (Fail tag) <- getEffect
260− unsafeEff_ . throwIO $ FailEx tag msg
261−
262−--------------------
263−
264−data FailEx = FailEx Unique String
265−instance Show FailEx where
266− showsPrec p (FailEx _ msg)
267− = ("Effectful.Internal.Monad.FailEx " ++)
268− . showsPrec p msg
269−instance Exception FailEx
270−
271−tryFailIO :: Unique -> IO a -> IO (Either String a)
272−tryFailIO tag m =
273− (Right <$> m) `catch` \err@(FailEx etag msg) -> do
274− if tag == etag
275− then pure $ Left msg
276− else throwIO err
256+ fail = send . Fail
277257
278258----------------------------------------
279259-- IO
280260
281−-- | Run arbitrary 'IO' operations via 'MonadIO' or 'MonadUnliftIO'.
261+-- | Run arbitrary 'IO' computations via 'MonadIO' or 'MonadUnliftIO'.
282262newtype IOE :: Effect where
283263 IOE :: UnliftStrategy -> IOE m r
284264
285−-- | Run an 'Eff' operation with side effects.
265+-- | Run an 'Eff' computation with side effects.
286266--
287−-- For running pure operations see 'runPureEff'.
267+-- For running pure computations see 'runPureEff'.
288268runEff :: Eff '[IOE] a -> IO a
289−runEff m = unEff (evalEffect (IdE (IOE SeqUnlift)) m) =<< emptyEnv
269+runEff m = unEff (evalData (DataA (IOE SeqUnlift)) m) =<< emptyEnv
290270
291271instance IOE :> es => MonadIO (Eff es) where
292272 liftIO = unsafeEff_
@@ -310,141 +290,126 @@ instance IOE :> es => MonadBaseControl IO (Eff es) where
310290----------------------------------------
311291-- Primitive
312292
313−-- | An effect to perform primitive state-transformer actions.
293+-- | Provide the ability to perform primitive state-transformer actions.
314294data Prim :: Effect where
315295 Prim :: Prim m r
316296
317−-- | Run an 'Eff' operation with primitive state-transformer actions.
297+-- | Run an 'Eff' computation with primitive state-transformer actions.
318298runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a
319−runPrim = evalEffect (IdE Prim)
299+runPrim = evalData (DataA Prim)
320300
321301instance Prim :> es => PrimMonad (Eff es) where
322− type PrimState (Eff es) = PrimState IO
302+ type PrimState (Eff es) = RealWorld
323303 primitive = unsafeEff_ . IO
324304
325305----------------------------------------
326−-- Unlift strategies
327−
328−-- | The strategy to use when unlifting 'Eff' operations via 'withRunInIO' or
329−-- the 'Effectful.Interpreter.localUnlift' family.
330−data UnliftStrategy
331− = SeqUnlift
332− -- ^ The fastest strategy and a default setting for 'IOE'. An attempt to call
333− -- the unlifting function in threads distinct from its creator will result in
334− -- a runtime error.
335− | ConcUnlift Persistence Limit
336− -- ^ A strategy that makes it possible for the unlifting function to be called
337− -- in threads distinct from its creator. See 'Persistence' and 'Limit'
338− -- settings for more information.
339− deriving (Eq, Ord, Show)
340−
341−-- | Persistence setting for the 'ConcUnlift' strategy.
342−--
343−-- Different functions require different persistence strategies. Examples:
344−--
345−-- - Lifting 'pooledMapConcurrentlyN' from the @unliftio@ library requires the
346−-- 'Ephemeral' strategy as we don't want jobs to share environment changes
347−-- made by previous jobs run in the same worker thread.
348−--
349−-- - Lifting 'Control.Concurrent.forkIOWithUnmask' requires the 'Persistent'
350−-- strategy, otherwise the unmasking function would start with a fresh
351−-- environment each time it's called.
352−data Persistence
353− = Ephemeral
354− -- ^ Don't persist the environment between calls to the unlifting function in
355− -- threads distinct from its creator.
356− | Persistent
357− -- ^ Persist the environment between calls to the unlifting function within a
358− -- particular thread.
359− deriving (Eq, Ord, Show)
360−
361−-- | Limit setting for the 'ConcUnlift' strategy.
362−data Limit
363− = Limited Int
364− -- ^ Behavior dependent on the 'Persistence' setting.
365− --
366− -- For 'Ephemeral', it limits the amount of uses of the unlifting function in
367− -- threads distinct from its creator to @N@. The unlifting function will
368− -- create @N@ copies of the environment when called @N@ times and @K+1@ copies
369− -- when called @K < N@ times.
370− --
371− -- For 'Persistent', it limits the amount of threads, distinct from the
372− -- creator of the unlifting function, it can be called in to @N@. The amount
373− -- of calls to the unlifting function within a particular threads is
374− -- unlimited. The unlifting function will create @N@ copies of the environment
375− -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads.
376− | Unlimited
377− -- ^ Unlimited use of the unlifting function.
378− deriving (Eq, Ord, Show)
306+-- Dynamic dispatch
379307
380−-- | Get the current 'UnliftStrategy'.
381−unliftStrategy :: IOE :> es => Eff es UnliftStrategy
382−unliftStrategy = do
383− IdE (IOE unlift) <- getEffect
384− pure unlift
308+type role LocalEnv nominal nominal
385309
386−-- | Locally override the 'UnliftStrategy' with a given value.
310+-- | Opaque representation of the 'Eff' environment at the point of calling the
311+-- 'send' function, i.e. right before the control is passed to the effect
312+-- handler.
387313--
388−-- /Note:/ the strategy is reset to 'SeqUnlift' for new threads.
389−withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
390−withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift)
314+-- The second type variable represents effects of a handler and is needed for
315+-- technical reasons to guarantee soundness.
316+newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env localEs)
317+
318+-- | Type signature of the effect handler.
319+type EffectHandler e es
320+ = forall a localEs. HasCallStack
321+ => LocalEnv localEs es
322+ -- ^ Capture of the local environment for handling local 'Eff' computations
323+ -- when @e@ is a higher order effect.
324+ -> e (Eff localEs) a
325+ -- ^ The effect performed in the local environment.
326+ -> Eff es a
391327
392−-- | Create an unlifting function with the current 'UnliftStrategy'.
328+-- | An adapter for dynamically dispatched effects.
393329--
394−-- This function is equivalent to 'withRunInIO', but has a 'HasCallStack'
395−-- constraint for accurate stack traces in case an insufficiently powerful
396−-- 'UnliftStrategy' is used and the unlifting function fails.
397−withEffToIO
398− :: (HasCallStack, IOE :> es)
399− => ((forall r. Eff es r -> IO r) -> IO a)
400− -- ^ Continuation with the unlifting function in scope.
401− -> Eff es a
402−withEffToIO f = unliftStrategy >>= \case
403− SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
404− ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
405− unsafeEff $ \es -> unsafeConcUnliftEff es p b f
330+-- Represents the effect handler bundled with its environment.
331+data HandlerA :: Effect -> Type where
332+ HandlerA :: !(Env es) -> !(EffectHandler e es) -> HandlerA e
333+
334+-- | Run a dynamically dispatched effect with the given handler.
335+runHandler :: HandlerA e -> Eff (e : es) a -> Eff es a
336+runHandler e m = unsafeEff $ \es0 -> do
337+ size0 <- sizeEnv es0
338+ E.bracket (unsafeConsEnv e relinker es0)
339+ (unsafeTailEnv size0)
340+ (\es -> unEff m es)
341+ where
342+ relinker :: Relinker HandlerA e
343+ relinker = Relinker $ \relink (HandlerA handlerEs handle) -> do
344+ newHandlerEs <- relink handlerEs
345+ pure $ HandlerA newHandlerEs handle
346+
347+-- | Send an operation of the given effect to its handler for execution.
348+send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
349+send op = unsafeEff $ \es -> do
350+ HandlerA handlerEs handle <- getEnv es
351+ unEff (handle (LocalEnv es) op) handlerEs
406352
407353----------------------------------------
408−-- Helpers
354+-- Static dispatch
409355
410−runEffect :: handler e -> Eff (e : es) a -> Eff es (a, handler e)
411−runEffect e0 m = unsafeEff $ \es0 -> do
356+-- | An adapter for statically dispatched effects.
357+--
358+-- Represents an arbitrary data type with the appropriate number of phantom type
359+-- parameters.
360+newtype DataA :: Effect -> Type where
361+ DataA :: (forall m r. e m r) -> DataA e
362+
363+-- | Run a statically dispatched effect with the given initial state and return
364+-- the final value along with the final state.
365+runData :: DataA e -> Eff (e : es) a -> Eff es (a, DataA e)
366+runData e0 m = unsafeEff $ \es0 -> do
412367 size0 <- sizeEnv es0
413− bracket (unsafeConsEnv e0 noRelinker es0)
414− (unsafeTailEnv size0)
415− (\es -> (,) <$> unEff m es <*> getEnv es)
416−
417−evalEffect :: handler e -> Eff (e : es) a -> Eff es a
418−evalEffect e m = unsafeEff $ \es0 -> do
368+ E.bracket (unsafeConsEnv e0 noRelinker es0)
369+ (unsafeTailEnv size0)
370+ (\es -> (,) <$> unEff m es <*> getEnv es)
371+
372+-- | Run a statically dispatched effect with the given initial state and return
373+-- the final value, discarding the final state.
374+evalData :: DataA e -> Eff (e : es) a -> Eff es a
375+evalData e m = unsafeEff $ \es0 -> do
419376 size0 <- sizeEnv es0
420− bracket (unsafeConsEnv e noRelinker es0)
421− (unsafeTailEnv size0)
422− (\es -> unEff m es)
423−
424−execEffect :: handler e -> Eff (e : es) a -> Eff es (handler e)
425−execEffect e0 m = unsafeEff $ \es0 -> do
377+ E.bracket (unsafeConsEnv e noRelinker es0)
378+ (unsafeTailEnv size0)
379+ (\es -> unEff m es)
380+
381+-- | Run a statically dispatched effect with the given initial state and return
382+-- the final state, discarding the final value.
383+execData :: DataA e -> Eff (e : es) a -> Eff es (DataA e)
384+execData e0 m = unsafeEff $ \es0 -> do
426385 size0 <- sizeEnv es0
427− bracket (unsafeConsEnv e0 noRelinker es0)
428− (unsafeTailEnv size0)
429− (\es -> unEff m es *> getEnv es)
430−
431−getEffect :: e :> es => Eff es (handler e)
432−getEffect = unsafeEff $ \es -> getEnv es
433−
434−putEffect :: e :> es => handler e -> Eff es ()
435−putEffect e = unsafeEff $ \es -> putEnv es e
436−
437−stateEffect :: e :> es => (handler e -> (a, handler e)) -> Eff es a
438−stateEffect f = unsafeEff $ \es -> stateEnv es f
439−
440−stateEffectM :: e :> es => (handler e -> Eff es (a, handler e)) -> Eff es a
441−stateEffectM f = unsafeEff $ \es -> mask $ \release -> do
386+ E.bracket (unsafeConsEnv e0 noRelinker es0)
387+ (unsafeTailEnv size0)
388+ (\es -> unEff m es *> getEnv es)
389+
390+-- | Fetch the current state of the effect.
391+getData :: e :> es => Eff es (DataA e)
392+getData = unsafeEff $ \es -> getEnv es
393+
394+-- | Set the current state of the effect to the given value.
395+putData :: e :> es => DataA e -> Eff es ()
396+putData e = unsafeEff $ \es -> putEnv es e
397+
398+-- | Apply the function to the current state of the effect and return a value.
399+stateData :: e :> es => (DataA e -> (a, DataA e)) -> Eff es a
400+stateData f = unsafeEff $ \es -> stateEnv es f
401+
402+-- | Apply the monadic function to the current state of the effect and return a
403+-- value.
404+stateDataM :: e :> es => (DataA e -> Eff es (a, DataA e)) -> Eff es a
405+stateDataM f = unsafeEff $ \es -> E.mask $ \release -> do
442406 (a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es
443407 putEnv es e
444408 pure a
445409
446−localEffect :: e :> es => (handler e -> handler e) -> Eff es a -> Eff es a
447−localEffect f m = unsafeEff $ \es -> do
448− bracket (stateEnv es $ \e -> (e, f e))
449− (\e -> putEnv es e)
450− (\_ -> unEff m es)
410+-- | Execute a computation with a temporarily modified state of the effect.
411+localData :: e :> es => (DataA e -> DataA e) -> Eff es a -> Eff es a
412+localData f m = unsafeEff $ \es -> do
413+ E.bracket (stateEnv es $ \e -> (e, f e))
414+ (\e -> putEnv es e)
415+ (\_ -> unEff m es)
effectful-core/src/Effectful/Internal/Unlift.hs+119−14
@@ -1,19 +1,28 @@
11{-# LANGUAGE MagicHash #-}
22{-# LANGUAGE UnboxedTuples #-}
33{-# OPTIONS_HADDOCK not-home #-}
4−-- | Implementation of concurrent unlifts.
4+-- | Implementation of sequential and concurrent unlifts.
55--
66-- This module is intended for internal use only, and may change without warning
77-- in subsequent releases.
88module Effectful.Internal.Unlift
9− ( unsafeEphemeralConcUnliftIO
10− , unsafePersistentConcUnliftIO
9+ ( -- * Unlifting strategies
10+ UnliftStrategy(..)
11+ , Persistence(..)
12+ , Limit(..)
13+
14+ -- * Unlifting functions
15+ , seqUnlift
16+ , concUnlift
17+ , ephemeralConcUnlift
18+ , persistentConcUnlift
1119 ) where
1220
1321import Control.Concurrent
1422import Control.Monad
1523import GHC.Conc.Sync (ThreadId(..))
1624import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)
25+import GHC.Generics (Generic)
1726import GHC.IO (IO(..))
1827import GHC.Stack (HasCallStack)
1928import GHC.Weak (Weak(..))
@@ -23,16 +32,111 @@ import qualified Data.IntMap.Strict as IM
2332import Effectful.Internal.Env
2433import Effectful.Internal.Utils
2534
35+----------------------------------------
36+-- Unlift strategies
37+
38+-- | The strategy to use when unlifting 'Eff' computations via 'withRunInIO',
39+-- 'Effectful.Monad.withEffToIO' or the 'Effectful.Dispatch.Dynamic.localUnlift'
40+-- family.
41+data UnliftStrategy
42+ = SeqUnlift
43+ -- ^ The fastest strategy and a default setting for 'IOE'. An attempt to call
44+ -- the unlifting function in threads distinct from its creator will result in
45+ -- a runtime error.
46+ | ConcUnlift !Persistence !Limit
47+ -- ^ A strategy that makes it possible for the unlifting function to be called
48+ -- in threads distinct from its creator. See 'Persistence' and 'Limit'
49+ -- settings for more information.
50+ deriving (Eq, Generic, Ord, Show)
51+
52+-- | Persistence setting for the 'ConcUnlift' strategy.
53+--
54+-- Different functions require different persistence strategies. Examples:
55+--
56+-- - Lifting 'pooledMapConcurrentlyN' from the @unliftio@ library requires the
57+-- 'Ephemeral' strategy as we don't want jobs to share environment changes
58+-- made by previous jobs run in the same worker thread.
59+--
60+-- - Lifting 'Control.Concurrent.forkIOWithUnmask' requires the 'Persistent'
61+-- strategy, otherwise the unmasking function would start with a fresh
62+-- environment each time it's called.
63+data Persistence
64+ = Ephemeral
65+ -- ^ Don't persist the environment between calls to the unlifting function in
66+ -- threads distinct from its creator.
67+ | Persistent
68+ -- ^ Persist the environment between calls to the unlifting function within a
69+ -- particular thread.
70+ deriving (Eq, Generic, Ord, Show)
71+
72+-- | Limit setting for the 'ConcUnlift' strategy.
73+data Limit
74+ = Limited !Int
75+ -- ^ Behavior dependent on the 'Persistence' setting.
76+ --
77+ -- For 'Ephemeral', it limits the amount of uses of the unlifting function in
78+ -- threads distinct from its creator to @N@. The unlifting function will
79+ -- create @N@ copies of the environment when called @N@ times and @K+1@ copies
80+ -- when called @K < N@ times.
81+ --
82+ -- For 'Persistent', it limits the amount of threads, distinct from the
83+ -- creator of the unlifting function, it can be called in to @N@. The amount
84+ -- of calls to the unlifting function within a particular threads is
85+ -- unlimited. The unlifting function will create @N@ copies of the environment
86+ -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads.
87+ | Unlimited
88+ -- ^ Unlimited use of the unlifting function.
89+ deriving (Eq, Generic, Ord, Show)
90+
91+----------------------------------------
92+-- Unlift functions
93+
94+-- | Sequential unlift.
95+seqUnlift
96+ :: HasCallStack
97+ => ((forall r. m r -> IO r) -> IO a)
98+ -> Env es
99+ -> (forall r. m r -> Env es -> IO r)
100+ -> IO a
101+seqUnlift k es unEff = do
102+ tid0 <- myThreadId
103+ k $ \m -> do
104+ tid <- myThreadId
105+ if tid `eqThreadId` tid0
106+ then unEff m es
107+ else error
108+ $ "If you want to use the unlifting function to run Eff computations "
109+ ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)."
110+
111+-- | Concurrent unlift for various strategies and limits.
112+concUnlift
113+ :: HasCallStack
114+ => Persistence
115+ -> Limit
116+ -> ((forall r. m r -> IO r) -> IO a)
117+ -> Env es
118+ -> (forall r. m r -> Env es -> IO r)
119+ -> IO a
120+concUnlift Ephemeral (Limited uses) k =
121+ ephemeralConcUnlift uses k
122+concUnlift Ephemeral Unlimited k =
123+ ephemeralConcUnlift maxBound k
124+concUnlift Persistent (Limited threads) k =
125+ persistentConcUnlift False threads k
126+concUnlift Persistent Unlimited k =
127+ persistentConcUnlift True maxBound k
128+
26129-- | Concurrent unlift that doesn't preserve the environment between calls to
27130-- the unlifting function in threads other than its creator.
28−unsafeEphemeralConcUnliftIO
131+ephemeralConcUnlift
29132 :: HasCallStack
30133 => Int
134+ -- ^ Number of permitted uses of the unlift function.
31135 -> ((forall r. m r -> IO r) -> IO a)
32136 -> Env es
33137 -> (forall r. m r -> Env es -> IO r)
34138 -> IO a
35−unsafeEphemeralConcUnliftIO uses k es0 unEff = do
139+ephemeralConcUnlift uses k es0 unEff = do
36140 unless (uses > 0) $ do
37141 error $ "Invalid number of uses: " ++ show uses
38142 tid0 <- myThreadId
@@ -58,15 +162,16 @@ unsafeEphemeralConcUnliftIO uses k es0 unEff = do
58162
59163-- | Concurrent unlift that preserves the environment between calls to the
60164-- unlifting function within a particular thread.
61−unsafePersistentConcUnliftIO
165+persistentConcUnlift
62166 :: HasCallStack
63167 => Bool
64168 -> Int
169+ -- ^ Number of threads that are allowed to use the unlift function.
65170 -> ((forall r. m r -> IO r) -> IO a)
66171 -> Env es
67172 -> (forall r. m r -> Env es -> IO r)
68173 -> IO a
69−unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do
174+persistentConcUnlift cleanUp threads k es0 unEff = do
70175 unless (threads > 0) $ do
71176 error $ "Invalid number of threads: " ++ show threads
72177 tid0 <- myThreadId
@@ -87,9 +192,9 @@ unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do
87192 Just es -> pure (te, es)
88193 Nothing -> case teCapacity te of
89194 0 -> error
90− $ "Number of other threads (" ++ show threads ++ ") permitted to "
91− ++ "use the unlifting function was exceeded. Please increase the "
92− ++ "limit or use the unlimited variant."
195+ $ "Number of other threads (" ++ show threads ++ ") permitted to "
196+ ++ "use the unlifting function was exceeded. Please increase the "
197+ ++ "limit or use the unlimited variant."
93198 1 -> do
94199 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp
95200 let newEntries = ThreadEntries
@@ -120,17 +225,17 @@ nextEntryId :: EntryId -> EntryId
120225nextEntryId (EntryId i) = EntryId (i + 1)
121226
122227data ThreadEntries es = ThreadEntries
123− { teCapacity :: Int
124− , teEntries :: IM.IntMap (ThreadEntry es)
228+ { teCapacity :: !Int
229+ , teEntries :: !(IM.IntMap (ThreadEntry es))
125230 }
126231
127232-- | In GHC < 9 weak thread ids are 32bit long, while ThreadIdS are 64bit long,
128233-- so there is potential for collisions. This is solved by keeping, for a
129234-- particular weak thread id, a list of ThreadIdS with unique EntryIdS.
130−data ThreadEntry es = ThreadEntry EntryId (ThreadData es)
235+data ThreadEntry es = ThreadEntry !EntryId !(ThreadData es)
131236
132237data ThreadData es
133− = ThreadData EntryId (Weak (ThreadId, Env es)) (ThreadData es)
238+ = ThreadData !EntryId !(Weak (ThreadId, Env es)) (ThreadData es)
134239 | NoThreadData
135240
136241----------------------------------------
effectful-core/src/Effectful/Monad.hs+7−4
@@ -11,10 +11,6 @@ module Effectful.Monad
1111 , IOE
1212 , runEff
1313
14− -- * Primitive actions
15− , Prim
16− , runPrim
17−
1814 -- ** Unlift strategies
1915 , UnliftStrategy(..)
2016 , Persistence(..)
@@ -22,7 +18,14 @@ module Effectful.Monad
2218 , unliftStrategy
2319 , withUnliftStrategy
2420 , withEffToIO
21+
22+ -- * Re-exports
23+ , MonadIO(..)
24+ , MonadUnliftIO(..)
2525 ) where
2626
27+import Control.Monad.IO.Class
28+import Control.Monad.IO.Unlift
29+
2730import Effectful.Internal.Effect
2831import Effectful.Internal.Monad
effectful-core/src/Effectful/Prim.hsnew file+7
@@ -0,0 +1,7 @@
1+-- | Provider of the 'MonadPrim' instance for 'Eff'.
2+module Effectful.Prim
3+ ( Prim
4+ , runPrim
5+ ) where
6+
7+import Effectful.Internal.Monad
effectful-core/src/Effectful/Reader.hs+29−12
@@ -1,4 +1,4 @@
1−-- | The 'Reader' effect.
1+-- | Support for access to a read only value of a particular type.
22module Effectful.Reader
33 ( Reader
44 , runReader
@@ -7,26 +7,43 @@ module Effectful.Reader
77 , local
88 ) where
99
10−import Effectful.Internal.Effect
11−import Effectful.Internal.Monad
10+import Effectful.Dispatch.Static
11+import Effectful.Monad
1212
1313-- | Provide access to a strict (WHNF), thread local, read only value of type
1414-- @r@.
1515newtype Reader r :: Effect where
1616 Reader :: r -> Reader r m a
1717
18−runReader :: r -> Eff (Reader r : es) a -> Eff es a
19−runReader r = evalEffect (IdE (Reader r))
18+-- | Run a 'Reader' effect with the given initial environment.
19+runReader
20+ :: r -- ^ An initial environment.
21+ -> Eff (Reader r : es) a
22+ -> Eff es a
23+runReader r = evalData (DataA (Reader r))
2024
25+-- | Fetch the value of the environment.
2126ask :: Reader r :> es => Eff es r
2227ask = do
23− IdE (Reader r) <- getEffect
28+ DataA (Reader r) <- getData
2429 pure r
2530
26−asks :: Reader r :> es => (r -> a) -> Eff es a
27−asks f = do
28− IdE (Reader r) <- getEffect
29− pure $ f r
31+-- | Retrieve a function of the current environment.
32+--
33+-- @'asks' f ≡ f '<$>' 'ask'@
34+asks
35+ :: Reader r :> es
36+ => (r -> a) -- ^ The function to apply to the environment.
37+ -> Eff es a
38+asks f = f <$> ask
3039
31−local :: Reader r :> es => (r -> r) -> Eff es a -> Eff es a
32−local f = localEffect $ \(IdE (Reader r)) -> IdE (Reader (f r))
40+-- | Execute a computation in a modified environment.
41+--
42+-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@
43+--
44+local
45+ :: Reader r :> es
46+ => (r -> r) -- ^ The function to modify the environment.
47+ -> Eff es a
48+ -> Eff es a
49+local f = localData $ \(DataA (Reader r)) -> DataA (Reader (f r))
effectful-core/src/Effectful/Reader/Dynamic.hs+1−1
@@ -6,7 +6,7 @@ module Effectful.Reader.Dynamic
66 , local
77 ) where
88
9−import Effectful.Handler
9+import Effectful.Dispatch.Dynamic
1010import Effectful.Monad
1111import qualified Effectful.Reader as R
1212
effectful-core/src/Effectful/State/Dynamic.hs+5−16
@@ -1,13 +1,4 @@
11-- | The 'State' effect with dynamic dispatch.
2−--
3−-- It's not clear in which situation it's beneficial to use this instead of
4−-- "Effectful.State.Local" or "Effectful.State.Shared" as you either:
5−--
6−-- - Share state between threads and need the shared version.
7−--
8−-- - Don't share state between threads (or want it to be thread local) and are
9−-- free to use the faster, local version.
10−--
112module Effectful.State.Dynamic
123 ( State(..)
134
@@ -31,17 +22,15 @@ module Effectful.State.Dynamic
3122 , modifyM
3223 ) where
3324
34−import Effectful.Handler
25+import Effectful.Dispatch.Dynamic
3526import Effectful.Monad
3627import qualified Effectful.State.Local as L
3728import qualified Effectful.State.Shared as S
3829
39−-- | Provide access to a mutable state of type @s@.
40−--
41−-- Whether the state is local or shared depends on the interpretation.
30+-- | Provide access to a mutable value of type @s@.
4231data State s :: Effect where
4332 Get :: State s m s
44− Put :: ~s -> State s m ()
33+ Put :: s -> State s m ()
4534 State :: (s -> (a, s)) -> State s m a
4635 StateM :: (s -> m (a, s)) -> State s m a
4736
@@ -59,7 +48,7 @@ execLocalState s0 = reinterpret (L.execState s0) localState
5948
6049localState
6150 :: L.State s :> es
62− => LocalEnv localEs
51+ => LocalEnv localEs es
6352 -> State s (Eff localEs) a
6453 -> Eff es a
6554localState env = \case
@@ -82,7 +71,7 @@ execSharedState s0 = reinterpret (S.execState s0) sharedState
8271
8372sharedState
8473 :: S.State s :> es
85− => LocalEnv localEs
74+ => LocalEnv localEs es
8675 -> State s (Eff localEs) a
8776 -> Eff es a
8877sharedState env = \case
effectful-core/src/Effectful/State/Local.hs+88−24
@@ -1,12 +1,29 @@
1−-- | The 'State' effect.
1+-- | Support for access to a mutable value of a particular type, which is:
22--
3−-- Represented as a pure value underneath, therefore:
4−--
5−-- - thread local (if you need the state to be shared between threads, have a
3+-- - thread local (if you want the value to be shared between threads, have a
64-- look at "Effectful.State.Shared"),
75--
86-- - very fast.
97--
8+-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from
9+-- the @transformers@ library, the 'State' effect doesn't lose state
10+-- modifications when an exception is received:
11+--
12+-- >>> import qualified Control.Monad.Trans.State.Strict as S
13+--
14+-- >>> :{
15+-- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do
16+-- S.modify (++ " there!")
17+-- error "oops"
18+-- :}
19+-- "Hi"
20+--
21+-- >>> :{
22+-- runEff . execState "Hi" . handle (\(_::ErrorCall) -> pure ()) $ do
23+-- modify (++ " there!")
24+-- error "oops"
25+-- :}
26+-- "Hi there!"
1027module Effectful.State.Local
1128 ( State
1229 , runState
@@ -21,47 +38,94 @@ module Effectful.State.Local
2138 , modifyM
2239 ) where
2340
24−import Effectful.Internal.Effect
25−import Effectful.Internal.Monad
41+import Effectful.Dispatch.Static
42+import Effectful.Monad
2643
27−-- | Provide access to a strict (WHNF), thread local, mutable state of type @s@.
44+-- | Provide access to a strict (WHNF), thread local, mutable value of type @s@.
2845newtype State s :: Effect where
2946 State :: s -> State s m r
3047
31−runState :: s -> Eff (State s : es) a -> Eff es (a, s)
48+-- | Run a 'State' effect with the given initial state and return the final
49+-- value along with the final state.
50+runState
51+ :: s -- ^ An initial state.
52+ -> Eff (State s : es) a
53+ -> Eff es (a, s)
3254runState s0 m = do
33− (a, IdE (State s)) <- runEffect (IdE (State s0)) m
55+ (a, DataA (State s)) <- runData (DataA (State s0)) m
3456 pure (a, s)
3557
36−evalState :: s -> Eff (State s : es) a -> Eff es a
37−evalState s = evalEffect (IdE (State s))
58+-- | Run a 'State' effect with the given initial state and return the final
59+-- value, discarding the final state.
60+evalState
61+ :: s -- ^ An initial state.
62+ -> Eff (State s : es) a
63+ -> Eff es a -- ^ A return value.
64+evalState s = evalData (DataA (State s))
3865
39−execState :: s -> Eff (State s : es) a -> Eff es s
66+-- | Run a 'State' effect with the given initial state and return the final
67+-- state, discarding the final value.
68+execState
69+ :: s -- ^ An initial state.
70+ -> Eff (State s : es) a
71+ -> Eff es s
4072execState s0 m = do
41− IdE (State s) <- execEffect (IdE (State s0)) m
73+ DataA (State s) <- execData (DataA (State s0)) m
4274 pure s
4375
76+-- | Fetch the current value of the state.
4477get :: State s :> es => Eff es s
4578get = do
46− IdE (State s) <- getEffect
79+ DataA (State s) <- getData
4780 pure s
4881
49−gets :: State s :> es => (s -> a) -> Eff es a
82+-- | Get a function of the current state.
83+--
84+-- @'gets' f ≡ f '<$>' 'get'@
85+gets
86+ :: State s :> es
87+ => (s -> a) -- ^ The function to apply to the state.
88+ -> Eff es a
5089gets f = f <$> get
5190
91+-- | Set the current state to the given value.
5292put :: State s :> es => s -> Eff es ()
53−put s = putEffect (IdE (State s))
93+put s = putData (DataA (State s))
5494
55−state :: State s :> es => (s -> (a, s)) -> Eff es a
56−state f = stateEffect $ \(IdE (State s0)) -> let (a, s) = f s0 in (a, IdE (State s))
95+-- | Apply the function to the current state and return a value.
96+state
97+ :: State s :> es
98+ => (s -> (a, s)) -- ^ The function to modify the state.
99+ -> Eff es a
100+state f = stateData $ \(DataA (State s0)) -> let (a, s) = f s0 in (a, DataA (State s))
57101
58−modify :: State s :> es => (s -> s) -> Eff es ()
59−modify f = state (\s -> ((), f s))
102+-- | Apply the function to the current state.
103+--
104+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@
105+modify
106+ :: State s :> es
107+ => (s -> s) -- ^ The function to modify the state.
108+ -> Eff es ()
109+modify f = state $ \s -> ((), f s)
60110
61−stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a
62−stateM f = stateEffectM $ \(IdE (State s0)) -> do
111+-- | Apply the monadic function to the current state and return a value.
112+stateM
113+ :: State s :> es
114+ => (s -> Eff es (a, s)) -- ^ The function to modify the state.
115+ -> Eff es a
116+stateM f = stateDataM $ \(DataA (State s0)) -> do
63117 (a, s) <- f s0
64− pure (a, IdE (State s))
118+ pure (a, DataA (State s))
65119
66−modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()
120+-- | Apply the monadic function to the current state.
121+--
122+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@
123+modifyM
124+ :: State s :> es
125+ => (s -> Eff es s) -- ^ The monadic function to modify the state.
126+ -> Eff es ()
67127modifyM f = stateM (\s -> ((), ) <$> f s)
128+
129+-- $setup
130+-- >>> import Control.Exception (ErrorCall)
131+-- >>> import Control.Monad.Catch
effectful-core/src/Effectful/State/Shared.hs+63−15
@@ -1,11 +1,29 @@
1−-- | The 'State' effect.
1+-- | Support for access to a mutable value of a particular type, which is:
22--
3−-- Represented as an 'MVar' underneath, therefore:
3+-- - shared between multiple threads (if you want each thead to manage its own
4+-- version of the value, see "Effectful.State.Local").
45--
5−-- - shareable between multiple threads,
6+-- - slightly slower than "Effectful.State.Local".
67--
7−-- - slower than "Effectful.State.Local".
8+-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from
9+-- the @transformers@ library, the 'State' effect doesn't lose state
10+-- modifications when an exception is received:
811--
12+-- >>> import qualified Control.Monad.Trans.State.Strict as S
13+--
14+-- >>> :{
15+-- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do
16+-- S.modify (++ " there!")
17+-- error "oops"
18+-- :}
19+-- "Hi"
20+--
21+-- >>> :{
22+-- runEff . execState "Hi" . handle (\(_::ErrorCall) -> pure ()) $ do
23+-- modify (++ " there!")
24+-- error "oops"
25+-- :}
26+-- "Hi there!"
927module Effectful.State.Shared
1028 ( State
1129 , runState
@@ -22,58 +40,88 @@ module Effectful.State.Shared
2240
2341import Control.Concurrent.MVar
2442
25−import Effectful.Internal.Effect
26−import Effectful.Internal.Env
27−import Effectful.Internal.Monad
43+import Effectful.Dispatch.Static
44+import Effectful.Monad
2845
29−-- | Provide access to a strict (WHNF), shareable, mutable state of type @s@.
46+-- | Provide access to a strict (WHNF), shared, mutable value of type @s@.
3047newtype State s :: Effect where
3148 State :: MVar s -> State s m r
3249
50+-- | Run a 'State' effect with the given initial state and return the final
51+-- value along with the final state.
3352runState :: s -> Eff (State s : es) a -> Eff es (a, s)
3453runState s m = do
3554 v <- unsafeEff_ $ newMVar s
36− a <- evalEffect (IdE (State v)) m
55+ a <- evalData (DataA (State v)) m
3756 (a, ) <$> unsafeEff_ (readMVar v)
3857
58+-- | Run a 'State' effect with the given initial state and return the final
59+-- value, discarding the final state.
3960evalState :: s -> Eff (State s : es) a -> Eff es a
4061evalState s m = do
4162 v <- unsafeEff_ $ newMVar s
42− evalEffect (IdE (State v)) m
63+ evalData (DataA (State v)) m
4364
65+-- | Run a 'State' effect with the given initial state and return the final
66+-- state, discarding the final value.
4467execState :: s -> Eff (State s : es) a -> Eff es s
4568execState s m = do
4669 v <- unsafeEff_ $ newMVar s
47− _ <- evalEffect (IdE (State v)) m
70+ _ <- evalData (DataA (State v)) m
4871 unsafeEff_ $ readMVar v
4972
73+-- | Fetch the current value of the state.
5074get :: State s :> es => Eff es s
5175get = unsafeEff $ \es -> do
52− IdE (State v) <- getEnv es
76+ DataA (State v) <- getEnv es
5377 readMVar v
5478
79+-- | Get a function of the current state.
80+--
81+-- @'gets' f ≡ f '<$>' 'get'@
5582gets :: State s :> es => (s -> a) -> Eff es a
5683gets f = f <$> get
5784
85+-- | Set the current state to the given value.
5886put :: State s :> es => s -> Eff es ()
5987put s = unsafeEff $ \es -> do
60− IdE (State v) <- getEnv es
88+ DataA (State v) <- getEnv es
6189 modifyMVar_ v $ \_ -> s `seq` pure s
6290
91+-- | Apply the function to the current state and return a value.
92+--
93+-- /Note:/ this function gets an exclusive access to the state for its duration.
6394state :: State s :> es => (s -> (a, s)) -> Eff es a
6495state f = unsafeEff $ \es -> do
65− IdE (State v) <- getEnv es
96+ DataA (State v) <- getEnv es
6697 modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)
6798
99+-- | Apply the function to the current state.
100+--
101+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@
102+--
103+-- /Note:/ this function gets an exclusive access to the state for its duration.
68104modify :: State s :> es => (s -> s) -> Eff es ()
69105modify f = state (\s -> ((), f s))
70106
107+-- | Apply the monadic function to the current state and return a value.
108+--
109+-- /Note:/ this function gets an exclusive access to the state for its duration.
71110stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a
72111stateM f = unsafeEff $ \es -> do
73− IdE (State v) <- getEnv es
112+ DataA (State v) <- getEnv es
74113 modifyMVar v $ \s0 -> do
75114 (a, s) <- unEff (f s0) es
76115 s `seq` pure (s, a)
77116
117+-- | Apply the monadic function to the current state.
118+--
119+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@
120+--
121+-- /Note:/ this function gets an exclusive access to the state for its duration.
78122modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()
79123modifyM f = stateM (\s -> ((), ) <$> f s)
124+
125+-- $setup
126+-- >>> import Control.Exception (ErrorCall)
127+-- >>> import Control.Monad.Catch
effectful-core/src/Effectful/Writer/Dynamic.hs+7−7
@@ -15,13 +15,13 @@ module Effectful.Writer.Dynamic
1515 , listens
1616 ) where
1717
18−import Effectful.Handler
18+import Effectful.Dispatch.Dynamic
1919import Effectful.Monad
2020import qualified Effectful.Writer.Local as L
2121import qualified Effectful.Writer.Shared as S
2222
2323data Writer w :: Effect where
24− Tell :: ~w -> Writer w m ()
24+ Tell :: w -> Writer w m ()
2525 Listen :: m a -> Writer w m (a, w)
2626
2727----------------------------------------
@@ -35,7 +35,7 @@ execLocalWriter = reinterpret L.execWriter localWriter
3535
3636localWriter
3737 :: (L.Writer w :> es, Monoid w)
38− => LocalEnv localEs
38+ => LocalEnv localEs es
3939 -> Writer w (Eff localEs) a
4040 -> Eff es a
4141localWriter env = \case
@@ -53,7 +53,7 @@ execSharedWriter = reinterpret S.execWriter sharedWriter
5353
5454sharedWriter
5555 :: (S.Writer w :> es, Monoid w)
56− => LocalEnv localEs
56+ => LocalEnv localEs es
5757 -> Writer w (Eff localEs) a
5858 -> Eff es a
5959sharedWriter env = \case
@@ -64,19 +64,19 @@ sharedWriter env = \case
6464-- Operations
6565
6666tell
67− :: (HasCallStack, Writer w :> es, Monoid w)
67+ :: (HasCallStack, Writer w :> es)
6868 => w
6969 -> Eff es ()
7070tell = send . Tell
7171
7272listen
73− :: (HasCallStack, Writer w :> es, Monoid w)
73+ :: (HasCallStack, Writer w :> es)
7474 => Eff es a
7575 -> Eff es (a, w)
7676listen = send . Listen
7777
7878listens
79− :: (HasCallStack, Writer w :> es, Monoid w)
79+ :: (HasCallStack, Writer w :> es)
8080 => (w -> b)
8181 -> Eff es a
8282 -> Eff es (a, b)
effectful-core/src/Effectful/Writer/Local.hs+56−10
@@ -1,4 +1,20 @@
1−-- | The 'Writer' effect.
1+-- | Support for access to a write only value of a particular type, which is:
2+--
3+-- - thread local (if you want the value to be shared between threads, have a
4+-- look at "Effectful.Writer.Shared"),
5+--
6+-- - very fast.
7+--
8+-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses
9+-- of '<>', which makes it unsuitable for use with types for which such pattern
10+-- is inefficient. __This applies, in particular, to the standard list type__,
11+-- which makes the 'Writer' effect pretty niche.
12+--
13+-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the
14+-- @transformers@ package includes additional operations
15+-- 'Control.Monad.Trans.Writer.Strict.pass' and
16+-- 'Control.Monad.Trans.Writer.Strict.censor', they don't cooperate with runtime
17+-- exceptions very well, so they're deliberately omitted here.
218module Effectful.Writer.Local
319 ( Writer
420 , runWriter
@@ -8,41 +24,71 @@ module Effectful.Writer.Local
824 , listens
925 ) where
1026
11−import Control.Exception
27+import Control.Exception (onException, mask)
1228
13−import Effectful.Internal.Effect
14−import Effectful.Internal.Env
15−import Effectful.Internal.Monad
29+import Effectful.Dispatch.Static
30+import Effectful.Monad
1631
1732-- | Provide access to a strict (WHNF), thread local, write only value of type
1833-- @w@.
1934newtype Writer w :: Effect where
2035 Writer :: w -> Writer w m r
2136
37+-- | Run a 'Writer' effect and return the final value along with the final
38+-- output.
2239runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
2340runWriter m = do
24− (a, IdE (Writer w)) <- runEffect (IdE (Writer mempty)) m
41+ (a, DataA (Writer w)) <- runData (DataA (Writer mempty)) m
2542 pure (a, w)
2643
44+-- | Run a 'Writer' effect and return the final output, discarding the final
45+-- value.
2746execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
2847execWriter m = do
29− IdE (Writer w) <- execEffect (IdE (Writer mempty)) m
48+ DataA (Writer w) <- execData (DataA (Writer mempty)) m
3049 pure w
3150
51+-- | Append the given output to the overall output of the 'Writer'.
3252tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
33−tell w = stateEffect $ \(IdE (Writer w0)) -> ((), IdE (Writer (w0 <> w)))
53+tell w = stateData $ \(DataA (Writer w0)) -> ((), DataA (Writer (w0 <> w)))
3454
55+-- | Execute an action and append its output to the overall output of the
56+-- 'Writer'.
57+--
58+-- /Note:/ if an exception is received while the action is executed, the partial
59+-- output of the action will still be appended to the overall output of the
60+-- 'Writer':
61+--
62+-- >>> :{
63+-- runEff . execWriter @String $ do
64+-- tell "Hi"
65+-- handle (\(_::ErrorCall) -> pure ((), "")) $ do
66+-- tell " there"
67+-- listen $ do
68+-- tell "!"
69+-- error "oops"
70+-- :}
71+-- "Hi there!"
3572listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
3673listen m = unsafeEff $ \es -> mask $ \restore -> do
37− w0 <- stateEnv es $ \(IdE (Writer w)) -> (w, IdE (Writer mempty))
74+ w0 <- stateEnv es $ \(DataA (Writer w)) -> (w, DataA (Writer mempty))
3875 a <- restore (unEff m es) `onException` merge es w0
3976 (a, ) <$> merge es w0
4077 where
4178 merge es w0 =
4279 -- If an exception is thrown, restore w0 and keep parts of w1.
43− stateEnv es $ \(IdE (Writer w1)) -> (w1, IdE (Writer (w0 <> w1)))
80+ stateEnv es $ \(DataA (Writer w1)) -> (w1, DataA (Writer (w0 <> w1)))
4481
82+-- | Execute an action and append its output to the overall output of the
83+-- 'Writer', then return the final value along with a function of the recorded
84+-- output.
85+--
86+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@
4587listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)
4688listens f m = do
4789 (a, w) <- listen m
4890 pure (a, f w)
91+
92+-- $setup
93+-- >>> import Control.Exception (ErrorCall)
94+-- >>> import Control.Monad.Catch
effectful-core/src/Effectful/Writer/Shared.hs+57−10
@@ -1,3 +1,20 @@
1+-- | Support for access to a write only value of a particular type, which is:
2+--
3+-- - shared between multiple threads (if you want each thead to manage its own
4+-- version of the value, see "Effectful.Writer.Local").
5+--
6+-- - slightly slower than "Effectful.Writer.Local".
7+--
8+-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses
9+-- of '<>', which makes it unsuitable for use with types for which such pattern
10+-- is inefficient. __This applies, in particular, to the standard list type__,
11+-- which makes the 'Writer' effect pretty niche.
12+--
13+-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the
14+-- @transformers@ package includes additional operations
15+-- 'Control.Monad.Trans.Writer.Strict.pass' and
16+-- 'Control.Monad.Trans.Writer.Strict.censor', they don't cooperate with runtime
17+-- exceptions very well, so they're deliberately omitted here.
118module Effectful.Writer.Shared
219 ( Writer
320 , runWriter
@@ -8,33 +25,54 @@ module Effectful.Writer.Shared
825 ) where
926
1027import Control.Concurrent.MVar
11−import Control.Exception
28+import Control.Exception (onException, uninterruptibleMask)
1229
13−import Effectful.Internal.Effect
14−import Effectful.Internal.Env
15−import Effectful.Internal.Monad
30+import Effectful.Dispatch.Static
31+import Effectful.Monad
1632
17−-- | Provide access to a strict (WHNF), shareable, write only value of type @w@.
33+-- | Provide access to a strict (WHNF), shared, write only value of type @w@.
1834newtype Writer w :: Effect where
1935 Writer :: MVar w -> Writer w m r
2036
37+-- | Run a 'Writer' effect and return the final value along with the final
38+-- output.
2139runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
2240runWriter m = do
2341 v <- unsafeEff_ $ newMVar mempty
24− a <- evalEffect (IdE (Writer v)) m
42+ a <- evalData (DataA (Writer v)) m
2543 (a, ) <$> unsafeEff_ (readMVar v)
2644
45+-- | Run a 'Writer' effect and return the final output, discarding the final
46+-- value.
2747execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
2848execWriter m = do
2949 v <- unsafeEff_ $ newMVar mempty
30− _ <- evalEffect (IdE (Writer v)) m
50+ _ <- evalData (DataA (Writer v)) m
3151 unsafeEff_ $ readMVar v
3252
53+-- | Append the given output to the overall output of the 'Writer'.
3354tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
3455tell w1 = unsafeEff $ \es -> do
35− IdE (Writer v) <- getEnv es
56+ DataA (Writer v) <- getEnv es
3657 modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w
3758
59+-- | Execute an action and append its output to the overall output of the
60+-- 'Writer'.
61+--
62+-- /Note:/ if an exception is received while the action is executed, the partial
63+-- output of the action will still be appended to the overall output of the
64+-- 'Writer':
65+--
66+-- >>> :{
67+-- runEff . execWriter @String $ do
68+-- tell "Hi"
69+-- handle (\(_::ErrorCall) -> pure ((), "")) $ do
70+-- tell " there"
71+-- listen $ do
72+-- tell "!"
73+-- error "oops"
74+-- :}
75+-- "Hi there!"
3876listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
3977listen m = unsafeEff $ \es -> do
4078 -- The mask is uninterruptible because modifyMVar_ v0 in the merge function
@@ -43,19 +81,28 @@ listen m = unsafeEff $ \es -> do
4381 uninterruptibleMask $ \restore -> do
4482 v1 <- newMVar mempty
4583 -- Replace thread local MVar with a fresh one for isolated listening.
46− v0 <- stateEnv es $ \(IdE (Writer v)) -> (v, IdE (Writer v1))
84+ v0 <- stateEnv es $ \(DataA (Writer v)) -> (v, DataA (Writer v1))
4785 a <- restore (unEff m es) `onException` merge es v0 v1
4886 (a, ) <$> merge es v0 v1
4987 where
5088 -- Merge results accumulated in the local MVar with the mainline. If an
5189 -- exception was received while listening, merge results recorded so far.
5290 merge es v0 v1 = do
53− putEnv es $ IdE (Writer v0)
91+ putEnv es $ DataA (Writer v0)
5492 w1 <- readMVar v1
5593 modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w
5694 pure w1
5795
96+-- | Execute an action and append its output to the overall output of the
97+-- 'Writer', then return the final value along with a function of the recorded
98+-- output.
99+--
100+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@
58101listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)
59102listens f m = do
60103 (a, w) <- listen m
61104 pure (a, f w)
105+
106+-- $setup
107+-- >>> import Control.Exception (ErrorCall)
108+-- >>> import Control.Monad.Catch
effectful/bench/Concurrency.hs+8−9
@@ -11,8 +11,7 @@ import Test.Tasty.Bench hiding (env)
1111
1212import Control.Concurrent.Async
1313import Control.Monad
14−import Control.Monad.IO.Class
15−import qualified Effectful.Async as A
14+import qualified Effectful.Concurrent.Async as A
1615
1716import Effectful
1817import Utils
@@ -26,7 +25,7 @@ concurrencyBenchmark = bgroup "concurrency"
2625shallowBench :: Int -> Benchmark
2726shallowBench n = bgroup ("unmask " ++ show n ++ "x")
2827 [ bench "async (IO)" $ nfAppIO (asyncBenchIO n) op
29− , bench "async (Eff)" $ nfAppIO (runShallow . A.runAsyncE . asyncBench n) op
28+ , bench "async (Eff)" $ nfAppIO (runShallow . A.runConcurrent . asyncBench n) op
3029 , bench "Fork (localUnliftIO/withLiftMapIO)" $
3130 nfAppIO (runShallow . runFork1 . forkBench n) op
3231 , bench "Fork (localUnlift/withLiftMap)" $
@@ -39,7 +38,7 @@ shallowBench n = bgroup ("unmask " ++ show n ++ "x")
3938
4039deepBench :: Int -> Benchmark
4140deepBench n = bgroup ("unmask " ++ show n ++ "x")
42− [ bench "async (Eff)" $ nfAppIO (runDeep . A.runAsyncE . asyncBench n) op
41+ [ bench "async (Eff)" $ nfAppIO (runDeep . A.runConcurrent . asyncBench n) op
4342 , bench "Fork (localUnliftIO/withLiftMapIO)" $
4443 nfAppIO (runDeep . runFork1 . forkBench n) op
4544 , bench "Fork (localUnlift/withLiftMap)" $
@@ -61,14 +60,14 @@ data Fork :: Effect where
6160-- | Uses 'localUnliftIO' and 'withLiftMapIO'.
6261runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a
6362runFork1 = interpret $ \env -> \case
64− ForkWithUnmask m -> withLiftMapIO $ \liftMap -> do
63+ ForkWithUnmask m -> withLiftMapIO env $ \liftMap -> do
6564 localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
6665 asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
6766
6867-- | Uses 'localUnlift' and 'withLiftMap'.
6968runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a
70−runFork2 = reinterpret A.runAsyncE $ \env -> \case
71− ForkWithUnmask m -> withLiftMap $ \liftMap -> do
69+runFork2 = reinterpret A.runConcurrent $ \env -> \case
70+ ForkWithUnmask m -> withLiftMap env $ \liftMap -> do
7271 localUnlift env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
7372 A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
7473
@@ -81,7 +80,7 @@ runFork3 = interpret $ \env -> \case
8180
8281-- | Uses 'localLiftUnlift'.
8382runFork4 :: IOE :> es => Eff (Fork : es) a -> Eff es a
84−runFork4 = reinterpret A.runAsyncE $ \env -> \case
83+runFork4 = reinterpret A.runConcurrent $ \env -> \case
8584 ForkWithUnmask m -> do
8685 localLiftUnlift env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do
8786 A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift
@@ -95,7 +94,7 @@ asyncBenchIO n f = do
9594 wait a
9695{-# NOINLINE asyncBenchIO #-}
9796
98−asyncBench :: A.AsyncE :> es => Int -> Eff es Int -> Eff es Int
97+asyncBench :: A.Concurrent :> es => Int -> Eff es Int -> Eff es Int
9998asyncBench n f = do
10099 a <- A.asyncWithUnmask $ \unmask -> do
101100 sum <$> replicateM n (unmask f)
effectful/bench/Main.hs+3−3
@@ -97,11 +97,11 @@ filesize n = bgroup (show n)
9797#ifdef VERSION_eff
9898 , bench "eff" $ nfAppIO eff_calculateFileSizesDeep (take n files)
9999#endif
100−#ifdef VERSION_polysemy
101− , bench "polysemy" $ nfAppIO poly_calculateFileSizesDeep (take n files)
102−#endif
103100#ifdef VERSION_mtl
104101 , bench "mtl" $ nfAppIO mtl_calculateFileSizesDeep (take n files)
102+#endif
103+#ifdef VERSION_polysemy
104+ , bench "polysemy" $ nfAppIO poly_calculateFileSizesDeep (take n files)
105105#endif
106106 ]
107107 ]
effectful/bench/Unlift.hs+14−14
@@ -9,12 +9,12 @@ import Criterion
99import Test.Tasty.Bench
1010#endif
1111
12−import UnliftIO
12+import qualified UnliftIO as U
1313
1414import Effectful
1515import Effectful.State.Dynamic
1616import Utils
17−import qualified Effectful.Async as A
17+import qualified Effectful.Concurrent.Async as A
1818
1919unliftBenchmark :: Benchmark
2020unliftBenchmark = bgroup "unlifting"
@@ -29,7 +29,7 @@ unliftBenchmark = bgroup "unlifting"
2929 , bench "seq" $ nfAppIO runShallow benchDummy
3030 , shallowConc "conc" 1 benchDummyE benchDummy
3131 ]
32− , shallowConc "async" 1 benchAsyncE benchAsync
32+ , shallowConc "async" 1 benchAsyncEff benchAsync
3333 , shallowConc "concurrently" 2 benchConcurrentlyE benchConcurrently
3434 ]
3535 , bgroup "deep"
@@ -38,7 +38,7 @@ unliftBenchmark = bgroup "unlifting"
3838 , bench "seq" $ nfAppIO runDeep benchDummy
3939 , deepConc "conc" 1 benchDummyE benchDummy
4040 ]
41− , deepConc "async" 1 benchAsyncE benchAsync
41+ , deepConc "async" 1 benchAsyncEff benchAsync
4242 , deepConc "concurrently" 2 benchConcurrentlyE benchConcurrently
4343 ]
4444 ]
@@ -48,11 +48,11 @@ unliftBenchmark = bgroup "unlifting"
4848shallowConc
4949 :: String
5050 -> Int
51− -> Eff '[A.AsyncE, IOE] ()
51+ -> Eff '[A.Concurrent, IOE] ()
5252 -> Eff '[IOE] ()
5353 -> Benchmark
5454shallowConc name n r f = bgroup name
55− [ bench "AsyncE" $ nfAppIO (runShallow . A.runAsyncE) r
55+ [ bench "Async" $ nfAppIO (runShallow . A.runConcurrent) r
5656 , bench "ephemeral/limited" $ nfAppIO
5757 (runShallow . withUnliftStrategy (ConcUnlift Ephemeral $ Limited n)) f
5858 , bench "ephemeral/unlimited" $ nfAppIO
@@ -66,7 +66,7 @@ shallowConc name n r f = bgroup name
6666deepConc
6767 :: String
6868 -> Int
69− -> Eff '[ A.AsyncE
69+ -> Eff '[ A.Concurrent
7070 , State (), State (), State (), State (), State ()
7171 , State (), State (), State (), State (), State ()
7272 , IOE] ()
@@ -75,7 +75,7 @@ deepConc
7575 , IOE] ()
7676 -> Benchmark
7777deepConc name n r f = bgroup name
78− [ bench "AsyncE" $ nfAppIO (runDeep . A.runAsyncE) r
78+ [ bench "Async" $ nfAppIO (runDeep . A.runConcurrent) r
7979 , bench "ephemeral/limited" $ nfAppIO
8080 (runDeep . withUnliftStrategy (ConcUnlift Ephemeral $ Limited n)) f
8181 , bench "ephemeral/unlimited" $ nfAppIO
@@ -92,19 +92,19 @@ benchDummy :: MonadUnliftIO m => m ()
9292benchDummy = withRunInIO $ \runIO -> runIO $ pure ()
9393
9494benchAsync :: MonadUnliftIO m => m ()
95−benchAsync = withAsync (pure ()) wait
95+benchAsync = U.withAsync (pure ()) U.wait
9696
9797benchConcurrently :: MonadUnliftIO m => m ()
98−benchConcurrently = concurrently_ (pure ()) (pure ())
98+benchConcurrently = U.concurrently_ (pure ()) (pure ())
9999
100100benchDummyE :: Eff es ()
101101benchDummyE = pure ()
102102{-# NOINLINE benchDummyE #-}
103103
104−benchAsyncE :: A.AsyncE :> es => Eff es ()
105−benchAsyncE = A.withAsync (pure ()) A.wait
106−{-# NOINLINE benchAsyncE #-}
104+benchAsyncEff :: A.Concurrent :> es => Eff es ()
105+benchAsyncEff = A.withAsync (pure ()) A.wait
106+{-# NOINLINE benchAsyncEff #-}
107107
108−benchConcurrentlyE :: A.AsyncE :> es => Eff es ()
108+benchConcurrentlyE :: A.Concurrent :> es => Eff es ()
109109benchConcurrentlyE = A.concurrently_ (pure ()) (pure ())
110110{-# NOINLINE benchConcurrentlyE #-}
effectful/effectful.cabal+44−25
@@ -1,7 +1,7 @@
11cabal-version: 2.4
22build-type: Simple
33name: effectful
4−version: 0.0.0.0
4+version: 0.1
55license: BSD-3-Clause
66license-file: LICENSE
77category: Control
@@ -10,16 +10,17 @@ author: Andrzej Rybczak
1010synopsis: An easy to use, performant extensible effects library.
1111
1212description: An easy to use, performant extensible effects library with seamless
13− integration with the existing Haskell ecosystem.
13+ integration with the existing Haskell ecosystem. See the main
14+ module "Effectful" for the documentation.
1415 .
15− This is the "batteries included" variant; See the
16− @<https://hackage.haskell.org/package/effectful-core effectful-core>@
17− package for the effect system itself as well as the various other
18− @effectful-*@ packages if you need a smaller dependency footprint.
16+ This is the "batteries-included" variant with many dependencies;
17+ See the @<https://hackage.haskell.org/package/effectful-core
18+ effectful-core>@ package and other @effectful-*@ packages if you
19+ need a more limited dependency footprint.
1920
2021extra-source-files: CHANGELOG.md
2122
22−tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210422
23+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1
2324
2425bug-reports: https://github.com/arybczak/effectful/issues
2526source-repository head
@@ -39,6 +40,7 @@ common language
3940 ConstraintKinds
4041 DataKinds
4142 DeriveFunctor
43+ DeriveGeneric
4244 FlexibleContexts
4345 FlexibleInstances
4446 GADTs
@@ -51,7 +53,6 @@ common language
5153 RoleAnnotations
5254 ScopedTypeVariables
5355 StandaloneDeriving
54− StrictData
5556 TupleSections
5657 TypeApplications
5758 TypeFamilies
@@ -60,30 +61,44 @@ common language
6061library
6162 import: language
6263
63− ghc-options: -O2
64−
65− build-depends: base >= 4.13 && <5
66− , async
67− , effectful-core
68− , resourcet
69− , unliftio
64+ build-depends: base >= 4.13 && < 5
65+ , async >= 2.2.2
66+ , directory >= 1.3.2
67+ , effectful-core >= 0.1 && < 0.1.1
68+ , process >= 1.6.9
69+ , resourcet >= 1.2.4.3
70+ , time >= 1.9.2
71+ , stm >= 2.5.0.0
72+ , unliftio >= 0.2.20
7073
7174 hs-source-dirs: src
7275
73− exposed-modules: Effectful
74− Effectful.Async
76+ exposed-modules: Effectful.Concurrent
77+ Effectful.Concurrent.Async
78+ Effectful.Concurrent.Chan
79+ Effectful.Concurrent.MVar
80+ Effectful.Concurrent.STM
81+ Effectful.Concurrent.QSem
82+ Effectful.Concurrent.QSemN
83+ Effectful.Environment
84+ Effectful.FileSystem
85+ Effectful.FileSystem.IO
86+ Effectful.Process
7587 Effectful.Resource
88+ Effectful.Temporary
89+ Effectful.Timeout
7690
77− reexported-modules: Effectful.Error
91+ other-modules: Effectful.Concurrent.Effect
92+ Effectful.FileSystem.Effect
93+
94+ reexported-modules: Effectful
95+ , Effectful.Dispatch.Dynamic
96+ , Effectful.Dispatch.Static
97+ , Effectful.Error
7898 , Effectful.Error.Dynamic
7999 , Effectful.Fail
80− , Effectful.Handler
81− , Effectful.Internal.Effect
82− , Effectful.Internal.Env
83− , Effectful.Internal.Monad
84− , Effectful.Internal.Unlift
85− , Effectful.Internal.Utils
86100 , Effectful.Monad
101+ , Effectful.Prim
87102 , Effectful.Reader
88103 , Effectful.Reader.Dynamic
89104 , Effectful.State.Dynamic
@@ -101,6 +116,7 @@ test-suite test
101116 build-depends: base
102117 , containers
103118 , effectful
119+ , effectful-core
104120 , exceptions
105121 , lifted-base
106122 , tasty
@@ -114,8 +130,11 @@ test-suite test
114130
115131 other-modules: AsyncTests
116132 ConcurrencyTests
133+ EnvironmentTests
117134 ErrorTests
118135 StateTests
136+ TimeoutTests
137+ UnliftTests
119138 Utils
120139 -- These are examples; We do not actually run them but list
121140 -- them here in order to check if they compile.
@@ -135,7 +154,7 @@ benchmark bench
135154 if impl(ghc < 9.2)
136155 build-depends: fused-effects
137156
138− if impl(ghc < 9.2)
157+ if impl(ghc < 9.3)
139158 build-depends: polysemy
140159
141160 build-depends: base
effectful/examples/FileSystem.hs−1
@@ -9,7 +9,6 @@ module FileSystem
99
1010import Control.Exception (IOException)
1111import Control.Monad.Catch
12−import Control.Monad.IO.Class
1312import Prelude hiding (readFile, writeFile)
1413import qualified Data.Map.Strict as M
1514import qualified System.IO as IO
effectful/src/Effectful/Concurrent.hsnew file+218
@@ -0,0 +1,218 @@
1+-- | Lifted version of "Control.Concurrent".
2+--
3+-- For functions that spawn threads, the order of preference for their usage is
4+-- recommended as follows:
5+--
6+-- 1) High level functions from "Effectful.Concurrent.Async" such as
7+-- 'Effectful.Concurrent.Async.withAsync',
8+-- 'Effectful.Concurrent.Async.concurrently' or
9+-- 'Effectful.Concurrent.Async.mapConcurrently'.
10+--
11+-- 2) Low level functions from "Effectful.Concurrent.Async" such as
12+-- 'Effectful.Concurrent.Async.async'.
13+--
14+-- 3) Low level functions from "Effectful.Concurrent" such as 'forkIO'.
15+module Effectful.Concurrent
16+ ( Concurrent
17+ , runConcurrent
18+
19+ -- * Basic concurrency operations
20+ , myThreadId
21+ , forkIO
22+ , forkFinally
23+ , forkIOWithUnmask
24+ , killThread
25+ , throwTo
26+
27+ -- ** Threads with affinity
28+ , forkOn
29+ , forkOnWithUnmask
30+ , getNumCapabilities
31+ , setNumCapabilities
32+ , getNumProcessors
33+ , threadCapability
34+
35+ -- * Scheduling
36+ , yield
37+
38+ -- ** Waiting
39+ , threadDelay
40+ , threadWaitRead
41+ , threadWaitWrite
42+ , threadWaitReadSTM
43+ , threadWaitWriteSTM
44+
45+ -- * Bound threads
46+ , forkOS
47+ , forkOSWithUnmask
48+ , isCurrentThreadBound
49+ , runInBoundThread
50+ , runInUnboundThread
51+
52+ -- * Weak references to ThreadIds
53+ , mkWeakThreadId
54+
55+ -- * Re-exports
56+ , C.rtsSupportsBoundThreads
57+ ) where
58+
59+import Control.Exception (Exception, SomeException)
60+import Data.Bifunctor (second)
61+import System.Mem.Weak (Weak)
62+import System.Posix.Types (Fd)
63+import UnliftIO.STM (STM)
64+import qualified Control.Concurrent as C
65+import qualified GHC.Conc as GHC
66+
67+import Effectful.Concurrent.Effect
68+import Effectful.Dispatch.Static
69+import Effectful.Monad
70+
71+----------------------------------------
72+-- Basic concurrency operations
73+
74+-- | Lifted 'C.myThreadId'.
75+myThreadId :: Concurrent :> es => Eff es C.ThreadId
76+myThreadId = unsafeEff_ C.myThreadId
77+
78+-- | Lifted 'C.forkIO'.
79+forkIO :: Concurrent :> es => Eff es () -> Eff es C.ThreadId
80+forkIO k = unsafeEff $ \es -> do
81+ esF <- cloneEnv es
82+ C.forkIO $ unEff k esF
83+
84+-- | Lifted 'C.forkFinally'.
85+forkFinally
86+ :: Concurrent :> es
87+ => Eff es a
88+ -> (Either SomeException a -> Eff es ())
89+ -> Eff es C.ThreadId
90+forkFinally k cleanup = unsafeEff $ \es -> do
91+ esF <- cloneEnv es
92+ C.forkFinally (unEff k esF) ((`unEff` esF) . cleanup)
93+
94+-- | Lifted 'C.forkIOWithUnmask'.
95+forkIOWithUnmask
96+ :: Concurrent :> es
97+ => ((forall a es'. IOE :> es' => Eff es' a -> Eff es' a)
98+ -> Eff es ())
99+ -> Eff es C.ThreadId
100+forkIOWithUnmask f = unsafeEff $ \es -> do
101+ esF <- cloneEnv es
102+ C.forkIOWithUnmask (\restore -> unEff (f (unsafeLiftMapIO restore)) esF)
103+
104+-- | Lifted 'C.killThread'.
105+killThread :: Concurrent :> es => C.ThreadId -> Eff es ()
106+killThread = unsafeEff_ . C.killThread
107+
108+-- | Lifted 'C.throwTo'.
109+throwTo :: (Concurrent :> es, Exception e) => C.ThreadId -> e -> Eff es ()
110+throwTo tid = unsafeEff_ . C.throwTo tid
111+
112+----------------------------------------
113+-- Threads with affinity
114+
115+-- | Lifted 'C.forkOn'.
116+forkOn :: Concurrent :> es => Int -> Eff es () -> Eff es C.ThreadId
117+forkOn n k = unsafeEff $ \es -> do
118+ esF <- cloneEnv es
119+ C.forkOn n (unEff k esF)
120+
121+-- | Lifted 'C.forkOnWithUnmask'.
122+forkOnWithUnmask
123+ :: Concurrent :> es
124+ => Int
125+ -> ((forall a es'. IOE :> es' => Eff es' a -> Eff es' a) -> Eff es ())
126+ -> Eff es C.ThreadId
127+forkOnWithUnmask n f = unsafeEff $ \es -> do
128+ esF <- cloneEnv es
129+ C.forkOnWithUnmask n (\restore -> unEff (f (unsafeLiftMapIO restore)) esF)
130+
131+-- | Lifted 'C.getNumCapabilities'.
132+getNumCapabilities :: Concurrent :> es => Eff es Int
133+getNumCapabilities = unsafeEff_ C.getNumCapabilities
134+
135+-- | Lifted 'C.setNumCapabilities'.
136+setNumCapabilities :: Concurrent :> es => Int -> Eff es ()
137+setNumCapabilities = unsafeEff_ . C.setNumCapabilities
138+
139+-- | Lifted 'GHC.getNumProcessors'.
140+getNumProcessors :: Concurrent :> es => Eff es Int
141+getNumProcessors = unsafeEff_ GHC.getNumProcessors
142+
143+-- | Lifted 'C.threadCapability'.
144+threadCapability :: Concurrent :> es => C.ThreadId -> Eff es (Int, Bool)
145+threadCapability = unsafeEff_ . C.threadCapability
146+
147+----------------------------------------
148+-- Scheduling
149+
150+-- | Lifted 'C.yield'.
151+yield :: Concurrent :> es => Eff es ()
152+yield = unsafeEff_ C.yield
153+
154+----------------------------------------
155+-- Waiting
156+
157+-- | Lifted 'C.threadDelay'.
158+threadDelay :: Concurrent :> es => Int -> Eff es ()
159+threadDelay = unsafeEff_ . C.threadDelay
160+
161+-- | Lifted 'C.threadWaitRead'.
162+threadWaitRead :: Concurrent :> es => Fd -> Eff es ()
163+threadWaitRead = unsafeEff_ . C.threadWaitRead
164+
165+-- | Lifted 'C.threadWaitWrite'.
166+threadWaitWrite :: Concurrent :> es => Fd -> Eff es ()
167+threadWaitWrite = unsafeEff_ . C.threadWaitWrite
168+
169+-- | Lifted 'C.threadWaitReadSTM'.
170+threadWaitReadSTM :: Concurrent :> es => Fd -> Eff es (STM (), Eff es ())
171+threadWaitReadSTM fd = unsafeEff_ $ do
172+ second unsafeEff_ <$> C.threadWaitReadSTM fd
173+
174+-- | Lifted 'C.threadWaitWriteSTM'.
175+threadWaitWriteSTM :: Concurrent :> es => Fd -> Eff es (STM (), Eff es ())
176+threadWaitWriteSTM fd = unsafeEff_ $ do
177+ second unsafeEff_ <$> C.threadWaitWriteSTM fd
178+
179+----------------------------------------
180+-- Bound threads
181+
182+-- | Lifted 'C.forkOS'.
183+forkOS :: Concurrent :> es => Eff es () -> Eff es C.ThreadId
184+forkOS k = unsafeEff $ \es -> do
185+ esF <- cloneEnv es
186+ C.forkOS $ unEff k esF
187+
188+-- | Lifted 'E.forkOSWithUnmask'.
189+forkOSWithUnmask
190+ :: Concurrent :> es
191+ => ((forall a es'. IOE :> es' => Eff es' a -> Eff es' a) -> Eff es ())
192+ -> Eff es C.ThreadId
193+forkOSWithUnmask f = unsafeEff $ \es -> do
194+ esF <- cloneEnv es
195+ C.forkOSWithUnmask (\restore -> unEff (f (unsafeLiftMapIO restore)) esF)
196+
197+-- | Lifted 'C.isCurrentThreadBound'.
198+isCurrentThreadBound :: Concurrent :> es => Eff es Bool
199+isCurrentThreadBound = unsafeEff_ C.isCurrentThreadBound
200+
201+-- | Lifted 'C.runInBoundThread'.
202+runInBoundThread :: Concurrent :> es => Eff es a -> Eff es a
203+runInBoundThread k = unsafeEff $ \es -> do
204+ esF <- cloneEnv es
205+ C.runInBoundThread $ unEff k esF
206+
207+-- | Lifted 'C.runInUnboundThread'.
208+runInUnboundThread :: Concurrent :> es => Eff es a -> Eff es a
209+runInUnboundThread k = unsafeEff $ \es -> do
210+ esF <- cloneEnv es
211+ C.runInUnboundThread $ unEff k esF
212+
213+----------------------------------------
214+-- Weak references to ThreadIds
215+
216+-- | Lifted 'C.mkWeakThreadId'.
217+mkWeakThreadId :: Concurrent :> es => C.ThreadId -> Eff es (Weak C.ThreadId)
218+mkWeakThreadId = unsafeEff_ . C.mkWeakThreadId
effectful/src/Effectful/Async.hs → effectful/src/Effectful/Concurrent/Async.hsrenamed+72−89
@@ -1,8 +1,8 @@
11{-# LANGUAGE UndecidableInstances #-}
2−module Effectful.Async
3− ( -- * Async effect
4− AsyncE
5− , runAsyncE
2+-- | Lifted version of "Control.Concurrent.Async".
3+module Effectful.Concurrent.Async
4+ ( Concurrent
5+ , runConcurrent
66
77 -- * Asynchronous actions
88 , Async
@@ -76,52 +76,37 @@ import Control.Concurrent (threadDelay)
7676import Control.Concurrent.Async (Async)
7777import Control.Exception (Exception, SomeException)
7878import Control.Monad (forever)
79−import Data.Kind
79+import Data.Kind (Type)
8080import qualified Control.Concurrent.Async as A
8181import qualified UnliftIO.Async as U
8282import qualified UnliftIO.Internals.Async as I
8383
84−import Effectful.Internal.Effect
85−import Effectful.Internal.Env
86−import Effectful.Internal.Monad
87−
88−-- | Run 'Eff' operations asynchronously via the @async@ library.
89−--
90−-- /Note:/ thread local state changes in 'Eff' operations run asynchronously
91−-- will not affect the parent thread.
92−--
93−-- /TODO:/ write about 'AsyncE' not respecting scoped operations.
94−data AsyncE :: Effect where
95− AsyncE :: AsyncE m r
96−
97−runAsyncE :: IOE :> es => Eff (AsyncE : es) a -> Eff es a
98−runAsyncE = evalEffect (IdE AsyncE)
99−
100−----------------------------------------
101−-- Operations
84+import Effectful.Concurrent.Effect
85+import Effectful.Dispatch.Static
86+import Effectful.Monad
10287
10388-- | Lifted 'A.async'.
104−async :: AsyncE :> es => Eff es a -> Eff es (Async a)
89+async :: Concurrent :> es => Eff es a -> Eff es (Async a)
10590async = liftAsync A.async
10691
10792-- | Lifted 'A.asyncBound'.
108−asyncBound :: AsyncE :> es => Eff es a -> Eff es (Async a)
93+asyncBound :: Concurrent :> es => Eff es a -> Eff es (Async a)
10994asyncBound = liftAsync A.asyncBound
11095
11196-- | Lifted 'A.asyncOn'.
112−asyncOn :: AsyncE :> es => Int -> Eff es a -> Eff es (Async a)
97+asyncOn :: Concurrent :> es => Int -> Eff es a -> Eff es (Async a)
11398asyncOn cpu = liftAsync (A.asyncOn cpu)
11499
115100-- | Lifted 'A.asyncWithUnmask'.
116101asyncWithUnmask
117− :: AsyncE :> es
102+ :: Concurrent :> es
118103 => ((forall b. Eff es b -> Eff es b) -> Eff es a)
119104 -> Eff es (Async a)
120105asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask
121106
122107-- | Lifted 'A.asyncOnWithUnmask'.
123108asyncOnWithUnmask
124− :: AsyncE :> es
109+ :: Concurrent :> es
125110 => Int
126111 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)
127112 -> Eff es (Async a)
@@ -129,7 +114,7 @@ asyncOnWithUnmask cpu = liftAsyncWithUnmask (A.asyncOnWithUnmask cpu)
129114
130115-- | Lifted 'A.withAsync'.
131116withAsync
132− :: AsyncE :> es
117+ :: Concurrent :> es
133118 => Eff es a
134119 -> (Async a -> Eff es b)
135120 -> Eff es b
@@ -137,7 +122,7 @@ withAsync = liftWithAsync A.withAsync
137122
138123-- | Lifted 'A.withAsyncBound'.
139124withAsyncBound
140− :: AsyncE :> es
125+ :: Concurrent :> es
141126 => Eff es a
142127 -> (Async a -> Eff es b)
143128 -> Eff es b
@@ -145,7 +130,7 @@ withAsyncBound = liftWithAsync A.withAsyncBound
145130
146131-- | Lifted 'A.withAsyncOn'.
147132withAsyncOn
148− :: AsyncE :> es
133+ :: Concurrent :> es
149134 => Int
150135 -> Eff es a
151136 -> (Async a -> Eff es b)
@@ -154,7 +139,7 @@ withAsyncOn cpu = liftWithAsync (A.withAsyncOn cpu)
154139
155140-- | Lifted 'A.withAsyncWithUnmask'.
156141withAsyncWithUnmask
157− :: AsyncE :> es
142+ :: Concurrent :> es
158143 => ((forall c. Eff es c -> Eff es c) -> Eff es a)
159144 -> (Async a -> Eff es b)
160145 -> Eff es b
@@ -162,7 +147,7 @@ withAsyncWithUnmask = liftWithAsyncWithUnmask A.withAsyncWithUnmask
162147
163148-- | Lifted 'A.withAsyncOnWithUnmask'.
164149withAsyncOnWithUnmask
165− :: AsyncE :> es
150+ :: Concurrent :> es
166151 => Int
167152 -> ((forall c. Eff es c -> Eff es c) -> Eff es a)
168153 -> (Async a -> Eff es b)
@@ -170,60 +155,60 @@ withAsyncOnWithUnmask
170155withAsyncOnWithUnmask cpu = liftWithAsyncWithUnmask (A.withAsyncOnWithUnmask cpu)
171156
172157-- | Lifted 'A.wait'.
173−wait :: AsyncE :> es => Async a -> Eff es a
158+wait :: Concurrent :> es => Async a -> Eff es a
174159wait = unsafeEff_ . A.wait
175160
176161-- | Lifted 'A.poll'.
177162poll
178− :: AsyncE :> es
163+ :: Concurrent :> es
179164 => Async a
180165 -> Eff es (Maybe (Either SomeException a))
181166poll = unsafeEff_ . A.poll
182167
183168-- | Lifted 'A.cancel'.
184−cancel :: AsyncE :> es => Async a -> Eff es ()
169+cancel :: Concurrent :> es => Async a -> Eff es ()
185170cancel = unsafeEff_ . A.cancel
186171
187172-- | Lifted 'A.cancelWith'.
188−cancelWith :: (Exception e, AsyncE :> es) => Async a -> e -> Eff es ()
173+cancelWith :: (Exception e, Concurrent :> es) => Async a -> e -> Eff es ()
189174cancelWith a = unsafeEff_ . A.cancelWith a
190175
191176-- | Lifted 'A.uninterruptibleCancel'.
192−uninterruptibleCancel :: AsyncE :> es => Async a -> Eff es ()
177+uninterruptibleCancel :: Concurrent :> es => Async a -> Eff es ()
193178uninterruptibleCancel = unsafeEff_ . A.uninterruptibleCancel
194179
195180-- | Lifted 'A.waitCatch'.
196181waitCatch
197− :: AsyncE :> es
182+ :: Concurrent :> es
198183 => Async a
199184 -> Eff es (Either SomeException a)
200185waitCatch = unsafeEff_ . A.waitCatch
201186
202187-- | Lifted 'A.waitAny'.
203−waitAny :: AsyncE :> es => [Async a] -> Eff es (Async a, a)
188+waitAny :: Concurrent :> es => [Async a] -> Eff es (Async a, a)
204189waitAny = unsafeEff_ . A.waitAny
205190
206191-- | Lifted 'A.waitAnyCatch'.
207192waitAnyCatch
208− :: AsyncE :> es
193+ :: Concurrent :> es
209194 => [Async a]
210195 -> Eff es (Async a, Either SomeException a)
211196waitAnyCatch = unsafeEff_ . A.waitAnyCatch
212197
213198-- | Lifted 'A.waitAnyCancel'.
214−waitAnyCancel :: AsyncE :> es => [Async a] -> Eff es (Async a, a)
199+waitAnyCancel :: Concurrent :> es => [Async a] -> Eff es (Async a, a)
215200waitAnyCancel = unsafeEff_ . A.waitAnyCancel
216201
217202-- | Lifted 'A.waitAnyCatchCancel'.
218203waitAnyCatchCancel
219− :: AsyncE :> es
204+ :: Concurrent :> es
220205 => [Async a]
221206 -> Eff es (Async a, Either SomeException a)
222207waitAnyCatchCancel = unsafeEff_ . A.waitAnyCatchCancel
223208
224209-- | Lifted 'A.waitEither'.
225210waitEither
226− :: AsyncE :> es
211+ :: Concurrent :> es
227212 => Async a
228213 -> Async b
229214 -> Eff es (Either a b)
@@ -231,7 +216,7 @@ waitEither a b = unsafeEff_ $ A.waitEither a b
231216
232217-- | Lifted 'A.waitEitherCatch'.
233218waitEitherCatch
234− :: AsyncE :> es
219+ :: Concurrent :> es
235220 => Async a
236221 -> Async b
237222 -> Eff es (Either (Either SomeException a) (Either SomeException b))
@@ -239,7 +224,7 @@ waitEitherCatch a b = unsafeEff_ $ A.waitEitherCatch a b
239224
240225-- | Lifted 'A.waitEitherCancel'.
241226waitEitherCancel
242− :: AsyncE :> es
227+ :: Concurrent :> es
243228 => Async a
244229 -> Async b
245230 -> Eff es (Either a b)
@@ -247,53 +232,53 @@ waitEitherCancel a b = unsafeEff_ $ A.waitEitherCancel a b
247232
248233-- | Lifted 'A.waitEitherCatchCancel'.
249234waitEitherCatchCancel
250− :: AsyncE :> es
235+ :: Concurrent :> es
251236 => Async a
252237 -> Async b
253238 -> Eff es (Either (Either SomeException a) (Either SomeException b))
254239waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatch a b
255240
256241-- | Lifted 'A.waitEither_'.
257−waitEither_ :: AsyncE :> es => Async a -> Async b -> Eff es ()
242+waitEither_ :: Concurrent :> es => Async a -> Async b -> Eff es ()
258243waitEither_ a b = unsafeEff_ $ A.waitEither_ a b
259244
260245-- | Lifted 'A.waitBoth'.
261−waitBoth :: AsyncE :> es => Async a -> Async b -> Eff es (a, b)
246+waitBoth :: Concurrent :> es => Async a -> Async b -> Eff es (a, b)
262247waitBoth a b = unsafeEff_ $ A.waitBoth a b
263248
264249-- | Lifted 'A.link'.
265−link :: AsyncE :> es => Async a -> Eff es ()
250+link :: Concurrent :> es => Async a -> Eff es ()
266251link = unsafeEff_ . A.link
267252
268253-- | Lifted 'A.linkOnly'.
269−linkOnly :: AsyncE :> es => (SomeException -> Bool) -> Async a -> Eff es ()
254+linkOnly :: Concurrent :> es => (SomeException -> Bool) -> Async a -> Eff es ()
270255linkOnly f = unsafeEff_ . A.linkOnly f
271256
272257-- | Lifted 'A.link2'.
273−link2 :: AsyncE :> es => Async a -> Async b -> Eff es ()
258+link2 :: Concurrent :> es => Async a -> Async b -> Eff es ()
274259link2 a b = unsafeEff_ $ A.link2 a b
275260
276261-- | Lifted 'A.link2Only'.
277−link2Only :: AsyncE :> es => (SomeException -> Bool) -> Async a -> Async b -> Eff es ()
262+link2Only :: Concurrent :> es => (SomeException -> Bool) -> Async a -> Async b -> Eff es ()
278263link2Only f a b = unsafeEff_ $ A.link2Only f a b
279264
280265-- | Lifted 'A.race'.
281−race :: AsyncE :> es => Eff es a -> Eff es b -> Eff es (Either a b)
266+race :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (Either a b)
282267race ma mb = unsafeEff $ \es -> do
283268 A.race (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)
284269
285270-- | Lifted 'A.race_'.
286−race_ :: AsyncE :> es => Eff es a -> Eff es b -> Eff es ()
271+race_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es ()
287272race_ ma mb = unsafeEff $ \es -> do
288273 A.race_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)
289274
290275-- | Lifted 'A.concurrently'.
291−concurrently :: AsyncE :> es => Eff es a -> Eff es b -> Eff es (a, b)
276+concurrently :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (a, b)
292277concurrently ma mb = unsafeEff $ \es -> do
293278 A.concurrently (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)
294279
295280-- | Lifted 'A.concurrently_'.
296−concurrently_ :: AsyncE :> es => Eff es a -> Eff es b -> Eff es ()
281+concurrently_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es ()
297282concurrently_ ma mb = unsafeEff $ \es -> do
298283 A.concurrently_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)
299284
@@ -303,7 +288,7 @@ concurrently_ ma mb = unsafeEff $ \es -> do
303288
304289-- | Lifted 'A.mapConcurrently'.
305290mapConcurrently
306− :: (Traversable f, AsyncE :> es)
291+ :: (Traversable f, Concurrent :> es)
307292 => (a -> Eff es b)
308293 -> f a
309294 -> Eff es (f b)
@@ -312,7 +297,7 @@ mapConcurrently f t = unsafeEff $ \es -> do
312297
313298-- | Lifted 'A.mapConcurrently_'.
314299mapConcurrently_
315− :: (Foldable f, AsyncE :> es)
300+ :: (Foldable f, Concurrent :> es)
316301 => (a -> Eff es b)
317302 -> f a
318303 -> Eff es ()
@@ -321,7 +306,7 @@ mapConcurrently_ f t = unsafeEff $ \es -> do
321306
322307-- | Lifted 'A.forConcurrently'.
323308forConcurrently
324− :: (Traversable f, AsyncE :> es)
309+ :: (Traversable f, Concurrent :> es)
325310 => f a
326311 -> (a -> Eff es b)
327312 -> Eff es (f b)
@@ -330,7 +315,7 @@ forConcurrently t f = unsafeEff $ \es -> do
330315
331316-- | Lifted 'A.forConcurrently_'.
332317forConcurrently_
333− :: (Foldable f, AsyncE :> es)
318+ :: (Foldable f, Concurrent :> es)
334319 => f a
335320 -> (a -> Eff es b)
336321 -> Eff es ()
@@ -338,12 +323,12 @@ forConcurrently_ t f = unsafeEff $ \es -> do
338323 U.forConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)
339324
340325-- | Lifted 'A.replicateConcurrently'.
341−replicateConcurrently :: AsyncE :> es => Int -> Eff es a -> Eff es [a]
326+replicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a]
342327replicateConcurrently n f = unsafeEff $ \es -> do
343328 U.replicateConcurrently n (unEff f =<< cloneEnv es)
344329
345330-- | Lifted 'A.replicateConcurrently_'.
346−replicateConcurrently_ :: AsyncE :> es => Int -> Eff es a -> Eff es ()
331+replicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es ()
347332replicateConcurrently_ n f = unsafeEff $ \es -> do
348333 U.replicateConcurrently_ n (unEff f =<< cloneEnv es)
349334
@@ -352,7 +337,7 @@ replicateConcurrently_ n f = unsafeEff $ \es -> do
352337
353338-- | Lifted 'U.pooledMapConcurrentlyN'.
354339pooledMapConcurrentlyN
355− :: (AsyncE :> es, Traversable t)
340+ :: (Concurrent :> es, Traversable t)
356341 => Int
357342 -> (a -> Eff es b)
358343 -> t a
@@ -362,7 +347,7 @@ pooledMapConcurrentlyN threads f t = unsafeEff $ \es -> do
362347
363348-- | Lifted 'U.pooledMapConcurrently'.
364349pooledMapConcurrently
365− :: (AsyncE :> es, Traversable t)
350+ :: (Concurrent :> es, Traversable t)
366351 => (a -> Eff es b)
367352 -> t a
368353 -> Eff es (t b)
@@ -371,7 +356,7 @@ pooledMapConcurrently f t = unsafeEff $ \es -> do
371356
372357-- | Lifted 'U.pooledMapConcurrentlyN'.
373358pooledMapConcurrentlyN_
374− :: (AsyncE :> es, Foldable f)
359+ :: (Concurrent :> es, Foldable f)
375360 => Int
376361 -> (a -> Eff es b)
377362 -> f a
@@ -381,7 +366,7 @@ pooledMapConcurrentlyN_ threads f t = unsafeEff $ \es -> do
381366
382367-- | Lifted 'U.pooledMapConcurrently_'.
383368pooledMapConcurrently_
384− :: (AsyncE :> es, Foldable f)
369+ :: (Concurrent :> es, Foldable f)
385370 => (a -> Eff es b)
386371 -> f a
387372 -> Eff es ()
@@ -390,7 +375,7 @@ pooledMapConcurrently_ f t = unsafeEff $ \es -> do
390375
391376-- | Lifted 'U.pooledForConcurrentlyN'.
392377pooledForConcurrentlyN
393− :: (AsyncE :> es, Traversable t)
378+ :: (Concurrent :> es, Traversable t)
394379 => Int
395380 -> t a
396381 -> (a -> Eff es b)
@@ -400,7 +385,7 @@ pooledForConcurrentlyN threads t f = unsafeEff $ \es -> do
400385
401386-- | Lifted 'U.pooledForConcurrently'.
402387pooledForConcurrently
403− :: (AsyncE :> es, Traversable t)
388+ :: (Concurrent :> es, Traversable t)
404389 => t a
405390 -> (a -> Eff es b)
406391 -> Eff es (t b)
@@ -409,7 +394,7 @@ pooledForConcurrently t f = unsafeEff $ \es -> do
409394
410395-- | Lifted 'U.pooledForConcurrentlyN'.
411396pooledForConcurrentlyN_
412− :: (AsyncE :> es, Foldable f)
397+ :: (Concurrent :> es, Foldable f)
413398 => Int
414399 -> f a
415400 -> (a -> Eff es b)
@@ -419,7 +404,7 @@ pooledForConcurrentlyN_ threads t f = unsafeEff $ \es -> do
419404
420405-- | Lifted 'U.pooledForConcurrently_'.
421406pooledForConcurrently_
422− :: (AsyncE :> es, Foldable f)
407+ :: (Concurrent :> es, Foldable f)
423408 => f a
424409 -> (a -> Eff es b)
425410 -> Eff es ()
@@ -427,22 +412,22 @@ pooledForConcurrently_ t f = unsafeEff $ \es -> do
427412 U.pooledForConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)
428413
429414-- | Lifted 'U.pooledReplicateConcurrentlyN'.
430−pooledReplicateConcurrentlyN :: AsyncE :> es => Int -> Int -> Eff es a -> Eff es [a]
415+pooledReplicateConcurrentlyN :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es [a]
431416pooledReplicateConcurrentlyN threads n f = unsafeEff $ \es -> do
432417 U.pooledReplicateConcurrentlyN threads n (unEff f =<< cloneEnv es)
433418
434419-- | Lifted 'U.pooledReplicateConcurrently'.
435−pooledReplicateConcurrently :: AsyncE :> es => Int -> Eff es a -> Eff es [a]
420+pooledReplicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a]
436421pooledReplicateConcurrently n f = unsafeEff $ \es -> do
437422 U.pooledReplicateConcurrently n (unEff f =<< cloneEnv es)
438423
439424-- | Lifted 'U.pooledReplicateConcurrentlyN_'.
440−pooledReplicateConcurrentlyN_ :: AsyncE :> es => Int -> Int -> Eff es a -> Eff es ()
425+pooledReplicateConcurrentlyN_ :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es ()
441426pooledReplicateConcurrentlyN_ threads n f = unsafeEff $ \es -> do
442427 U.pooledReplicateConcurrentlyN_ threads n (unEff f =<< cloneEnv es)
443428
444429-- | Lifted 'U.pooledReplicateConcurrently_'.
445−pooledReplicateConcurrently_ :: AsyncE :> es => Int -> Eff es a -> Eff es ()
430+pooledReplicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es ()
446431pooledReplicateConcurrently_ n f = unsafeEff $ \es -> do
447432 U.pooledReplicateConcurrently_ n (unEff f =<< cloneEnv es)
448433
@@ -482,7 +467,7 @@ conc :: Eff es a -> Conc es a
482467conc = Action
483468
484469-- | Lifted 'U.runConc'.
485−runConc :: AsyncE :> es => Conc es a -> Eff es a
470+runConc :: Concurrent :> es => Conc es a -> Eff es a
486471runConc m = unsafeEff $ \es -> U.runConc (unliftConc es m)
487472 where
488473 unliftConc :: Env es -> Conc es a -> U.Conc IO a
@@ -503,20 +488,20 @@ newtype Concurrently es a = Concurrently { runConcurrently :: Eff es a }
503488instance Functor (Concurrently es) where
504489 fmap f (Concurrently a) = Concurrently (fmap f a)
505490
506−instance AsyncE :> es => Applicative (Concurrently es) where
491+instance Concurrent :> es => Applicative (Concurrently es) where
507492 pure = Concurrently . pure
508493 Concurrently fs <*> Concurrently as =
509494 Concurrently ((\(f, a) -> f a) <$> concurrently fs as)
510495
511−instance AsyncE :> es => Alternative (Concurrently es) where
496+instance Concurrent :> es => Alternative (Concurrently es) where
512497 empty = Concurrently . unsafeEff_ . forever $ threadDelay maxBound
513498 Concurrently as <|> Concurrently bs =
514499 Concurrently (either id id <$> race as bs)
515500
516−instance (AsyncE :> es, Semigroup a) => Semigroup (Concurrently es a) where
501+instance (Concurrent :> es, Semigroup a) => Semigroup (Concurrently es a) where
517502 (<>) = liftA2 (<>)
518503
519−instance (AsyncE :> es, Monoid a) => Monoid (Concurrently es a) where
504+instance (Concurrent :> es, Monoid a) => Monoid (Concurrently es a) where
520505 mempty = pure mempty
521506
522507----------------------------------------
@@ -534,10 +519,9 @@ liftAsyncWithUnmask
534519 :: (((forall b. IO b -> IO b) -> IO a) -> IO (Async a))
535520 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)
536521 -> Eff es (Async a)
537−liftAsyncWithUnmask fork action = do
538− unsafeWithLiftMapIO $ \liftMap -> unsafeEff $ \es -> do
539− esA <- cloneEnv es
540− fork $ \unmask -> unEff (action $ liftMap unmask) esA
522+liftAsyncWithUnmask fork action = unsafeEff $ \es -> do
523+ esA <- cloneEnv es
524+ fork $ \unmask -> unEff (action $ unsafeLiftMapIO unmask) esA
541525
542526liftWithAsync
543527 :: (IO a -> (Async a -> IO b) -> IO b)
@@ -554,8 +538,7 @@ liftWithAsyncWithUnmask
554538 -> ((forall c. Eff es c -> Eff es c) -> Eff es a)
555539 -> (Async a -> Eff es b)
556540 -> Eff es b
557−liftWithAsyncWithUnmask withA action k = do
558− unsafeWithLiftMapIO $ \liftMap -> unsafeEff $ \es -> do
559− esA <- cloneEnv es
560− withA (\unmask -> unEff (action $ liftMap unmask) esA)
561− (\a -> unEff (k a) es)
541+liftWithAsyncWithUnmask withA action k = unsafeEff $ \es -> do
542+ esA <- cloneEnv es
543+ withA (\unmask -> unEff (action $ unsafeLiftMapIO unmask) esA)
544+ (\a -> unEff (k a) es)
effectful/src/Effectful/Concurrent/Chan.hsnew file+45
@@ -0,0 +1,45 @@
1+-- | Lifted version of "Control.Concurrent.Chan".
2+module Effectful.Concurrent.Chan
3+ ( Concurrent
4+ , runConcurrent
5+
6+ -- * Chan
7+ , Chan
8+ , newChan
9+ , writeChan
10+ , readChan
11+ , dupChan
12+ , getChanContents
13+ , writeList2Chan
14+ ) where
15+
16+import Control.Concurrent.Chan (Chan)
17+import qualified Control.Concurrent.Chan as C
18+
19+import Effectful.Concurrent.Effect
20+import Effectful.Dispatch.Static
21+import Effectful.Monad
22+
23+-- | Lifted 'C.newChan'.
24+newChan :: Concurrent :> es => Eff es (Chan a)
25+newChan = unsafeEff_ C.newChan
26+
27+-- | Lifted 'C.writeChan'.
28+writeChan :: Concurrent :> es => Chan a -> a -> Eff es ()
29+writeChan c = unsafeEff_ . C.writeChan c
30+
31+-- | Lifted 'C.readChan'.
32+readChan :: Concurrent :> es => Chan a -> Eff es a
33+readChan = unsafeEff_ . C.readChan
34+
35+-- | Lifted 'C.dupChan'.
36+dupChan :: Concurrent :> es => Chan a -> Eff es (Chan a)
37+dupChan = unsafeEff_ . C.dupChan
38+
39+-- | Lifted 'C.getChanContents'.
40+getChanContents :: Concurrent :> es => Chan a -> Eff es [a]
41+getChanContents = unsafeEff_ . C.getChanContents
42+
43+-- | Lifted 'C.writeList2Chan'.
44+writeList2Chan :: Concurrent :> es => Chan a -> [a] -> Eff es ()
45+writeList2Chan c = unsafeEff_ . C.writeList2Chan c
effectful/src/Effectful/Concurrent/Effect.hsnew file+79
@@ -0,0 +1,79 @@
1+module Effectful.Concurrent.Effect
2+ ( Concurrent
3+ , runConcurrent
4+ ) where
5+
6+import Effectful.Dispatch.Static
7+import Effectful.Monad
8+
9+-- | Provide the ability to run 'Eff' computations concurrently in multiple
10+-- threads and communicate between them.
11+--
12+-- /Warning:/ unless you stick to high level functions from the
13+-- 'Effectful.Concurrent.Async.withAsync' family, the 'Concurrent' effect makes
14+-- it possible to escape the scope of any scoped effect operation. Consider the
15+-- following:
16+--
17+-- >>> import qualified Effectful.Reader as R
18+-- >>> let printAsk msg = liftIO . putStrLn . (msg ++) . (": " ++) =<< R.ask
19+-- >>> :{
20+-- runEff . R.runReader "GLOBAL" . runConcurrent $ do
21+-- a <- R.local (const "LOCAL") $ do
22+-- a <- async $ do
23+-- printAsk "child (first)"
24+-- threadDelay 20000
25+-- printAsk "child (second)"
26+-- threadDelay 10000
27+-- printAsk "parent (inside)"
28+-- pure a
29+-- printAsk "parent (outside)"
30+-- wait a
31+-- :}
32+-- child (first): LOCAL
33+-- parent (inside): LOCAL
34+-- parent (outside): GLOBAL
35+-- child (second): LOCAL
36+--
37+-- Note that the asynchronous computation doesn't respect the scope of
38+-- 'Effectful.Reader.local', i.e. the child thread still behaves like it's
39+-- inside the 'Effectful.Reader.local' block, even though the parent thread
40+-- already got out of it.
41+--
42+-- This is because the value provided by the 'Effectful.Reader.Reader' effect is
43+-- thread local, i.e. each thread manages its own version of it. For the
44+-- 'Effectful.Reader.Reader' it is the only reasonable behavior, it wouldn't be
45+-- very useful if its "read only" value was affected by calls to
46+-- 'Effectful.Reader.local' from its parent or child threads.
47+--
48+-- However, the cut isn't so clear if it comes to effects that provide access to
49+-- a mutable state. That's why primitive @State@ and @Writer@ effects come in
50+-- two flavors, local and shared:
51+--
52+-- >>> import qualified Effectful.State.Local as SL
53+-- >>> :{
54+-- runEff . SL.execState "Hi" . runConcurrent $ do
55+-- replicateConcurrently_ 3 $ SL.modify (++ "!")
56+-- :}
57+-- "Hi"
58+--
59+-- >>> import qualified Effectful.State.Shared as SS
60+-- >>> :{
61+-- runEff . SS.execState "Hi" . runConcurrent $ do
62+-- replicateConcurrently_ 3 $ SS.modify (++ "!")
63+-- :}
64+-- "Hi!!!"
65+--
66+-- In the first example state modification made concurrently are not reflected
67+-- in the parent thread because the value is thread local, but in the second
68+-- example they are, because the value is shared.
69+--
70+data Concurrent :: Effect where
71+ Concurrent :: Concurrent m r
72+
73+-- | Run the 'Concurrent' effect.
74+runConcurrent :: IOE :> es => Eff (Concurrent : es) a -> Eff es a
75+runConcurrent = evalData (DataA Concurrent)
76+
77+-- $setup
78+-- >>> import Effectful.Concurrent
79+-- >>> import Effectful.Concurrent.Async
effectful/src/Effectful/Concurrent/MVar.hsnew file+108
@@ -0,0 +1,108 @@
1+-- | Lifted version of "Control.Concurrent.MVar".
2+module Effectful.Concurrent.MVar
3+ ( Concurrent
4+ , runConcurrent
5+
6+ -- * MVar
7+ , MVar
8+ , newEmptyMVar
9+ , newMVar
10+ , takeMVar
11+ , putMVar
12+ , readMVar
13+ , swapMVar
14+ , tryTakeMVar
15+ , tryPutMVar
16+ , isEmptyMVar
17+ , withMVar
18+ , withMVarMasked
19+ , modifyMVar
20+ , modifyMVar_
21+ , modifyMVarMasked
22+ , modifyMVarMasked_
23+ , tryReadMVar
24+ , mkWeakMVar
25+ ) where
26+
27+import System.Mem.Weak (Weak)
28+import Control.Concurrent.MVar (MVar)
29+import qualified Control.Concurrent.MVar as M
30+
31+import Effectful.Concurrent.Effect
32+import Effectful.Dispatch.Static
33+import Effectful.Monad
34+
35+-- | Lifted 'M.newEmptyMVar'.
36+newEmptyMVar :: Concurrent :> es => Eff es (MVar a)
37+newEmptyMVar = unsafeEff_ M.newEmptyMVar
38+
39+-- | Lifted 'M.newMVar'.
40+newMVar :: Concurrent :> es => a -> Eff es (MVar a)
41+newMVar = unsafeEff_ . M.newMVar
42+
43+-- | Lifted 'M.takeMVar'.
44+takeMVar :: Concurrent :> es => MVar a -> Eff es a
45+takeMVar = unsafeEff_ . M.takeMVar
46+
47+-- | Lifted 'M.putMVar'.
48+putMVar :: Concurrent :> es => MVar a -> a -> Eff es ()
49+putMVar var = unsafeEff_ . M.putMVar var
50+
51+-- | Lifted 'M.readMVar'.
52+readMVar :: Concurrent :> es => MVar a -> Eff es a
53+readMVar = unsafeEff_ . M.readMVar
54+
55+-- | Lifted 'M.swapMVar'.
56+swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a
57+swapMVar var = unsafeEff_ . M.swapMVar var
58+
59+-- | Lifted 'M.tryTakeMVar'.
60+tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)
61+tryTakeMVar = unsafeEff_ . M.tryTakeMVar
62+
63+-- | Lifted 'M.tryPutMVar'.
64+tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool
65+tryPutMVar var = unsafeEff_ . M.tryPutMVar var
66+
67+-- | Lifted 'M.isEmptyMVar'.
68+isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool
69+isEmptyMVar = unsafeEff_ . M.isEmptyMVar
70+
71+-- | Lifted 'M.tryReadMVar'.
72+tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)
73+tryReadMVar = unsafeEff_ . M.tryReadMVar
74+
75+-- | Lifted 'M.withMVar'.
76+withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b
77+withMVar var f = unsafeUnliftIO $ \unlift -> do
78+ M.withMVar var $ unlift . f
79+
80+-- | Lifted 'M.withMVarMasked'.
81+withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b
82+withMVarMasked var f = unsafeUnliftIO $ \unlift -> do
83+ M.withMVarMasked var $ unlift . f
84+
85+-- | Lifted 'M.modifyMVar_'.
86+modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es ()
87+modifyMVar_ var f = unsafeUnliftIO $ \unlift -> do
88+ M.modifyMVar_ var $ unlift . f
89+
90+-- | Lifted 'M.modifyMVar'.
91+modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b
92+modifyMVar var f = unsafeUnliftIO $ \unlift -> do
93+ M.modifyMVar var $ unlift . f
94+
95+-- | Lifted 'M.modifyMVarMasked_'.
96+modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es ()
97+modifyMVarMasked_ var f = unsafeUnliftIO $ \unlift -> do
98+ M.modifyMVarMasked_ var $ unlift . f
99+
100+-- | Lifted 'M.modifyMVarMasked'.
101+modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b
102+modifyMVarMasked var f = unsafeUnliftIO $ \unlift -> do
103+ M.modifyMVarMasked var $ unlift . f
104+
105+-- | Lifted 'M.mkWeakMVar'.
106+mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a))
107+mkWeakMVar var f = unsafeUnliftIO $ \unlift -> do
108+ M.mkWeakMVar var $ unlift f
effectful/src/Effectful/Concurrent/QSem.hsnew file+30
@@ -0,0 +1,30 @@
1+-- | Lifted version of "Control.Concurrent.QSem".
2+module Effectful.Concurrent.QSem
3+ ( Concurrent
4+ , runConcurrent
5+
6+ -- * QSem
7+ , QSem
8+ , newQSem
9+ , waitQSem
10+ , signalQSem
11+ ) where
12+
13+import Control.Concurrent.QSem (QSem)
14+import qualified Control.Concurrent.QSem as Q
15+
16+import Effectful.Concurrent.Effect
17+import Effectful.Dispatch.Static
18+import Effectful.Monad
19+
20+-- | Lifted 'Q.newQSem'.
21+newQSem :: Concurrent :> es => Int -> Eff es QSem
22+newQSem = unsafeEff_ . Q.newQSem
23+
24+-- | Lifted 'Q.waitQSem'.
25+waitQSem :: Concurrent :> es => QSem -> Eff es ()
26+waitQSem = unsafeEff_ . Q.waitQSem
27+
28+-- | Lifted 'Q.signalQSem'.
29+signalQSem :: Concurrent :> es => QSem -> Eff es ()
30+signalQSem = unsafeEff_ . Q.signalQSem
effectful/src/Effectful/Concurrent/QSemN.hsnew file+30
@@ -0,0 +1,30 @@
1+-- | Lifted version of "Control.Concurrent.QSemN".
2+module Effectful.Concurrent.QSemN
3+ ( Concurrent
4+ , runConcurrent
5+
6+ -- * QSemN
7+ , QSemN
8+ , newQSemN
9+ , waitQSemN
10+ , signalQSemN
11+ ) where
12+
13+import Control.Concurrent.QSemN (QSemN)
14+import qualified Control.Concurrent.QSemN as Q
15+
16+import Effectful.Concurrent.Effect
17+import Effectful.Dispatch.Static
18+import Effectful.Monad
19+
20+-- | Lifted 'Q.newQSemN'.
21+newQSemN :: Concurrent :> es => Int -> Eff es QSemN
22+newQSemN = unsafeEff_ . Q.newQSemN
23+
24+-- | Lifted 'Q.waitQSemN'.
25+waitQSemN :: Concurrent :> es => QSemN -> Int -> Eff es ()
26+waitQSemN x = unsafeEff_ . Q.waitQSemN x
27+
28+-- | Lifted 'Q.signalQSemN'.
29+signalQSemN :: Concurrent :> es => QSemN -> Int -> Eff es ()
30+signalQSemN x = unsafeEff_ . Q.signalQSemN x
effectful/src/Effectful/Concurrent/STM.hsnew file+146
@@ -0,0 +1,146 @@
1+-- | Lifted version of "Control.Concurrent.STM".
2+module Effectful.Concurrent.STM
3+ ( Concurrent
4+ , runConcurrent
5+
6+ -- * Core
7+ , STM.STM
8+ , atomically
9+ , STM.retry
10+ , STM.orElse
11+ , STM.check
12+ , STM.throwSTM
13+ , STM.catchSTM
14+
15+ -- * TVar
16+ , STM.TVar
17+ , newTVarIO
18+ , readTVarIO
19+ , STM.newTVar
20+ , STM.readTVar
21+ , STM.writeTVar
22+ , STM.modifyTVar
23+ , STM.modifyTVar'
24+ , STM.swapTVar
25+ , registerDelay
26+ , mkWeakTVar
27+
28+ -- * TMVar
29+ , STM.TMVar
30+ , STM.newTMVar
31+ , STM.newEmptyTMVar
32+ , newTMVarIO
33+ , newEmptyTMVarIO
34+ , STM.takeTMVar
35+ , STM.putTMVar
36+ , STM.readTMVar
37+ , STM.tryReadTMVar
38+ , STM.swapTMVar
39+ , STM.tryTakeTMVar
40+ , STM.tryPutTMVar
41+ , STM.isEmptyTMVar
42+ , mkWeakTMVar
43+
44+ -- * TChan
45+ , STM.TChan
46+ , STM.newTChan
47+ , newTChanIO
48+ , STM.newBroadcastTChan
49+ , newBroadcastTChanIO
50+ , STM.dupTChan
51+ , STM.cloneTChan
52+ , STM.readTChan
53+ , STM.tryReadTChan
54+ , STM.peekTChan
55+ , STM.tryPeekTChan
56+ , STM.writeTChan
57+ , STM.unGetTChan
58+ , STM.isEmptyTChan
59+
60+ -- * TQueue
61+ , STM.TQueue
62+ , STM.newTQueue
63+ , newTQueueIO
64+ , STM.readTQueue
65+ , STM.tryReadTQueue
66+ , STM.peekTQueue
67+ , STM.tryPeekTQueue
68+ , STM.flushTQueue
69+ , STM.writeTQueue
70+ , STM.unGetTQueue
71+ , STM.isEmptyTQueue
72+
73+ -- * TBQueue
74+ , STM.TBQueue
75+ , STM.newTBQueue
76+ , newTBQueueIO
77+ , STM.readTBQueue
78+ , STM.tryReadTBQueue
79+ , STM.peekTBQueue
80+ , STM.tryPeekTBQueue
81+ , STM.flushTBQueue
82+ , STM.writeTBQueue
83+ , STM.unGetTBQueue
84+ , STM.lengthTBQueue
85+ , STM.isEmptyTBQueue
86+ , STM.isFullTBQueue
87+ ) where
88+
89+import Control.Concurrent.STM (STM, TVar, TMVar, TChan, TQueue, TBQueue)
90+import qualified Control.Concurrent.STM as STM
91+import System.Mem.Weak (Weak)
92+import GHC.Natural (Natural)
93+
94+import Effectful.Concurrent.Effect
95+import Effectful.Dispatch.Static
96+import Effectful.Monad
97+
98+-- | Lifted version of 'STM.atomically'
99+atomically :: Concurrent :> es => STM a -> Eff es a
100+atomically = unsafeEff_ . STM.atomically
101+
102+-- | Lifted version of 'STM.newTVarIO'
103+newTVarIO :: Concurrent :> es => a -> Eff es (TVar a)
104+newTVarIO = unsafeEff_ . STM.newTVarIO
105+
106+-- | Lifted version of 'STM.readTVarIO'
107+readTVarIO :: Concurrent :> es => TVar a -> Eff es a
108+readTVarIO = unsafeEff_ . STM.readTVarIO
109+
110+-- | Lifted version of 'STM.registerDelay'
111+registerDelay :: Concurrent :> es => Int -> Eff es (TVar Bool)
112+registerDelay = unsafeEff_ . STM.registerDelay
113+
114+-- | Lifted version of 'STM.mkWeakTVar'
115+mkWeakTVar :: Concurrent :> es => TVar a -> Eff es () -> Eff es (Weak (TVar a))
116+mkWeakTVar var final = unsafeUnliftIO $ \unlift -> do
117+ STM.mkWeakTVar var $ unlift final
118+
119+-- | Lifted version of 'STM.newTMVarIO'
120+newTMVarIO :: Concurrent :> es => a -> Eff es (TMVar a)
121+newTMVarIO = unsafeEff_ . STM.newTMVarIO
122+
123+-- | Lifted version of 'STM.newEmptyTMVarIO'
124+newEmptyTMVarIO :: Concurrent :> es => Eff es (TMVar a)
125+newEmptyTMVarIO = unsafeEff_ STM.newEmptyTMVarIO
126+
127+-- | Lifted version of 'STM.mkWeakTMVar'
128+mkWeakTMVar :: Concurrent :> es => TMVar a -> Eff es () -> Eff es (Weak (TMVar a))
129+mkWeakTMVar var final = unsafeUnliftIO $ \unlift -> do
130+ STM.mkWeakTMVar var $ unlift final
131+
132+-- | Lifted version of 'STM.newTChanIO'
133+newTChanIO :: Concurrent :> es => Eff es (TChan a)
134+newTChanIO = unsafeEff_ STM.newTChanIO
135+
136+-- | Lifted version of 'STM.newBroadcastTChanIO'
137+newBroadcastTChanIO :: Concurrent :> es => Eff es (TChan a)
138+newBroadcastTChanIO = unsafeEff_ STM.newBroadcastTChanIO
139+
140+-- | Lifted version of 'STM.newTQueueIO'
141+newTQueueIO :: Concurrent :> es => Eff es (TQueue a)
142+newTQueueIO = unsafeEff_ STM.newTQueueIO
143+
144+-- | Lifted version of 'STM.newTBQueueIO'
145+newTBQueueIO :: Concurrent :> es => Natural -> Eff es (TBQueue a)
146+newTBQueueIO = unsafeEff_ . STM.newTBQueueIO
effectful/src/Effectful/Environment.hsnew file+71
@@ -0,0 +1,71 @@
1+module Effectful.Environment
2+ ( Environment
3+ , runEnvironment
4+
5+ -- * Querying the environment
6+ , getArgs
7+ , getProgName
8+ , getExecutablePath
9+ , getEnv
10+ , getEnvironment
11+ , lookupEnv
12+
13+ -- * Modifying the environment
14+ , setEnv
15+ , unsetEnv
16+ , withArgs
17+ , withProgName
18+ ) where
19+
20+import qualified System.Environment as E
21+
22+import Effectful.Dispatch.Static hiding (getEnv)
23+import Effectful.Monad
24+
25+-- | An effect for querying and modifying the system environment.
26+data Environment :: Effect where
27+ Environment :: Environment m r
28+
29+-- | Run the 'Environment' effect.
30+runEnvironment :: IOE :> es => Eff (Environment : es) a -> Eff es a
31+runEnvironment = evalData (DataA Environment)
32+
33+-- | Lifted 'E.getArgs'.
34+getArgs :: Environment :> es => Eff es [String]
35+getArgs = unsafeEff_ E.getArgs
36+
37+-- | Lifted 'E.getEnv'.
38+getEnv :: Environment :> es => String -> Eff es String
39+getEnv = unsafeEff_ . E.getEnv
40+
41+-- | Lifted 'E.getEnvironment'.
42+getEnvironment :: Environment :> es => Eff es [(String, String)]
43+getEnvironment = unsafeEff_ E.getEnvironment
44+
45+-- | Lifted 'E.getExecutablePath'.
46+getExecutablePath :: Environment :> es => Eff es FilePath
47+getExecutablePath = unsafeEff_ E.getExecutablePath
48+
49+-- | Lifted 'E.getProgName'.
50+getProgName :: Environment :> es => Eff es String
51+getProgName = unsafeEff_ E.getProgName
52+
53+-- | Lifted 'E.lookupEnv'.
54+lookupEnv :: Environment :> es => String -> Eff es (Maybe String)
55+lookupEnv = unsafeEff_ . E.lookupEnv
56+
57+-- | Lifted 'E.setEnv'.
58+setEnv :: Environment :> es => String -> String -> Eff es ()
59+setEnv n = unsafeEff_ . E.setEnv n
60+
61+-- | Lifted 'E.unsetEnv'.
62+unsetEnv :: Environment :> es => String -> Eff es ()
63+unsetEnv = unsafeEff_ . E.unsetEnv
64+
65+-- | Lifted 'E.withArgs'.
66+withArgs :: Environment :> es => [String] -> Eff es a -> Eff es a
67+withArgs = unsafeLiftMapIO . E.withArgs
68+
69+-- | Lifted 'E.withProgName'.
70+withProgName :: Environment :> es => String -> Eff es a -> Eff es a
71+withProgName = unsafeLiftMapIO . E.withProgName
effectful/src/Effectful/FileSystem.hsnew file+347
@@ -0,0 +1,347 @@
1+module Effectful.FileSystem
2+ ( FileSystem
3+ , runFileSystem
4+
5+ -- * Actions on directories
6+ , createDirectory
7+ , createDirectoryIfMissing
8+ , removeDirectory
9+ , removeDirectoryRecursive
10+ , removePathForcibly
11+ , renameDirectory
12+ , listDirectory
13+ , getDirectoryContents
14+
15+ -- ** Current working directory
16+ , getCurrentDirectory
17+ , setCurrentDirectory
18+ , withCurrentDirectory
19+
20+ -- * Pre-defined directories
21+ , getHomeDirectory
22+ , getXdgDirectory
23+ , getXdgDirectoryList
24+ , getAppUserDataDirectory
25+ , getUserDocumentsDirectory
26+ , getTemporaryDirectory
27+
28+ -- * Actions on files
29+ , removeFile
30+ , renameFile
31+ , renamePath
32+ , copyFile
33+ , copyFileWithMetadata
34+ , getFileSize
35+ , canonicalizePath
36+ , makeAbsolute
37+ , makeRelativeToCurrentDirectory
38+
39+ -- * Existence tests
40+ , doesPathExist
41+ , doesFileExist
42+ , doesDirectoryExist
43+ , findExecutable
44+ , findExecutables
45+ , findExecutablesInDirectories
46+ , findFile
47+ , findFiles
48+ , findFileWith
49+ , findFilesWith
50+
51+ -- * Symbolic links
52+ , createFileLink
53+ , createDirectoryLink
54+ , removeDirectoryLink
55+ , pathIsSymbolicLink
56+ , getSymbolicLinkTarget
57+
58+ -- * Permissions
59+ , getPermissions
60+ , setPermissions
61+ , copyPermissions
62+
63+ -- * Timestamps
64+ , getAccessTime
65+ , getModificationTime
66+ , setAccessTime
67+ , setModificationTime
68+
69+ -- * Re-exports
70+
71+ -- ** Pre-defined directories
72+ , D.XdgDirectory(..)
73+ , D.XdgDirectoryList(..)
74+
75+ -- ** Existence tests
76+ , D.exeExtension
77+
78+ -- ** Permissions
79+ , D.Permissions
80+ , D.emptyPermissions
81+ , D.readable
82+ , D.writable
83+ , D.executable
84+ , D.searchable
85+ , D.setOwnerReadable
86+ , D.setOwnerWritable
87+ , D.setOwnerExecutable
88+ , D.setOwnerSearchable
89+ ) where
90+
91+import Data.Time (UTCTime)
92+import qualified System.Directory as D
93+
94+import Effectful.Dispatch.Static
95+import Effectful.Monad
96+
97+-- | An effect for interacting with the filesystem.
98+data FileSystem :: Effect where
99+ FileSystem :: FileSystem m r
100+
101+-- | Run the 'FileSystem' effect.
102+runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a
103+runFileSystem = evalData (DataA FileSystem)
104+
105+----------------------------------------
106+-- Actions on directories
107+
108+-- | Lifted 'D.createDirectory'.
109+createDirectory :: FileSystem :> es => FilePath -> Eff es ()
110+createDirectory = unsafeEff_ . D.createDirectory
111+
112+-- | Lifted 'D.createDirectoryIfMissing'.
113+createDirectoryIfMissing :: FileSystem :> es => Bool -> FilePath -> Eff es ()
114+createDirectoryIfMissing doCreateParents =
115+ unsafeEff_ . D.createDirectoryIfMissing doCreateParents
116+
117+-- | Lifted 'D.removeDirectory'.
118+removeDirectory :: FileSystem :> es => FilePath -> Eff es ()
119+removeDirectory = unsafeEff_ . D.removeDirectory
120+
121+-- | Lifted 'D.removeDirectoryRecursive'.
122+removeDirectoryRecursive :: FileSystem :> es => FilePath -> Eff es ()
123+removeDirectoryRecursive = unsafeEff_ . D.removeDirectoryRecursive
124+
125+-- | Lifted 'D.removePathForcibly'.
126+removePathForcibly :: FileSystem :> es => FilePath -> Eff es ()
127+removePathForcibly = unsafeEff_ . D.removePathForcibly
128+
129+-- | Lifted 'D.renameDirectory'.
130+renameDirectory :: FileSystem :> es => FilePath -> FilePath -> Eff es ()
131+renameDirectory old = unsafeEff_ . D.renameDirectory old
132+
133+-- | Lifted 'D.listDirectory'.
134+listDirectory :: FileSystem :> es => FilePath -> Eff es [FilePath]
135+listDirectory = unsafeEff_ . D.listDirectory
136+
137+-- | Lifted 'D.getDirectoryContents'.
138+getDirectoryContents :: FileSystem :> es => FilePath -> Eff es [FilePath]
139+getDirectoryContents = unsafeEff_ . D.getDirectoryContents
140+
141+----------------------------------------
142+-- Current working directory
143+
144+-- | Lifted 'D.getCurrentDirectory'.
145+getCurrentDirectory :: FileSystem :> es => Eff es FilePath
146+getCurrentDirectory = unsafeEff_ D.getCurrentDirectory
147+
148+-- | Lifted 'D.setCurrentDirectory'.
149+setCurrentDirectory :: FileSystem :> es => FilePath -> Eff es ()
150+setCurrentDirectory = unsafeEff_ . D.setCurrentDirectory
151+
152+-- | Lifted 'D.withCurrentDirectory'.
153+withCurrentDirectory :: FileSystem :> es => FilePath -> Eff es a -> Eff es a
154+withCurrentDirectory path = unsafeLiftMapIO (D.withCurrentDirectory path)
155+
156+----------------------------------------
157+-- Pre-defined directories
158+
159+-- | Lifted 'D.getHomeDirectory'.
160+getHomeDirectory :: FileSystem :> es => Eff es FilePath
161+getHomeDirectory = unsafeEff_ D.getHomeDirectory
162+
163+-- | Lifted 'D.getXdgDirectory'.
164+getXdgDirectory
165+ :: FileSystem :> es
166+ => D.XdgDirectory
167+ -> FilePath
168+ -> Eff es FilePath
169+getXdgDirectory xdgDir = unsafeEff_ . D.getXdgDirectory xdgDir
170+
171+-- | Lifted 'D.getXdgDirectoryList'.
172+getXdgDirectoryList
173+ :: FileSystem :> es
174+ => D.XdgDirectoryList
175+ -> Eff es [FilePath]
176+getXdgDirectoryList = unsafeEff_ . D.getXdgDirectoryList
177+
178+-- | Lifted 'D.getAppUserDataDirectory'.
179+getAppUserDataDirectory :: FileSystem :> es => FilePath -> Eff es FilePath
180+getAppUserDataDirectory = unsafeEff_ . D.getAppUserDataDirectory
181+
182+-- | Lifted 'D.getUserDocumentsDirectory'.
183+getUserDocumentsDirectory :: FileSystem :> es => Eff es FilePath
184+getUserDocumentsDirectory = unsafeEff_ D.getUserDocumentsDirectory
185+
186+-- | Lifted 'D.getTemporaryDirectory'.
187+getTemporaryDirectory :: FileSystem :> es => Eff es FilePath
188+getTemporaryDirectory = unsafeEff_ D.getTemporaryDirectory
189+
190+----------------------------------------
191+-- Actions on files
192+
193+-- | Lifted 'D.removeFile'.
194+removeFile :: FileSystem :> es => FilePath -> Eff es ()
195+removeFile = unsafeEff_ . D.removeFile
196+
197+-- | Lifted 'D.renameFile'.
198+renameFile :: FileSystem :> es => FilePath -> FilePath -> Eff es ()
199+renameFile old = unsafeEff_ . D.renameFile old
200+
201+-- | Lifted 'D.renamePath'.
202+renamePath :: FileSystem :> es => FilePath -> FilePath -> Eff es ()
203+renamePath old = unsafeEff_ . D.renamePath old
204+
205+-- | Lifted 'D.copyFile'.
206+copyFile :: FileSystem :> es => FilePath -> FilePath -> Eff es ()
207+copyFile src = unsafeEff_ . D.copyFile src
208+
209+-- | Lifted 'D.copyFileWithMetadata'.
210+copyFileWithMetadata :: FileSystem :> es => FilePath -> FilePath -> Eff es ()
211+copyFileWithMetadata src = unsafeEff_ . D.copyFileWithMetadata src
212+
213+-- | Lifted 'D.getFileSize'.
214+getFileSize :: FileSystem :> es => FilePath -> Eff es Integer
215+getFileSize = unsafeEff_ . D.getFileSize
216+
217+-- | Lifted 'D.canonicalizePath'.
218+canonicalizePath :: FileSystem :> es => FilePath -> Eff es FilePath
219+canonicalizePath = unsafeEff_ . D.canonicalizePath
220+
221+-- | Lifted 'D.makeAbsolute'.
222+makeAbsolute :: FileSystem :> es => FilePath -> Eff es FilePath
223+makeAbsolute = unsafeEff_ . D.makeAbsolute
224+
225+-- | Lifted 'D.makeRelativeToCurrentDirectory'.
226+makeRelativeToCurrentDirectory
227+ :: FileSystem :> es
228+ => FilePath
229+ -> Eff es FilePath
230+makeRelativeToCurrentDirectory = unsafeEff_ . D.makeRelativeToCurrentDirectory
231+
232+----------------------------------------
233+-- Existence tests
234+
235+-- | Lifted 'D.doesPathExist'.
236+doesPathExist :: FileSystem :> es => FilePath -> Eff es Bool
237+doesPathExist = unsafeEff_ . D.doesPathExist
238+
239+-- | Lifted 'D.doesFileExist'.
240+doesFileExist :: FileSystem :> es => FilePath -> Eff es Bool
241+doesFileExist = unsafeEff_ . D.doesFileExist
242+
243+-- | Lifted 'D.doesDirectoryExist'.
244+doesDirectoryExist :: FileSystem :> es => FilePath -> Eff es Bool
245+doesDirectoryExist = unsafeEff_ . D.doesDirectoryExist
246+
247+-- | Lifted 'D.findExecutable'.
248+findExecutable :: FileSystem :> es => String -> Eff es (Maybe FilePath)
249+findExecutable = unsafeEff_ . D.findExecutable
250+
251+-- | Lifted 'D.findExecutables'.
252+findExecutables :: FileSystem :> es => String -> Eff es [FilePath]
253+findExecutables = unsafeEff_ . D.findExecutables
254+
255+-- | Lifted 'D.findExecutablesInDirectories'.
256+findExecutablesInDirectories
257+ :: FileSystem :> es
258+ => [FilePath]
259+ -> String
260+ -> Eff es [FilePath]
261+findExecutablesInDirectories dirs =
262+ unsafeEff_ . D.findExecutablesInDirectories dirs
263+
264+-- | Lifted 'D.findFile'.
265+findFile :: FileSystem :> es => [FilePath] -> String -> Eff es (Maybe FilePath)
266+findFile dirs = unsafeEff_ . D.findFile dirs
267+
268+-- | Lifted 'D.findFiles'.
269+findFiles :: FileSystem :> es => [FilePath] -> String -> Eff es [FilePath]
270+findFiles dirs = unsafeEff_ . D.findFiles dirs
271+
272+-- | Lifted 'D.findFileWith'.
273+findFileWith
274+ :: FileSystem :> es
275+ => (FilePath -> Eff es Bool)
276+ -> [FilePath]
277+ -> String
278+ -> Eff es (Maybe FilePath)
279+findFileWith p dirs n = unsafeUnliftIO $ \unlift -> do
280+ D.findFileWith (unlift . p) dirs n
281+
282+-- | Lifted 'D.findFilesWith'.
283+findFilesWith
284+ :: FileSystem :> es
285+ => (FilePath -> Eff es Bool)
286+ -> [FilePath]
287+ -> String
288+ -> Eff es [FilePath]
289+findFilesWith p dirs ns = unsafeUnliftIO $ \unlift -> do
290+ D.findFilesWith (unlift . p) dirs ns
291+
292+----------------------------------------
293+-- Symbolic links
294+
295+-- | Lifted 'D.createFileLink'.
296+createFileLink :: FileSystem :> es => FilePath -> FilePath -> Eff es ()
297+createFileLink target = unsafeEff_ . D.createFileLink target
298+
299+-- | Lifted 'D.createDirectoryLink'.
300+createDirectoryLink :: FileSystem :> es => FilePath -> FilePath -> Eff es ()
301+createDirectoryLink target = unsafeEff_ . D.createDirectoryLink target
302+
303+-- | Lifted 'D.removeDirectoryLink'.
304+removeDirectoryLink :: FileSystem :> es => FilePath -> Eff es ()
305+removeDirectoryLink = unsafeEff_ . D.removeDirectoryLink
306+
307+-- | Lifted 'D.pathIsSymbolicLink'.
308+pathIsSymbolicLink :: FileSystem :> es => FilePath -> Eff es Bool
309+pathIsSymbolicLink = unsafeEff_ . D.pathIsSymbolicLink
310+
311+-- | Lifted 'D.getSymbolicLinkTarget'.
312+getSymbolicLinkTarget :: FileSystem :> es => FilePath -> Eff es FilePath
313+getSymbolicLinkTarget = unsafeEff_ . D.getSymbolicLinkTarget
314+
315+----------------------------------------
316+-- Permissions
317+
318+-- | Lifted 'D.getPermissions'.
319+getPermissions :: FileSystem :> es => FilePath -> Eff es D.Permissions
320+getPermissions = unsafeEff_ . D.getPermissions
321+
322+-- | Lifted 'D.setPermissions'.
323+setPermissions :: FileSystem :> es => FilePath -> D.Permissions -> Eff es ()
324+setPermissions path = unsafeEff_ . D.setPermissions path
325+
326+-- | Lifted 'D.copyPermissions'.
327+copyPermissions :: FileSystem :> es => FilePath -> FilePath -> Eff es ()
328+copyPermissions src = unsafeEff_ . D.copyPermissions src
329+
330+----------------------------------------
331+-- Timestamps
332+
333+-- | Lifted 'D.getAccessTime'.
334+getAccessTime :: FileSystem :> es => FilePath -> Eff es UTCTime
335+getAccessTime = unsafeEff_ . D.getAccessTime
336+
337+-- | Lifted 'D.getModificationTime'.
338+getModificationTime :: FileSystem :> es => FilePath -> Eff es UTCTime
339+getModificationTime = unsafeEff_ . D.getModificationTime
340+
341+-- | Lifted 'D.setAccessTime'.
342+setAccessTime :: FileSystem :> es => FilePath -> UTCTime -> Eff es ()
343+setAccessTime path = unsafeEff_ . D.setAccessTime path
344+
345+-- | Lifted 'D.setModificationTime'.
346+setModificationTime :: FileSystem :> es => FilePath -> UTCTime -> Eff es ()
347+setModificationTime path = unsafeEff_ . D.setModificationTime path
effectful/src/Effectful/FileSystem/Effect.hsnew file+15
@@ -0,0 +1,15 @@
1+module Effectful.FileSystem.Effect
2+ ( FileSystem
3+ , runFileSystem
4+ ) where
5+
6+import Effectful.Dispatch.Static
7+import Effectful.Monad
8+
9+-- | An effect for interacting with the filesystem.
10+data FileSystem :: Effect where
11+ FileSystem :: FileSystem m r
12+
13+-- | Run the 'FileSystem' effect.
14+runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a
15+runFileSystem = evalData (DataA FileSystem)
effectful/src/Effectful/FileSystem/IO.hsnew file+143
@@ -0,0 +1,143 @@
1+-- | Lifted version of "System.IO".
2+module Effectful.FileSystem.IO
3+ ( FileSystem
4+ , runFileSystem
5+
6+ -- * IO
7+ , IOMode (..)
8+ , Handle
9+ , IO.stdin
10+ , IO.stdout
11+ , IO.stderr
12+ , withFile
13+ , withBinaryFile
14+ , openFile
15+ , hClose
16+ , hFlush
17+ , hFileSize
18+ , hSetFileSize
19+ , hIsEOF
20+ , IO.BufferMode (..)
21+ , hSetBuffering
22+ , hGetBuffering
23+ , hSeek
24+ , IO.SeekMode (..)
25+ , hTell
26+ , hIsOpen
27+ , hIsClosed
28+ , hIsReadable
29+ , hIsWritable
30+ , hIsSeekable
31+ , hIsTerminalDevice
32+ , hSetEcho
33+ , hGetEcho
34+ , hWaitForInput
35+ , hReady
36+ ) where
37+
38+import qualified System.IO as IO
39+import System.IO (Handle, IOMode (..))
40+
41+import Effectful.Dispatch.Static
42+import Effectful.FileSystem.Effect
43+import Effectful.Monad
44+
45+-- | Lifted version of 'IO.withFile'.
46+withFile
47+ :: FileSystem :> es
48+ => FilePath
49+ -> IOMode
50+ -> (Handle -> Eff es a)
51+ -> Eff es a
52+withFile fp mode inner = unsafeUnliftIO $ \unlift -> do
53+ IO.withFile fp mode $ unlift . inner
54+
55+-- | Lifted version of 'IO.withBinaryFile'.
56+withBinaryFile
57+ :: FileSystem :> es
58+ => FilePath
59+ -> IOMode
60+ -> (Handle -> Eff es a)
61+ -> Eff es a
62+withBinaryFile fp mode inner = unsafeUnliftIO $ \unlift -> do
63+ IO.withBinaryFile fp mode $ unlift . inner
64+
65+-- | Lifted version of 'IO.openFile'
66+openFile :: FileSystem :> es => FilePath -> IOMode -> Eff es Handle
67+openFile fp = unsafeEff_ . IO.openFile fp
68+
69+-- | Lifted version of 'IO.hClose'
70+hClose :: FileSystem :> es => Handle -> Eff es ()
71+hClose = unsafeEff_ . IO.hClose
72+
73+-- | Lifted version of 'IO.hFlush'
74+hFlush :: FileSystem :> es => Handle -> Eff es ()
75+hFlush = unsafeEff_ . IO.hFlush
76+
77+-- | Lifted version of 'IO.hFileSize'
78+hFileSize :: FileSystem :> es => Handle -> Eff es Integer
79+hFileSize = unsafeEff_ . IO.hFileSize
80+
81+-- | Lifted version of 'IO.hSetFileSize'
82+hSetFileSize :: FileSystem :> es => Handle -> Integer -> Eff es ()
83+hSetFileSize h = unsafeEff_ . IO.hSetFileSize h
84+
85+-- | Lifted version of 'IO.hIsEOF'
86+hIsEOF :: FileSystem :> es => Handle -> Eff es Bool
87+hIsEOF = unsafeEff_ . IO.hIsEOF
88+
89+-- | Lifted version of 'IO.hSetBuffering'
90+hSetBuffering :: FileSystem :> es => Handle -> IO.BufferMode -> Eff es ()
91+hSetBuffering h = unsafeEff_ . IO.hSetBuffering h
92+
93+-- | Lifted version of 'IO.hGetBuffering'
94+hGetBuffering :: FileSystem :> es => Handle -> Eff es IO.BufferMode
95+hGetBuffering = unsafeEff_ . IO.hGetBuffering
96+
97+-- | Lifted version of 'IO.hSeek'
98+hSeek :: FileSystem :> es => Handle -> IO.SeekMode -> Integer -> Eff es ()
99+hSeek h s = unsafeEff_ . IO.hSeek h s
100+
101+-- | Lifted version of 'IO.hTell'
102+hTell :: FileSystem :> es => Handle -> Eff es Integer
103+hTell = unsafeEff_ . IO.hTell
104+
105+-- | Lifted version of 'IO.hIsOpen'
106+hIsOpen :: FileSystem :> es => Handle -> Eff es Bool
107+hIsOpen = unsafeEff_ . IO.hIsOpen
108+
109+-- | Lifted version of 'IO.hIsClosed'
110+hIsClosed :: FileSystem :> es => Handle -> Eff es Bool
111+hIsClosed = unsafeEff_ . IO.hIsClosed
112+
113+-- | Lifted version of 'IO.hIsReadable'
114+hIsReadable :: FileSystem :> es => Handle -> Eff es Bool
115+hIsReadable = unsafeEff_ . IO.hIsReadable
116+
117+-- | Lifted version of 'IO.hIsWritable'
118+hIsWritable :: FileSystem :> es => Handle -> Eff es Bool
119+hIsWritable = unsafeEff_ . IO.hIsWritable
120+
121+-- | Lifted version of 'IO.hIsSeekable'
122+hIsSeekable :: FileSystem :> es => Handle -> Eff es Bool
123+hIsSeekable = unsafeEff_ . IO.hIsSeekable
124+
125+-- | Lifted version of 'IO.hIsTerminalDevice'
126+hIsTerminalDevice :: FileSystem :> es => Handle -> Eff es Bool
127+hIsTerminalDevice = unsafeEff_ . IO.hIsTerminalDevice
128+
129+-- | Lifted version of 'IO.hSetEcho'
130+hSetEcho :: FileSystem :> es => Handle -> Bool -> Eff es ()
131+hSetEcho h = unsafeEff_ . IO.hSetEcho h
132+
133+-- | Lifted version of 'IO.hGetEcho'
134+hGetEcho :: FileSystem :> es => Handle -> Eff es Bool
135+hGetEcho = unsafeEff_ . IO.hGetEcho
136+
137+-- | Lifted version of 'IO.hWaitForInput'
138+hWaitForInput :: FileSystem :> es => Handle -> Int -> Eff es Bool
139+hWaitForInput h = unsafeEff_ . IO.hWaitForInput h
140+
141+-- | Lifted version of 'IO.hReady'
142+hReady :: FileSystem :> es => Handle -> Eff es Bool
143+hReady = unsafeEff_ . IO.hReady
effectful/src/Effectful/Process.hsnew file+182
@@ -0,0 +1,182 @@
1+{-# LANGUAGE CPP #-}
2+-- | Lifted version of "System.Process".
3+module Effectful.Process
4+ ( Process
5+ , runProcess
6+
7+ -- * Running sub-processes
8+ , createProcess
9+ , createProcess_
10+ , P.shell
11+ , P.proc
12+ , P.CreateProcess(..)
13+ , P.CmdSpec(..)
14+ , P.StdStream(..)
15+ , P.ProcessHandle
16+
17+ -- ** Simpler functions for common tasks
18+ , callProcess
19+ , callCommand
20+ , spawnProcess
21+ , spawnCommand
22+ , readCreateProcess
23+ , readProcess
24+ , readCreateProcessWithExitCode
25+ , readProcessWithExitCode
26+ , withCreateProcess
27+ , cleanupProcess
28+
29+ -- ** Related utilities
30+ , P.showCommandForUser
31+ , P.Pid
32+ , getPid
33+#if MIN_VERSION_process(1,6,12)
34+ , getCurrentPid
35+#endif
36+
37+ -- * Process completion
38+ , waitForProcess
39+ , getProcessExitCode
40+ , terminateProcess
41+ , interruptProcessGroupOf
42+
43+ -- * Interprocess communication
44+ , createPipe
45+ , createPipeFd
46+ ) where
47+
48+import System.Exit (ExitCode)
49+import System.IO (Handle)
50+import System.Posix.Internals (FD)
51+import qualified System.Process as P
52+
53+import Effectful.Dispatch.Static
54+import Effectful.Monad
55+
56+-- | An effect for running child processes using the @process@ library.
57+data Process :: Effect where
58+ Process :: Process m r
59+
60+runProcess :: IOE :> es => Eff (Process : es) a -> Eff es a
61+runProcess = evalData (DataA Process)
62+
63+----------------------------------------
64+-- Running sub-processes
65+
66+-- | Lifted 'P.createProcess'.
67+createProcess
68+ :: Process :> es
69+ => P.CreateProcess
70+ -> Eff es (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
71+createProcess = unsafeEff_ . P.createProcess
72+
73+-- | Lifted 'P.createProcess_'.
74+createProcess_
75+ :: Process :> es
76+ => String
77+ -> P.CreateProcess
78+ -> Eff es (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
79+createProcess_ msg = unsafeEff_ . P.createProcess_ msg
80+
81+----------------------------------------
82+-- Simpler functions for common tasks
83+
84+-- | Lifted 'P.callProcess'.
85+callProcess :: Process :> es => FilePath -> [String] -> Eff es ()
86+callProcess fp = unsafeEff_ . P.callProcess fp
87+
88+-- | Lifted 'P.callCommand'.
89+callCommand :: Process :> es => String -> Eff es ()
90+callCommand = unsafeEff_ . P.callCommand
91+
92+-- | Lifted 'P.spawnProcess'.
93+spawnProcess :: Process :> es => FilePath -> [String] -> Eff es P.ProcessHandle
94+spawnProcess fp = unsafeEff_ . P.spawnProcess fp
95+
96+-- | Lifted 'P.spawnCommand'.
97+spawnCommand :: Process :> es => String -> Eff es P.ProcessHandle
98+spawnCommand = unsafeEff_ . P.spawnCommand
99+
100+-- | Lifted 'P.readCreateProcess'.
101+readCreateProcess :: Process :> es => P.CreateProcess -> String -> Eff es String
102+readCreateProcess cp = unsafeEff_ . P.readCreateProcess cp
103+
104+-- | Lifted 'P.readProcess'.
105+readProcess :: Process :> es => FilePath -> [String] -> String -> Eff es String
106+readProcess fp args = unsafeEff_ . P.readProcess fp args
107+
108+-- | Lifted 'P.readCreateProcessWithExitCode'.
109+readCreateProcessWithExitCode
110+ :: Process :> es
111+ => P.CreateProcess
112+ -> String
113+ -> Eff es (ExitCode, String, String)
114+readCreateProcessWithExitCode cp = unsafeEff_ . P.readCreateProcessWithExitCode cp
115+
116+-- | Lifted 'P.readProcessWithExitCode'.
117+readProcessWithExitCode
118+ :: Process :> es
119+ => FilePath
120+ -> [String]
121+ -> String
122+ -> Eff es (ExitCode, String, String)
123+readProcessWithExitCode fp args = unsafeEff_ . P.readProcessWithExitCode fp args
124+
125+-- | Lifted 'P.withCreateProcess'.
126+withCreateProcess
127+ :: Process :> es
128+ => P.CreateProcess
129+ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> P.ProcessHandle -> Eff es a)
130+ -> Eff es a
131+withCreateProcess cp cb = unsafeUnliftIO $ \unlift -> do
132+ P.withCreateProcess cp $ \inh outh errh ph -> unlift $ cb inh outh errh ph
133+
134+-- | Lifted 'P.cleanupProcess'.
135+cleanupProcess
136+ :: Process :> es
137+ => (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
138+ -> Eff es ()
139+cleanupProcess = unsafeEff_ . P.cleanupProcess
140+
141+----------------------------------------
142+-- Related utilities
143+
144+-- | Lifted 'P.getPid'.
145+getPid :: Process :> es => P.ProcessHandle -> Eff es (Maybe P.Pid)
146+getPid = unsafeEff_ . P.getPid
147+
148+#if MIN_VERSION_process(1,6,12)
149+-- | Lifted 'P.getCurrentPid'.
150+getCurrentPid :: Process :> es => Eff es P.Pid
151+getCurrentPid = unsafeEff_ P.getCurrentPid
152+#endif
153+
154+----------------------------------------
155+-- Process completion
156+
157+-- | Lifted 'P.waitForProcess'.
158+waitForProcess :: Process :> es => P.ProcessHandle -> Eff es ExitCode
159+waitForProcess = unsafeEff_ . P.waitForProcess
160+
161+-- | Lifted 'P.getProcessExitCode'.
162+getProcessExitCode :: Process :> es => P.ProcessHandle -> Eff es (Maybe ExitCode)
163+getProcessExitCode = unsafeEff_ . P.getProcessExitCode
164+
165+-- | Lifted 'P.terminateProcess'.
166+terminateProcess :: Process :> es => P.ProcessHandle -> Eff es ()
167+terminateProcess = unsafeEff_ . P.terminateProcess
168+
169+-- | Lifted 'P.interruptProcessGroupOf'.
170+interruptProcessGroupOf :: Process :> es => P.ProcessHandle -> Eff es ()
171+interruptProcessGroupOf = unsafeEff_ . P.interruptProcessGroupOf
172+
173+----------------------------------------
174+-- Interprocess communication
175+
176+-- | Lifted 'P.createPipe'.
177+createPipe :: Process :> es => Eff es (Handle, Handle)
178+createPipe = unsafeEff_ P.createPipe
179+
180+-- | Lifted 'P.createPipeFd'.
181+createPipeFd :: Process :> es => Eff es (FD, FD)
182+createPipeFd = unsafeEff_ P.createPipeFd
effectful/src/Effectful/Resource.hs+31−7
@@ -11,15 +11,21 @@ module Effectful.Resource
1111 , R.register
1212 , R.release
1313 , R.unprotect
14+
15+ -- * Internal state
16+ , R.InternalState
17+ , getInternalState
18+ , runInternalState
19+ , R.createInternalState
20+ , R.closeInternalState
1421 ) where
1522
1623import Control.Exception
1724import qualified Control.Monad.Trans.Resource as R
1825import qualified Control.Monad.Trans.Resource.Internal as RI
1926
20−import Effectful.Internal.Effect
21−import Effectful.Internal.Env
22−import Effectful.Internal.Monad
27+import Effectful.Dispatch.Static
28+import Effectful.Monad
2329
2430-- | Data tag for a resource effect.
2531newtype Resource :: Effect where
@@ -31,15 +37,33 @@ runResource m = unsafeEff $ \es0 -> do
3137 size0 <- sizeEnv es0
3238 istate <- R.createInternalState
3339 mask $ \restore -> do
34− es <- unsafeConsEnv (IdE (Resource istate)) noRelinker es0
40+ es <- unsafeConsEnv (DataA (Resource istate)) noRelinker es0
3541 a <- restore (unEff m es) `catch` \e -> do
36− _ <- unsafeTailEnv size0 es
42+ unsafeTailEnv size0 es
3743 RI.stateCleanupChecked (Just e) istate
3844 throwIO e
39− _ <- unsafeTailEnv size0 es
45+ unsafeTailEnv size0 es
4046 RI.stateCleanupChecked Nothing istate
4147 pure a
4248
49+----------------------------------------
50+-- Internal state
51+
52+-- | Get the 'R.InternalState' of the current 'Resource' effect.
53+getInternalState :: Resource :> es => Eff es R.InternalState
54+getInternalState = do
55+ DataA (Resource istate) <- getData
56+ pure istate
57+
58+-- | Run the 'Resource' effect with existing 'R.InternalState'.
59+--
60+-- /Note:/ the 'R.InternalState' will not be closed at the end.
61+runInternalState :: R.InternalState -> Eff (Resource : es) a -> Eff es a
62+runInternalState istate = evalData (DataA (Resource istate))
63+
64+----------------------------------------
65+-- Orphan instance
66+
4367instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where
4468 liftResourceT (RI.ResourceT m) = unsafeEff $ \es -> do
45− getEnv es >>= \(IdE (Resource istate)) -> m istate
69+ getEnv es >>= \(DataA (Resource istate)) -> m istate
effectful/src/Effectful/Temporary.hsnew file+70
@@ -0,0 +1,70 @@
1+module Effectful.Temporary
2+ ( Temporary
3+ , runTemporary
4+ , withSystemTempFile
5+ , withSystemTempDirectory
6+ , withTempFile
7+ , withTempDirectory
8+ ) where
9+
10+import System.IO
11+import qualified UnliftIO.Temporary as T
12+
13+import Effectful.Dispatch.Static
14+import Effectful.Monad
15+
16+-- | An effect for interacting with temporary files.
17+data Temporary :: Effect where
18+ Temporary :: Temporary m r
19+
20+-- | Run the 'Temporary' effect.
21+runTemporary :: IOE :> es => Eff (Temporary : es) a -> Eff es a
22+runTemporary = evalData (DataA Temporary)
23+
24+-- | Lifted 'T.withSystemTempFile'.
25+withSystemTempFile
26+ :: Temporary :> es
27+ => String
28+ -- ^ File name template. See 'openTempFile'.
29+ -> (FilePath -> Handle -> Eff es a)
30+ -- ^ Callback that can use the file.
31+ -> Eff es a
32+withSystemTempFile template action = unsafeUnliftIO $ \unlift -> do
33+ T.withSystemTempFile template $ \fp handle -> unlift $ action fp handle
34+
35+-- | Lifted 'T.withSystemTempDirectory'.
36+withSystemTempDirectory
37+ :: Temporary :> es
38+ => String
39+ -- ^ Directory name template. See 'openTempFile'.
40+ -> (FilePath -> Eff es a)
41+ -- ^ Callback that can use the directory.
42+ -> Eff es a
43+withSystemTempDirectory template action = unsafeUnliftIO $ \unlift -> do
44+ T.withSystemTempDirectory template $ \fp -> unlift $ action fp
45+
46+-- | Lifted 'T.withTempFile'.
47+withTempFile
48+ :: Temporary :> es
49+ => FilePath
50+ -- ^ Temp dir to create the file in.
51+ -> String
52+ -- ^ File name template. See 'openTempFile'.
53+ -> (FilePath -> Handle -> Eff es a)
54+ -- ^ Callback that can use the file.
55+ -> Eff es a
56+withTempFile tmpDir template action = unsafeUnliftIO $ \unlift -> do
57+ T.withTempFile tmpDir template $ \fp handle -> unlift $ action fp handle
58+
59+-- | Lifted 'T.withTempDirectory'.
60+withTempDirectory
61+ :: Temporary :> es
62+ => FilePath
63+ -- ^ Temp directory to create the directory in.
64+ -> String
65+ -- ^ Directory name template. See 'openTempFile'.
66+ -> (FilePath -> Eff es a)
67+ -- ^ Callback that can use the directory.
68+ -> Eff es a
69+withTempDirectory tmpDir template action = unsafeUnliftIO $ \unlift -> do
70+ T.withTempDirectory tmpDir template $ \fp -> unlift $ action fp
effectful/src/Effectful/Timeout.hsnew file+28
@@ -0,0 +1,28 @@
1+module Effectful.Timeout
2+ ( Timeout
3+ , runTimeout
4+ , timeout
5+ ) where
6+
7+import qualified System.Timeout as T
8+
9+import Effectful.Dispatch.Static
10+import Effectful.Monad
11+
12+-- | An effect for timing out computations.
13+data Timeout :: Effect where
14+ Timeout :: Timeout m r
15+
16+-- | Run the 'Timeout' effect.
17+runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a
18+runTimeout = evalData (DataA Timeout)
19+
20+-- | Lifted 'T.timeout'.
21+timeout
22+ :: Timeout :> es
23+ => Int
24+ -- ^ The timeout in microseconds (1/10^6 seconds).
25+ -> Eff es a
26+ -- ^ The computation the timeout applies to.
27+ -> Eff es (Maybe a)
28+timeout = unsafeLiftMapIO . T.timeout
effectful/tests/AsyncTests.hs+6−7
@@ -2,13 +2,12 @@ module AsyncTests (asyncTests) where
22
33import Control.Concurrent (threadDelay)
44import Control.Monad
5−import Control.Monad.IO.Class
65import Test.Tasty
76import Test.Tasty.HUnit
87import qualified Data.Set as S
98
109import Effectful
11−import Effectful.Async
10+import Effectful.Concurrent.Async
1211import Effectful.Error
1312import Effectful.State.Dynamic
1413
@@ -24,7 +23,7 @@ asyncTests = testGroup "Async"
2423 ]
2524
2625test_localState :: Assertion
27−test_localState = runEff . runAsyncE . evalLocalState x $ do
26+test_localState = runEff . runConcurrent . evalLocalState x $ do
2827 replicateConcurrently_ 2 $ do
2928 r <- goDownward 0
3029 U.assertEqual "expected result" x r
@@ -42,7 +41,7 @@ test_localState = runEff . runAsyncE . evalLocalState x $ do
4241 else goDownward $ acc + 1
4342
4443test_sharedState :: Assertion
45−test_sharedState = runEff . runAsyncE . evalSharedState (S.empty @Int) $ do
44+test_sharedState = runEff . runConcurrent . evalSharedState (S.empty @Int) $ do
4645 concurrently_ (addWhen even x) (addWhen odd x)
4746 U.assertEqual "expected result" (S.fromList [1..x]) =<< get
4847 where
@@ -58,7 +57,7 @@ test_sharedState = runEff . runAsyncE . evalSharedState (S.empty @Int) $ do
5857 addWhen f $ n - 1
5958
6059test_errorHandling :: Assertion
61−test_errorHandling = runEff . runAsyncE . evalSharedState (0::Int) $ do
60+test_errorHandling = runEff . runConcurrent . evalSharedState (0::Int) $ do
6261 r <- runError $ concurrently_
6362 (liftIO (threadDelay 10000) >> throwError err)
6463 (modify (+x))
@@ -74,7 +73,7 @@ test_errorHandling = runEff . runAsyncE . evalSharedState (0::Int) $ do
7473 err = "thrown from async"
7574
7675test_asyncWithUnmask :: Assertion
77−test_asyncWithUnmask = runEff . runAsyncE . evalLocalState "initial" $ do
76+test_asyncWithUnmask = runEff . runConcurrent . evalLocalState "initial" $ do
7877 x <- asyncWithUnmask $ \unmask -> do
7978 liftIO $ threadDelay 10000
8079 r1 <- get @String -- 2
@@ -89,7 +88,7 @@ test_asyncWithUnmask = runEff . runAsyncE . evalLocalState "initial" $ do
8988 (inner1, inner2, outer)
9089
9190test_pooledWorkers :: Assertion
92−test_pooledWorkers = runEff . runAsyncE . evalLocalState (0::Int) $ do
91+test_pooledWorkers = runEff . runConcurrent . evalLocalState (0::Int) $ do
9392 x <- pooledForConcurrentlyN threads [1..n] $ \k -> do
9493 r <- get @Int
9594 modify @Int (+1)
effectful/tests/ConcurrencyTests.hs−1
@@ -2,7 +2,6 @@ module ConcurrencyTests (concurrencyTests) where
22
33import Control.Concurrent (threadDelay)
44import Control.Monad
5−import Control.Monad.IO.Class
65import Test.Tasty
76import Test.Tasty.HUnit
87import UnliftIO
effectful/tests/EnvironmentTests.hsnew file+48
@@ -0,0 +1,48 @@
1+module EnvironmentTests (environmentTests) where
2+
3+import Test.Tasty
4+import Test.Tasty.HUnit
5+import System.IO.Error (isDoesNotExistError)
6+
7+import Effectful
8+import Effectful.Environment
9+import qualified Utils as U
10+
11+environmentTests :: TestTree
12+environmentTests = testCaseSteps "Environment" $ \step -> do
13+ -- These tests need to be run sequentially because of
14+ -- https://github.com/arybczak/effectful/issues/39.
15+ step "set and get an environment variable"
16+ test_setAndGet
17+ step "unset and try to get an environment variable"
18+ test_unsetAndGet
19+ step "execute effects with custom arguments"
20+ test_withArgs
21+ step "execute effects with custom program name"
22+ test_withProg
23+
24+test_setAndGet :: Assertion
25+test_setAndGet = runEff . runEnvironment $ do
26+ let expected = "value"
27+ n = "EFFECTFUL_TEST1"
28+ setEnv n expected
29+ v <- getEnv n
30+ U.assertEqual "environment variable not set" expected v
31+
32+test_unsetAndGet :: Assertion
33+test_unsetAndGet = runEff . runEnvironment $ do
34+ let n = "EFFECTFUL_TEST2"
35+ unsetEnv n
36+ U.assertThrows "environment variable is set" isDoesNotExistError (getEnv n)
37+
38+test_withArgs :: Assertion
39+test_withArgs = runEff . runEnvironment $ do
40+ let expected = ["effectful-test"]
41+ args <- withArgs expected getArgs
42+ U.assertEqual "correct arguments" expected args
43+
44+test_withProg :: Assertion
45+test_withProg = runEff . runEnvironment $ do
46+ let expected = "effectful-test"
47+ n <- withProgName expected getProgName
48+ U.assertEqual "correct program name" expected n
effectful/tests/ErrorTests.hs−1
@@ -1,6 +1,5 @@
11module ErrorTests (errorTests) where
22
3−import Control.Monad.IO.Class
43import Test.Tasty
54import Test.Tasty.HUnit
65
effectful/tests/Main.hs+6
@@ -4,13 +4,19 @@ import Test.Tasty
44
55import AsyncTests
66import ConcurrencyTests
7+import EnvironmentTests
78import ErrorTests
89import StateTests
10+import TimeoutTests
11+import UnliftTests
912
1013main :: IO ()
1114main = defaultMain $ testGroup "effectful"
1215 [ asyncTests
1316 , concurrencyTests
17+ , environmentTests
1418 , errorTests
1519 , stateTests
20+ , timeoutTests
21+ , unliftTests
1622 ]
effectful/tests/StateTests.hs+1
@@ -97,6 +97,7 @@ test_localEffects = runEff $ do
9797 where
9898 expected :: Int
9999 expected = 4
100+
100101----------------------------------------
101102-- Helpers
102103
effectful/tests/TimeoutTests.hsnew file+25
@@ -0,0 +1,25 @@
1+module TimeoutTests (timeoutTests) where
2+
3+import Control.Concurrent (threadDelay)
4+import Test.Tasty
5+import Test.Tasty.HUnit
6+
7+import Effectful
8+import Effectful.Timeout
9+import qualified Utils as U
10+
11+timeoutTests :: TestTree
12+timeoutTests = testGroup "Timeout"
13+ [ testCase "return before timeout" test_returnBeforeTimeout
14+ , testCase "timeout before return" test_timeoutBeforeReturn
15+ ]
16+
17+test_returnBeforeTimeout :: Assertion
18+test_returnBeforeTimeout = runEff $ do
19+ result <- runTimeout $ timeout 1000 $ return ()
20+ U.assertEqual "return value" (Just ()) result
21+
22+test_timeoutBeforeReturn :: Assertion
23+test_timeoutBeforeReturn = runEff $ do
24+ result <- runTimeout $ timeout 0 $ liftIO $ threadDelay 1000
25+ U.assertEqual "no return value" Nothing result
effectful/tests/UnliftTests.hsnew file+93
@@ -0,0 +1,93 @@
1+module UnliftTests (unliftTests) where
2+
3+import Control.Exception
4+import Test.Tasty
5+import Test.Tasty.HUnit
6+import qualified UnliftIO.Async as A
7+
8+import Effectful
9+import qualified Utils as U
10+
11+unliftTests :: TestTree
12+unliftTests = testGroup "Unlift"
13+ [ testCase "Reset strategy in new thread" test_resetStrategy
14+ , testCase "SeqUnlift in new thread" test_seqUnliftInNewThread
15+ , testGroup "Ephemeral strategy"
16+ [ testCase "Invalid limit" test_ephemeralInvalid
17+ , testCase "Uses in same thread" test_ephemeralSameThread
18+ , testCase "Uses in multiple threads" test_ephemeralMultipleThreads
19+ ]
20+ , testGroup "Persistent strategy"
21+ [ testCase "Invalid limit" test_persistentInvalid
22+ , testCase "Uses in same thread" test_persistentSameThread
23+ , testCase "Uses in multiple threads" test_persistentMultipleThreads
24+ ]
25+ ]
26+
27+test_resetStrategy :: Assertion
28+test_resetStrategy = runEff $ do
29+ s <- withUnliftStrategy (ConcUnlift Ephemeral Unlimited) $ do
30+ withEffToIO $ \runInIO -> do
31+ inThread $ runInIO unliftStrategy
32+ U.assertEqual "correct strategy" SeqUnlift s
33+
34+test_seqUnliftInNewThread :: Assertion
35+test_seqUnliftInNewThread = runEff $ do
36+ assertThrowsUnliftError "InvalidUseOfSeqUnlift error" $ do
37+ withUnliftStrategy SeqUnlift $ do
38+ withEffToIO $ \runInIO -> do
39+ inThread $ runInIO $ return ()
40+
41+test_ephemeralInvalid :: Assertion
42+test_ephemeralInvalid = runEff $ do
43+ assertThrowsUnliftError "InvalidNumberOfUses error" $ do
44+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 0) $ do
45+ withEffToIO $ \_ -> return ()
46+
47+test_ephemeralSameThread :: Assertion
48+test_ephemeralSameThread = runEff $ do
49+ assertThrowsUnliftError "ExceededNumberOfUses error" $ do
50+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do
51+ withEffToIO $ \runInIO -> inThread $ do
52+ runInIO $ return ()
53+ runInIO $ return ()
54+
55+test_ephemeralMultipleThreads :: Assertion
56+test_ephemeralMultipleThreads = runEff $ do
57+ assertThrowsUnliftError "ExceededNumberOfUses error" $ do
58+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do
59+ withEffToIO $ \runInIO -> do
60+ inThread $ runInIO $ return ()
61+ inThread $ runInIO $ return ()
62+
63+test_persistentInvalid :: Assertion
64+test_persistentInvalid = runEff $ do
65+ assertThrowsUnliftError "InvalidNumberOfThreads error" $ do
66+ withUnliftStrategy (ConcUnlift Persistent $ Limited 0) $ do
67+ withEffToIO $ \_ -> return ()
68+
69+test_persistentSameThread :: Assertion
70+test_persistentSameThread = runEff $ do
71+ withUnliftStrategy (ConcUnlift Persistent $ Limited 1) $ do
72+ withEffToIO $ \runInIO -> inThread $ do
73+ runInIO $ return ()
74+ runInIO $ return ()
75+
76+test_persistentMultipleThreads :: Assertion
77+test_persistentMultipleThreads = runEff $ do
78+ assertThrowsUnliftError "ExceededNumberOfThreads error" $ do
79+ withUnliftStrategy (ConcUnlift Persistent $ Limited 1) $ do
80+ withEffToIO $ \runInIO -> do
81+ inThread $ runInIO $ return ()
82+ inThread $ runInIO $ return ()
83+
84+----------------------------------------
85+-- Helpers
86+
87+assertThrowsUnliftError
88+ :: IOE :> es
89+ => String -> Eff es a -> Eff es ()
90+assertThrowsUnliftError err = U.assertThrows err (\ErrorCall{} -> True)
91+
92+inThread :: IO a -> IO a
93+inThread k = A.async k >>= A.wait
effectful/tests/Utils.hs+17−1
@@ -2,11 +2,12 @@ module Utils
22 ( assertBool
33 , assertEqual
44 , assertFailure
5+ , assertThrows
56 , Ex(..)
67 ) where
78
89import Control.Exception
9−import Control.Monad.IO.Class
10+import Control.Monad
1011import GHC.Stack
1112import qualified Test.Tasty.HUnit as T
1213
@@ -26,5 +27,20 @@ assertEqual msg expected given = liftIO $ T.assertEqual msg expected given
2627assertFailure :: (HasCallStack, IOE :> es) => String -> Eff es a
2728assertFailure msg = liftIO $ T.assertFailure msg
2829
30+assertThrows
31+ :: (Exception e, IOE :> es)
32+ => String
33+ -> (e -> Bool)
34+ -> Eff es a
35+ -> Eff es ()
36+assertThrows msg p k = withEffToIO $ \runInIO -> do
37+ let k' = do
38+ void $ runInIO k
39+ T.assertFailure msg
40+
41+ k' `catch` \e -> if p e
42+ then return ()
43+ else throwIO e
44+
2945data Ex = Ex deriving (Eq, Show)
3046instance Exception Ex