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−16
@@ -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,33 +61,42 @@ common language
60library
61library
61 import: language
62 import: language
62
63
63− build-depends: base >= 4.13 && <5
64+ build-depends: base >= 4.13 && < 5
64− , async
65+ , async >= 2.2.2
65− , directory
66+ , directory >= 1.3.2
66− , effectful-core >= 0.1 && <0.1.1
67+ , effectful-core >= 0.1 && < 0.1.1
67− , process
68+ , process >= 1.6.9
68− , resourcet
69+ , resourcet >= 1.2.4.3
69− , time
70+ , time >= 1.9.2
71+ , stm >= 2.5.0.0
70− , unliftio
72+ , unliftio >= 0.2.20
71
73
72 hs-source-dirs: src
74 hs-source-dirs: src
73
75
74− exposed-modules: Effectful
76+ exposed-modules: Effectful.Concurrent
75 Effectful.Concurrent.Async
77 Effectful.Concurrent.Async
76− Effectful.Concurrent.Base
78+ Effectful.Concurrent.Chan
79+ Effectful.Concurrent.MVar
80+ Effectful.Concurrent.STM
81+ Effectful.Concurrent.QSem
82+ Effectful.Concurrent.QSemN
77 Effectful.Environment
83 Effectful.Environment
78 Effectful.FileSystem
84 Effectful.FileSystem
85+ Effectful.FileSystem.IO
79 Effectful.Process
86 Effectful.Process
80 Effectful.Resource
87 Effectful.Resource
81 Effectful.Temporary
88 Effectful.Temporary
82 Effectful.Timeout
89 Effectful.Timeout
83
90
84− other-modules: Effectful.Concurrent.Internal
91+ other-modules: Effectful.Concurrent.Effect
92+ Effectful.FileSystem.Effect
85
93
86− reexported-modules: Effectful.Error
94+ reexported-modules: Effectful
95+ , Effectful.Dispatch.Dynamic
96+ , Effectful.Dispatch.Static
97+ , Effectful.Error
87 , Effectful.Error.Dynamic
98 , Effectful.Error.Dynamic
88 , Effectful.Fail
99 , Effectful.Fail
89− , Effectful.Handler
90 , Effectful.Monad
100 , Effectful.Monad
91 , Effectful.Prim
101 , Effectful.Prim
92 , Effectful.Reader
102 , Effectful.Reader
@@ -109,7 +119,6 @@ test-suite test
109 , effectful-core
119 , effectful-core
110 , exceptions
120 , exceptions
111 , lifted-base
121 , lifted-base
112− , optics-core >= 0.4
113 , tasty
122 , tasty
114 , tasty-hunit
123 , tasty-hunit
115 , unliftio
124 , unliftio
@@ -145,7 +154,7 @@ benchmark bench
145 if impl(ghc < 9.2)
154 if impl(ghc < 9.2)
146 build-depends: fused-effects
155 build-depends: fused-effects
147
156
148− if impl(ghc < 9.2)
157+ if impl(ghc < 9.3)
149 build-depends: polysemy
158 build-depends: polysemy
150
159
151 build-depends: base
160 build-depends: base
effectful/src/Effectful/Concurrent/Base.hs → effectful/src/Effectful/Concurrent.hsrenamed+19−7
@@ -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
@@ -51,10 +64,9 @@ import UnliftIO.STM (STM)
51import qualified Control.Concurrent as C
64import qualified Control.Concurrent as C
52import qualified GHC.Conc as GHC
65import qualified GHC.Conc as GHC
53
66
54−import Effectful.Concurrent.Internal
67+import Effectful.Concurrent.Effect
55−import Effectful.Internal.Effect
56−import Effectful.Internal.Env
68+import Effectful.Dispatch.Static
57−import Effectful.Internal.Monad
69+import Effectful.Monad
58
70
59----------------------------------------
71----------------------------------------
60-- Basic concurrency operations
72-- Basic concurrency operations
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