on master help sign in
.github/workflows/haskell-ci.yml+19−18
since splitsnapshots
unifiedsplit
@@ -8,9 +8,9 @@
8#
8#
9# For more information, see https://github.com/haskell-CI/haskell-ci
9# For more information, see https://github.com/haskell-CI/haskell-ci
10#
10#
11−# version: 0.13.20211030
11+# version: 0.13.20211116
12#
12#
13−# REGENDATA ("0.13.20211030",["github","--config=cabal.haskell-ci","cabal.project"])
13+# REGENDATA ("0.13.20211116",["github","--config=cabal.haskell-ci","cabal.project"])
14#
14#
15name: Haskell-CI
15name: Haskell-CI
16on:
16on:
@@ -24,6 +24,8 @@ jobs:
24 linux:
24 linux:
25 name: Haskell-CI - Linux - ${{ matrix.compiler }}
25 name: Haskell-CI - Linux - ${{ matrix.compiler }}
26 runs-on: ubuntu-18.04
26 runs-on: ubuntu-18.04
27+ timeout-minutes:
28+ 60
27 container:
29 container:
28 image: buildpack-deps:bionic
30 image: buildpack-deps:bionic
29 continue-on-error: ${{ matrix.allow-failure }}
31 continue-on-error: ${{ matrix.allow-failure }}
@@ -35,11 +37,6 @@ jobs:
35 compilerVersion: 9.2.1
37 compilerVersion: 9.2.1
36 setup-method: ghcup
38 setup-method: ghcup
37 allow-failure: false
39 allow-failure: false
38− - compiler: ghc-9.0.1
39− compilerKind: ghc
40− compilerVersion: 9.0.1
41− setup-method: hvr-ppa
42− allow-failure: false
43 - compiler: ghc-8.10.7
40 - compiler: ghc-8.10.7
44 compilerKind: ghc
41 compilerKind: ghc
45 compilerVersion: 8.10.7
42 compilerVersion: 8.10.7
@@ -129,6 +126,10 @@ jobs:
129 repository hackage.haskell.org
126 repository hackage.haskell.org
130 url: http://hackage.haskell.org/
127 url: http://hackage.haskell.org/
131 EOF
128 EOF
129+ cat >> $CABAL_CONFIG <<EOF
130+ program-default-options
131+ ghc-options: $GHCJOBS +RTS -M3G -RTS
132+ EOF
132 cat $CABAL_CONFIG
133 cat $CABAL_CONFIG
133 - name: versions
134 - name: versions
134 run: |
135 run: |
@@ -141,7 +142,7 @@ jobs:
141 - name: cache (tools)
142 - name: cache (tools)
142 uses: actions/cache@v2
143 uses: actions/cache@v2
143 with:
144 with:
144− key: ${{ runner.os }}-${{ matrix.compiler }}-tools-b692a344
145+ key: ${{ runner.os }}-${{ matrix.compiler }}-tools-16fe7d6d
145 path: ~/.haskell-ci-tools
146 path: ~/.haskell-ci-tools
146 - name: install cabal-plan
147 - name: install cabal-plan
147 run: |
148 run: |
@@ -154,8 +155,8 @@ jobs:
154 cabal-plan --version
155 cabal-plan --version
155 - name: install doctest
156 - name: install doctest
156 run: |
157 run: |
157− 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
158+ $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.20'
158− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest --version ; fi
159+ doctest --version
159 - name: checkout
160 - name: checkout
160 uses: actions/checkout@v2
161 uses: actions/checkout@v2
161 with:
162 with:
@@ -163,8 +164,8 @@ jobs:
163 - name: initial cabal.project for sdist
164 - name: initial cabal.project for sdist
164 run: |
165 run: |
165 touch cabal.project
166 touch cabal.project
166− echo "packages: $GITHUB_WORKSPACE/source/./effectful" >> cabal.project
167+ echo "packages: $GITHUB_WORKSPACE/source/effectful" >> cabal.project
167− echo "packages: $GITHUB_WORKSPACE/source/./effectful-core" >> cabal.project
168+ echo "packages: $GITHUB_WORKSPACE/source/effectful-core" >> cabal.project
168 cat cabal.project
169 cat cabal.project
169 - name: sdist
170 - name: sdist
170 run: |
171 run: |
@@ -221,12 +222,12 @@ jobs:
221 $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
222 $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
222 - name: doctest
223 - name: doctest
223 run: |
224 run: |
224− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful} || false ; fi
225+ cd ${PKGDIR_effectful} || false
225− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi
226+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
226− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful_core} || false ; fi
227+ cd ${PKGDIR_effectful_core} || false
227− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi
228+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
228− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful_core} || false ; fi
229+ cd ${PKGDIR_effectful_core} || false
229− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators utils ; fi
230+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators utils
230 - name: cabal check
231 - name: cabal check
231 run: |
232 run: |
232 cd ${PKGDIR_effectful} || false
233 cd ${PKGDIR_effectful} || false
README.md+2−2
@@ -20,8 +20,8 @@ Main features:
20
20
212. Easy to use API (no boilerplate code and dealing with arcane types).
212. Easy to use API (no boilerplate code and dealing with arcane types).
22
22
23−3. Correct semantics in presence of runtime exceptions (no more lost or
23+3. Correct semantics in presence of runtime exceptions (no more lost state
24− discarded state).
24+ modifications).
25
25
264. Seamless integration with the existing ecosystem (`exceptions`,
264. Seamless integration with the existing ecosystem (`exceptions`,
27 `monad-control`, `unliftio-core`, `resourcet` etc.).
27 `monad-control`, `unliftio-core`, `resourcet` etc.).
cabal.haskell-ci+1−3
@@ -1,11 +1,9 @@
1branches: master
1branches: master
2
2
3−doctest: <9.2
3+doctest: <9.3
4tests: True
4tests: True
5benchmarks: True
5benchmarks: True
6
6
7−ghcup-jobs: ==8.10.7 || >=9.2
8−
9raw-project
7raw-project
10 package effectful
8 package effectful
11 flags: +benchmark-foreign-libraries
9 flags: +benchmark-foreign-libraries
doctest.sh+2−1
@@ -17,6 +17,7 @@ run_doctest() {
17 -XConstraintKinds \
17 -XConstraintKinds \
18 -XDataKinds \
18 -XDataKinds \
19 -XDeriveFunctor \
19 -XDeriveFunctor \
20+ -XDeriveGeneric \
20 -XFlexibleContexts \
21 -XFlexibleContexts \
21 -XFlexibleInstances \
22 -XFlexibleInstances \
22 -XGADTs \
23 -XGADTs \
@@ -36,5 +37,5 @@ run_doctest() {
36 popd
37 popd
37}
38}
38
39
39−run_doctest effectful src
40run_doctest effectful-core src
40run_doctest effectful-core src
41+run_doctest effectful src
effectful-core/effectful-core.cabal+15−11
@@ -18,7 +18,7 @@ description: An easy to use, performant extensible effects library with seamless
18
18
19extra-source-files: CHANGELOG.md
19extra-source-files: CHANGELOG.md
20
20
21−tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.1
21+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1
22
22
23bug-reports: https://github.com/arybczak/effectful/issues
23bug-reports: https://github.com/arybczak/effectful/issues
24source-repository head
24source-repository head
@@ -34,6 +34,7 @@ common language
34 ConstraintKinds
34 ConstraintKinds
35 DataKinds
35 DataKinds
36 DeriveFunctor
36 DeriveFunctor
37+ DeriveGeneric
37 FlexibleContexts
38 FlexibleContexts
38 FlexibleInstances
39 FlexibleInstances
39 GADTs
40 GADTs
@@ -66,21 +67,24 @@ library
66
67
67 ghc-options: -O2
68 ghc-options: -O2
68
69
69− build-depends: base >= 4.13 && <5
70+ build-depends: effectful-internal-utils
71+
72+ build-depends: base >= 4.13 && < 5
70− , containers
73+ , containers >= 0.6
71− , effectful-internal-utils
72− , exceptions
74+ , exceptions >= 0.10.4
73− , monad-control
75+ , monad-control >= 1.0.3
74− , primitive
76+ , primitive >= 0.7.3.0
75− , transformers-base
77+ , transformers-base >= 0.4.6
76− , unliftio-core
78+ , unliftio-core >= 0.2.0.1
77
79
78 hs-source-dirs: src
80 hs-source-dirs: src
79
81
80− exposed-modules: Effectful.Error
82+ exposed-modules: Effectful
83+ Effectful.Dispatch.Dynamic
84+ Effectful.Dispatch.Static
85+ Effectful.Error
81 Effectful.Error.Dynamic
86 Effectful.Error.Dynamic
82 Effectful.Fail
87 Effectful.Fail
83− Effectful.Handler
84 Effectful.Internal.Effect
88 Effectful.Internal.Effect
85 Effectful.Internal.Env
89 Effectful.Internal.Env
86 Effectful.Internal.Monad
90 Effectful.Internal.Monad
effectful/src/Effectful.hs → effectful-core/src/Effectful.hsrenamed+4−5
@@ -8,10 +8,10 @@ module Effectful
8
8
9 -- * Running the 'Eff' monad
9 -- * Running the 'Eff' monad
10
10
11− -- ** Pure operations
11+ -- ** Pure computations
12 , runPureEff
12 , runPureEff
13
13
14− -- ** Operations with side effects
14+ -- ** Computations with side effects
15 , IOE
15 , IOE
16 , runEff
16 , runEff
17
17
@@ -22,7 +22,6 @@ module Effectful
22 , unliftStrategy
22 , unliftStrategy
23 , withUnliftStrategy
23 , withUnliftStrategy
24 , withEffToIO
24 , withEffToIO
25− , UnliftError(..)
26
25
27 -- * 'Effect' handlers
26 -- * 'Effect' handlers
28
27
@@ -33,7 +32,7 @@ module Effectful
33 , interpret
32 , interpret
34 , reinterpret
33 , reinterpret
35
34
36− -- ** Handling local 'Eff' operations
35+ -- ** Handling local 'Eff' computations
37 , LocalEnv
36 , LocalEnv
38
37
39 -- *** Unlifts
38 -- *** Unlifts
@@ -55,5 +54,5 @@ module Effectful
55 , MonadUnliftIO(..)
54 , MonadUnliftIO(..)
56 ) where
55 ) where
57
56
58−import Effectful.Handler
57+import Effectful.Dispatch.Dynamic
59import Effectful.Monad
58import Effectful.Monad
effectful-core/src/Effectful/Handler.hs → effectful-core/src/Effectful/Dispatch/Dynamic.hsrenamed+42−30
@@ -1,4 +1,4 @@
1−module Effectful.Handler
1+module Effectful.Dispatch.Dynamic
2 ( -- * Sending operations to the handler
2 ( -- * Sending operations to the handler
3 send
3 send
4
4
@@ -7,7 +7,7 @@ module Effectful.Handler
7 , interpret
7 , interpret
8 , reinterpret
8 , reinterpret
9
9
10− -- ** Handling local 'Eff' operations
10+ -- ** Handling local 'Eff' computations
11 , LocalEnv
11 , LocalEnv
12
12
13 -- *** Unlifts
13 -- *** Unlifts
@@ -32,7 +32,8 @@ module Effectful.Handler
32 ) where
32 ) where
33
33
34import Control.Monad.IO.Unlift
34import Control.Monad.IO.Unlift
35−import GHC.Stack
35+import Data.Kind
36+import GHC.Stack (HasCallStack)
36
37
37import Effectful.Internal.Effect
38import Effectful.Internal.Effect
38import Effectful.Internal.Env
39import Effectful.Internal.Env
@@ -49,7 +50,7 @@ interpret
49 -> Eff es a
50 -> Eff es a
50interpret handler m = unsafeEff $ \es -> do
51interpret handler m = unsafeEff $ \es -> do
51 les <- forkEnv es
52 les <- forkEnv es
52− (`unEff` es) $ runHandler (Handler les handler) m
53+ (`unEff` es) $ runHandler (HandlerA les handler) m
53
54
54-- | Interpret an effect using other effects.
55-- | Interpret an effect using other effects.
55reinterpret
56reinterpret
@@ -62,7 +63,7 @@ reinterpret
62reinterpret runHandlerEs handler m = unsafeEff $ \es -> do
63reinterpret runHandlerEs handler m = unsafeEff $ \es -> do
63 les0 <- forkEnv es
64 les0 <- forkEnv es
64 (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do
65 (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do
65− (`unEff` es) $ runHandler (Handler les handler) m
66+ (`unEff` es) $ runHandler (HandlerA les handler) m
66
67
67----------------------------------------
68----------------------------------------
68-- Unlifts
69-- Unlifts
@@ -77,7 +78,7 @@ localSeqUnlift
77 -- ^ Continuation with the unlifting function in scope.
78 -- ^ Continuation with the unlifting function in scope.
78 -> Eff es a
79 -> Eff es a
79localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do
80localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do
80− seqUnliftEff les $ \unlift -> do
81+ seqUnliftIO les $ \unlift -> do
81 (`unEff` es) $ k $ unsafeEff_ . unlift
82 (`unEff` es) $ k $ unsafeEff_ . unlift
82
83
83-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
84-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
@@ -89,7 +90,7 @@ localSeqUnliftIO
89 -> ((forall r. Eff localEs r -> IO r) -> IO a)
90 -> ((forall r. Eff localEs r -> IO r) -> IO a)
90 -- ^ Continuation with the unlifting function in scope.
91 -- ^ Continuation with the unlifting function in scope.
91 -> Eff es a
92 -> Eff es a
92−localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftEff les k
93+localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k
93
94
94-- | Create a local unlifting function with the given strategy.
95-- | Create a local unlifting function with the given strategy.
95localUnlift
96localUnlift
@@ -102,10 +103,10 @@ localUnlift
102 -> Eff es a
103 -> Eff es a
103localUnlift (LocalEnv les) strategy k = case strategy of
104localUnlift (LocalEnv les) strategy k = case strategy of
104 SeqUnlift -> unsafeEff $ \es -> do
105 SeqUnlift -> unsafeEff $ \es -> do
105− seqUnliftEff les $ \unlift -> do
106+ seqUnliftIO les $ \unlift -> do
106 (`unEff` es) $ k $ unsafeEff_ . unlift
107 (`unEff` es) $ k $ unsafeEff_ . unlift
107 ConcUnlift p l -> unsafeEff $ \es -> do
108 ConcUnlift p l -> unsafeEff $ \es -> do
108− concUnliftEff les p l $ \unlift -> do
109+ concUnliftIO les p l $ \unlift -> do
109 (`unEff` es) $ k $ unsafeEff_ . unlift
110 (`unEff` es) $ k $ unsafeEff_ . unlift
110
111
111-- | Create a local unlifting function with the given strategy.
112-- | Create a local unlifting function with the given strategy.
@@ -118,10 +119,10 @@ localUnliftIO
118 -- ^ Continuation with the unlifting function in scope.
119 -- ^ Continuation with the unlifting function in scope.
119 -> Eff es a
120 -> Eff es a
120localUnliftIO (LocalEnv les) strategy k = case strategy of
121localUnliftIO (LocalEnv les) strategy k = case strategy of
121− SeqUnlift -> liftIO $ seqUnliftEff les k
122+ SeqUnlift -> liftIO $ seqUnliftIO les k
122− ConcUnlift p l -> liftIO $ concUnliftEff les p l k
123+ ConcUnlift p l -> liftIO $ concUnliftIO les p l k
123
124
124−-- | Utility for lifting 'Eff' operations of type
125+-- | Utility for lifting 'Eff' computations of type
125--
126--
126-- @'Eff' es a -> 'Eff' es b@
127-- @'Eff' es a -> 'Eff' es b@
127--
128--
@@ -129,7 +130,7 @@ localUnliftIO (LocalEnv les) strategy k = case strategy of
129--
130--
130-- @'Eff' localEs a -> 'Eff' localEs b@
131-- @'Eff' localEs a -> 'Eff' localEs b@
131--
132--
132−-- /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,
133-- attempting to do so will result in a runtime error.
134-- attempting to do so will result in a runtime error.
134withLiftMap
135withLiftMap
135 :: (HasCallStack, SuffixOf es handlerEs)
136 :: (HasCallStack, SuffixOf es handlerEs)
@@ -142,10 +143,10 @@ withLiftMap !_ k = unsafeEff $ \es -> do
142 -- The LocalEnv parameter is not used, but we need it to constraint the
143 -- The LocalEnv parameter is not used, but we need it to constraint the
143 -- localEs type variable. It's also strict so that callers don't cheat.
144 -- localEs type variable. It's also strict so that callers don't cheat.
144 (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do
145 (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do
145− seqUnliftEff localEs $ \unlift -> do
146+ seqUnliftIO localEs $ \unlift -> do
146 (`unEff` es) . mapEff . unsafeEff_ $ unlift m
147 (`unEff` es) . mapEff . unsafeEff_ $ unlift m
147
148
148−-- | Utility for lifting 'IO' operations of type
149+-- | Utility for lifting 'IO' computations of type
149--
150--
150-- @'IO' a -> 'IO' b@
151-- @'IO' a -> 'IO' b@
151--
152--
@@ -153,11 +154,11 @@ withLiftMap !_ k = unsafeEff $ \es -> do
153--
154--
154-- @'Eff' localEs a -> 'Eff' localEs b@
155-- @'Eff' localEs a -> 'Eff' localEs b@
155--
156--
156−-- /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,
157-- attempting to do so will result in a runtime error.
158-- attempting to do so will result in a runtime error.
158--
159--
159-- Useful e.g. for lifting the unmasking function in
160-- Useful e.g. for lifting the unmasking function in
160−-- 'Control.Exception.mask'-like operations:
161+-- 'Control.Exception.mask'-like computations:
161--
162--
162-- >>> :{
163-- >>> :{
163-- data Fork :: Effect where
164-- data Fork :: Effect where
@@ -180,17 +181,17 @@ withLiftMapIO
180withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do
181withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do
181 -- The LocalEnv parameter is not used, but we need it to constraint the
182 -- The LocalEnv parameter is not used, but we need it to constraint the
182 -- localEs type variable. It's also strict so that callers don't cheat.
183 -- localEs type variable. It's also strict so that callers don't cheat.
183− seqUnliftEff es $ \unlift -> mapIO $ unlift m
184+ seqUnliftIO es $ \unlift -> mapIO $ unlift m
184
185
185----------------------------------------
186----------------------------------------
186-- Bidirectional lifts
187-- Bidirectional lifts
187
188
188-- | Create a local lifting and unlifting function with the given strategy.
189-- | Create a local lifting and unlifting function with the given strategy.
189--
190--
190−-- Useful for lifting complicated 'Eff' operations where the monadic action
191+-- Useful for lifting complicated 'Eff' computations where the monadic action
191-- shows in both positive (as a result) and negative (as an argument) position.
192-- shows in both positive (as a result) and negative (as an argument) position.
192--
193--
193−-- /Note:/ depending on the operation you're lifting 'localUnlift' along with
194+-- /Note:/ depending on the computation you're lifting 'localUnlift' along with
194-- 'withLiftMap' might be enough and is more efficient.
195-- 'withLiftMap' might be enough and is more efficient.
195localLiftUnlift
196localLiftUnlift
196 :: (HasCallStack, SuffixOf es handlerEs)
197 :: (HasCallStack, SuffixOf es handlerEs)
@@ -202,22 +203,22 @@ localLiftUnlift
202 -> Eff es a
203 -> Eff es a
203localLiftUnlift (LocalEnv les) strategy k = case strategy of
204localLiftUnlift (LocalEnv les) strategy k = case strategy of
204 SeqUnlift -> unsafeEff $ \es -> do
205 SeqUnlift -> unsafeEff $ \es -> do
205− seqUnliftEff es $ \unliftEs -> do
206+ seqUnliftIO es $ \unliftEs -> do
206− seqUnliftEff les $ \unliftLocalEs -> do
207+ seqUnliftIO les $ \unliftLocalEs -> do
207 (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)
208 (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)
208 ConcUnlift p l -> unsafeEff $ \es -> do
209 ConcUnlift p l -> unsafeEff $ \es -> do
209− concUnliftEff es p l $ \unliftEs -> do
210+ concUnliftIO es p l $ \unliftEs -> do
210− concUnliftEff les p l $ \unliftLocalEs -> do
211+ concUnliftIO les p l $ \unliftLocalEs -> do
211 (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)
212 (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)
212
213
213-- | Create a local unlifting function with the given strategy along with an
214-- | Create a local unlifting function with the given strategy along with an
214-- unrestricted lifting function.
215-- unrestricted lifting function.
215--
216--
216−-- Useful for lifting complicated 'IO' operations where the monadic action shows
217+-- Useful for lifting complicated 'IO' computations where the monadic action
217−-- in both positive (as a result) and negative (as an argument) position.
218+-- shows in both positive (as a result) and negative (as an argument) position.
218--
219--
219−-- /Note:/ depending on the operation you're lifting 'localUnliftIO' along with
220+-- /Note:/ depending on the computation you're lifting 'localUnliftIO' along
220−-- 'withLiftMapIO' might be enough and is more efficient.
221+-- with 'withLiftMapIO' might be enough and is more efficient.
221localLiftUnliftIO
222localLiftUnliftIO
222 :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
223 :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
223 => LocalEnv localEs handlerEs
224 => LocalEnv localEs handlerEs
@@ -227,8 +228,19 @@ localLiftUnliftIO
227 -- ^ Continuation with the lifting and unlifting function in scope.
228 -- ^ Continuation with the lifting and unlifting function in scope.
228 -> Eff es a
229 -> Eff es a
229localLiftUnliftIO (LocalEnv les) strategy k = case strategy of
230localLiftUnliftIO (LocalEnv les) strategy k = case strategy of
230− SeqUnlift -> liftIO $ seqUnliftEff les $ k unsafeEff_
231+ SeqUnlift -> liftIO $ seqUnliftIO les $ k unsafeEff_
231− ConcUnlift p l -> liftIO $ concUnliftEff les p l $ 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
232
244
233-- $setup
245-- $setup
234-- >>> import Control.Concurrent
246-- >>> 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+96−26
@@ -1,28 +1,78 @@
1−{- | Support for checked exceptions.
1+-- | Support for handling errors of a particular type, i.e. checked exceptions.
2−
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
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
6−functions from the "Control.Monad.Catch" module are for.
5+-- "Control.Monad.Catch" for more information).
7−
6+--
8−For example, if you want to catch an unchecked exception like
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
9−'Control.Exception.ErrorCall' you could use 'Control.Monad.Catch.catch':
17+-- 'Control.Monad.Catch.catch' (or a similar function):
10−
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
11−>>> import qualified Control.Monad.Catch as E
24+-- 'Control.Monad.Catch.bracket' work as expected:
25+--
26+-- >>> let msg = liftIO . putStrLn
12−>>> :{
27+-- >>> :{
13− let boom :: Eff es String
28+-- runEff . fmap (either (Left . snd) Right) . runError @String $ do
14− boom = error "BOOM!"
29+-- E.bracket_ (msg "Beginning.")
15− in
30+-- (msg "Cleaning up.")
16− runEff $ boom `E.catch` \(e :: ErrorCall) -> pure "caught some error"
31+-- (msg "Computing." >> throwError "oops" >> msg "More.")
17−:}
32+-- :}
18−"caught some error"
33+-- Beginning.
19−
34+-- Computing.
20−-}
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.
21module Effectful.Error
70module Effectful.Error
22 ( Error
71 ( Error
23 , runError
72 , runError
24 , throwError
73 , throwError
25 , catchError
74 , catchError
75+ , handleError
26 , tryError
76 , tryError
27
77
28 -- * Re-exports
78 -- * Re-exports
@@ -37,13 +87,14 @@ import Data.Typeable
37import Data.Unique
87import Data.Unique
38import GHC.Stack
88import GHC.Stack
39
89
40−import Effectful.Internal.Effect
90+import Effectful.Dispatch.Static
41−import Effectful.Internal.Env
42−import Effectful.Internal.Monad
91+import Effectful.Monad
43
92
93+-- | Provide the ability to handle errors of type @e@.
44newtype Error e :: Effect where
94newtype Error e :: Effect where
45 Error :: ErrorId -> Error e m r
95 Error :: ErrorId -> Error e m r
46
96
97+-- | Handle errors of type @e@.
47runError
98runError
48 :: forall e es a. Typeable e
99 :: forall e es a. Typeable e
49 => Eff (Error e : es) a
100 => Eff (Error e : es) a
@@ -51,7 +102,7 @@ runError
51runError m = unsafeEff $ \es0 -> mask $ \release -> do
102runError m = unsafeEff $ \es0 -> mask $ \release -> do
52 eid <- newErrorId
103 eid <- newErrorId
53 size0 <- sizeEnv es0
104 size0 <- sizeEnv es0
54− es <- unsafeConsEnv (IdE (Error @e eid)) noRelinker es0
105+ es <- unsafeConsEnv (DataA (Error @e eid)) noRelinker es0
55 r <- tryErrorIO release eid es `onException` unsafeTailEnv size0 es
106 r <- tryErrorIO release eid es `onException` unsafeTailEnv size0 es
56 unsafeTailEnv size0 es
107 unsafeTailEnv size0 es
57 pure r
108 pure r
@@ -61,29 +112,48 @@ runError m = unsafeEff $ \es0 -> mask $ \release -> do
61 Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))
112 Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))
62 $ throwIO ex
113 $ throwIO ex
63
114
115+-- | Throw an error of type @e@.
64throwError
116throwError
65 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
117 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)
66 => e
118 => e
119+ -- ^ The error.
67 -> Eff es a
120 -> Eff es a
68throwError e = unsafeEff $ \es -> do
121throwError e = unsafeEff $ \es -> do
69− IdE (Error eid) <- getEnv @(Error e) es
122+ DataA (Error eid) <- getEnv @(Error e) es
70 throwIO $ ErrorEx eid callStack e
123 throwIO $ ErrorEx eid callStack e
71
124
125+-- | Handle an error of type @e@.
72catchError
126catchError
73 :: forall e es a. (Typeable e, Error e :> es)
127 :: forall e es a. (Typeable e, Error e :> es)
74 => Eff es a
128 => Eff es a
129+ -- ^ The inner computation.
75 -> (CallStack -> e -> Eff es a)
130 -> (CallStack -> e -> Eff es a)
131+ -- ^ A handler for errors in the inner computation.
76 -> Eff es a
132 -> Eff es a
77catchError m handler = unsafeEff $ \es -> do
133catchError m handler = unsafeEff $ \es -> do
78− IdE (Error eid) <- getEnv @(Error e) es
134+ DataA (Error eid) <- getEnv @(Error e) es
79 size <- sizeEnv es
135 size <- sizeEnv es
80 catchErrorIO eid (unEff m es) $ \cs e -> do
136 catchErrorIO eid (unEff m es) $ \cs e -> do
81 checkSizeEnv size es
137 checkSizeEnv size es
82 unEff (handler cs e) es
138 unEff (handler cs e) es
83
139
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.
84tryError
153tryError
85 :: forall e es a. (Typeable e, Error e :> es)
154 :: forall e es a. (Typeable e, Error e :> es)
86 => Eff es a
155 => Eff es a
156+ -- ^ The inner computation.
87 -> Eff es (Either (CallStack, e) a)
157 -> Eff es (Either (CallStack, e) a)
88tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
158tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)
89
159
effectful-core/src/Effectful/Error/Dynamic.hs+1−1
@@ -8,7 +8,7 @@ module Effectful.Error.Dynamic
8
8
9import Data.Typeable
9import Data.Typeable
10
10
11−import Effectful.Handler
11+import Effectful.Dispatch.Dynamic
12import Effectful.Monad
12import Effectful.Monad
13import qualified Effectful.Error as E
13import qualified Effectful.Error as E
14
14
effectful-core/src/Effectful/Fail.hs+2−1
@@ -1,10 +1,11 @@
1+-- | Provider of the 'MonadFail' instance for 'Eff'.
1module Effectful.Fail
2module Effectful.Fail
2 ( Fail(..)
3 ( Fail(..)
3 , runFail
4 , runFail
4 ) where
5 ) where
5
6
7+import Effectful.Dispatch.Dynamic
6import Effectful.Error
8import Effectful.Error
7−import Effectful.Handler
8import Effectful.Internal.Monad
9import Effectful.Internal.Monad
9
10
10-- | Run the 'Fail' effect via 'Error'.
11-- | Run the 'Fail' effect via 'Error'.
effectful-core/src/Effectful/Internal/Effect.hs+7−23
@@ -8,10 +8,6 @@
8module Effectful.Internal.Effect
8module Effectful.Internal.Effect
9 ( Effect
9 ( Effect
10 , (:>)(..)
10 , (:>)(..)
11− , IdE(..)
12−
13− -- * Utils
14− , SuffixOf
15
11
16 -- * Re-exports
12 -- * Re-exports
17 , Type
13 , Type
@@ -23,20 +19,16 @@ import GHC.TypeLits
23-- | The kind of effects.
19-- | The kind of effects.
24type Effect = (Type -> Type) -> Type -> Type
20type Effect = (Type -> Type) -> Type -> Type
25
21
26−-- | Adapter for statically dispatched effects.
27−newtype IdE :: Effect -> Type where
28− IdE :: (forall m r. e m r) -> IdE e
29−
30−-- | A constraint that requires that a particular effect, @e@, is a member of
22+-- | A constraint that requires that a particular effect @e@ is a member of the
31−-- the type-level list @es@. This is used to parameterize an
23+-- type-level list @es@. This is used to parameterize an 'Effectful.Monad.Eff'
32−-- 'Effectful.Monad.Eff' operation over an arbitrary list of effects, so long as
24+-- computation over an arbitrary list of effects, so long as @e@ is /somewhere/
33−-- @e@ is /somewhere/ in the list.
25+-- in the list.
34--
26--
35−-- For example, an operation that only needs access to a cell of mutable state
27+-- For example, a computation that only needs access to a mutable value of type
36−-- containing an 'Integer' would likely use the following type:
28+-- 'Integer' would likely use the following type:
37--
29--
38-- @
30-- @
39−-- 'Effectful.State.State' 'Integer' ':>' es => 'Effectful.Monad.Eff' es ()
31+-- 'Effectful.State.Local.State' 'Integer' ':>' es => 'Effectful.Monad.Eff' es ()
40-- @
32-- @
41class (e :: Effect) :> (es :: [Effect]) where
33class (e :: Effect) :> (es :: [Effect]) where
42 -- | Get the position of @e@ in @es@.
34 -- | Get the position of @e@ in @es@.
@@ -59,11 +51,3 @@ instance {-# OVERLAPPING #-} e :> (e : es) where
59
51
60instance e :> es => e :> (x : es) where
52instance e :> es => e :> (x : es) where
61 reifyIndex = 1 + reifyIndex @e @es
53 reifyIndex = 1 + reifyIndex @e @es
62−
63−-- | Require that the second list of effects is a suffix of the first one.
64−--
65−-- In other words, 'SuffixOf' @es@ @baseEs@ means "a suffix of @es@ is
66−-- @baseEs@".
67−type family SuffixOf (es :: [Effect]) (baseEs :: [Effect]) :: Constraint where
68− SuffixOf baseEs baseEs = ()
69− SuffixOf (e : es) baseEs = SuffixOf es baseEs
effectful-core/src/Effectful/Internal/Env.hs+59−40
@@ -1,25 +1,38 @@
1+{-# LANGUAGE MagicHash #-}
1{-# OPTIONS_HADDOCK not-home #-}
2{-# OPTIONS_HADDOCK not-home #-}
2-- | The environment for the 'Effectful.Internal.Monad.Eff' monad.
3-- | The environment for the 'Effectful.Internal.Monad.Eff' monad.
3--
4--
4-- This module is intended for internal use only, and may change without warning
5-- This module is intended for internal use only, and may change without warning
5-- in subsequent releases.
6-- in subsequent releases.
6module Effectful.Internal.Env
7module Effectful.Internal.Env
8+ ( -- * The environment
7− ( Env
9+ Env(..)
10+ , Forks(..)
11+ , EnvRef(..)
12+
13+ -- ** ForkId
14+ , ForkId(..)
15+ , ForkIdGen(..)
16+ , newForkIdGen
17+ , cloneForkIdGen
18+ , newForkId
19+
20+ -- ** Relinker
8 , Relinker(..)
21 , Relinker(..)
9 , noRelinker
22 , noRelinker
10
23
11− -- * Operations
24+ -- * Operations
12 , emptyEnv
25 , emptyEnv
13 , cloneEnv
26 , cloneEnv
14 , forkEnv
27 , forkEnv
15 , sizeEnv
28 , sizeEnv
16 , checkSizeEnv
29 , checkSizeEnv
17
30
18− -- ** Extending and shrinking
31+ -- ** Extending and shrinking
19 , unsafeConsEnv
32 , unsafeConsEnv
20 , unsafeTailEnv
33 , unsafeTailEnv
21
34
22− -- ** Data retrieval and update
35+ -- ** Data retrieval and update
23 , getEnv
36 , getEnv
24 , putEnv
37 , putEnv
25 , stateEnv
38 , stateEnv
@@ -30,7 +43,7 @@ import Control.Monad
30import Control.Monad.Primitive
43import Control.Monad.Primitive
31import Data.IORef
44import Data.IORef
32import Data.Primitive.SmallArray
45import Data.Primitive.SmallArray
33−import GHC.Exts (Any)
46+import GHC.Exts (Any, SmallMutableArray#)
34import GHC.Stack (HasCallStack)
47import GHC.Stack (HasCallStack)
35import Unsafe.Coerce
48import Unsafe.Coerce
36import qualified Data.IntMap.Strict as IM
49import qualified Data.IntMap.Strict as IM
@@ -68,17 +81,17 @@ type role Env nominal
68-- @
81-- @
69--
82--
70-- The point of execution is currently at (*), i.e. the mainline. Moreover,
83-- The point of execution is currently at (*), i.e. the mainline. Moreover,
71−-- currently:
84+-- currently (brackets represent forks):
72--
85--
73-- - Mainline sees @[e00, e01, e05, e07]@.
86-- - Mainline sees @[e00, e01, e05, e07]@.
74--
87--
75−-- - @e01@ is an interpreted effect, its handler sees @[e00, e02, e03]@.
88+-- - @e01@ is an interpreted effect, its handler sees @[e00][e02, e03]@.
76--
89--
77−-- - @e03@ is an interpreted effect, its handler sees @[e00, e02, e04]@.
90+-- - @e03@ is an interpreted effect, its handler sees @[e00][e02][e04]@.
78--
91--
79−-- - @e05@ is an interpreted effect, its handler sees @[e00, e01, e06]@.
92+-- - @e05@ is an interpreted effect, its handler sees @[e00, e01][e06]@.
80--
93--
81−-- - @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,
82-- e09]@.
95-- e09]@.
83--
96--
84-- If an operation from @e01@ is invoked, the environment in the middle of
97-- If an operation from @e01@ is invoked, the environment in the middle of
@@ -101,11 +114,11 @@ type role Env nominal
101-- introduced @e12@), so its local environment was temporarily extended with
114-- introduced @e12@), so its local environment was temporarily extended with
102-- it. Moreover, currently:
115-- it. Moreover, currently:
103--
116--
104−-- - Handler of @e01@ sees @[e00, e02, e03, e10]@.
117+-- - Handler of @e01@ sees @[e00][e02, e03, e10]@.
105--
118--
106−-- - Handler of @e10@ sees @[e00, e02, e03, e11]@.
119+-- - Handler of @e10@ sees @[e00][e02, e03][e11]@.
107--
120--
108−-- - Handler of @e11@ sees @[e00, e02, e03, e12]@.
121+-- - Handler of @e11@ sees @[e00][e02, e03][e12]@.
109--
122--
110data Env (es :: [Effect]) = Env
123data Env (es :: [Effect]) = Env
111 { _forks :: !Forks
124 { _forks :: !Forks
@@ -116,6 +129,7 @@ data Env (es :: [Effect]) = Env
116-- | Local forks of the environment.
129-- | Local forks of the environment.
117data Forks = Forks !ForkId !Int !(IORef EnvRef) Forks | NoFork
130data Forks = Forks !ForkId !Int !(IORef EnvRef) Forks | NoFork
118
131
132+-- | Data held in the environment.
119data EnvRef = EnvRef
133data EnvRef = EnvRef
120 { _size :: !Int
134 { _size :: !Int
121 , _data :: !(SmallMutableArray RealWorld Any)
135 , _data :: !(SmallMutableArray RealWorld Any)
@@ -125,6 +139,7 @@ data EnvRef = EnvRef
125----------------------------------------
139----------------------------------------
126-- ForkId
140-- ForkId
127
141
142+-- | Internal id of the fork.
128newtype ForkId = ForkId { unForkId :: Int }
143newtype ForkId = ForkId { unForkId :: Int }
129
144
130-- | 'ForkId' generation.
145-- | 'ForkId' generation.
@@ -152,11 +167,11 @@ newForkId (ForkIdGen ref) = do
152-- the environment.
167-- the environment.
153newtype Relinker :: (Effect -> Type) -> Effect -> Type where
168newtype Relinker :: (Effect -> Type) -> Effect -> Type where
154 Relinker
169 Relinker
155− :: ((forall es. Env es -> IO (Env es)) -> handler e -> IO (handler e))
170+ :: ((forall es. Env es -> IO (Env es)) -> adapter e -> IO (adapter e))
156− -> Relinker handler e
171+ -> Relinker adapter e
157
172
158-- | A dummy 'Relinker' that does nothing.
173-- | A dummy 'Relinker' that does nothing.
159−noRelinker :: Relinker handler e
174+noRelinker :: Relinker adapter e
160noRelinker = Relinker $ \_ -> pure
175noRelinker = Relinker $ \_ -> pure
161
176
162----------------------------------------
177----------------------------------------
@@ -344,7 +359,7 @@ checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do
344-- This function is __highly unsafe__ because it renders the input 'Env'
359-- This function is __highly unsafe__ because it renders the input 'Env'
345-- unusable until the corresponding 'unsafeTailEnv' call is made, but it's not
360-- unusable until the corresponding 'unsafeTailEnv' call is made, but it's not
346-- checked anywhere.
361-- checked anywhere.
347−unsafeConsEnv :: handler e -> Relinker handler e -> Env es -> IO (Env (e : es))
362+unsafeConsEnv :: adapter e -> Relinker adapter e -> Env es -> IO (Env (e : es))
348unsafeConsEnv e f (Env fork gref gen) = case fork of
363unsafeConsEnv e f (Env fork gref gen) = case fork of
349 NoFork -> do
364 NoFork -> do
350 extendEnvRef gref
365 extendEnvRef gref
@@ -403,43 +418,43 @@ unsafeTailEnv len (Env fork gref _) = case fork of
403
418
404-- | Extract a specific data type from the environment.
419-- | Extract a specific data type from the environment.
405getEnv
420getEnv
406− :: forall e es handler. e :> es
421+ :: forall e adapter es. e :> es
407 => Env es
422 => Env es
408− -> IO (handler e)
423+ -> IO (adapter e)
409getEnv env = do
424getEnv env = do
410− (i, es) <- getLocation (reifyIndex @e @es) env
425+ Location i es <- getLocation (reifyIndex @e @es) env
411 fromAny <$> readSmallArray es i
426 fromAny <$> readSmallArray es i
412
427
413-- | Replace the data type in the environment with a new value (in place).
428-- | Replace the data type in the environment with a new value (in place).
414putEnv
429putEnv
415− :: forall e es handler. e :> es
430+ :: forall e adapter es. e :> es
416 => Env es
431 => Env es
417− -> handler e
432+ -> adapter e
418 -> IO ()
433 -> IO ()
419putEnv env e = do
434putEnv env e = do
420− (i, es) <- getLocation (reifyIndex @e @es) env
435+ Location i es <- getLocation (reifyIndex @e @es) env
421 e `seq` writeSmallArray es i (toAny e)
436 e `seq` writeSmallArray es i (toAny e)
422
437
423-- | Modify the data type in the environment (in place) and return a value.
438-- | Modify the data type in the environment (in place) and return a value.
424stateEnv
439stateEnv
425− :: forall e es handler a. e :> es
440+ :: forall e adapter es a. e :> es
426 => Env es
441 => Env es
427− -> (handler e -> (a, handler e))
442+ -> (adapter e -> (a, adapter e))
428 -> IO a
443 -> IO a
429stateEnv env f = do
444stateEnv env f = do
430− (i, es) <- getLocation (reifyIndex @e @es) env
445+ Location i es <- getLocation (reifyIndex @e @es) env
431 (a, e) <- f . fromAny <$> readSmallArray es i
446 (a, e) <- f . fromAny <$> readSmallArray es i
432 e `seq` writeSmallArray es i (toAny e)
447 e `seq` writeSmallArray es i (toAny e)
433 pure a
448 pure a
434
449
435-- | Modify the data type in the environment (in place).
450-- | Modify the data type in the environment (in place).
436modifyEnv
451modifyEnv
437− :: forall e es handler. e :> es
452+ :: forall e adapter es. e :> es
438 => Env es
453 => Env es
439− -> (handler e -> handler e)
454+ -> (adapter e -> adapter e)
440 -> IO ()
455 -> IO ()
441modifyEnv env f = do
456modifyEnv env f = do
442− (i, es) <- getLocation (reifyIndex @e @es) env
457+ Location i es <- getLocation (reifyIndex @e @es) env
443 e <- f . fromAny <$> readSmallArray es i
458 e <- f . fromAny <$> readSmallArray es i
444 e `seq` writeSmallArray es i (toAny e)
459 e `seq` writeSmallArray es i (toAny e)
445
460
@@ -455,13 +470,17 @@ emptyEnvRef = do
455 fs <- newSmallArray 0 undefinedData
470 fs <- newSmallArray 0 undefinedData
456 newIORef $ EnvRef 0 es fs
471 newIORef $ EnvRef 0 es fs
457
472
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+
458-- | Determine location of the data type in the environment.
477-- | Determine location of the data type in the environment.
459getLocation
478getLocation
460 :: Int
479 :: Int
461 -> Env es
480 -> Env es
462− -> IO (Int, SmallMutableArray RealWorld Any)
481+ -> IO Location
463getLocation ixE (Env fork ref _) = do
482getLocation ixE (Env fork ref _) = do
464− EnvRef n es _ <- readIORef ref
483+ EnvRef n es@(SmallMutableArray es#) _ <- readIORef ref
465 -- Optimized for the common access pattern:
484 -- Optimized for the common access pattern:
466 --
485 --
467 -- - Most application code has no access to forks, in which case we look at
486 -- - Most application code has no access to forks, in which case we look at
@@ -470,25 +489,25 @@ getLocation ixE (Env fork ref _) = do
470 -- - Effect handlers will most likely access the newest fork with handler
489 -- - Effect handlers will most likely access the newest fork with handler
471 -- specific effects for reinterpretation.
490 -- specific effects for reinterpretation.
472 case fork of
491 case fork of
473− NoFork -> pure (ix n, es)
492+ NoFork -> pure $ Location (ix n) es
474 Forks _ baseIx lref forks -> do
493 Forks _ baseIx lref forks -> do
475 EnvRef ln les _ <- readIORef lref
494 EnvRef ln les _ <- readIORef lref
476 let i = ix (baseIx + ln)
495 let i = ix (baseIx + ln)
477 if i >= baseIx
496 if i >= baseIx
478− then pure (i - baseIx, les)
497+ then pure $ Location (i - baseIx) les
479− else go es i forks
498+ else go es# i forks
480 where
499 where
481− go :: SmallMutableArray RealWorld Any
500+ go :: SmallMutableArray# RealWorld Any
482 -> Int
501 -> Int
483 -> Forks
502 -> Forks
484− -> IO (Int, SmallMutableArray RealWorld Any)
503+ -> IO Location
485− go es i = \case
504+ go es# i = \case
486− NoFork -> pure (i, es)
505+ NoFork -> pure $ Location i (SmallMutableArray es#)
487 Forks _ baseIx lref forks -> do
506 Forks _ baseIx lref forks -> do
488 EnvRef _ les _ <- readIORef lref
507 EnvRef _ les _ <- readIORef lref
489 if i >= baseIx
508 if i >= baseIx
490− then pure (i - baseIx, les)
509+ then pure $ Location (i - baseIx) les
491− else go es i forks
510+ else go es# i forks
492
511
493 ix :: Int -> Int
512 ix :: Int -> Int
494 ix n = n - ixE - 1
513 ix n = n - ixE - 1
effectful-core/src/Effectful/Internal/Monad.hs+122−137
@@ -6,7 +6,7 @@
6-- This module is intended for internal use only, and may change without warning
6-- This module is intended for internal use only, and may change without warning
7-- in subsequent releases.
7-- in subsequent releases.
8module Effectful.Internal.Monad
8module Effectful.Internal.Monad
9− ( -- * Monad
9+ ( -- * The 'Eff' monad
10 Eff
10 Eff
11 , runPureEff
11 , runPureEff
12
12
@@ -22,49 +22,41 @@ module Effectful.Internal.Monad
22 , IOE
22 , IOE
23 , runEff
23 , runEff
24
24
25− -- * Primitive
25+ -- * Prim
26 , Prim
26 , Prim
27 , runPrim
27 , runPrim
28
28
29− -- ** Unlift strategies
29+ -- * Unlift strategies
30 , UnliftStrategy(..)
30 , UnliftStrategy(..)
31 , Persistence(..)
31 , Persistence(..)
32 , Limit(..)
32 , Limit(..)
33 , unliftStrategy
33 , unliftStrategy
34 , withUnliftStrategy
34 , withUnliftStrategy
35 , withEffToIO
35 , withEffToIO
36− , UnliftError(..)
37
36
38− --- *** Low-level helpers
37+ -- ** Low-level unlifts
39− , unsafeLiftMapIO
38+ , seqUnliftIO
40− , unsafeUnliftToEff
39+ , concUnliftIO
41− , seqUnliftEff
42− , concUnliftEff
43
40
44 -- * Effects
41 -- * Effects
45
42
46− -- ** Handler
43+ -- ** Dynamic dispatch
47 , EffectHandler
44 , EffectHandler
48 , LocalEnv(..)
45 , LocalEnv(..)
49− , Handler(..)
46+ , HandlerA(..)
50 , runHandler
47 , runHandler
51−
52− -- *** Sending operations
53 , send
48 , send
54
49
55− -- ** Primitive
50+ -- ** Static dispatch
56−
51+ , DataA(..)
57− -- *** Running
52+ , runData
58− , runEffect
53+ , evalData
59− , evalEffect
54+ , execData
60− , execEffect
55+ , getData
61−
56+ , putData
62− -- *** Modification
57+ , stateData
63− , getEffect
58+ , stateDataM
64− , putEffect
59+ , localData
65− , stateEffect
66− , stateEffectM
67− , localEffect
68 ) where
60 ) where
69
61
70import Control.Applicative (liftA2)
62import Control.Applicative (liftA2)
@@ -87,44 +79,43 @@ import Effectful.Internal.Unlift
87
79
88type role Eff nominal representational
80type role Eff nominal representational
89
81
90−-- | The 'Eff' monad provides the implementation of an operation that performs
82+-- | The 'Eff' monad provides the implementation of a computation that performs
91-- an arbitrary set of effects. In @'Eff' es a@, @es@ is a type-level list that
83-- an arbitrary set of effects. In @'Eff' es a@, @es@ is a type-level list that
92−-- contains all the effects that the operation may perform. For example, an
84+-- contains all the effects that the computation may perform. For example, a
93−-- operation that produces an 'Integer' by consuming a 'String' from the global
85+-- computation that produces an 'Integer' by consuming a 'String' from the
94−-- environment and acting upon a single mutable cell containing a 'Bool' would
86+-- global environment and acting upon a single mutable value of type 'Bool'
95−-- have the following type:
87+-- would have the following type:
96--
88--
97-- @
89-- @
98−-- 'Eff' '['Effectful.Reader.Reader' 'String', 'Effectful.State.State' 'Bool'] 'Integer'
90+-- 'Eff' '['Effectful.Reader.Reader' 'String', 'Effectful.State.Local.State' 'Bool'] 'Integer'
99-- @
91-- @
100--
92--
101-- Normally, a concrete list of effects is not used to parameterize 'Eff'.
93-- Normally, a concrete list of effects is not used to parameterize 'Eff'.
102-- Instead, the '(:>)' type class is used to express constraints on the list of
94-- Instead, the '(:>)' type class is used to express constraints on the list of
103−-- effects without coupling an operation to a concrete list of effects. For
95+-- effects without coupling a computation to a concrete list of effects. For
104−-- example, the above example would more commonly be expressed with the
96+-- example, the above example would be expressed with the following type:
105−-- following type:
106--
97--
107-- @
98-- @
108−-- ('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'
109-- @
100-- @
110--
101--
111−-- 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
112-- perform other effects, and it also allows the effects to be handled in any
103-- perform other effects, and it also allows the effects to be handled in any
113-- order.
104-- order.
114newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a)
105newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a)
115 deriving (Monoid, Semigroup)
106 deriving (Monoid, Semigroup)
116
107
117−-- | Run a pure 'Eff' operation.
108+-- | Run a pure 'Eff' computation.
118--
109--
119−-- For running operations with side effects see 'runEff'.
110+-- For running computations with side effects see 'runEff'.
120runPureEff :: Eff '[] a -> a
111runPureEff :: Eff '[] a -> a
121runPureEff (Eff m) =
112runPureEff (Eff m) =
122− -- unsafePerformIO is safe here since IOE was not on the stack, so no IO with
113+ -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no
123− -- side effects was performed (unless someone sneakily introduced side effects
114+ -- IO with side effects was performed (unless someone sneakily introduced side
124− -- with unsafeEff, but then all bets are off).
115+ -- effects with unsafeEff, but then all bets are off).
125 --
116 --
126 -- Moreover, internals don't allocate any resources that require explicit
117 -- Moreover, internals don't allocate any resources that require explicit
127− -- cleanup actions to run, so the "Dupable" part should also be just fine.
118+ -- cleanup actions to run.
128 unsafeDupablePerformIO $ m =<< emptyEnv
119 unsafeDupablePerformIO $ m =<< emptyEnv
129
120
130----------------------------------------
121----------------------------------------
@@ -137,69 +128,29 @@ unEff (Eff m) = m
137-- | Access the underlying 'IO' monad along with the environment.
128-- | Access the underlying 'IO' monad along with the environment.
138--
129--
139-- This function is __unsafe__ because it can be used to introduce arbitrary
130-- This function is __unsafe__ because it can be used to introduce arbitrary
140−-- 'IO' actions into pure 'Eff' operations.
131+-- 'IO' actions into pure 'Eff' computations.
141unsafeEff :: (Env es -> IO a) -> Eff es a
132unsafeEff :: (Env es -> IO a) -> Eff es a
142unsafeEff m = Eff (oneShot m)
133unsafeEff m = Eff (oneShot m)
143
134
144-- | Access the underlying 'IO' monad.
135-- | Access the underlying 'IO' monad.
145--
136--
146-- This function is __unsafe__ because it can be used to introduce arbitrary
137-- This function is __unsafe__ because it can be used to introduce arbitrary
147−-- 'IO' actions into pure 'Eff' operations.
138+-- 'IO' actions into pure 'Eff' computations.
148unsafeEff_ :: IO a -> Eff es a
139unsafeEff_ :: IO a -> Eff es a
149unsafeEff_ m = unsafeEff $ \_ -> m
140unsafeEff_ m = unsafeEff $ \_ -> m
150
141
151−-- | Utility for lifting 'IO' operations of type
152−--
153−-- @'IO' a -> 'IO' b@
154−--
155−-- to
156−--
157−-- @'Eff' es a -> 'Eff' es b@
158−--
159−-- This function is __unsafe__ because:
160−--
161−-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'
162−-- operations.
163−--
164−-- - The 'IO' operation must not run its argument in a separate thread, but it's
165−-- not checked anywhere.
166−unsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b
167−unsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)
168−
169----------------------------------------
142----------------------------------------
170−-- Unlifting Eff
143+-- Unlifting IO
171
144
172-- | Get the current 'UnliftStrategy'.
145-- | Get the current 'UnliftStrategy'.
173unliftStrategy :: IOE :> es => Eff es UnliftStrategy
146unliftStrategy :: IOE :> es => Eff es UnliftStrategy
174unliftStrategy = do
147unliftStrategy = do
175− IdE (IOE unlift) <- getEffect
148+ DataA (IOE unlift) <- getData
176 pure unlift
149 pure unlift
177
150
178-- | Locally override the 'UnliftStrategy' with the given value.
151-- | Locally override the 'UnliftStrategy' with the given value.
179withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
152withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
180−withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift)
153+withUnliftStrategy unlift = localData $ \_ -> DataA (IOE unlift)
181−
182−-- | Lower 'Eff' operations into 'IO' ('SeqUnlift').
183−--
184−-- Exceptions thrown by this function:
185−--
186−-- - 'InvalidUseOfSeqUnlift' if the unlift function is used in another thread.
187−seqUnliftEff
188− :: HasCallStack
189− => Env es
190− -> ((forall r. Eff es r -> IO r) -> IO a)
191− -> IO a
192−seqUnliftEff es k = seqUnliftIO k es unEff
193−
194−-- | Lower 'Eff' operations into 'IO' ('ConcUnlift').
195−concUnliftEff
196− :: HasCallStack
197− => Env es
198− -> Persistence
199− -> Limit
200− -> ((forall r. Eff es r -> IO r) -> IO a)
201− -> IO a
202−concUnliftEff es persistence limit k = concUnliftIO persistence limit k es unEff
203
154
204-- | Create an unlifting function with the current 'UnliftStrategy'.
155-- | Create an unlifting function with the current 'UnliftStrategy'.
205--
156--
@@ -207,25 +158,38 @@ concUnliftEff es persistence limit k = concUnliftIO persistence limit k es unEff
207-- constraint for accurate stack traces in case an insufficiently powerful
158-- constraint for accurate stack traces in case an insufficiently powerful
208-- 'UnliftStrategy' is used and the unlifting function fails.
159-- 'UnliftStrategy' is used and the unlifting function fails.
209--
160--
210−-- /Note:/ the strategy is reset to 'SeqUnlift' for new threads.
161+-- /Note:/ the strategy is reset to 'SeqUnlift' inside the continuation.
211withEffToIO
162withEffToIO
212 :: (HasCallStack, IOE :> es)
163 :: (HasCallStack, IOE :> es)
213 => ((forall r. Eff es r -> IO r) -> IO a)
164 => ((forall r. Eff es r -> IO r) -> IO a)
214 -- ^ Continuation with the unlifting function in scope.
165 -- ^ Continuation with the unlifting function in scope.
215 -> Eff es a
166 -> Eff es a
216withEffToIO f = unliftStrategy >>= \case
167withEffToIO f = unliftStrategy >>= \case
217− SeqUnlift -> unsafeEff $ \es -> seqUnliftEff es f
168+ SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f
218 ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
169 ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
219− unsafeEff $ \es -> concUnliftEff es p b f
170+ unsafeEff $ \es -> concUnliftIO es p b f
220
171
221−-- | An unlifing function that lifts a function and its callback from 'IO' to
172+-- | Create an unlifting function with the 'SeqUnlift' strategy.
222−-- 'Eff'.
173+seqUnliftIO
223−--
174+ :: HasCallStack
224−-- This function is unsafe since there are no checks wrt. to concurrency at all.
175+ => Env es
225−-- Use with care.
176+ -- ^ The environment.
226−unsafeUnliftToEff :: ((a -> IO b) -> IO c) -> (a -> Eff es b) -> Eff es c
177+ -> ((forall r. Eff es r -> IO r) -> IO a)
227−unsafeUnliftToEff k f = unsafeEff $ \es -> do
178+ -- ^ Continuation with the unlifting function in scope.
228− k ((`unEff` es) . f)
179+ -> IO a
180+seqUnliftIO es k = seqUnlift k es unEff
181+
182+-- | Create an unlifting function with the 'ConcUnlift' strategy.
183+concUnliftIO
184+ :: HasCallStack
185+ => Env es
186+ -- ^ The environment.
187+ -> Persistence
188+ -> Limit
189+ -> ((forall r. Eff es r -> IO r) -> IO a)
190+ -- ^ Continuation with the unlifting function in scope.
191+ -> IO a
192+concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff
229
193
230----------------------------------------
194----------------------------------------
231-- Base
195-- Base
@@ -294,15 +258,15 @@ instance Fail :> es => MonadFail (Eff es) where
294----------------------------------------
258----------------------------------------
295-- IO
259-- IO
296
260
297−-- | Run arbitrary 'IO' operations via 'MonadIO' or 'MonadUnliftIO'.
261+-- | Run arbitrary 'IO' computations via 'MonadIO' or 'MonadUnliftIO'.
298newtype IOE :: Effect where
262newtype IOE :: Effect where
299 IOE :: UnliftStrategy -> IOE m r
263 IOE :: UnliftStrategy -> IOE m r
300
264
301−-- | Run an 'Eff' operation with side effects.
265+-- | Run an 'Eff' computation with side effects.
302--
266--
303−-- For running pure operations see 'runPureEff'.
267+-- For running pure computations see 'runPureEff'.
304runEff :: Eff '[IOE] a -> IO a
268runEff :: Eff '[IOE] a -> IO a
305−runEff m = unEff (evalEffect (IdE (IOE SeqUnlift)) m) =<< emptyEnv
269+runEff m = unEff (evalData (DataA (IOE SeqUnlift)) m) =<< emptyEnv
306
270
307instance IOE :> es => MonadIO (Eff es) where
271instance IOE :> es => MonadIO (Eff es) where
308 liftIO = unsafeEff_
272 liftIO = unsafeEff_
@@ -326,20 +290,20 @@ instance IOE :> es => MonadBaseControl IO (Eff es) where
326----------------------------------------
290----------------------------------------
327-- Primitive
291-- Primitive
328
292
329−-- | An effect to perform primitive state-transformer actions.
293+-- | Provide the ability to perform primitive state-transformer actions.
330data Prim :: Effect where
294data Prim :: Effect where
331 Prim :: Prim m r
295 Prim :: Prim m r
332
296
333−-- | Run an 'Eff' operation with primitive state-transformer actions.
297+-- | Run an 'Eff' computation with primitive state-transformer actions.
334runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a
298runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a
335−runPrim = evalEffect (IdE Prim)
299+runPrim = evalData (DataA Prim)
336
300
337instance Prim :> es => PrimMonad (Eff es) where
301instance Prim :> es => PrimMonad (Eff es) where
338 type PrimState (Eff es) = RealWorld
302 type PrimState (Eff es) = RealWorld
339 primitive = unsafeEff_ . IO
303 primitive = unsafeEff_ . IO
340
304
341----------------------------------------
305----------------------------------------
342−-- Handler
306+-- Dynamic dispatch
343
307
344type role LocalEnv nominal nominal
308type role LocalEnv nominal nominal
345
309
@@ -355,76 +319,97 @@ newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env l
355type EffectHandler e es
319type EffectHandler e es
356 = forall a localEs. HasCallStack
320 = forall a localEs. HasCallStack
357 => LocalEnv localEs es
321 => LocalEnv localEs es
358− -- ^ Capture of the local environment for handling local 'Eff' operations when
322+ -- ^ Capture of the local environment for handling local 'Eff' computations
359− -- @e@ is a higher order effect.
323+ -- when @e@ is a higher order effect.
360 -> e (Eff localEs) a
324 -> e (Eff localEs) a
361 -- ^ The effect performed in the local environment.
325 -- ^ The effect performed in the local environment.
362 -> Eff es a
326 -> Eff es a
363
327
328+-- | An adapter for dynamically dispatched effects.
329+--
364−-- | An effect handler bundled along with its environment.
330+-- Represents the effect handler bundled with its environment.
365−data Handler :: Effect -> Type where
331+data HandlerA :: Effect -> Type where
366− Handler :: !(Env es) -> !(EffectHandler e es) -> Handler e
332+ HandlerA :: !(Env es) -> !(EffectHandler e es) -> HandlerA e
367
333
368−-- | Run the effect with the given handler.
334+-- | Run a dynamically dispatched effect with the given handler.
369−runHandler :: Handler e -> Eff (e : es) a -> Eff es a
335+runHandler :: HandlerA e -> Eff (e : es) a -> Eff es a
370runHandler e m = unsafeEff $ \es0 -> do
336runHandler e m = unsafeEff $ \es0 -> do
371 size0 <- sizeEnv es0
337 size0 <- sizeEnv es0
372 E.bracket (unsafeConsEnv e relinker es0)
338 E.bracket (unsafeConsEnv e relinker es0)
373 (unsafeTailEnv size0)
339 (unsafeTailEnv size0)
374 (\es -> unEff m es)
340 (\es -> unEff m es)
375 where
341 where
376− relinker :: Relinker Handler e
342+ relinker :: Relinker HandlerA e
377− relinker = Relinker $ \relink (Handler env handle) -> do
343+ relinker = Relinker $ \relink (HandlerA handlerEs handle) -> do
378− newEnv <- relink env
344+ newHandlerEs <- relink handlerEs
379− pure $ Handler newEnv handle
345+ pure $ HandlerA newHandlerEs handle
380
346
381-- | Send an operation of the given effect to its handler for execution.
347-- | Send an operation of the given effect to its handler for execution.
382send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
348send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
383send op = unsafeEff $ \es -> do
349send op = unsafeEff $ \es -> do
384− Handler env handle <- getEnv es
350+ HandlerA handlerEs handle <- getEnv es
385− unEff (handle (LocalEnv es) op) env
351+ unEff (handle (LocalEnv es) op) handlerEs
386
352
387----------------------------------------
353----------------------------------------
388−-- Helpers
354+-- Static dispatch
389
355
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.
390−runEffect :: handler e -> Eff (e : es) a -> Eff es (a, handler e)
365+runData :: DataA e -> Eff (e : es) a -> Eff es (a, DataA e)
391−runEffect e0 m = unsafeEff $ \es0 -> do
366+runData e0 m = unsafeEff $ \es0 -> do
392 size0 <- sizeEnv es0
367 size0 <- sizeEnv es0
393 E.bracket (unsafeConsEnv e0 noRelinker es0)
368 E.bracket (unsafeConsEnv e0 noRelinker es0)
394 (unsafeTailEnv size0)
369 (unsafeTailEnv size0)
395 (\es -> (,) <$> unEff m es <*> getEnv es)
370 (\es -> (,) <$> unEff m es <*> getEnv es)
396
371
372+-- | Run a statically dispatched effect with the given initial state and return
373+-- the final value, discarding the final state.
397−evalEffect :: handler e -> Eff (e : es) a -> Eff es a
374+evalData :: DataA e -> Eff (e : es) a -> Eff es a
398−evalEffect e m = unsafeEff $ \es0 -> do
375+evalData e m = unsafeEff $ \es0 -> do
399 size0 <- sizeEnv es0
376 size0 <- sizeEnv es0
400 E.bracket (unsafeConsEnv e noRelinker es0)
377 E.bracket (unsafeConsEnv e noRelinker es0)
401 (unsafeTailEnv size0)
378 (unsafeTailEnv size0)
402 (\es -> unEff m es)
379 (\es -> unEff m es)
403
380
381+-- | Run a statically dispatched effect with the given initial state and return
382+-- the final state, discarding the final value.
404−execEffect :: handler e -> Eff (e : es) a -> Eff es (handler e)
383+execData :: DataA e -> Eff (e : es) a -> Eff es (DataA e)
405−execEffect e0 m = unsafeEff $ \es0 -> do
384+execData e0 m = unsafeEff $ \es0 -> do
406 size0 <- sizeEnv es0
385 size0 <- sizeEnv es0
407 E.bracket (unsafeConsEnv e0 noRelinker es0)
386 E.bracket (unsafeConsEnv e0 noRelinker es0)
408 (unsafeTailEnv size0)
387 (unsafeTailEnv size0)
409 (\es -> unEff m es *> getEnv es)
388 (\es -> unEff m es *> getEnv es)
410
389
411−getEffect :: e :> es => Eff es (handler e)
390+-- | Fetch the current state of the effect.
391+getData :: e :> es => Eff es (DataA e)
412−getEffect = unsafeEff $ \es -> getEnv es
392+getData = unsafeEff $ \es -> getEnv es
413
393
414−putEffect :: e :> es => handler e -> Eff es ()
394+-- | Set the current state of the effect to the given value.
395+putData :: e :> es => DataA e -> Eff es ()
415−putEffect e = unsafeEff $ \es -> putEnv es e
396+putData e = unsafeEff $ \es -> putEnv es e
416
397
417−stateEffect :: e :> es => (handler e -> (a, handler e)) -> Eff es a
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
418−stateEffect f = unsafeEff $ \es -> stateEnv es f
400+stateData f = unsafeEff $ \es -> stateEnv es f
419
401
402+-- | Apply the monadic function to the current state of the effect and return a
403+-- value.
420−stateEffectM :: e :> es => (handler e -> Eff es (a, handler e)) -> Eff es a
404+stateDataM :: e :> es => (DataA e -> Eff es (a, DataA e)) -> Eff es a
421−stateEffectM f = unsafeEff $ \es -> E.mask $ \release -> do
405+stateDataM f = unsafeEff $ \es -> E.mask $ \release -> do
422 (a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es
406 (a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es
423 putEnv es e
407 putEnv es e
424 pure a
408 pure a
425
409
410+-- | Execute a computation with a temporarily modified state of the effect.
426−localEffect :: e :> es => (handler e -> handler e) -> Eff es a -> Eff es a
411+localData :: e :> es => (DataA e -> DataA e) -> Eff es a -> Eff es a
427−localEffect f m = unsafeEff $ \es -> do
412+localData f m = unsafeEff $ \es -> do
428 E.bracket (stateEnv es $ \e -> (e, f e))
413 E.bracket (stateEnv es $ \e -> (e, f e))
429 (\e -> putEnv es e)
414 (\e -> putEnv es e)
430 (\_ -> unEff m es)
415 (\_ -> unEff m es)
effectful-core/src/Effectful/Internal/Unlift.hs+35−78
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE MagicHash #-}
1{-# LANGUAGE MagicHash #-}
3{-# LANGUAGE UnboxedTuples #-}
2{-# LANGUAGE UnboxedTuples #-}
4{-# OPTIONS_HADDOCK not-home #-}
3{-# OPTIONS_HADDOCK not-home #-}
@@ -13,17 +12,13 @@ module Effectful.Internal.Unlift
13 , Limit(..)
12 , Limit(..)
14
13
15 -- * Unlifting functions
14 -- * Unlifting functions
16− , seqUnliftIO
15+ , seqUnlift
17− , concUnliftIO
16+ , concUnlift
18− , ephemeralConcUnliftIO
17+ , ephemeralConcUnlift
19− , persistentConcUnliftIO
18+ , persistentConcUnlift
20−
21− -- * Unlifting errors
22− , UnliftError(..)
23 ) where
19 ) where
24
20
25import Control.Concurrent
21import Control.Concurrent
26−import Control.Exception
27import Control.Monad
22import Control.Monad
28import GHC.Conc.Sync (ThreadId(..))
23import GHC.Conc.Sync (ThreadId(..))
29import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)
24import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)
@@ -40,8 +35,9 @@ import Effectful.Internal.Utils
40----------------------------------------
35----------------------------------------
41-- Unlift strategies
36-- Unlift strategies
42
37
43−-- | The strategy to use when unlifting 'Eff' operations via 'withRunInIO' or
38+-- | The strategy to use when unlifting 'Eff' computations via 'withRunInIO',
44−-- the 'Effectful.Interpreter.localUnlift' family.
39+-- 'Effectful.Monad.withEffToIO' or the 'Effectful.Dispatch.Dynamic.localUnlift'
40+-- family.
45data UnliftStrategy
41data UnliftStrategy
46 = SeqUnlift
42 = SeqUnlift
47 -- ^ The fastest strategy and a default setting for 'IOE'. An attempt to call
43 -- ^ The fastest strategy and a default setting for 'IOE'. An attempt to call
@@ -96,26 +92,24 @@ data Limit
96-- Unlift functions
92-- Unlift functions
97
93
98-- | Sequential unlift.
94-- | Sequential unlift.
99−--
95+seqUnlift
100−-- Exceptions thrown by this function:
101−--
102−-- - 'InvalidUseOfSeqUnlift' if the unlift function is used in another thread.
103−seqUnliftIO
104 :: HasCallStack
96 :: HasCallStack
105 => ((forall r. m r -> IO r) -> IO a)
97 => ((forall r. m r -> IO r) -> IO a)
106 -> Env es
98 -> Env es
107 -> (forall r. m r -> Env es -> IO r)
99 -> (forall r. m r -> Env es -> IO r)
108 -> IO a
100 -> IO a
109−seqUnliftIO k es unEff = do
101+seqUnlift k es unEff = do
110 tid0 <- myThreadId
102 tid0 <- myThreadId
111 k $ \m -> do
103 k $ \m -> do
112 tid <- myThreadId
104 tid <- myThreadId
113 if tid `eqThreadId` tid0
105 if tid `eqThreadId` tid0
114 then unEff m es
106 then unEff m es
115− else throwIO InvalidUseOfSeqUnlift
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)."
116
110
117-- | Concurrent unlift for various strategies and limits.
111-- | Concurrent unlift for various strategies and limits.
118−concUnliftIO
112+concUnlift
119 :: HasCallStack
113 :: HasCallStack
120 => Persistence
114 => Persistence
121 -> Limit
115 -> Limit
@@ -123,23 +117,18 @@ concUnliftIO
123 -> Env es
117 -> Env es
124 -> (forall r. m r -> Env es -> IO r)
118 -> (forall r. m r -> Env es -> IO r)
125 -> IO a
119 -> IO a
126−concUnliftIO Ephemeral (Limited uses) k =
120+concUnlift Ephemeral (Limited uses) k =
127− ephemeralConcUnliftIO uses k
121+ ephemeralConcUnlift uses k
128−concUnliftIO Ephemeral Unlimited k =
122+concUnlift Ephemeral Unlimited k =
129− ephemeralConcUnliftIO maxBound k
123+ ephemeralConcUnlift maxBound k
130−concUnliftIO Persistent (Limited threads) k =
124+concUnlift Persistent (Limited threads) k =
131− persistentConcUnliftIO False threads k
125+ persistentConcUnlift False threads k
132−concUnliftIO Persistent Unlimited k =
126+concUnlift Persistent Unlimited k =
133− persistentConcUnliftIO True maxBound k
127+ persistentConcUnlift True maxBound k
134
128
135-- | Concurrent unlift that doesn't preserve the environment between calls to
129-- | Concurrent unlift that doesn't preserve the environment between calls to
136-- the unlifting function in threads other than its creator.
130-- the unlifting function in threads other than its creator.
137−--
131+ephemeralConcUnlift
138−-- Exceptions thrown by this function:
139−--
140−-- - 'InvalidNumberOfUses' if the number of uses is less or equal zero.
141−-- - 'ExceededNumberOfUses' if the unlift function is called too often.
142−ephemeralConcUnliftIO
143 :: HasCallStack
132 :: HasCallStack
144 => Int
133 => Int
145 -- ^ Number of permitted uses of the unlift function.
134 -- ^ Number of permitted uses of the unlift function.
@@ -147,9 +136,9 @@ ephemeralConcUnliftIO
147 -> Env es
136 -> Env es
148 -> (forall r. m r -> Env es -> IO r)
137 -> (forall r. m r -> Env es -> IO r)
149 -> IO a
138 -> IO a
150−ephemeralConcUnliftIO uses k es0 unEff = do
139+ephemeralConcUnlift uses k es0 unEff = do
151 unless (uses > 0) $ do
140 unless (uses > 0) $ do
152− throwIO $ InvalidNumberOfUses uses
141+ error $ "Invalid number of uses: " ++ show uses
153 tid0 <- myThreadId
142 tid0 <- myThreadId
154 -- Create a copy of the environment as a template for the other threads to
143 -- Create a copy of the environment as a template for the other threads to
155 -- use. This can't be done from inside the callback as the environment might
144 -- use. This can't be done from inside the callback as the environment might
@@ -160,7 +149,10 @@ ephemeralConcUnliftIO uses k es0 unEff = do
160 es <- myThreadId >>= \case
149 es <- myThreadId >>= \case
161 tid | tid0 `eqThreadId` tid -> pure es0
150 tid | tid0 `eqThreadId` tid -> pure es0
162 _ -> modifyMVar mvUses $ \case
151 _ -> modifyMVar mvUses $ \case
163− 0 -> throwIO $ ExceededNumberOfUses uses
152+ 0 -> error
153+ $ "Number of permitted calls (" ++ show uses ++ ") to the unlifting "
154+ ++ "function in other threads was exceeded. Please increase the limit "
155+ ++ "or use the unlimited variant."
164 1 -> pure (0, esTemplate)
156 1 -> pure (0, esTemplate)
165 n -> do
157 n -> do
166 let newUses = n - 1
158 let newUses = n - 1
@@ -170,13 +162,7 @@ ephemeralConcUnliftIO uses k es0 unEff = do
170
162
171-- | Concurrent unlift that preserves the environment between calls to the
163-- | Concurrent unlift that preserves the environment between calls to the
172-- unlifting function within a particular thread.
164-- unlifting function within a particular thread.
173−--
165+persistentConcUnlift
174−-- Exceptions thrown by this function:
175−--
176−-- - 'InvalidNumberOfThreads' if the number of threads is less or equal zero.
177−-- - 'ExceededNumberOfThreads' if the unlift function is called by too many
178−-- threads.
179−persistentConcUnliftIO
180 :: HasCallStack
166 :: HasCallStack
181 => Bool
167 => Bool
182 -> Int
168 -> Int
@@ -185,9 +171,9 @@ persistentConcUnliftIO
185 -> Env es
171 -> Env es
186 -> (forall r. m r -> Env es -> IO r)
172 -> (forall r. m r -> Env es -> IO r)
187 -> IO a
173 -> IO a
188−persistentConcUnliftIO cleanUp threads k es0 unEff = do
174+persistentConcUnlift cleanUp threads k es0 unEff = do
189 unless (threads > 0) $ do
175 unless (threads > 0) $ do
190− throwIO $ InvalidNumberOfThreads threads
176+ error $ "Invalid number of threads: " ++ show threads
191 tid0 <- myThreadId
177 tid0 <- myThreadId
192 -- Create a copy of the environment as a template for the other threads to
178 -- Create a copy of the environment as a template for the other threads to
193 -- use. This can't be done from inside the callback as the environment might
179 -- use. This can't be done from inside the callback as the environment might
@@ -205,7 +191,10 @@ persistentConcUnliftIO cleanUp threads k es0 unEff = do
205 case mes of
191 case mes of
206 Just es -> pure (te, es)
192 Just es -> pure (te, es)
207 Nothing -> case teCapacity te of
193 Nothing -> case teCapacity te of
208− 0 -> throwIO $ ExceededNumberOfThreads threads
194+ 0 -> error
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."
209 1 -> do
198 1 -> do
210 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp
199 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp
211 let newEntries = ThreadEntries
200 let newEntries = ThreadEntries
@@ -223,38 +212,6 @@ persistentConcUnliftIO cleanUp threads k es0 unEff = do
223 newEntries `seq` pure (newEntries, es)
212 newEntries `seq` pure (newEntries, es)
224 unEff m es
213 unEff m es
225
214
226−----------------------------------------
227−-- Errors
228−
229−-- | An type used for errors occuring in unlifting functions.
230−--
231−-- Use the 'displayException' method of the 'Exception' type class to get
232−-- descriptive error messages.
233−data UnliftError
234− = InvalidNumberOfThreads !Int
235− | InvalidNumberOfUses !Int
236− | InvalidUseOfSeqUnlift
237− | ExceededNumberOfThreads !Int
238− | ExceededNumberOfUses !Int
239− deriving (Eq, Generic, Show)
240−
241−instance Exception UnliftError where
242− displayException (InvalidNumberOfThreads threads) =
243− "Invalid number of threads: " ++ show threads
244− displayException (InvalidNumberOfUses uses) =
245− "Invalid number of uses: " ++ show uses
246− displayException (ExceededNumberOfThreads threads) =
247− "Number of other threads (" ++ show threads ++ ") permitted to use the " ++
248− "unlifting function was exceeded. Please increase the limit or use the " ++
249− "unlimited variant."
250− displayException (ExceededNumberOfUses uses) =
251− "Number of permitted calls (" ++ show uses ++ ") to the unlifting " ++
252− "function in other threads was exceeded. Please increase the limit or " ++
253− "use the unlimited variant."
254− displayException InvalidUseOfSeqUnlift =
255− "If you want to use the unlifting function to run Eff operations in " ++
256− "multiple threads, have a look at UnliftStrategy (ConcUnlift)."
257−
258----------------------------------------
215----------------------------------------
259-- Data types
216-- Data types
260
217
effectful-core/src/Effectful/Monad.hs−1
@@ -18,7 +18,6 @@ module Effectful.Monad
18 , unliftStrategy
18 , unliftStrategy
19 , withUnliftStrategy
19 , withUnliftStrategy
20 , withEffToIO
20 , withEffToIO
21− , UnliftError(..)
22
21
23 -- * Re-exports
22 -- * Re-exports
24 , MonadIO(..)
23 , MonadIO(..)
effectful-core/src/Effectful/Prim.hs+1
@@ -1,3 +1,4 @@
1+-- | Provider of the 'MonadPrim' instance for 'Eff'.
1module Effectful.Prim
2module Effectful.Prim
2 ( Prim
3 ( Prim
3 , runPrim
4 , runPrim
effectful-core/src/Effectful/Reader.hs+6−6
@@ -1,4 +1,4 @@
1−-- | The 'Reader' effect.
1+-- | Support for access to a read only value of a particular type.
2module Effectful.Reader
2module Effectful.Reader
3 ( Reader
3 ( Reader
4 , runReader
4 , runReader
@@ -7,8 +7,8 @@ module Effectful.Reader
7 , local
7 , local
8 ) where
8 ) where
9
9
10−import Effectful.Internal.Effect
10+import Effectful.Dispatch.Static
11−import Effectful.Internal.Monad
11+import Effectful.Monad
12
12
13-- | Provide access to a strict (WHNF), thread local, read only value of type
13-- | Provide access to a strict (WHNF), thread local, read only value of type
14-- @r@.
14-- @r@.
@@ -20,12 +20,12 @@ runReader
20 :: r -- ^ An initial environment.
20 :: r -- ^ An initial environment.
21 -> Eff (Reader r : es) a
21 -> Eff (Reader r : es) a
22 -> Eff es a
22 -> Eff es a
23−runReader r = evalEffect (IdE (Reader r))
23+runReader r = evalData (DataA (Reader r))
24
24
25-- | Fetch the value of the environment.
25-- | Fetch the value of the environment.
26ask :: Reader r :> es => Eff es r
26ask :: Reader r :> es => Eff es r
27ask = do
27ask = do
28− IdE (Reader r) <- getEffect
28+ DataA (Reader r) <- getData
29 pure r
29 pure r
30
30
31-- | Retrieve a function of the current environment.
31-- | Retrieve a function of the current environment.
@@ -46,4 +46,4 @@ local
46 => (r -> r) -- ^ The function to modify the environment.
46 => (r -> r) -- ^ The function to modify the environment.
47 -> Eff es a
47 -> Eff es a
48 -> Eff es a
48 -> Eff es a
49−local f = localEffect $ \(IdE (Reader r)) -> IdE (Reader (f r))
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
6 , local
6 , local
7 ) where
7 ) where
8
8
9−import Effectful.Handler
9+import Effectful.Dispatch.Dynamic
10import Effectful.Monad
10import Effectful.Monad
11import qualified Effectful.Reader as R
11import qualified Effectful.Reader as R
12
12
effectful-core/src/Effectful/State/Dynamic.hs+2−2
@@ -22,12 +22,12 @@ module Effectful.State.Dynamic
22 , modifyM
22 , modifyM
23 ) where
23 ) where
24
24
25−import Effectful.Handler
25+import Effectful.Dispatch.Dynamic
26import Effectful.Monad
26import Effectful.Monad
27import qualified Effectful.State.Local as L
27import qualified Effectful.State.Local as L
28import qualified Effectful.State.Shared as S
28import qualified Effectful.State.Shared as S
29
29
30−-- | Provide access to a mutable state of type @s@.
30+-- | Provide access to a mutable value of type @s@.
31data State s :: Effect where
31data State s :: Effect where
32 Get :: State s m s
32 Get :: State s m s
33 Put :: s -> State s m ()
33 Put :: s -> State s m ()
effectful-core/src/Effectful/State/Local.hs+36−15
@@ -1,12 +1,29 @@
1−-- | The 'State' effect.
1+-- | Support for access to a mutable value of a particular type, which is:
2--
2--
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
6-- look at "Effectful.State.Shared"),
4-- look at "Effectful.State.Shared"),
7--
5--
8-- - very fast.
6-- - very fast.
9--
7--
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!"
10module Effectful.State.Local
27module Effectful.State.Local
11 ( State
28 ( State
12 , runState
29 , runState
@@ -21,10 +38,10 @@ module Effectful.State.Local
21 , modifyM
38 , modifyM
22 ) where
39 ) where
23
40
24−import Effectful.Internal.Effect
41+import Effectful.Dispatch.Static
25−import Effectful.Internal.Monad
42+import Effectful.Monad
26
43
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@.
28newtype State s :: Effect where
45newtype State s :: Effect where
29 State :: s -> State s m r
46 State :: s -> State s m r
30
47
@@ -35,7 +52,7 @@ runState
35 -> Eff (State s : es) a
52 -> Eff (State s : es) a
36 -> Eff es (a, s)
53 -> Eff es (a, s)
37runState s0 m = do
54runState s0 m = do
38− (a, IdE (State s)) <- runEffect (IdE (State s0)) m
55+ (a, DataA (State s)) <- runData (DataA (State s0)) m
39 pure (a, s)
56 pure (a, s)
40
57
41-- | Run a 'State' effect with the given initial state and return the final
58-- | Run a 'State' effect with the given initial state and return the final
@@ -44,7 +61,7 @@ evalState
44 :: s -- ^ An initial state.
61 :: s -- ^ An initial state.
45 -> Eff (State s : es) a
62 -> Eff (State s : es) a
46 -> Eff es a -- ^ A return value.
63 -> Eff es a -- ^ A return value.
47−evalState s = evalEffect (IdE (State s))
64+evalState s = evalData (DataA (State s))
48
65
49-- | Run a 'State' effect with the given initial state and return the final
66-- | Run a 'State' effect with the given initial state and return the final
50-- state, discarding the final value.
67-- state, discarding the final value.
@@ -53,13 +70,13 @@ execState
53 -> Eff (State s : es) a
70 -> Eff (State s : es) a
54 -> Eff es s
71 -> Eff es s
55execState s0 m = do
72execState s0 m = do
56− IdE (State s) <- execEffect (IdE (State s0)) m
73+ DataA (State s) <- execData (DataA (State s0)) m
57 pure s
74 pure s
58
75
59-- | Fetch the current value of the state.
76-- | Fetch the current value of the state.
60get :: State s :> es => Eff es s
77get :: State s :> es => Eff es s
61get = do
78get = do
62− IdE (State s) <- getEffect
79+ DataA (State s) <- getData
63 pure s
80 pure s
64
81
65-- | Get a function of the current state.
82-- | Get a function of the current state.
@@ -73,14 +90,14 @@ gets f = f <$> get
73
90
74-- | Set the current state to the given value.
91-- | Set the current state to the given value.
75put :: State s :> es => s -> Eff es ()
92put :: State s :> es => s -> Eff es ()
76−put s = putEffect (IdE (State s))
93+put s = putData (DataA (State s))
77
94
78-- | Apply the function to the current state and return a value.
95-- | Apply the function to the current state and return a value.
79state
96state
80 :: State s :> es
97 :: State s :> es
81 => (s -> (a, s)) -- ^ The function to modify the state.
98 => (s -> (a, s)) -- ^ The function to modify the state.
82 -> Eff es a
99 -> Eff es a
83−state f = stateEffect $ \(IdE (State s0)) -> let (a, s) = f s0 in (a, IdE (State s))
100+state f = stateData $ \(DataA (State s0)) -> let (a, s) = f s0 in (a, DataA (State s))
84
101
85-- | Apply the function to the current state.
102-- | Apply the function to the current state.
86--
103--
@@ -96,9 +113,9 @@ stateM
96 :: State s :> es
113 :: State s :> es
97 => (s -> Eff es (a, s)) -- ^ The function to modify the state.
114 => (s -> Eff es (a, s)) -- ^ The function to modify the state.
98 -> Eff es a
115 -> Eff es a
99−stateM f = stateEffectM $ \(IdE (State s0)) -> do
116+stateM f = stateDataM $ \(DataA (State s0)) -> do
100 (a, s) <- f s0
117 (a, s) <- f s0
101− pure (a, IdE (State s))
118+ pure (a, DataA (State s))
102
119
103-- | Apply the monadic function to the current state.
120-- | Apply the monadic function to the current state.
104--
121--
@@ -108,3 +125,7 @@ modifyM
108 => (s -> Eff es s) -- ^ The monadic function to modify the state.
125 => (s -> Eff es s) -- ^ The monadic function to modify the state.
109 -> Eff es ()
126 -> Eff es ()
110modifyM f = stateM (\s -> ((), ) <$> f s)
127modifyM 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:
2--
2--
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").
4--
5--
5−-- - shareable between multiple threads,
6+-- - slightly slower than "Effectful.State.Local".
6--
7--
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:
8--
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!"
9module Effectful.State.Shared
27module Effectful.State.Shared
10 ( State
28 ( State
11 , runState
29 , runState
@@ -22,58 +40,88 @@ module Effectful.State.Shared
22
40
23import Control.Concurrent.MVar
41import Control.Concurrent.MVar
24
42
25−import Effectful.Internal.Effect
43+import Effectful.Dispatch.Static
26−import Effectful.Internal.Env
27−import Effectful.Internal.Monad
44+import Effectful.Monad
28
45
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@.
30newtype State s :: Effect where
47newtype State s :: Effect where
31 State :: MVar s -> State s m r
48 State :: MVar s -> State s m r
32
49
50+-- | Run a 'State' effect with the given initial state and return the final
51+-- value along with the final state.
33runState :: s -> Eff (State s : es) a -> Eff es (a, s)
52runState :: s -> Eff (State s : es) a -> Eff es (a, s)
34runState s m = do
53runState s m = do
35 v <- unsafeEff_ $ newMVar s
54 v <- unsafeEff_ $ newMVar s
36− a <- evalEffect (IdE (State v)) m
55+ a <- evalData (DataA (State v)) m
37 (a, ) <$> unsafeEff_ (readMVar v)
56 (a, ) <$> unsafeEff_ (readMVar v)
38
57
58+-- | Run a 'State' effect with the given initial state and return the final
59+-- value, discarding the final state.
39evalState :: s -> Eff (State s : es) a -> Eff es a
60evalState :: s -> Eff (State s : es) a -> Eff es a
40evalState s m = do
61evalState s m = do
41 v <- unsafeEff_ $ newMVar s
62 v <- unsafeEff_ $ newMVar s
42− evalEffect (IdE (State v)) m
63+ evalData (DataA (State v)) m
43
64
65+-- | Run a 'State' effect with the given initial state and return the final
66+-- state, discarding the final value.
44execState :: s -> Eff (State s : es) a -> Eff es s
67execState :: s -> Eff (State s : es) a -> Eff es s
45execState s m = do
68execState s m = do
46 v <- unsafeEff_ $ newMVar s
69 v <- unsafeEff_ $ newMVar s
47− _ <- evalEffect (IdE (State v)) m
70+ _ <- evalData (DataA (State v)) m
48 unsafeEff_ $ readMVar v
71 unsafeEff_ $ readMVar v
49
72
73+-- | Fetch the current value of the state.
50get :: State s :> es => Eff es s
74get :: State s :> es => Eff es s
51get = unsafeEff $ \es -> do
75get = unsafeEff $ \es -> do
52− IdE (State v) <- getEnv es
76+ DataA (State v) <- getEnv es
53 readMVar v
77 readMVar v
54
78
79+-- | Get a function of the current state.
80+--
81+-- @'gets' f ≡ f '<$>' 'get'@
55gets :: State s :> es => (s -> a) -> Eff es a
82gets :: State s :> es => (s -> a) -> Eff es a
56gets f = f <$> get
83gets f = f <$> get
57
84
85+-- | Set the current state to the given value.
58put :: State s :> es => s -> Eff es ()
86put :: State s :> es => s -> Eff es ()
59put s = unsafeEff $ \es -> do
87put s = unsafeEff $ \es -> do
60− IdE (State v) <- getEnv es
88+ DataA (State v) <- getEnv es
61 modifyMVar_ v $ \_ -> s `seq` pure s
89 modifyMVar_ v $ \_ -> s `seq` pure s
62
90
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.
63state :: State s :> es => (s -> (a, s)) -> Eff es a
94state :: State s :> es => (s -> (a, s)) -> Eff es a
64state f = unsafeEff $ \es -> do
95state f = unsafeEff $ \es -> do
65− IdE (State v) <- getEnv es
96+ DataA (State v) <- getEnv es
66 modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)
97 modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)
67
98
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.
68modify :: State s :> es => (s -> s) -> Eff es ()
104modify :: State s :> es => (s -> s) -> Eff es ()
69modify f = state (\s -> ((), f s))
105modify f = state (\s -> ((), f s))
70
106
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.
71stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a
110stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a
72stateM f = unsafeEff $ \es -> do
111stateM f = unsafeEff $ \es -> do
73− IdE (State v) <- getEnv es
112+ DataA (State v) <- getEnv es
74 modifyMVar v $ \s0 -> do
113 modifyMVar v $ \s0 -> do
75 (a, s) <- unEff (f s0) es
114 (a, s) <- unEff (f s0) es
76 s `seq` pure (s, a)
115 s `seq` pure (s, a)
77
116
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.
78modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()
122modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()
79modifyM f = stateM (\s -> ((), ) <$> f s)
123modifyM 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+1−1
@@ -15,7 +15,7 @@ module Effectful.Writer.Dynamic
15 , listens
15 , listens
16 ) where
16 ) where
17
17
18−import Effectful.Handler
18+import Effectful.Dispatch.Dynamic
19import Effectful.Monad
19import Effectful.Monad
20import qualified Effectful.Writer.Local as L
20import qualified Effectful.Writer.Local as L
21import qualified Effectful.Writer.Shared as S
21import qualified Effectful.Writer.Shared as S
effectful-core/src/Effectful/Writer/Local.hs+28−16
@@ -1,8 +1,6 @@
1−-- | The 'Writer' effect.
1+-- | Support for access to a write only value of a particular type, which is:
2--
2--
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
6-- look at "Effectful.Writer.Shared"),
4-- look at "Effectful.Writer.Shared"),
7--
5--
8-- - very fast.
6-- - very fast.
@@ -26,11 +24,10 @@ module Effectful.Writer.Local
26 , listens
24 , listens
27 ) where
25 ) where
28
26
29−import Control.Exception
27+import Control.Exception (onException, mask)
30
28
31−import Effectful.Internal.Effect
29+import Effectful.Dispatch.Static
32−import Effectful.Internal.Env
33−import Effectful.Internal.Monad
30+import Effectful.Monad
34
31
35-- | Provide access to a strict (WHNF), thread local, write only value of type
32-- | Provide access to a strict (WHNF), thread local, write only value of type
36-- @w@.
33-- @w@.
@@ -41,35 +38,46 @@ newtype Writer w :: Effect where
41-- output.
38-- output.
42runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
39runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
43runWriter m = do
40runWriter m = do
44− (a, IdE (Writer w)) <- runEffect (IdE (Writer mempty)) m
41+ (a, DataA (Writer w)) <- runData (DataA (Writer mempty)) m
45 pure (a, w)
42 pure (a, w)
46
43
47-- | Run a 'Writer' effect and return the final output, discarding the final
44-- | Run a 'Writer' effect and return the final output, discarding the final
48-- value.
45-- value.
49execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
46execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
50execWriter m = do
47execWriter m = do
51− IdE (Writer w) <- execEffect (IdE (Writer mempty)) m
48+ DataA (Writer w) <- execData (DataA (Writer mempty)) m
52 pure w
49 pure w
53
50
54-- | Append the given output to the overall output of the 'Writer'.
51-- | Append the given output to the overall output of the 'Writer'.
55tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
52tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
56−tell w = stateEffect $ \(IdE (Writer w0)) -> ((), IdE (Writer (w0 <> w)))
53+tell w = stateData $ \(DataA (Writer w0)) -> ((), DataA (Writer (w0 <> w)))
57
54
58-- | Execute an action and append its output to the overall output of the
55-- | Execute an action and append its output to the overall output of the
59-- 'Writer'.
56-- 'Writer'.
60--
57--
61−-- /Note:/ if a runtime exception is received while the action is executed, the
58+-- /Note:/ if an exception is received while the action is executed, the partial
62−-- partial output of the action will still be appended to the overall output of
59+-- output of the action will still be appended to the overall output of the
63−-- the 'Writer'.
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!"
64listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
72listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
65listen m = unsafeEff $ \es -> mask $ \restore -> do
73listen m = unsafeEff $ \es -> mask $ \restore -> do
66− w0 <- stateEnv es $ \(IdE (Writer w)) -> (w, IdE (Writer mempty))
74+ w0 <- stateEnv es $ \(DataA (Writer w)) -> (w, DataA (Writer mempty))
67 a <- restore (unEff m es) `onException` merge es w0
75 a <- restore (unEff m es) `onException` merge es w0
68 (a, ) <$> merge es w0
76 (a, ) <$> merge es w0
69 where
77 where
70 merge es w0 =
78 merge es w0 =
71 -- If an exception is thrown, restore w0 and keep parts of w1.
79 -- If an exception is thrown, restore w0 and keep parts of w1.
72− stateEnv es $ \(IdE (Writer w1)) -> (w1, IdE (Writer (w0 <> w1)))
80+ stateEnv es $ \(DataA (Writer w1)) -> (w1, DataA (Writer (w0 <> w1)))
73
81
74-- | Execute an action and append its output to the overall output of the
82-- | Execute an action and append its output to the overall output of the
75-- 'Writer', then return the final value along with a function of the recorded
83-- 'Writer', then return the final value along with a function of the recorded
@@ -80,3 +88,7 @@ listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)
80listens f m = do
88listens f m = do
81 (a, w) <- listen m
89 (a, w) <- listen m
82 pure (a, f w)
90 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.
1module Effectful.Writer.Shared
18module Effectful.Writer.Shared
2 ( Writer
19 ( Writer
3 , runWriter
20 , runWriter
@@ -8,33 +25,54 @@ module Effectful.Writer.Shared
8 ) where
25 ) where
9
26
10import Control.Concurrent.MVar
27import Control.Concurrent.MVar
11−import Control.Exception
28+import Control.Exception (onException, uninterruptibleMask)
12
29
13−import Effectful.Internal.Effect
30+import Effectful.Dispatch.Static
14−import Effectful.Internal.Env
15−import Effectful.Internal.Monad
31+import Effectful.Monad
16
32
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@.
18newtype Writer w :: Effect where
34newtype Writer w :: Effect where
19 Writer :: MVar w -> Writer w m r
35 Writer :: MVar w -> Writer w m r
20
36
37+-- | Run a 'Writer' effect and return the final value along with the final
38+-- output.
21runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
39runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
22runWriter m = do
40runWriter m = do
23 v <- unsafeEff_ $ newMVar mempty
41 v <- unsafeEff_ $ newMVar mempty
24− a <- evalEffect (IdE (Writer v)) m
42+ a <- evalData (DataA (Writer v)) m
25 (a, ) <$> unsafeEff_ (readMVar v)
43 (a, ) <$> unsafeEff_ (readMVar v)
26
44
45+-- | Run a 'Writer' effect and return the final output, discarding the final
46+-- value.
27execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
47execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
28execWriter m = do
48execWriter m = do
29 v <- unsafeEff_ $ newMVar mempty
49 v <- unsafeEff_ $ newMVar mempty
30− _ <- evalEffect (IdE (Writer v)) m
50+ _ <- evalData (DataA (Writer v)) m
31 unsafeEff_ $ readMVar v
51 unsafeEff_ $ readMVar v
32
52
53+-- | Append the given output to the overall output of the 'Writer'.
33tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
54tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
34tell w1 = unsafeEff $ \es -> do
55tell w1 = unsafeEff $ \es -> do
35− IdE (Writer v) <- getEnv es
56+ DataA (Writer v) <- getEnv es
36 modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w
57 modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w
37
58
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!"
38listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
76listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
39listen m = unsafeEff $ \es -> do
77listen m = unsafeEff $ \es -> do
40 -- The mask is uninterruptible because modifyMVar_ v0 in the merge function
78 -- The mask is uninterruptible because modifyMVar_ v0 in the merge function
@@ -43,19 +81,28 @@ listen m = unsafeEff $ \es -> do
43 uninterruptibleMask $ \restore -> do
81 uninterruptibleMask $ \restore -> do
44 v1 <- newMVar mempty
82 v1 <- newMVar mempty
45 -- Replace thread local MVar with a fresh one for isolated listening.
83 -- 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))
47 a <- restore (unEff m es) `onException` merge es v0 v1
85 a <- restore (unEff m es) `onException` merge es v0 v1
48 (a, ) <$> merge es v0 v1
86 (a, ) <$> merge es v0 v1
49 where
87 where
50 -- Merge results accumulated in the local MVar with the mainline. If an
88 -- Merge results accumulated in the local MVar with the mainline. If an
51 -- exception was received while listening, merge results recorded so far.
89 -- exception was received while listening, merge results recorded so far.
52 merge es v0 v1 = do
90 merge es v0 v1 = do
53− putEnv es $ IdE (Writer v0)
91+ putEnv es $ DataA (Writer v0)
54 w1 <- readMVar v1
92 w1 <- readMVar v1
55 modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w
93 modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w
56 pure w1
94 pure w1
57
95
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@
58listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)
101listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)
59listens f m = do
102listens f m = do
60 (a, w) <- listen m
103 (a, w) <- listen m
61 pure (a, f w)
104 pure (a, f w)
105+
106+-- $setup
107+-- >>> import Control.Exception (ErrorCall)
108+-- >>> import Control.Monad.Catch
effectful/bench/Main.hs+3−3
@@ -97,11 +97,11 @@ filesize n = bgroup (show n)
97#ifdef VERSION_eff
97#ifdef VERSION_eff
98 , bench "eff" $ nfAppIO eff_calculateFileSizesDeep (take n files)
98 , bench "eff" $ nfAppIO eff_calculateFileSizesDeep (take n files)
99#endif
99#endif
100−#ifdef VERSION_polysemy
101− , bench "polysemy" $ nfAppIO poly_calculateFileSizesDeep (take n files)
102−#endif
103#ifdef VERSION_mtl
100#ifdef VERSION_mtl
104 , bench "mtl" $ nfAppIO mtl_calculateFileSizesDeep (take n files)
101 , bench "mtl" $ nfAppIO mtl_calculateFileSizesDeep (take n files)
102+#endif
103+#ifdef VERSION_polysemy
104+ , bench "polysemy" $ nfAppIO poly_calculateFileSizesDeep (take n files)
105#endif
105#endif
106 ]
106 ]
107 ]
107 ]
effectful/effectful.cabal+25−18
@@ -20,7 +20,7 @@ description: An easy to use, performant extensible effects library with seamless
20
20
21extra-source-files: CHANGELOG.md
21extra-source-files: CHANGELOG.md
22
22
23−tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.1
23+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1
24
24
25bug-reports: https://github.com/arybczak/effectful/issues
25bug-reports: https://github.com/arybczak/effectful/issues
26source-repository head
26source-repository head
@@ -40,6 +40,7 @@ common language
40 ConstraintKinds
40 ConstraintKinds
41 DataKinds
41 DataKinds
42 DeriveFunctor
42 DeriveFunctor
43+ DeriveGeneric
43 FlexibleContexts
44 FlexibleContexts
44 FlexibleInstances
45 FlexibleInstances
45 GADTs
46 GADTs
@@ -60,35 +61,42 @@ common language
60library
61library
61 import: language
62 import: language
62
63
63− ghc-options: -O2
64−
65− build-depends: base >= 4.13 && <5
64+ build-depends: base >= 4.13 && < 5
66− , async
65+ , async >= 2.2.2
67− , directory
66+ , directory >= 1.3.2
68− , effectful-core >= 0.1 && <0.1.1
67+ , effectful-core >= 0.1 && < 0.1.1
69− , process
68+ , process >= 1.6.9
70− , resourcet
69+ , resourcet >= 1.2.4.3
71− , time
70+ , time >= 1.9.2
71+ , stm >= 2.5.0.0
72− , unliftio
72+ , unliftio >= 0.2.20
73
73
74 hs-source-dirs: src
74 hs-source-dirs: src
75
75
76− exposed-modules: Effectful
76+ exposed-modules: Effectful.Concurrent
77 Effectful.Concurrent.Async
77 Effectful.Concurrent.Async
78− Effectful.Concurrent.Base
78+ Effectful.Concurrent.Chan
79+ Effectful.Concurrent.MVar
80+ Effectful.Concurrent.STM
81+ Effectful.Concurrent.QSem
82+ Effectful.Concurrent.QSemN
79 Effectful.Environment
83 Effectful.Environment
80 Effectful.FileSystem
84 Effectful.FileSystem
85+ Effectful.FileSystem.IO
81 Effectful.Process
86 Effectful.Process
82 Effectful.Resource
87 Effectful.Resource
83 Effectful.Temporary
88 Effectful.Temporary
84 Effectful.Timeout
89 Effectful.Timeout
85
90
86− other-modules: Effectful.Concurrent.Internal
91+ other-modules: Effectful.Concurrent.Effect
92+ Effectful.FileSystem.Effect
87
93
88− reexported-modules: Effectful.Error
94+ reexported-modules: Effectful
95+ , Effectful.Dispatch.Dynamic
96+ , Effectful.Dispatch.Static
97+ , Effectful.Error
89 , Effectful.Error.Dynamic
98 , Effectful.Error.Dynamic
90 , Effectful.Fail
99 , Effectful.Fail
91− , Effectful.Handler
92 , Effectful.Monad
100 , Effectful.Monad
93 , Effectful.Prim
101 , Effectful.Prim
94 , Effectful.Reader
102 , Effectful.Reader
@@ -111,7 +119,6 @@ test-suite test
111 , effectful-core
119 , effectful-core
112 , exceptions
120 , exceptions
113 , lifted-base
121 , lifted-base
114− , optics-core >= 0.4
115 , tasty
122 , tasty
116 , tasty-hunit
123 , tasty-hunit
117 , unliftio
124 , unliftio
@@ -147,7 +154,7 @@ benchmark bench
147 if impl(ghc < 9.2)
154 if impl(ghc < 9.2)
148 build-depends: fused-effects
155 build-depends: fused-effects
149
156
150− if impl(ghc < 9.2)
157+ if impl(ghc < 9.3)
151 build-depends: polysemy
158 build-depends: polysemy
152
159
153 build-depends: base
160 build-depends: base
effectful/src/Effectful/Concurrent/Base.hs → effectful/src/Effectful/Concurrent.hsrenamed+26−8
@@ -1,6 +1,19 @@
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'.
1−module Effectful.Concurrent.Base
15+module Effectful.Concurrent
2− ( -- * Concurrent effect
3− Concurrent
16+ ( Concurrent
4 , runConcurrent
17 , runConcurrent
5
18
6 -- * Basic concurrency operations
19 -- * Basic concurrency operations
@@ -16,6 +29,7 @@ module Effectful.Concurrent.Base
16 , forkOnWithUnmask
29 , forkOnWithUnmask
17 , getNumCapabilities
30 , getNumCapabilities
18 , setNumCapabilities
31 , setNumCapabilities
32+ , getNumProcessors
19 , threadCapability
33 , threadCapability
20
34
21 -- * Scheduling
35 -- * Scheduling
@@ -42,17 +56,17 @@ module Effectful.Concurrent.Base
42 , C.rtsSupportsBoundThreads
56 , C.rtsSupportsBoundThreads
43 ) where
57 ) where
44
58
45−import qualified Control.Concurrent as C
46import Control.Exception (Exception, SomeException)
59import Control.Exception (Exception, SomeException)
47import Data.Bifunctor (second)
60import Data.Bifunctor (second)
48import System.Mem.Weak (Weak)
61import System.Mem.Weak (Weak)
49import System.Posix.Types (Fd)
62import System.Posix.Types (Fd)
50import UnliftIO.STM (STM)
63import UnliftIO.STM (STM)
64+import qualified Control.Concurrent as C
65+import qualified GHC.Conc as GHC
51
66
52−import Effectful.Concurrent.Internal
67+import Effectful.Concurrent.Effect
53−import Effectful.Internal.Effect
54−import Effectful.Internal.Env
68+import Effectful.Dispatch.Static
55−import Effectful.Internal.Monad
69+import Effectful.Monad
56
70
57----------------------------------------
71----------------------------------------
58-- Basic concurrency operations
72-- Basic concurrency operations
@@ -122,6 +136,10 @@ getNumCapabilities = unsafeEff_ C.getNumCapabilities
122setNumCapabilities :: Concurrent :> es => Int -> Eff es ()
136setNumCapabilities :: Concurrent :> es => Int -> Eff es ()
123setNumCapabilities = unsafeEff_ . C.setNumCapabilities
137setNumCapabilities = unsafeEff_ . C.setNumCapabilities
124
138
139+-- | Lifted 'GHC.getNumProcessors'.
140+getNumProcessors :: Concurrent :> es => Eff es Int
141+getNumProcessors = unsafeEff_ GHC.getNumProcessors
142+
125-- | Lifted 'C.threadCapability'.
143-- | Lifted 'C.threadCapability'.
126threadCapability :: Concurrent :> es => C.ThreadId -> Eff es (Int, Bool)
144threadCapability :: Concurrent :> es => C.ThreadId -> Eff es (Int, Bool)
127threadCapability = unsafeEff_ . C.threadCapability
145threadCapability = unsafeEff_ . C.threadCapability
effectful/src/Effectful/Concurrent/Async.hs+6−6
@@ -1,7 +1,7 @@
1{-# LANGUAGE UndecidableInstances #-}
1{-# LANGUAGE UndecidableInstances #-}
2+-- | Lifted version of "Control.Concurrent.Async".
2module Effectful.Concurrent.Async
3module Effectful.Concurrent.Async
3− ( -- * Concurrent effect
4− Concurrent
4+ ( Concurrent
5 , runConcurrent
5 , runConcurrent
6
6
7 -- * Asynchronous actions
7 -- * Asynchronous actions
@@ -76,14 +76,14 @@ import Control.Concurrent (threadDelay)
76import Control.Concurrent.Async (Async)
76import Control.Concurrent.Async (Async)
77import Control.Exception (Exception, SomeException)
77import Control.Exception (Exception, SomeException)
78import Control.Monad (forever)
78import Control.Monad (forever)
79+import Data.Kind (Type)
79import qualified Control.Concurrent.Async as A
80import qualified Control.Concurrent.Async as A
80import qualified UnliftIO.Async as U
81import qualified UnliftIO.Async as U
81import qualified UnliftIO.Internals.Async as I
82import qualified UnliftIO.Internals.Async as I
82
83
83−import Effectful.Concurrent.Internal
84+import Effectful.Concurrent.Effect
84−import Effectful.Internal.Effect
85−import Effectful.Internal.Env
85+import Effectful.Dispatch.Static
86−import Effectful.Internal.Monad
86+import Effectful.Monad
87
87
88-- | Lifted 'A.async'.
88-- | Lifted 'A.async'.
89async :: Concurrent :> es => Eff es a -> Eff es (Async a)
89async :: Concurrent :> es => Eff es a -> Eff es (Async a)
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/Internal.hsdeleted−20
@@ -1,20 +0,0 @@
1−module Effectful.Concurrent.Internal
2− ( -- * Concurrent effect
3− Concurrent
4− , runConcurrent
5− ) where
6−
7−import Effectful.Internal.Effect
8−import Effectful.Internal.Monad
9−
10−-- | Run 'Eff' operations asynchronously via the @async@ library.
11−--
12−-- /Note:/ thread local state changes in 'Eff' operations run asynchronously
13−-- will not affect the parent thread.
14−--
15−-- /TODO:/ write about 'Concurrent' not respecting scoped operations.
16−data Concurrent :: Effect where
17− Concurrent :: Concurrent m r
18−
19−runConcurrent :: IOE :> es => Eff (Concurrent : es) a -> Eff es a
20−runConcurrent = evalEffect (IdE Concurrent)
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.hs+7−11
@@ -1,6 +1,5 @@
1module Effectful.Environment
1module Effectful.Environment
2− ( -- * Environment effect
3− Environment
2+ ( Environment
4 , runEnvironment
3 , runEnvironment
5
4
6 -- * Querying the environment
5 -- * Querying the environment
@@ -20,15 +19,16 @@ module Effectful.Environment
20
19
21import qualified System.Environment as E
20import qualified System.Environment as E
22
21
23−import Effectful.Internal.Effect
22+import Effectful.Dispatch.Static hiding (getEnv)
24−import Effectful.Internal.Monad
23+import Effectful.Monad
25
24
26-- | An effect for querying and modifying the system environment.
25-- | An effect for querying and modifying the system environment.
27data Environment :: Effect where
26data Environment :: Effect where
28 Environment :: Environment m r
27 Environment :: Environment m r
29
28
29+-- | Run the 'Environment' effect.
30runEnvironment :: IOE :> es => Eff (Environment : es) a -> Eff es a
30runEnvironment :: IOE :> es => Eff (Environment : es) a -> Eff es a
31−runEnvironment = evalEffect (IdE Environment)
31+runEnvironment = evalData (DataA Environment)
32
32
33-- | Lifted 'E.getArgs'.
33-- | Lifted 'E.getArgs'.
34getArgs :: Environment :> es => Eff es [String]
34getArgs :: Environment :> es => Eff es [String]
@@ -64,12 +64,8 @@ unsetEnv = unsafeEff_ . E.unsetEnv
64
64
65-- | Lifted 'E.withArgs'.
65-- | Lifted 'E.withArgs'.
66withArgs :: Environment :> es => [String] -> Eff es a -> Eff es a
66withArgs :: Environment :> es => [String] -> Eff es a -> Eff es a
67−withArgs env k = unsafeEff $ \es -> do
67+withArgs = unsafeLiftMapIO . E.withArgs
68− seqUnliftEff es $ \runInIO -> do
69− E.withArgs env (runInIO k)
70
68
71-- | Lifted 'E.withProgName'.
69-- | Lifted 'E.withProgName'.
72withProgName :: Environment :> es => String -> Eff es a -> Eff es a
70withProgName :: Environment :> es => String -> Eff es a -> Eff es a
73−withProgName n k = unsafeEff $ \es -> do
74− seqUnliftEff es $ \runInIO -> do
75− E.withProgName n (runInIO k)
71+withProgName = unsafeLiftMapIO . E.withProgName
effectful/src/Effectful/FileSystem.hs+95−95
@@ -1,98 +1,98 @@
1module Effectful.FileSystem
1module Effectful.FileSystem
2− ( FileSystem
2+ ( FileSystem
3− , runFileSystem
3+ , runFileSystem
4−
4+
5− -- * Actions on directories
5+ -- * Actions on directories
6− , createDirectory
6+ , createDirectory
7− , createDirectoryIfMissing
7+ , createDirectoryIfMissing
8− , removeDirectory
8+ , removeDirectory
9− , removeDirectoryRecursive
9+ , removeDirectoryRecursive
10− , removePathForcibly
10+ , removePathForcibly
11− , renameDirectory
11+ , renameDirectory
12− , listDirectory
12+ , listDirectory
13− , getDirectoryContents
13+ , getDirectoryContents
14−
14+
15− -- ** Current working directory
15+ -- ** Current working directory
16− , getCurrentDirectory
16+ , getCurrentDirectory
17− , setCurrentDirectory
17+ , setCurrentDirectory
18− , withCurrentDirectory
18+ , withCurrentDirectory
19−
19+
20− -- * Pre-defined directories
20+ -- * Pre-defined directories
21− , getHomeDirectory
21+ , getHomeDirectory
22− , getXdgDirectory
22+ , getXdgDirectory
23− , getXdgDirectoryList
23+ , getXdgDirectoryList
24− , getAppUserDataDirectory
24+ , getAppUserDataDirectory
25− , getUserDocumentsDirectory
25+ , getUserDocumentsDirectory
26− , getTemporaryDirectory
26+ , getTemporaryDirectory
27−
27+
28− -- * Actions on files
28+ -- * Actions on files
29− , removeFile
29+ , removeFile
30− , renameFile
30+ , renameFile
31− , renamePath
31+ , renamePath
32− , copyFile
32+ , copyFile
33− , copyFileWithMetadata
33+ , copyFileWithMetadata
34− , getFileSize
34+ , getFileSize
35− , canonicalizePath
35+ , canonicalizePath
36− , makeAbsolute
36+ , makeAbsolute
37− , makeRelativeToCurrentDirectory
37+ , makeRelativeToCurrentDirectory
38−
38+
39− -- * Existence tests
39+ -- * Existence tests
40− , doesPathExist
40+ , doesPathExist
41− , doesFileExist
41+ , doesFileExist
42− , doesDirectoryExist
42+ , doesDirectoryExist
43− , findExecutable
43+ , findExecutable
44− , findExecutables
44+ , findExecutables
45− , findExecutablesInDirectories
45+ , findExecutablesInDirectories
46− , findFile
46+ , findFile
47− , findFiles
47+ , findFiles
48− , findFileWith
48+ , findFileWith
49− , findFilesWith
49+ , findFilesWith
50−
50+
51− -- * Symbolic links
51+ -- * Symbolic links
52− , createFileLink
52+ , createFileLink
53− , createDirectoryLink
53+ , createDirectoryLink
54− , removeDirectoryLink
54+ , removeDirectoryLink
55− , pathIsSymbolicLink
55+ , pathIsSymbolicLink
56− , getSymbolicLinkTarget
56+ , getSymbolicLinkTarget
57−
57+
58− -- * Permissions
58+ -- * Permissions
59− , getPermissions
59+ , getPermissions
60− , setPermissions
60+ , setPermissions
61− , copyPermissions
61+ , copyPermissions
62−
62+
63− -- * Timestamps
63+ -- * Timestamps
64− , getAccessTime
64+ , getAccessTime
65− , getModificationTime
65+ , getModificationTime
66− , setAccessTime
66+ , setAccessTime
67− , setModificationTime
67+ , setModificationTime
68−
68+
69− -- * Re-exports
69+ -- * Re-exports
70−
70+
71− -- ** Pre-defined directories
71+ -- ** Pre-defined directories
72− , D.XdgDirectory(..)
72+ , D.XdgDirectory(..)
73− , D.XdgDirectoryList(..)
73+ , D.XdgDirectoryList(..)
74−
74+
75− -- ** Existence tests
75+ -- ** Existence tests
76− , D.exeExtension
76+ , D.exeExtension
77−
77+
78− -- ** Permissions
78+ -- ** Permissions
79− , D.Permissions
79+ , D.Permissions
80− , D.emptyPermissions
80+ , D.emptyPermissions
81− , D.readable
81+ , D.readable
82− , D.writable
82+ , D.writable
83− , D.executable
83+ , D.executable
84− , D.searchable
84+ , D.searchable
85− , D.setOwnerReadable
85+ , D.setOwnerReadable
86− , D.setOwnerWritable
86+ , D.setOwnerWritable
87− , D.setOwnerExecutable
87+ , D.setOwnerExecutable
88− , D.setOwnerSearchable
88+ , D.setOwnerSearchable
89− ) where
89+ ) where
90
90
91import Data.Time (UTCTime)
91import Data.Time (UTCTime)
92import qualified System.Directory as D
92import qualified System.Directory as D
93
93
94−import Effectful.Internal.Effect
94+import Effectful.Dispatch.Static
95−import Effectful.Internal.Monad
95+import Effectful.Monad
96
96
97-- | An effect for interacting with the filesystem.
97-- | An effect for interacting with the filesystem.
98data FileSystem :: Effect where
98data FileSystem :: Effect where
@@ -100,7 +100,7 @@ data FileSystem :: Effect where
100
100
101-- | Run the 'FileSystem' effect.
101-- | Run the 'FileSystem' effect.
102runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a
102runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a
103−runFileSystem = evalEffect (IdE FileSystem)
103+runFileSystem = evalData (DataA FileSystem)
104
104
105----------------------------------------
105----------------------------------------
106-- Actions on directories
106-- Actions on directories
@@ -276,8 +276,8 @@ findFileWith
276 -> [FilePath]
276 -> [FilePath]
277 -> String
277 -> String
278 -> Eff es (Maybe FilePath)
278 -> Eff es (Maybe FilePath)
279−findFileWith p dirs n = unsafeEff $ \es -> do
279+findFileWith p dirs n = unsafeUnliftIO $ \unlift -> do
280− D.findFileWith ((`unEff` es) . p) dirs n
280+ D.findFileWith (unlift . p) dirs n
281
281
282-- | Lifted 'D.findFilesWith'.
282-- | Lifted 'D.findFilesWith'.
283findFilesWith
283findFilesWith
@@ -286,8 +286,8 @@ findFilesWith
286 -> [FilePath]
286 -> [FilePath]
287 -> String
287 -> String
288 -> Eff es [FilePath]
288 -> Eff es [FilePath]
289−findFilesWith p dirs ns = unsafeEff $ \es -> do
289+findFilesWith p dirs ns = unsafeUnliftIO $ \unlift -> do
290− D.findFilesWith ((`unEff` es) . p) dirs ns
290+ D.findFilesWith (unlift . p) dirs ns
291
291
292----------------------------------------
292----------------------------------------
293-- Symbolic links
293-- Symbolic links
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.hs+7−9
@@ -1,8 +1,7 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−
2+-- | Lifted version of "System.Process".
3module Effectful.Process
3module Effectful.Process
4− ( -- * Process effect
5− Process
4+ ( Process
6 , runProcess
5 , runProcess
7
6
8 -- * Running sub-processes
7 -- * Running sub-processes
@@ -51,15 +50,15 @@ import System.IO (Handle)
51import System.Posix.Internals (FD)
50import System.Posix.Internals (FD)
52import qualified System.Process as P
51import qualified System.Process as P
53
52
54−import Effectful.Internal.Effect
53+import Effectful.Dispatch.Static
55−import Effectful.Internal.Monad
54+import Effectful.Monad
56
55
57-- | An effect for running child processes using the @process@ library.
56-- | An effect for running child processes using the @process@ library.
58data Process :: Effect where
57data Process :: Effect where
59 Process :: Process m r
58 Process :: Process m r
60
59
61runProcess :: IOE :> es => Eff (Process : es) a -> Eff es a
60runProcess :: IOE :> es => Eff (Process : es) a -> Eff es a
62−runProcess = evalEffect (IdE Process)
61+runProcess = evalData (DataA Process)
63
62
64----------------------------------------
63----------------------------------------
65-- Running sub-processes
64-- Running sub-processes
@@ -129,9 +128,8 @@ withCreateProcess
129 => P.CreateProcess
128 => P.CreateProcess
130 -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> P.ProcessHandle -> Eff es a)
129 -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> P.ProcessHandle -> Eff es a)
131 -> Eff es a
130 -> Eff es a
132−withCreateProcess cp cb = unsafeEff $ \es -> do
131+withCreateProcess cp cb = unsafeUnliftIO $ \unlift -> do
133− seqUnliftEff es $ \runInIO -> do
134− P.withCreateProcess cp (\inh outh errh ph -> runInIO $ cb inh outh errh ph)
132+ P.withCreateProcess cp $ \inh outh errh ph -> unlift $ cb inh outh errh ph
135
133
136-- | Lifted 'P.cleanupProcess'.
134-- | Lifted 'P.cleanupProcess'.
137cleanupProcess
135cleanupProcess
effectful/src/Effectful/Resource.hs+6−7
@@ -24,9 +24,8 @@ import Control.Exception
24import qualified Control.Monad.Trans.Resource as R
24import qualified Control.Monad.Trans.Resource as R
25import qualified Control.Monad.Trans.Resource.Internal as RI
25import qualified Control.Monad.Trans.Resource.Internal as RI
26
26
27−import Effectful.Internal.Effect
27+import Effectful.Dispatch.Static
28−import Effectful.Internal.Env
29−import Effectful.Internal.Monad
28+import Effectful.Monad
30
29
31-- | Data tag for a resource effect.
30-- | Data tag for a resource effect.
32newtype Resource :: Effect where
31newtype Resource :: Effect where
@@ -38,7 +37,7 @@ runResource m = unsafeEff $ \es0 -> do
38 size0 <- sizeEnv es0
37 size0 <- sizeEnv es0
39 istate <- R.createInternalState
38 istate <- R.createInternalState
40 mask $ \restore -> do
39 mask $ \restore -> do
41− es <- unsafeConsEnv (IdE (Resource istate)) noRelinker es0
40+ es <- unsafeConsEnv (DataA (Resource istate)) noRelinker es0
42 a <- restore (unEff m es) `catch` \e -> do
41 a <- restore (unEff m es) `catch` \e -> do
43 unsafeTailEnv size0 es
42 unsafeTailEnv size0 es
44 RI.stateCleanupChecked (Just e) istate
43 RI.stateCleanupChecked (Just e) istate
@@ -53,18 +52,18 @@ runResource m = unsafeEff $ \es0 -> do
53-- | Get the 'R.InternalState' of the current 'Resource' effect.
52-- | Get the 'R.InternalState' of the current 'Resource' effect.
54getInternalState :: Resource :> es => Eff es R.InternalState
53getInternalState :: Resource :> es => Eff es R.InternalState
55getInternalState = do
54getInternalState = do
56− IdE (Resource istate) <- getEffect
55+ DataA (Resource istate) <- getData
57 pure istate
56 pure istate
58
57
59-- | Run the 'Resource' effect with existing 'R.InternalState'.
58-- | Run the 'Resource' effect with existing 'R.InternalState'.
60--
59--
61-- /Note:/ the 'R.InternalState' will not be closed at the end.
60-- /Note:/ the 'R.InternalState' will not be closed at the end.
62runInternalState :: R.InternalState -> Eff (Resource : es) a -> Eff es a
61runInternalState :: R.InternalState -> Eff (Resource : es) a -> Eff es a
63−runInternalState istate = evalEffect $ IdE (Resource istate)
62+runInternalState istate = evalData (DataA (Resource istate))
64
63
65----------------------------------------
64----------------------------------------
66-- Orphan instance
65-- Orphan instance
67
66
68instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where
67instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where
69 liftResourceT (RI.ResourceT m) = unsafeEff $ \es -> do
68 liftResourceT (RI.ResourceT m) = unsafeEff $ \es -> do
70− getEnv es >>= \(IdE (Resource istate)) -> m istate
69+ getEnv es >>= \(DataA (Resource istate)) -> m istate
effectful/src/Effectful/Temporary.hs+11−15
@@ -10,8 +10,8 @@ module Effectful.Temporary
10import System.IO
10import System.IO
11import qualified UnliftIO.Temporary as T
11import qualified UnliftIO.Temporary as T
12
12
13−import Effectful.Internal.Effect
13+import Effectful.Dispatch.Static
14−import Effectful.Internal.Monad
14+import Effectful.Monad
15
15
16-- | An effect for interacting with temporary files.
16-- | An effect for interacting with temporary files.
17data Temporary :: Effect where
17data Temporary :: Effect where
@@ -19,7 +19,7 @@ data Temporary :: Effect where
19
19
20-- | Run the 'Temporary' effect.
20-- | Run the 'Temporary' effect.
21runTemporary :: IOE :> es => Eff (Temporary : es) a -> Eff es a
21runTemporary :: IOE :> es => Eff (Temporary : es) a -> Eff es a
22−runTemporary = evalEffect (IdE Temporary)
22+runTemporary = evalData (DataA Temporary)
23
23
24-- | Lifted 'T.withSystemTempFile'.
24-- | Lifted 'T.withSystemTempFile'.
25withSystemTempFile
25withSystemTempFile
@@ -29,9 +29,8 @@ withSystemTempFile
29 -> (FilePath -> Handle -> Eff es a)
29 -> (FilePath -> Handle -> Eff es a)
30 -- ^ Callback that can use the file.
30 -- ^ Callback that can use the file.
31 -> Eff es a
31 -> Eff es a
32−withSystemTempFile template action = unsafeEff $ \es -> do
32+withSystemTempFile template action = unsafeUnliftIO $ \unlift -> do
33− seqUnliftEff es $ \unlift -> do
34− T.withSystemTempFile template $ \fp handle -> unlift (action fp handle)
33+ T.withSystemTempFile template $ \fp handle -> unlift $ action fp handle
35
34
36-- | Lifted 'T.withSystemTempDirectory'.
35-- | Lifted 'T.withSystemTempDirectory'.
37withSystemTempDirectory
36withSystemTempDirectory
@@ -41,9 +40,8 @@ withSystemTempDirectory
41 -> (FilePath -> Eff es a)
40 -> (FilePath -> Eff es a)
42 -- ^ Callback that can use the directory.
41 -- ^ Callback that can use the directory.
43 -> Eff es a
42 -> Eff es a
44−withSystemTempDirectory template action = unsafeEff $ \es -> do
43+withSystemTempDirectory template action = unsafeUnliftIO $ \unlift -> do
45− seqUnliftEff es $ \unlift -> do
46− T.withSystemTempDirectory template $ \fp -> unlift (action fp)
44+ T.withSystemTempDirectory template $ \fp -> unlift $ action fp
47
45
48-- | Lifted 'T.withTempFile'.
46-- | Lifted 'T.withTempFile'.
49withTempFile
47withTempFile
@@ -55,9 +53,8 @@ withTempFile
55 -> (FilePath -> Handle -> Eff es a)
53 -> (FilePath -> Handle -> Eff es a)
56 -- ^ Callback that can use the file.
54 -- ^ Callback that can use the file.
57 -> Eff es a
55 -> Eff es a
58−withTempFile tmpDir template action = unsafeEff $ \es -> do
56+withTempFile tmpDir template action = unsafeUnliftIO $ \unlift -> do
59− seqUnliftEff es $ \unlift -> do
60− T.withTempFile tmpDir template $ \fp handle -> unlift (action fp handle)
57+ T.withTempFile tmpDir template $ \fp handle -> unlift $ action fp handle
61
58
62-- | Lifted 'T.withTempDirectory'.
59-- | Lifted 'T.withTempDirectory'.
63withTempDirectory
60withTempDirectory
@@ -69,6 +66,5 @@ withTempDirectory
69 -> (FilePath -> Eff es a)
66 -> (FilePath -> Eff es a)
70 -- ^ Callback that can use the directory.
67 -- ^ Callback that can use the directory.
71 -> Eff es a
68 -> Eff es a
72−withTempDirectory tmpDir template action = unsafeEff $ \es -> do
69+withTempDirectory tmpDir template action = unsafeUnliftIO $ \unlift -> do
73− seqUnliftEff es $ \unlift -> do
74− T.withTempDirectory tmpDir template $ \fp -> unlift (action fp)
70+ T.withTempDirectory tmpDir template $ \fp -> unlift $ action fp
effectful/src/Effectful/Timeout.hs+4−6
@@ -6,8 +6,8 @@ module Effectful.Timeout
6
6
7import qualified System.Timeout as T
7import qualified System.Timeout as T
8
8
9−import Effectful.Internal.Effect
9+import Effectful.Dispatch.Static
10−import Effectful.Internal.Monad
10+import Effectful.Monad
11
11
12-- | An effect for timing out computations.
12-- | An effect for timing out computations.
13data Timeout :: Effect where
13data Timeout :: Effect where
@@ -15,7 +15,7 @@ data Timeout :: Effect where
15
15
16-- | Run the 'Timeout' effect.
16-- | Run the 'Timeout' effect.
17runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a
17runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a
18−runTimeout = evalEffect (IdE Timeout)
18+runTimeout = evalData (DataA Timeout)
19
19
20-- | Lifted 'T.timeout'.
20-- | Lifted 'T.timeout'.
21timeout
21timeout
@@ -25,6 +25,4 @@ timeout
25 -> Eff es a
25 -> Eff es a
26 -- ^ The computation the timeout applies to.
26 -- ^ The computation the timeout applies to.
27 -> Eff es (Maybe a)
27 -> Eff es (Maybe a)
28−timeout n k = unsafeEff $ \es -> do
28+timeout = unsafeLiftMapIO . T.timeout
29− seqUnliftEff es $ \unlift -> do
30− T.timeout n $ unlift k
effectful/tests/EnvironmentTests.hs+11−6
@@ -9,12 +9,17 @@ import Effectful.Environment
9import qualified Utils as U
9import qualified Utils as U
10
10
11environmentTests :: TestTree
11environmentTests :: TestTree
12−environmentTests = testGroup "Environment"
12+environmentTests = testCaseSteps "Environment" $ \step -> do
13+ -- These tests need to be run sequentially because of
14+ -- https://github.com/arybczak/effectful/issues/39.
13− [ testCase "set and get an environment variable" test_setAndGet
15+ step "set and get an environment variable"
16+ test_setAndGet
14− , testCase "unset and try to get an environment variable" test_unsetAndGet
17+ step "unset and try to get an environment variable"
18+ test_unsetAndGet
15− , testCase "execute effects with custom arguments" test_withArgs
19+ step "execute effects with custom arguments"
20+ test_withArgs
16− , testCase "execute effects with custom program name" test_withProg
21+ step "execute effects with custom program name"
17− ]
22+ test_withProg
18
23
19test_setAndGet :: Assertion
24test_setAndGet :: Assertion
20test_setAndGet = runEff . runEnvironment $ do
25test_setAndGet = runEff . runEnvironment $ do
effectful/tests/UnliftTests.hs+28−35
@@ -1,7 +1,6 @@
1−{-# LANGUAGE OverloadedLabels #-}
2module UnliftTests (unliftTests) where
1module UnliftTests (unliftTests) where
3
2
4−import Optics.Core
3+import Control.Exception
5import Test.Tasty
4import Test.Tasty
6import Test.Tasty.HUnit
5import Test.Tasty.HUnit
7import qualified UnliftIO.Async as A
6import qualified UnliftIO.Async as A
@@ -34,43 +33,38 @@ test_resetStrategy = runEff $ do
34
33
35test_seqUnliftInNewThread :: Assertion
34test_seqUnliftInNewThread :: Assertion
36test_seqUnliftInNewThread = runEff $ do
35test_seqUnliftInNewThread = runEff $ do
37− assertThrowsUnliftError "InvalidUseOfSeqUnlift error"
36+ assertThrowsUnliftError "InvalidUseOfSeqUnlift error" $ do
38− (has #_InvalidUseOfSeqUnlift) $ do
39− withUnliftStrategy SeqUnlift $ do
37+ withUnliftStrategy SeqUnlift $ do
40− withEffToIO $ \runInIO -> do
38+ withEffToIO $ \runInIO -> do
41− inThread $ runInIO $ return ()
39+ inThread $ runInIO $ return ()
42
40
43test_ephemeralInvalid :: Assertion
41test_ephemeralInvalid :: Assertion
44test_ephemeralInvalid = runEff $ do
42test_ephemeralInvalid = runEff $ do
45− assertThrowsUnliftError "InvalidNumberOfUses error"
43+ assertThrowsUnliftError "InvalidNumberOfUses error" $ do
46− (has #_InvalidNumberOfUses) $ do
47− withUnliftStrategy (ConcUnlift Ephemeral $ Limited 0) $ do
44+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 0) $ do
48− withEffToIO $ \_ -> return ()
45+ withEffToIO $ \_ -> return ()
49
46
50test_ephemeralSameThread :: Assertion
47test_ephemeralSameThread :: Assertion
51test_ephemeralSameThread = runEff $ do
48test_ephemeralSameThread = runEff $ do
52− assertThrowsUnliftError "ExceededNumberOfUses error"
49+ assertThrowsUnliftError "ExceededNumberOfUses error" $ do
53− (has #_ExceededNumberOfUses) $ do
54− withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do
50+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do
55− withEffToIO $ \runInIO -> inThread $ do
51+ withEffToIO $ \runInIO -> inThread $ do
56− runInIO $ return ()
52+ runInIO $ return ()
57− runInIO $ return ()
53+ runInIO $ return ()
58
54
59test_ephemeralMultipleThreads :: Assertion
55test_ephemeralMultipleThreads :: Assertion
60test_ephemeralMultipleThreads = runEff $ do
56test_ephemeralMultipleThreads = runEff $ do
61− assertThrowsUnliftError "ExceededNumberOfUses error"
57+ assertThrowsUnliftError "ExceededNumberOfUses error" $ do
62− (has #_ExceededNumberOfUses) $ do
63− withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do
58+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do
64− withEffToIO $ \runInIO -> do
59+ withEffToIO $ \runInIO -> do
65− inThread $ runInIO $ return ()
60+ inThread $ runInIO $ return ()
66− inThread $ runInIO $ return ()
61+ inThread $ runInIO $ return ()
67
62
68test_persistentInvalid :: Assertion
63test_persistentInvalid :: Assertion
69test_persistentInvalid = runEff $ do
64test_persistentInvalid = runEff $ do
70− assertThrowsUnliftError "InvalidNumberOfThreads error"
65+ assertThrowsUnliftError "InvalidNumberOfThreads error" $ do
71− (has #_InvalidNumberOfThreads) $ do
72− withUnliftStrategy (ConcUnlift Persistent $ Limited 0) $ do
66+ withUnliftStrategy (ConcUnlift Persistent $ Limited 0) $ do
73− withEffToIO $ \_ -> return ()
67+ withEffToIO $ \_ -> return ()
74
68
75test_persistentSameThread :: Assertion
69test_persistentSameThread :: Assertion
76test_persistentSameThread = runEff $ do
70test_persistentSameThread = runEff $ do
@@ -81,20 +75,19 @@ test_persistentSameThread = runEff $ do
81
75
82test_persistentMultipleThreads :: Assertion
76test_persistentMultipleThreads :: Assertion
83test_persistentMultipleThreads = runEff $ do
77test_persistentMultipleThreads = runEff $ do
84− assertThrowsUnliftError "ExceededNumberOfThreads error"
78+ assertThrowsUnliftError "ExceededNumberOfThreads error" $ do
85− (has #_ExceededNumberOfThreads) $ do
86− withUnliftStrategy (ConcUnlift Persistent $ Limited 1) $ do
79+ withUnliftStrategy (ConcUnlift Persistent $ Limited 1) $ do
87− withEffToIO $ \runInIO -> do
80+ withEffToIO $ \runInIO -> do
88− inThread $ runInIO $ return ()
81+ inThread $ runInIO $ return ()
89− inThread $ runInIO $ return ()
82+ inThread $ runInIO $ return ()
90
83
91----------------------------------------
84----------------------------------------
92-- Helpers
85-- Helpers
93
86
94assertThrowsUnliftError
87assertThrowsUnliftError
95 :: IOE :> es
88 :: IOE :> es
96− => String -> (UnliftError -> Bool) -> Eff es a -> Eff es ()
89+ => String -> Eff es a -> Eff es ()
97−assertThrowsUnliftError = U.assertThrows
90+assertThrowsUnliftError err = U.assertThrows err (\ErrorCall{} -> True)
98
91
99inThread :: IO a -> IO a
92inThread :: IO a -> IO a
100inThread k = A.async k >>= A.wait
93inThread k = A.async k >>= A.wait