04aa70d...master · effectful

.github/workflows/haskell-ci.yml+26−39

since splitsnapshots

unifiedsplit

@@ -8,9 +8,9 @@

8#

9# For more information, see https://github.com/haskell-CI/haskell-ci

10#

11−# version: 0.13.20210912

11+# version: 0.13.20211116

12#

13−# REGENDATA ("0.13.20210912",["github","--config=cabal.haskell-ci","cabal.project"])

13+# REGENDATA ("0.13.20211116",["github","--config=cabal.haskell-ci","cabal.project"])

14#

15name: Haskell-CI

16on:

@@ -24,21 +24,18 @@ jobs:

24 linux:

25 name: Haskell-CI - Linux - ${{ matrix.compiler }}

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 }}

30 strategy:

32 strategy:

31 matrix:

33 matrix:

32 include:

34 include:

33− - compiler: ghc-9.2.0.20210821

35+ - compiler: ghc-9.2.1

34 compilerKind: ghc

36 compilerKind: ghc

35− compilerVersion: 9.2.0.20210821

37+ compilerVersion: 9.2.1

36 setup-method: ghcup

38 setup-method: ghcup

37− allow-failure: true

38− - compiler: ghc-9.0.1

39− compilerKind: ghc

40− compilerVersion: 9.0.1

41− setup-method: hvr-ppa

42 allow-failure: false

39 allow-failure: false

43 - compiler: ghc-8.10.7

40 - compiler: ghc-8.10.7

44 compilerKind: ghc

41 compilerKind: ghc

@@ -58,18 +55,18 @@ jobs:

58 apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5

55 apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5

59 if [ "${{ matrix.setup-method }}" = ghcup ]; then

56 if [ "${{ matrix.setup-method }}" = ghcup ]; then

60 mkdir -p "$HOME/.ghcup/bin"

57 mkdir -p "$HOME/.ghcup/bin"

61− curl -sL https://downloads.haskell.org/ghcup/0.1.16.2/x86_64-linux-ghcup-0.1.16.2 > "$HOME/.ghcup/bin/ghcup"

58+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"

62 chmod a+x "$HOME/.ghcup/bin/ghcup"

59 chmod a+x "$HOME/.ghcup/bin/ghcup"

63 "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"

60 "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"

64− "$HOME/.ghcup/bin/ghcup" install cabal 3.6.0.0

61+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0

65 else

62 else

66 apt-add-repository -y 'ppa:hvr/ghc'

63 apt-add-repository -y 'ppa:hvr/ghc'

67 apt-get update

64 apt-get update

68 apt-get install -y "$HCNAME"

65 apt-get install -y "$HCNAME"

69 mkdir -p "$HOME/.ghcup/bin"

66 mkdir -p "$HOME/.ghcup/bin"

70− curl -sL https://downloads.haskell.org/ghcup/0.1.16.2/x86_64-linux-ghcup-0.1.16.2 > "$HOME/.ghcup/bin/ghcup"

67+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"

71 chmod a+x "$HOME/.ghcup/bin/ghcup"

68 chmod a+x "$HOME/.ghcup/bin/ghcup"

72− "$HOME/.ghcup/bin/ghcup" install cabal 3.6.0.0

69+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0

73 fi

70 fi

74 env:

71 env:

75 HCKIND: ${{ matrix.compilerKind }}

72 HCKIND: ${{ matrix.compilerKind }}

@@ -87,20 +84,20 @@ jobs:

87 echo "HC=$HC" >> "$GITHUB_ENV"

84 echo "HC=$HC" >> "$GITHUB_ENV"

88 echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"

85 echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"

89 echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"

86 echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"

90− echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.0.0 -vnormal+nowrap" >> "$GITHUB_ENV"

87+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"

91 else

88 else

92 HC=$HCDIR/bin/$HCKIND

89 HC=$HCDIR/bin/$HCKIND

93 echo "HC=$HC" >> "$GITHUB_ENV"

90 echo "HC=$HC" >> "$GITHUB_ENV"

94 echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"

91 echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"

95 echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"

92 echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"

96− echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.0.0 -vnormal+nowrap" >> "$GITHUB_ENV"

93+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"

97 fi

94 fi

98

95

99 HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')

96 HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')

100 echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"

97 echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"

101 echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"

98 echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"

102 echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"

99 echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"

103− if [ $((HCNUMVER >= 90200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi

100+ echo "HEADHACKAGE=false" >> "$GITHUB_ENV"

104 echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"

101 echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"

105 echo "GHCJSARITH=0" >> "$GITHUB_ENV"

102 echo "GHCJSARITH=0" >> "$GITHUB_ENV"

106 env:

103 env:

@@ -129,17 +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

132− if $HEADHACKAGE; then

133 cat >> $CABAL_CONFIG <<EOF

129 cat >> $CABAL_CONFIG <<EOF

134− repository head.hackage.ghc.haskell.org

130+ program-default-options

135− url: https://ghc.gitlab.haskell.org/head.hackage/

131+ ghc-options: $GHCJOBS +RTS -M3G -RTS

136− secure: True

137− root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d

138− 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329

139− f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89

140− key-threshold: 3

141 EOF

132 EOF

142− fi

143 cat $CABAL_CONFIG

133 cat $CABAL_CONFIG

144 - name: versions

134 - name: versions

145 run: |

135 run: |

@@ -152,7 +142,7 @@ jobs:

152 - name: cache (tools)

142 - name: cache (tools)

153 uses: actions/cache@v2

143 uses: actions/cache@v2

154 with:

144 with:

155− key: ${{ runner.os }}-${{ matrix.compiler }}-tools-b692a344

145+ key: ${{ runner.os }}-${{ matrix.compiler }}-tools-16fe7d6d

156 path: ~/.haskell-ci-tools

146 path: ~/.haskell-ci-tools

157 - name: install cabal-plan

147 - name: install cabal-plan

158 run: |

148 run: |

@@ -165,8 +155,8 @@ jobs:

165 cabal-plan --version

155 cabal-plan --version

166 - name: install doctest

156 - name: install doctest

167 run: |

157 run: |

168− 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'

169− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest --version ; fi

159+ doctest --version

170 - name: checkout

160 - name: checkout

171 uses: actions/checkout@v2

161 uses: actions/checkout@v2

172 with:

162 with:

@@ -174,8 +164,8 @@ jobs:

174 - name: initial cabal.project for sdist

164 - name: initial cabal.project for sdist

175 run: |

165 run: |

176 touch cabal.project

166 touch cabal.project

177− echo "packages: $GITHUB_WORKSPACE/source/./effectful" >> cabal.project

167+ echo "packages: $GITHUB_WORKSPACE/source/effectful" >> cabal.project

178− echo "packages: $GITHUB_WORKSPACE/source/./effectful-core" >> cabal.project

168+ echo "packages: $GITHUB_WORKSPACE/source/effectful-core" >> cabal.project

179 cat cabal.project

169 cat cabal.project

180 - name: sdist

170 - name: sdist

181 run: |

171 run: |

@@ -204,9 +194,6 @@ jobs:

204 package effectful

194 package effectful

205 flags: +benchmark-foreign-libraries

195 flags: +benchmark-foreign-libraries

206 EOF

196 EOF

207− if $HEADHACKAGE; then

208− echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project

209− fi

210 $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(effectful|effectful-core)$/; }' >> cabal.project.local

197 $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(effectful|effectful-core)$/; }' >> cabal.project.local

211 cat cabal.project

198 cat cabal.project

212 cat cabal.project.local

199 cat cabal.project.local

@@ -235,12 +222,12 @@ jobs:

235 $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

236 - name: doctest

223 - name: doctest

237 run: |

224 run: |

238− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful} || false ; fi

225+ cd ${PKGDIR_effectful} || false

239− 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

240− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful_core} || false ; fi

227+ cd ${PKGDIR_effectful_core} || false

241− 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

242− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful_core} || false ; fi

229+ cd ${PKGDIR_effectful_core} || false

243− 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

244 - name: cabal check

231 - name: cabal check

245 run: |

232 run: |

246 cd ${PKGDIR_effectful} || false

233 cd ${PKGDIR_effectful} || false

README.md+2−2

@@ -20,8 +20,8 @@ Main features:

20

212. Easy to use API (no boilerplate code and dealing with arcane types).

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

264. Seamless integration with the existing ecosystem (`exceptions`,

27 `monad-control`, `unliftio-core`, `resourcet` etc.).

cabal.haskell-ci+1−3

@@ -1,11 +1,9 @@

1branches: master

2

3−doctest: <9.2

3+doctest: <9.3

4tests: True

5benchmarks: True

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 \

18 -XDataKinds \

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

41+run_doctest effectful src

effectful-core/effectful-core.cabal+17−14

@@ -13,13 +13,12 @@ description: An easy to use, performant extensible effects library with seamless

13 integration with the existing Haskell ecosystem.

14 .

15 This library provides core definitions with a minimal dependency

16− footprint. See the @<https://hackage.haskell.org/package/effectful

16+ footprint. See the @<https://hackage.haskell.org/package/effectful effectful>@

17− effectful>@ package for documentation and the "batteries-included"

17+ package for documentation and the "batteries-included" variant.

18− variant.

19

18

20extra-source-files: CHANGELOG.md

19extra-source-files: CHANGELOG.md

21

20

22−tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.0.20210821

21+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1

23

22

24bug-reports: https://github.com/arybczak/effectful/issues

23bug-reports: https://github.com/arybczak/effectful/issues

25source-repository head

24source-repository head

@@ -35,6 +34,7 @@ common language

35 ConstraintKinds

34 ConstraintKinds

36 DataKinds

35 DataKinds

37 DeriveFunctor

36 DeriveFunctor

37+ DeriveGeneric

38 FlexibleContexts

39 FlexibleInstances

40 GADTs

@@ -67,21 +67,24 @@ library

67

68 ghc-options: -O2

69

70− build-depends: base >= 4.13 && <5

70+ build-depends: effectful-internal-utils

71+

72+ build-depends: base >= 4.13 && < 5

71− , containers

73+ , containers >= 0.6

72− , effectful-internal-utils

73− , exceptions

74+ , exceptions >= 0.10.4

74− , monad-control

75+ , monad-control >= 1.0.3

75− , primitive

76+ , primitive >= 0.7.3.0

76− , transformers-base

77+ , transformers-base >= 0.4.6

77− , unliftio-core

78+ , unliftio-core >= 0.2.0.1

78

79

79 hs-source-dirs: src

80 hs-source-dirs: src

80

81

81− exposed-modules: Effectful.Error

82+ exposed-modules: Effectful

83+ Effectful.Dispatch.Dynamic

84+ Effectful.Dispatch.Static

85+ Effectful.Error

82 Effectful.Error.Dynamic

86 Effectful.Error.Dynamic

83 Effectful.Fail

87 Effectful.Fail

84− Effectful.Handler

85 Effectful.Internal.Effect

88 Effectful.Internal.Effect

86 Effectful.Internal.Env

89 Effectful.Internal.Env

87 Effectful.Internal.Monad

90 Effectful.Internal.Monad

effectful/src/Effectful.hs → effectful-core/src/Effectful.hsrenamed+4−4

@@ -8,10 +8,10 @@ module Effectful

8

9 -- * Running the 'Eff' monad

10

11− -- ** Pure operations

11+ -- ** Pure computations

12 , runPureEff

13

14− -- ** Operations with side effects

14+ -- ** Computations with side effects

15 , IOE

16 , runEff

17

@@ -32,7 +32,7 @@ module Effectful

32 , interpret

33 , reinterpret

34

35− -- ** Handling local 'Eff' operations

35+ -- ** Handling local 'Eff' computations

36 , LocalEnv

37

38 -- *** Unlifts

@@ -54,5 +54,5 @@ module Effectful

54 , MonadUnliftIO(..)

55 ) where

56

57−import Effectful.Handler

57+import Effectful.Dispatch.Dynamic

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

3 send

4

@@ -7,7 +7,7 @@ module Effectful.Handler

7 , interpret

8 , reinterpret

9

10− -- ** Handling local 'Eff' operations

10+ -- ** Handling local 'Eff' computations

11 , LocalEnv

12

13 -- *** Unlifts

@@ -32,7 +32,8 @@ module Effectful.Handler

32 ) where

33

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

9import Data.Typeable

10

11−import Effectful.Handler

11+import Effectful.Dispatch.Dynamic

12import Effectful.Monad

13import qualified Effectful.Error as E

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

9 ( Effect

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+134−201

@@ -6,7 +6,7 @@

6-- This module is intended for internal use only, and may change without warning

7-- in subsequent releases.

8module Effectful.Internal.Monad

9− ( -- * Monad

9+ ( -- * The 'Eff' monad

10 Eff

11 , runPureEff

12

@@ -22,11 +22,11 @@ module Effectful.Internal.Monad

22 , IOE

23 , runEff

24

25− -- * Primitive

25+ -- * Prim

26 , Prim

27 , runPrim

28

29− -- ** Unlift strategies

29+ -- * Unlift strategies

30 , UnliftStrategy(..)

31 , Persistence(..)

32 , Limit(..)

@@ -34,39 +34,32 @@ module Effectful.Internal.Monad

34 , withUnliftStrategy

35 , withEffToIO

36

37− --- *** Low-level helpers

37+ -- ** Low-level unlifts

38− , unsafeLiftMapIO

38+ , seqUnliftIO

39− , seqUnliftEff

39+ , concUnliftIO

40− , concUnliftEff

41

40

42 -- * Effects

41 -- * Effects

43

42

44− -- ** Handler

43+ -- ** Dynamic dispatch

45 , EffectHandler

44 , EffectHandler

46 , LocalEnv(..)

45 , LocalEnv(..)

47− , Handler(..)

46+ , HandlerA(..)

48 , runHandler

47 , runHandler

49−

50− -- *** Sending operations

51 , send

48 , send

52

49

53− -- ** Primitive

50+ -- ** Static dispatch

54−

51+ , DataA(..)

55− -- *** Running

52+ , runData

56− , runEffect

53+ , evalData

57− , evalEffect

54+ , execData

58− , execEffect

55+ , getData

59−

56+ , putData

60− -- *** Modification

57+ , stateData

61− , getEffect

58+ , stateDataM

62− , putEffect

59+ , localData

63− , stateEffect

64− , stateEffectM

65− , localEffect

66 ) where

60 ) where

67

61

68import Control.Applicative (liftA2)

62import Control.Applicative (liftA2)

69−import Control.Concurrent (myThreadId)

70import Control.Monad.Base

63import Control.Monad.Base

71import Control.Monad.Fix

64import Control.Monad.Fix

72import Control.Monad.IO.Class

65import Control.Monad.IO.Class

@@ -83,48 +76,46 @@ import qualified Control.Monad.Catch as C

83import Effectful.Internal.Effect

76import Effectful.Internal.Effect

84import Effectful.Internal.Env

77import Effectful.Internal.Env

85import Effectful.Internal.Unlift

78import Effectful.Internal.Unlift

86−import Effectful.Internal.Utils

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,67 +128,68 @@ 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

142+----------------------------------------

152−--

143+-- Unlifting IO

153−-- @'IO' a -> 'IO' b@

144+

154−--

145+-- | Get the current 'UnliftStrategy'.

155−-- to

146+unliftStrategy :: IOE :> es => Eff es UnliftStrategy

156−--

147+unliftStrategy = do

157−-- @'Eff' es a -> 'Eff' es b@

148+ DataA (IOE unlift) <- getData

158−--

149+ pure unlift

159−-- This function is __unsafe__ because:

150+

151+-- | Locally override the 'UnliftStrategy' with the given value.

152+withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a

153+withUnliftStrategy unlift = localData $ \_ -> DataA (IOE unlift)

154+

155+-- | Create an unlifting function with the current 'UnliftStrategy'.

160--

156--

161−-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'

157+-- This function is equivalent to 'withRunInIO', but has a 'HasCallStack'

162−-- operations.

158+-- constraint for accurate stack traces in case an insufficiently powerful

159+-- 'UnliftStrategy' is used and the unlifting function fails.

163--

160--

164−-- - The 'IO' operation must not run its argument in a separate thread, but it's

161+-- /Note:/ the strategy is reset to 'SeqUnlift' inside the continuation.

165−-- not checked anywhere.

162+withEffToIO

166−unsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b

163+ :: (HasCallStack, IOE :> es)

167−unsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)

164+ => ((forall r. Eff es r -> IO r) -> IO a)

165+ -- ^ Continuation with the unlifting function in scope.

166+ -> Eff es a

167+withEffToIO f = unliftStrategy >>= \case

168+ SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f

169+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do

170+ unsafeEff $ \es -> concUnliftIO es p b f

168

171

169−-- | Lower 'Eff' operations into 'IO' ('SeqUnlift').

172+-- | Create an unlifting function with the 'SeqUnlift' strategy.

170−seqUnliftEff

173+seqUnliftIO

171 :: HasCallStack

174 :: HasCallStack

172 => Env es

175 => Env es

176+ -- ^ The environment.

173 -> ((forall r. Eff es r -> IO r) -> IO a)

177 -> ((forall r. Eff es r -> IO r) -> IO a)

178+ -- ^ Continuation with the unlifting function in scope.

174 -> IO a

179 -> IO a

175−seqUnliftEff es k = do

180+seqUnliftIO es k = seqUnlift k es unEff

176− tid0 <- myThreadId

181+

177− k $ \m -> do

182+-- | Create an unlifting function with the 'ConcUnlift' strategy.

178− tid <- myThreadId

183+concUnliftIO

179− if tid `eqThreadId` tid0

180− then unEff m es

181− else error

182− $ "If you want to use the unlifting function to run Eff operations "

183− ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)."

184−

185−-- | Lower 'Eff' operations into 'IO' ('ConcUnlift').

186−concUnliftEff

187 :: HasCallStack

184 :: HasCallStack

188 => Env es

185 => Env es

186+ -- ^ The environment.

189 -> Persistence

187 -> Persistence

190 -> Limit

188 -> Limit

191 -> ((forall r. Eff es r -> IO r) -> IO a)

189 -> ((forall r. Eff es r -> IO r) -> IO a)

190+ -- ^ Continuation with the unlifting function in scope.

192 -> IO a

191 -> IO a

193−concUnliftEff es Ephemeral (Limited uses) k =

192+concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff

194− ephemeralConcUnliftIO uses k es unEff

195−concUnliftEff es Ephemeral Unlimited k =

196− ephemeralConcUnliftIO maxBound k es unEff

197−concUnliftEff es Persistent (Limited threads) k =

198− persistentConcUnliftIO False threads k es unEff

199−concUnliftEff es Persistent Unlimited k =

200− persistentConcUnliftIO True maxBound k es unEff

201

193

202----------------------------------------

194----------------------------------------

203-- Base

195-- Base

@@ -266,15 +258,15 @@ instance Fail :> es => MonadFail (Eff es) where

266----------------------------------------

258----------------------------------------

267-- IO

259-- IO

268

260

269−-- | Run arbitrary 'IO' operations via 'MonadIO' or 'MonadUnliftIO'.

261+-- | Run arbitrary 'IO' computations via 'MonadIO' or 'MonadUnliftIO'.

270newtype IOE :: Effect where

262newtype IOE :: Effect where

271 IOE :: UnliftStrategy -> IOE m r

263 IOE :: UnliftStrategy -> IOE m r

272

264

273−-- | Run an 'Eff' operation with side effects.

265+-- | Run an 'Eff' computation with side effects.

274--

266--

275−-- For running pure operations see 'runPureEff'.

267+-- For running pure computations see 'runPureEff'.

276runEff :: Eff '[IOE] a -> IO a

268runEff :: Eff '[IOE] a -> IO a

277−runEff m = unEff (evalEffect (IdE (IOE SeqUnlift)) m) =<< emptyEnv

269+runEff m = unEff (evalData (DataA (IOE SeqUnlift)) m) =<< emptyEnv

278

270

279instance IOE :> es => MonadIO (Eff es) where

271instance IOE :> es => MonadIO (Eff es) where

280 liftIO = unsafeEff_

272 liftIO = unsafeEff_

@@ -298,102 +290,22 @@ instance IOE :> es => MonadBaseControl IO (Eff es) where

298----------------------------------------

290----------------------------------------

299-- Primitive

291-- Primitive

300

292

301−-- | An effect to perform primitive state-transformer actions.

293+-- | Provide the ability to perform primitive state-transformer actions.

302data Prim :: Effect where

294data Prim :: Effect where

303 Prim :: Prim m r

295 Prim :: Prim m r

304

296

305−-- | Run an 'Eff' operation with primitive state-transformer actions.

297+-- | Run an 'Eff' computation with primitive state-transformer actions.

306runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a

298runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a

307−runPrim = evalEffect (IdE Prim)

299+runPrim = evalData (DataA Prim)

308

300

309instance Prim :> es => PrimMonad (Eff es) where

301instance Prim :> es => PrimMonad (Eff es) where

310 type PrimState (Eff es) = RealWorld

302 type PrimState (Eff es) = RealWorld

311 primitive = unsafeEff_ . IO

303 primitive = unsafeEff_ . IO

312

304

313----------------------------------------

305----------------------------------------

314−-- Unlift strategies

306+-- Dynamic dispatch

315−

316−-- | The strategy to use when unlifting 'Eff' operations via 'withRunInIO' or

317−-- the 'Effectful.Interpreter.localUnlift' family.

318−data UnliftStrategy

319− = SeqUnlift

320− -- ^ The fastest strategy and a default setting for 'IOE'. An attempt to call

321− -- the unlifting function in threads distinct from its creator will result in

322− -- a runtime error.

323− | ConcUnlift !Persistence !Limit

324− -- ^ A strategy that makes it possible for the unlifting function to be called

325− -- in threads distinct from its creator. See 'Persistence' and 'Limit'

326− -- settings for more information.

327− deriving (Eq, Ord, Show)

328−

329−-- | Persistence setting for the 'ConcUnlift' strategy.

330−--

331−-- Different functions require different persistence strategies. Examples:

332−--

333−-- - Lifting 'pooledMapConcurrentlyN' from the @unliftio@ library requires the

334−-- 'Ephemeral' strategy as we don't want jobs to share environment changes

335−-- made by previous jobs run in the same worker thread.

336−--

337−-- - Lifting 'Control.Concurrent.forkIOWithUnmask' requires the 'Persistent'

338−-- strategy, otherwise the unmasking function would start with a fresh

339−-- environment each time it's called.

340−data Persistence

341− = Ephemeral

342− -- ^ Don't persist the environment between calls to the unlifting function in

343− -- threads distinct from its creator.

344− | Persistent

345− -- ^ Persist the environment between calls to the unlifting function within a

346− -- particular thread.

347− deriving (Eq, Ord, Show)

348−

349−-- | Limit setting for the 'ConcUnlift' strategy.

350−data Limit

351− = Limited !Int

352− -- ^ Behavior dependent on the 'Persistence' setting.

353− --

354− -- For 'Ephemeral', it limits the amount of uses of the unlifting function in

355− -- threads distinct from its creator to @N@. The unlifting function will

356− -- create @N@ copies of the environment when called @N@ times and @K+1@ copies

357− -- when called @K < N@ times.

358− --

359− -- For 'Persistent', it limits the amount of threads, distinct from the

360− -- creator of the unlifting function, it can be called in to @N@. The amount

361− -- of calls to the unlifting function within a particular threads is

362− -- unlimited. The unlifting function will create @N@ copies of the environment

363− -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads.

364− | Unlimited

365− -- ^ Unlimited use of the unlifting function.

366− deriving (Eq, Ord, Show)

367−

368−-- | Get the current 'UnliftStrategy'.

369−unliftStrategy :: IOE :> es => Eff es UnliftStrategy

370−unliftStrategy = do

371− IdE (IOE unlift) <- getEffect

372− pure unlift

373−

374−-- | Locally override the 'UnliftStrategy' with the given value.

375−--

376−-- /Note:/ the strategy is reset to 'SeqUnlift' for new threads.

377−withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a

378−withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift)

379−

380−-- | Create an unlifting function with the current 'UnliftStrategy'.

381−--

382−-- This function is equivalent to 'withRunInIO', but has a 'HasCallStack'

383−-- constraint for accurate stack traces in case an insufficiently powerful

384−-- 'UnliftStrategy' is used and the unlifting function fails.

385−withEffToIO

386− :: (HasCallStack, IOE :> es)

387− => ((forall r. Eff es r -> IO r) -> IO a)

388− -- ^ Continuation with the unlifting function in scope.

389− -> Eff es a

390−withEffToIO f = unliftStrategy >>= \case

391− SeqUnlift -> unsafeEff $ \es -> seqUnliftEff es f

392− ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do

393− unsafeEff $ \es -> concUnliftEff es p b f

394

307

395−----------------------------------------

308+type role LocalEnv nominal nominal

396−-- Handler

397

309

398-- | Opaque representation of the 'Eff' environment at the point of calling the

310-- | Opaque representation of the 'Eff' environment at the point of calling the

399-- 'send' function, i.e. right before the control is passed to the effect

311-- 'send' function, i.e. right before the control is passed to the effect

@@ -407,76 +319,97 @@ newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env l

407type EffectHandler e es

319type EffectHandler e es

408 = forall a localEs. HasCallStack

320 = forall a localEs. HasCallStack

409 => LocalEnv localEs es

321 => LocalEnv localEs es

410− -- ^ Capture of the local environment for handling local 'Eff' operations when

322+ -- ^ Capture of the local environment for handling local 'Eff' computations

411− -- @e@ is a higher order effect.

323+ -- when @e@ is a higher order effect.

412 -> e (Eff localEs) a

324 -> e (Eff localEs) a

413 -- ^ The effect performed in the local environment.

325 -- ^ The effect performed in the local environment.

414 -> Eff es a

326 -> Eff es a

415

327

416−-- | An effect handler bundled along with its environment.

328+-- | An adapter for dynamically dispatched effects.

417−data Handler :: Effect -> Type where

329+--

418− Handler :: !(Env es) -> !(EffectHandler e es) -> Handler e

330+-- Represents the effect handler bundled with its environment.

331+data HandlerA :: Effect -> Type where

332+ HandlerA :: !(Env es) -> !(EffectHandler e es) -> HandlerA e

419

333

420−-- | Run the effect with the given handler.

334+-- | Run a dynamically dispatched effect with the given handler.

421−runHandler :: Handler e -> Eff (e : es) a -> Eff es a

335+runHandler :: HandlerA e -> Eff (e : es) a -> Eff es a

422runHandler e m = unsafeEff $ \es0 -> do

336runHandler e m = unsafeEff $ \es0 -> do

423 size0 <- sizeEnv es0

337 size0 <- sizeEnv es0

424 E.bracket (unsafeConsEnv e relinker es0)

338 E.bracket (unsafeConsEnv e relinker es0)

425 (unsafeTailEnv size0)

339 (unsafeTailEnv size0)

426 (\es -> unEff m es)

340 (\es -> unEff m es)

427 where

341 where

428− relinker :: Relinker Handler e

342+ relinker :: Relinker HandlerA e

429− relinker = Relinker $ \relink (Handler env handle) -> do

343+ relinker = Relinker $ \relink (HandlerA handlerEs handle) -> do

430− newEnv <- relink env

344+ newHandlerEs <- relink handlerEs

431− pure $ Handler newEnv handle

345+ pure $ HandlerA newHandlerEs handle

432

346

433-- | 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.

434send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a

348send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a

435send op = unsafeEff $ \es -> do

349send op = unsafeEff $ \es -> do

436− Handler env handle <- getEnv es

350+ HandlerA handlerEs handle <- getEnv es

437− unEff (handle (LocalEnv es) op) env

351+ unEff (handle (LocalEnv es) op) handlerEs

438

352

439----------------------------------------

353----------------------------------------

440−-- Helpers

354+-- Static dispatch

441

355

442−runEffect :: handler e -> Eff (e : es) a -> Eff es (a, handler e)

356+-- | An adapter for statically dispatched effects.

443−runEffect e0 m = unsafeEff $ \es0 -> do

357+--

358+-- Represents an arbitrary data type with the appropriate number of phantom type

359+-- parameters.

360+newtype DataA :: Effect -> Type where

361+ DataA :: (forall m r. e m r) -> DataA e

362+

363+-- | Run a statically dispatched effect with the given initial state and return

364+-- the final value along with the final state.

365+runData :: DataA e -> Eff (e : es) a -> Eff es (a, DataA e)

366+runData e0 m = unsafeEff $ \es0 -> do

444 size0 <- sizeEnv es0

367 size0 <- sizeEnv es0

445 E.bracket (unsafeConsEnv e0 noRelinker es0)

368 E.bracket (unsafeConsEnv e0 noRelinker es0)

446 (unsafeTailEnv size0)

369 (unsafeTailEnv size0)

447 (\es -> (,) <$> unEff m es <*> getEnv es)

370 (\es -> (,) <$> unEff m es <*> getEnv es)

448

371

449−evalEffect :: handler e -> Eff (e : es) a -> Eff es a

372+-- | Run a statically dispatched effect with the given initial state and return

450−evalEffect e m = unsafeEff $ \es0 -> do

373+-- the final value, discarding the final state.

374+evalData :: DataA e -> Eff (e : es) a -> Eff es a

375+evalData e m = unsafeEff $ \es0 -> do

451 size0 <- sizeEnv es0

376 size0 <- sizeEnv es0

452 E.bracket (unsafeConsEnv e noRelinker es0)

377 E.bracket (unsafeConsEnv e noRelinker es0)

453 (unsafeTailEnv size0)

378 (unsafeTailEnv size0)

454 (\es -> unEff m es)

379 (\es -> unEff m es)

455

380

456−execEffect :: handler e -> Eff (e : es) a -> Eff es (handler e)

381+-- | Run a statically dispatched effect with the given initial state and return

457−execEffect e0 m = unsafeEff $ \es0 -> do

382+-- the final state, discarding the final value.

383+execData :: DataA e -> Eff (e : es) a -> Eff es (DataA e)

384+execData e0 m = unsafeEff $ \es0 -> do

458 size0 <- sizeEnv es0

385 size0 <- sizeEnv es0

459 E.bracket (unsafeConsEnv e0 noRelinker es0)

386 E.bracket (unsafeConsEnv e0 noRelinker es0)

460 (unsafeTailEnv size0)

387 (unsafeTailEnv size0)

461 (\es -> unEff m es *> getEnv es)

388 (\es -> unEff m es *> getEnv es)

462

389

463−getEffect :: e :> es => Eff es (handler e)

390+-- | Fetch the current state of the effect.

464−getEffect = unsafeEff $ \es -> getEnv es

391+getData :: e :> es => Eff es (DataA e)

392+getData = unsafeEff $ \es -> getEnv es

465

393

466−putEffect :: e :> es => handler e -> Eff es ()

394+-- | Set the current state of the effect to the given value.

467−putEffect e = unsafeEff $ \es -> putEnv es e

395+putData :: e :> es => DataA e -> Eff es ()

396+putData e = unsafeEff $ \es -> putEnv es e

468

397

469−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.

470−stateEffect f = unsafeEff $ \es -> stateEnv es f

399+stateData :: e :> es => (DataA e -> (a, DataA e)) -> Eff es a

400+stateData f = unsafeEff $ \es -> stateEnv es f

471

401

472−stateEffectM :: e :> es => (handler e -> Eff es (a, handler e)) -> Eff es a

402+-- | Apply the monadic function to the current state of the effect and return a

473−stateEffectM f = unsafeEff $ \es -> E.mask $ \release -> do

403+-- value.

404+stateDataM :: e :> es => (DataA e -> Eff es (a, DataA e)) -> Eff es a

405+stateDataM f = unsafeEff $ \es -> E.mask $ \release -> do

474 (a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es

406 (a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es

475 putEnv es e

407 putEnv es e

476 pure a

408 pure a

477

409

478−localEffect :: e :> es => (handler e -> handler e) -> Eff es a -> Eff es a

410+-- | Execute a computation with a temporarily modified state of the effect.

479−localEffect f m = unsafeEff $ \es -> do

411+localData :: e :> es => (DataA e -> DataA e) -> Eff es a -> Eff es a

412+localData f m = unsafeEff $ \es -> do

480 E.bracket (stateEnv es $ \e -> (e, f e))

413 E.bracket (stateEnv es $ \e -> (e, f e))

481 (\e -> putEnv es e)

414 (\e -> putEnv es e)

482 (\_ -> unEff m es)

415 (\_ -> unEff m es)

effectful-core/src/Effectful/Internal/Unlift.hs+115−10

@@ -1,19 +1,28 @@

1{-# LANGUAGE MagicHash #-}

2{-# LANGUAGE UnboxedTuples #-}

3{-# OPTIONS_HADDOCK not-home #-}

4−-- | Implementation of concurrent unlifts.

4+-- | Implementation of sequential and concurrent unlifts.

5--

6-- This module is intended for internal use only, and may change without warning

7-- in subsequent releases.

8module Effectful.Internal.Unlift

9− ( ephemeralConcUnliftIO

9+ ( -- * Unlifting strategies

10− , persistentConcUnliftIO

10+ UnliftStrategy(..)

11+ , Persistence(..)

12+ , Limit(..)

13+

14+ -- * Unlifting functions

15+ , seqUnlift

16+ , concUnlift

17+ , ephemeralConcUnlift

18+ , persistentConcUnlift

11 ) where

19 ) where

12

20

13import Control.Concurrent

21import Control.Concurrent

14import Control.Monad

22import Control.Monad

15import GHC.Conc.Sync (ThreadId(..))

23import GHC.Conc.Sync (ThreadId(..))

16import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)

24import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)

25+import GHC.Generics (Generic)

17import GHC.IO (IO(..))

26import GHC.IO (IO(..))

18import GHC.Stack (HasCallStack)

27import GHC.Stack (HasCallStack)

19import GHC.Weak (Weak(..))

28import GHC.Weak (Weak(..))

@@ -23,16 +32,111 @@ import qualified Data.IntMap.Strict as IM

23import Effectful.Internal.Env

32import Effectful.Internal.Env

24import Effectful.Internal.Utils

33import Effectful.Internal.Utils

25

34

35+----------------------------------------

36+-- Unlift strategies

37+

38+-- | The strategy to use when unlifting 'Eff' computations via 'withRunInIO',

39+-- 'Effectful.Monad.withEffToIO' or the 'Effectful.Dispatch.Dynamic.localUnlift'

40+-- family.

41+data UnliftStrategy

42+ = SeqUnlift

43+ -- ^ The fastest strategy and a default setting for 'IOE'. An attempt to call

44+ -- the unlifting function in threads distinct from its creator will result in

45+ -- a runtime error.

46+ | ConcUnlift !Persistence !Limit

47+ -- ^ A strategy that makes it possible for the unlifting function to be called

48+ -- in threads distinct from its creator. See 'Persistence' and 'Limit'

49+ -- settings for more information.

50+ deriving (Eq, Generic, Ord, Show)

51+

52+-- | Persistence setting for the 'ConcUnlift' strategy.

53+--

54+-- Different functions require different persistence strategies. Examples:

55+--

56+-- - Lifting 'pooledMapConcurrentlyN' from the @unliftio@ library requires the

57+-- 'Ephemeral' strategy as we don't want jobs to share environment changes

58+-- made by previous jobs run in the same worker thread.

59+--

60+-- - Lifting 'Control.Concurrent.forkIOWithUnmask' requires the 'Persistent'

61+-- strategy, otherwise the unmasking function would start with a fresh

62+-- environment each time it's called.

63+data Persistence

64+ = Ephemeral

65+ -- ^ Don't persist the environment between calls to the unlifting function in

66+ -- threads distinct from its creator.

67+ | Persistent

68+ -- ^ Persist the environment between calls to the unlifting function within a

69+ -- particular thread.

70+ deriving (Eq, Generic, Ord, Show)

71+

72+-- | Limit setting for the 'ConcUnlift' strategy.

73+data Limit

74+ = Limited !Int

75+ -- ^ Behavior dependent on the 'Persistence' setting.

76+ --

77+ -- For 'Ephemeral', it limits the amount of uses of the unlifting function in

78+ -- threads distinct from its creator to @N@. The unlifting function will

79+ -- create @N@ copies of the environment when called @N@ times and @K+1@ copies

80+ -- when called @K < N@ times.

81+ --

82+ -- For 'Persistent', it limits the amount of threads, distinct from the

83+ -- creator of the unlifting function, it can be called in to @N@. The amount

84+ -- of calls to the unlifting function within a particular threads is

85+ -- unlimited. The unlifting function will create @N@ copies of the environment

86+ -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads.

87+ | Unlimited

88+ -- ^ Unlimited use of the unlifting function.

89+ deriving (Eq, Generic, Ord, Show)

90+

91+----------------------------------------

92+-- Unlift functions

93+

94+-- | Sequential unlift.

95+seqUnlift

96+ :: HasCallStack

97+ => ((forall r. m r -> IO r) -> IO a)

98+ -> Env es

99+ -> (forall r. m r -> Env es -> IO r)

100+ -> IO a

101+seqUnlift k es unEff = do

102+ tid0 <- myThreadId

103+ k $ \m -> do

104+ tid <- myThreadId

105+ if tid `eqThreadId` tid0

106+ then unEff m es

107+ else error

108+ $ "If you want to use the unlifting function to run Eff computations "

109+ ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)."

110+

111+-- | Concurrent unlift for various strategies and limits.

112+concUnlift

113+ :: HasCallStack

114+ => Persistence

115+ -> Limit

116+ -> ((forall r. m r -> IO r) -> IO a)

117+ -> Env es

118+ -> (forall r. m r -> Env es -> IO r)

119+ -> IO a

120+concUnlift Ephemeral (Limited uses) k =

121+ ephemeralConcUnlift uses k

122+concUnlift Ephemeral Unlimited k =

123+ ephemeralConcUnlift maxBound k

124+concUnlift Persistent (Limited threads) k =

125+ persistentConcUnlift False threads k

126+concUnlift Persistent Unlimited k =

127+ persistentConcUnlift True maxBound k

128+

26-- | Concurrent unlift that doesn't preserve the environment between calls to

129-- | Concurrent unlift that doesn't preserve the environment between calls to

27-- the unlifting function in threads other than its creator.

130-- the unlifting function in threads other than its creator.

28−ephemeralConcUnliftIO

131+ephemeralConcUnlift

29 :: HasCallStack

132 :: HasCallStack

30 => Int

133 => Int

134+ -- ^ Number of permitted uses of the unlift function.

31 -> ((forall r. m r -> IO r) -> IO a)

135 -> ((forall r. m r -> IO r) -> IO a)

32 -> Env es

136 -> Env es

33 -> (forall r. m r -> Env es -> IO r)

137 -> (forall r. m r -> Env es -> IO r)

34 -> IO a

138 -> IO a

35−ephemeralConcUnliftIO uses k es0 unEff = do

139+ephemeralConcUnlift uses k es0 unEff = do

36 unless (uses > 0) $ do

140 unless (uses > 0) $ do

37 error $ "Invalid number of uses: " ++ show uses

141 error $ "Invalid number of uses: " ++ show uses

38 tid0 <- myThreadId

142 tid0 <- myThreadId

@@ -58,15 +162,16 @@ ephemeralConcUnliftIO uses k es0 unEff = do

58

162

59-- | Concurrent unlift that preserves the environment between calls to the

163-- | Concurrent unlift that preserves the environment between calls to the

60-- unlifting function within a particular thread.

164-- unlifting function within a particular thread.

61−persistentConcUnliftIO

165+persistentConcUnlift

62 :: HasCallStack

166 :: HasCallStack

63 => Bool

167 => Bool

64 -> Int

168 -> Int

169+ -- ^ Number of threads that are allowed to use the unlift function.

65 -> ((forall r. m r -> IO r) -> IO a)

170 -> ((forall r. m r -> IO r) -> IO a)

66 -> Env es

171 -> Env es

67 -> (forall r. m r -> Env es -> IO r)

172 -> (forall r. m r -> Env es -> IO r)

68 -> IO a

173 -> IO a

69−persistentConcUnliftIO cleanUp threads k es0 unEff = do

174+persistentConcUnlift cleanUp threads k es0 unEff = do

70 unless (threads > 0) $ do

175 unless (threads > 0) $ do

71 error $ "Invalid number of threads: " ++ show threads

176 error $ "Invalid number of threads: " ++ show threads

72 tid0 <- myThreadId

177 tid0 <- myThreadId

@@ -87,9 +192,9 @@ persistentConcUnliftIO cleanUp threads k es0 unEff = do

87 Just es -> pure (te, es)

192 Just es -> pure (te, es)

88 Nothing -> case teCapacity te of

193 Nothing -> case teCapacity te of

89 0 -> error

194 0 -> error

90− $ "Number of other threads (" ++ show threads ++ ") permitted to "

195+ $ "Number of other threads (" ++ show threads ++ ") permitted to "

91− ++ "use the unlifting function was exceeded. Please increase the "

196+ ++ "use the unlifting function was exceeded. Please increase the "

92− ++ "limit or use the unlimited variant."

197+ ++ "limit or use the unlimited variant."

93 1 -> do

198 1 -> do

94 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp

199 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp

95 let newEntries = ThreadEntries

200 let newEntries = ThreadEntries

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

3 ( Reader

4 , runReader

@@ -7,8 +7,8 @@ module Effectful.Reader

7 , local

8 ) where

9

10−import Effectful.Internal.Effect

10+import Effectful.Dispatch.Static

11−import Effectful.Internal.Monad

11+import Effectful.Monad

12

13-- | Provide access to a strict (WHNF), thread local, read only value of type

14-- @r@.

@@ -20,12 +20,12 @@ runReader

20 :: r -- ^ An initial environment.

21 -> Eff (Reader r : es) a

22 -> Eff es a

23−runReader r = evalEffect (IdE (Reader r))

23+runReader r = evalData (DataA (Reader r))

24

25-- | Fetch the value of the environment.

26ask :: Reader r :> es => Eff es r

27ask = do

28− IdE (Reader r) <- getEffect

28+ DataA (Reader r) <- getData

29 pure r

30

31-- | Retrieve a function of the current environment.

@@ -46,4 +46,4 @@ local

46 => (r -> r) -- ^ The function to modify the environment.

47 -> 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

7 ) where

8

9−import Effectful.Handler

9+import Effectful.Dispatch.Dynamic

10import Effectful.Monad

11import qualified Effectful.Reader as R

12

effectful-core/src/Effectful/State/Dynamic.hs+2−2

@@ -22,12 +22,12 @@ module Effectful.State.Dynamic

22 , modifyM

23 ) where

24

25−import Effectful.Handler

25+import Effectful.Dispatch.Dynamic

26import Effectful.Monad

27import qualified Effectful.State.Local as L

28import qualified Effectful.State.Shared as S

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

32 Get :: State s m s

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--

3−-- Represented as a pure value underneath, therefore:

3+-- - thread local (if you want the value to be shared between threads, have a

4−--

5−-- - thread local (if you need the state 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--

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

44+import Effectful.Monad

27−import Effectful.Internal.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

16 ) where

17

18−import Effectful.Handler

18+import Effectful.Dispatch.Dynamic

19import Effectful.Monad

20import qualified Effectful.Writer.Local as L

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--

3−-- Represented as a pure value underneath, therefore:

3+-- - thread local (if you want the value to be shared between threads, have a

4−--

5−-- - thread local (if you need the state 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

30+import Effectful.Monad

33−import Effectful.Internal.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

31+import Effectful.Monad

15−import Effectful.Internal.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/Concurrency.hs+6−6

@@ -11,7 +11,7 @@ import Test.Tasty.Bench hiding (env)

11

12import Control.Concurrent.Async

13import Control.Monad

14−import qualified Effectful.Async as A

14+import qualified Effectful.Concurrent.Async as A

15

16import Effectful

17import Utils

@@ -25,7 +25,7 @@ concurrencyBenchmark = bgroup "concurrency"

25shallowBench :: Int -> Benchmark

26shallowBench n = bgroup ("unmask " ++ show n ++ "x")

27 [ bench "async (IO)" $ nfAppIO (asyncBenchIO n) op

28− , bench "async (Eff)" $ nfAppIO (runShallow . A.runAsyncE . asyncBench n) op

28+ , bench "async (Eff)" $ nfAppIO (runShallow . A.runConcurrent . asyncBench n) op

29 , bench "Fork (localUnliftIO/withLiftMapIO)" $

30 nfAppIO (runShallow . runFork1 . forkBench n) op

31 , bench "Fork (localUnlift/withLiftMap)" $

@@ -38,7 +38,7 @@ shallowBench n = bgroup ("unmask " ++ show n ++ "x")

38

39deepBench :: Int -> Benchmark

40deepBench n = bgroup ("unmask " ++ show n ++ "x")

41− [ bench "async (Eff)" $ nfAppIO (runDeep . A.runAsyncE . asyncBench n) op

41+ [ bench "async (Eff)" $ nfAppIO (runDeep . A.runConcurrent . asyncBench n) op

42 , bench "Fork (localUnliftIO/withLiftMapIO)" $

43 nfAppIO (runDeep . runFork1 . forkBench n) op

44 , bench "Fork (localUnlift/withLiftMap)" $

@@ -66,7 +66,7 @@ runFork1 = interpret $ \env -> \case

66

67-- | Uses 'localUnlift' and 'withLiftMap'.

68runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a

69−runFork2 = reinterpret A.runAsyncE $ \env -> \case

69+runFork2 = reinterpret A.runConcurrent $ \env -> \case

70 ForkWithUnmask m -> withLiftMap env $ \liftMap -> do

71 localUnlift env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

72 A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

@@ -80,7 +80,7 @@ runFork3 = interpret $ \env -> \case

80

81-- | Uses 'localLiftUnlift'.

82runFork4 :: IOE :> es => Eff (Fork : es) a -> Eff es a

83−runFork4 = reinterpret A.runAsyncE $ \env -> \case

83+runFork4 = reinterpret A.runConcurrent $ \env -> \case

84 ForkWithUnmask m -> do

85 localLiftUnlift env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do

86 A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift

@@ -94,7 +94,7 @@ asyncBenchIO n f = do

94 wait a

95{-# NOINLINE asyncBenchIO #-}

96

97−asyncBench :: A.AsyncE :> es => Int -> Eff es Int -> Eff es Int

97+asyncBench :: A.Concurrent :> es => Int -> Eff es Int -> Eff es Int

98asyncBench n f = do

99 a <- A.asyncWithUnmask $ \unmask -> do

100 sum <$> replicateM n (unmask f)

effectful/bench/Main.hs+3−3

@@ -97,11 +97,11 @@ filesize n = bgroup (show n)

97#ifdef VERSION_eff

98 , bench "eff" $ nfAppIO eff_calculateFileSizesDeep (take n files)

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

106 ]

107 ]

effectful/bench/Unlift.hs+11−11

@@ -14,7 +14,7 @@ import qualified UnliftIO as U

14import Effectful

15import Effectful.State.Dynamic

16import Utils

17−import qualified Effectful.Async as A

17+import qualified Effectful.Concurrent.Async as A

18

19unliftBenchmark :: Benchmark

20unliftBenchmark = bgroup "unlifting"

@@ -29,7 +29,7 @@ unliftBenchmark = bgroup "unlifting"

29 , bench "seq" $ nfAppIO runShallow benchDummy

30 , shallowConc "conc" 1 benchDummyE benchDummy

31 ]

32− , shallowConc "async" 1 benchAsyncE benchAsync

32+ , shallowConc "async" 1 benchAsyncEff benchAsync

33 , shallowConc "concurrently" 2 benchConcurrentlyE benchConcurrently

34 ]

35 , bgroup "deep"

@@ -38,7 +38,7 @@ unliftBenchmark = bgroup "unlifting"

38 , bench "seq" $ nfAppIO runDeep benchDummy

39 , deepConc "conc" 1 benchDummyE benchDummy

40 ]

41− , deepConc "async" 1 benchAsyncE benchAsync

41+ , deepConc "async" 1 benchAsyncEff benchAsync

42 , deepConc "concurrently" 2 benchConcurrentlyE benchConcurrently

43 ]

44 ]

@@ -48,11 +48,11 @@ unliftBenchmark = bgroup "unlifting"

48shallowConc

49 :: String

50 -> Int

51− -> Eff '[A.AsyncE, IOE] ()

51+ -> Eff '[A.Concurrent, IOE] ()

52 -> Eff '[IOE] ()

53 -> Benchmark

54shallowConc name n r f = bgroup name

55− [ bench "AsyncE" $ nfAppIO (runShallow . A.runAsyncE) r

55+ [ bench "Async" $ nfAppIO (runShallow . A.runConcurrent) r

56 , bench "ephemeral/limited" $ nfAppIO

57 (runShallow . withUnliftStrategy (ConcUnlift Ephemeral $ Limited n)) f

58 , bench "ephemeral/unlimited" $ nfAppIO

@@ -66,7 +66,7 @@ shallowConc name n r f = bgroup name

66deepConc

67 :: String

68 -> Int

69− -> Eff '[ A.AsyncE

69+ -> Eff '[ A.Concurrent

70 , State (), State (), State (), State (), State ()

71 , State (), State (), State (), State (), State ()

72 , IOE] ()

@@ -75,7 +75,7 @@ deepConc

75 , IOE] ()

76 -> Benchmark

77deepConc name n r f = bgroup name

78− [ bench "AsyncE" $ nfAppIO (runDeep . A.runAsyncE) r

78+ [ bench "Async" $ nfAppIO (runDeep . A.runConcurrent) r

79 , bench "ephemeral/limited" $ nfAppIO

80 (runDeep . withUnliftStrategy (ConcUnlift Ephemeral $ Limited n)) f

81 , bench "ephemeral/unlimited" $ nfAppIO

@@ -101,10 +101,10 @@ benchDummyE :: Eff es ()

101benchDummyE = pure ()

102{-# NOINLINE benchDummyE #-}

103

104−benchAsyncE :: A.AsyncE :> es => Eff es ()

104+benchAsyncEff :: A.Concurrent :> es => Eff es ()

105−benchAsyncE = A.withAsync (pure ()) A.wait

105+benchAsyncEff = A.withAsync (pure ()) A.wait

106−{-# NOINLINE benchAsyncE #-}

106+{-# NOINLINE benchAsyncEff #-}

107

108−benchConcurrentlyE :: A.AsyncE :> es => Eff es ()

108+benchConcurrentlyE :: A.Concurrent :> es => Eff es ()

109benchConcurrentlyE = A.concurrently_ (pure ()) (pure ())

110{-# NOINLINE benchConcurrentlyE #-}

effectful/effectful.cabal+30−14

@@ -20,7 +20,7 @@ description: An easy to use, performant extensible effects library with seamless

20

21extra-source-files: CHANGELOG.md

22

23−tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.1 || ==9.2.0.20210821

23+tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1

24

25bug-reports: https://github.com/arybczak/effectful/issues

26source-repository head

@@ -40,6 +40,7 @@ common language

40 ConstraintKinds

41 DataKinds

42 DeriveFunctor

43+ DeriveGeneric

43 FlexibleContexts

44 FlexibleContexts

44 FlexibleInstances

45 FlexibleInstances

45 GADTs

46 GADTs

@@ -60,29 +61,42 @@ common language

60library

61library

61 import: language

62 import: language

62

63

63− ghc-options: -O2

64+ build-depends: base >= 4.13 && < 5

64−

65+ , async >= 2.2.2

65− build-depends: base >= 4.13 && <5

66+ , directory >= 1.3.2

66− , async

67+ , effectful-core >= 0.1 && < 0.1.1

67− , effectful-core >= 0.1 && <0.1.1

68+ , process >= 1.6.9

68− , process

69+ , resourcet >= 1.2.4.3

69− , resourcet

70+ , time >= 1.9.2

70− , unliftio

71+ , stm >= 2.5.0.0

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.Async

77+ Effectful.Concurrent.Async

78+ Effectful.Concurrent.Chan

79+ Effectful.Concurrent.MVar

80+ Effectful.Concurrent.STM

81+ Effectful.Concurrent.QSem

82+ Effectful.Concurrent.QSemN

76 Effectful.Environment

83 Effectful.Environment

84+ Effectful.FileSystem

85+ Effectful.FileSystem.IO

77 Effectful.Process

86 Effectful.Process

78 Effectful.Resource

87 Effectful.Resource

79 Effectful.Temporary

88 Effectful.Temporary

80 Effectful.Timeout

89 Effectful.Timeout

81

90

82− reexported-modules: Effectful.Error

91+ other-modules: Effectful.Concurrent.Effect

92+ Effectful.FileSystem.Effect

93+

94+ reexported-modules: Effectful

95+ , Effectful.Dispatch.Dynamic

96+ , Effectful.Dispatch.Static

97+ , Effectful.Error

83 , Effectful.Error.Dynamic

98 , Effectful.Error.Dynamic

84 , Effectful.Fail

99 , Effectful.Fail

85− , Effectful.Handler

86 , Effectful.Monad

100 , Effectful.Monad

87 , Effectful.Prim

101 , Effectful.Prim

88 , Effectful.Reader

102 , Effectful.Reader

@@ -102,6 +116,7 @@ test-suite test

102 build-depends: base

116 build-depends: base

103 , containers

117 , containers

104 , effectful

118 , effectful

119+ , effectful-core

105 , exceptions

120 , exceptions

106 , lifted-base

121 , lifted-base

107 , tasty

122 , tasty

@@ -119,6 +134,7 @@ test-suite test

119 ErrorTests

134 ErrorTests

120 StateTests

135 StateTests

121 TimeoutTests

136 TimeoutTests

137+ UnliftTests

122 Utils

138 Utils

123 -- These are examples; We do not actually run them but list

139 -- These are examples; We do not actually run them but list

124 -- them here in order to check if they compile.

140 -- them here in order to check if they compile.

@@ -138,7 +154,7 @@ benchmark bench

138 if impl(ghc < 9.2)

154 if impl(ghc < 9.2)

139 build-depends: fused-effects

155 build-depends: fused-effects

140

156

141− if impl(ghc < 9.2)

157+ if impl(ghc < 9.3)

142 build-depends: polysemy

158 build-depends: polysemy

143

159

144 build-depends: base

160 build-depends: base

effectful/src/Effectful/Concurrent.hsnew file+218

@@ -0,0 +1,218 @@

1+-- | Lifted version of "Control.Concurrent".

2+--

3+-- For functions that spawn threads, the order of preference for their usage is

4+-- recommended as follows:

5+--

6+-- 1) High level functions from "Effectful.Concurrent.Async" such as

7+-- 'Effectful.Concurrent.Async.withAsync',

8+-- 'Effectful.Concurrent.Async.concurrently' or

9+-- 'Effectful.Concurrent.Async.mapConcurrently'.

10+--

11+-- 2) Low level functions from "Effectful.Concurrent.Async" such as

12+-- 'Effectful.Concurrent.Async.async'.

13+--

14+-- 3) Low level functions from "Effectful.Concurrent" such as 'forkIO'.

15+module Effectful.Concurrent

16+ ( Concurrent

17+ , runConcurrent

18+

19+ -- * Basic concurrency operations

20+ , myThreadId

21+ , forkIO

22+ , forkFinally

23+ , forkIOWithUnmask

24+ , killThread

25+ , throwTo

26+

27+ -- ** Threads with affinity

28+ , forkOn

29+ , forkOnWithUnmask

30+ , getNumCapabilities

31+ , setNumCapabilities

32+ , getNumProcessors

33+ , threadCapability

34+

35+ -- * Scheduling

36+ , yield

37+

38+ -- ** Waiting

39+ , threadDelay

40+ , threadWaitRead

41+ , threadWaitWrite

42+ , threadWaitReadSTM

43+ , threadWaitWriteSTM

44+

45+ -- * Bound threads

46+ , forkOS

47+ , forkOSWithUnmask

48+ , isCurrentThreadBound

49+ , runInBoundThread

50+ , runInUnboundThread

51+

52+ -- * Weak references to ThreadIds

53+ , mkWeakThreadId

54+

55+ -- * Re-exports

56+ , C.rtsSupportsBoundThreads

57+ ) where

58+

59+import Control.Exception (Exception, SomeException)

60+import Data.Bifunctor (second)

61+import System.Mem.Weak (Weak)

62+import System.Posix.Types (Fd)

63+import UnliftIO.STM (STM)

64+import qualified Control.Concurrent as C

65+import qualified GHC.Conc as GHC

66+

67+import Effectful.Concurrent.Effect

68+import Effectful.Dispatch.Static

69+import Effectful.Monad

70+

71+----------------------------------------

72+-- Basic concurrency operations

73+

74+-- | Lifted 'C.myThreadId'.

75+myThreadId :: Concurrent :> es => Eff es C.ThreadId

76+myThreadId = unsafeEff_ C.myThreadId

77+

78+-- | Lifted 'C.forkIO'.

79+forkIO :: Concurrent :> es => Eff es () -> Eff es C.ThreadId

80+forkIO k = unsafeEff $ \es -> do

81+ esF <- cloneEnv es

82+ C.forkIO $ unEff k esF

83+

84+-- | Lifted 'C.forkFinally'.

85+forkFinally

86+ :: Concurrent :> es

87+ => Eff es a

88+ -> (Either SomeException a -> Eff es ())

89+ -> Eff es C.ThreadId

90+forkFinally k cleanup = unsafeEff $ \es -> do

91+ esF <- cloneEnv es

92+ C.forkFinally (unEff k esF) ((`unEff` esF) . cleanup)

93+

94+-- | Lifted 'C.forkIOWithUnmask'.

95+forkIOWithUnmask

96+ :: Concurrent :> es

97+ => ((forall a es'. IOE :> es' => Eff es' a -> Eff es' a)

98+ -> Eff es ())

99+ -> Eff es C.ThreadId

100+forkIOWithUnmask f = unsafeEff $ \es -> do

101+ esF <- cloneEnv es

102+ C.forkIOWithUnmask (\restore -> unEff (f (unsafeLiftMapIO restore)) esF)

103+

104+-- | Lifted 'C.killThread'.

105+killThread :: Concurrent :> es => C.ThreadId -> Eff es ()

106+killThread = unsafeEff_ . C.killThread

107+

108+-- | Lifted 'C.throwTo'.

109+throwTo :: (Concurrent :> es, Exception e) => C.ThreadId -> e -> Eff es ()

110+throwTo tid = unsafeEff_ . C.throwTo tid

111+

112+----------------------------------------

113+-- Threads with affinity

114+

115+-- | Lifted 'C.forkOn'.

116+forkOn :: Concurrent :> es => Int -> Eff es () -> Eff es C.ThreadId

117+forkOn n k = unsafeEff $ \es -> do

118+ esF <- cloneEnv es

119+ C.forkOn n (unEff k esF)

120+

121+-- | Lifted 'C.forkOnWithUnmask'.

122+forkOnWithUnmask

123+ :: Concurrent :> es

124+ => Int

125+ -> ((forall a es'. IOE :> es' => Eff es' a -> Eff es' a) -> Eff es ())

126+ -> Eff es C.ThreadId

127+forkOnWithUnmask n f = unsafeEff $ \es -> do

128+ esF <- cloneEnv es

129+ C.forkOnWithUnmask n (\restore -> unEff (f (unsafeLiftMapIO restore)) esF)

130+

131+-- | Lifted 'C.getNumCapabilities'.

132+getNumCapabilities :: Concurrent :> es => Eff es Int

133+getNumCapabilities = unsafeEff_ C.getNumCapabilities

134+

135+-- | Lifted 'C.setNumCapabilities'.

136+setNumCapabilities :: Concurrent :> es => Int -> Eff es ()

137+setNumCapabilities = unsafeEff_ . C.setNumCapabilities

138+

139+-- | Lifted 'GHC.getNumProcessors'.

140+getNumProcessors :: Concurrent :> es => Eff es Int

141+getNumProcessors = unsafeEff_ GHC.getNumProcessors

142+

143+-- | Lifted 'C.threadCapability'.

144+threadCapability :: Concurrent :> es => C.ThreadId -> Eff es (Int, Bool)

145+threadCapability = unsafeEff_ . C.threadCapability

146+

147+----------------------------------------

148+-- Scheduling

149+

150+-- | Lifted 'C.yield'.

151+yield :: Concurrent :> es => Eff es ()

152+yield = unsafeEff_ C.yield

153+

154+----------------------------------------

155+-- Waiting

156+

157+-- | Lifted 'C.threadDelay'.

158+threadDelay :: Concurrent :> es => Int -> Eff es ()

159+threadDelay = unsafeEff_ . C.threadDelay

160+

161+-- | Lifted 'C.threadWaitRead'.

162+threadWaitRead :: Concurrent :> es => Fd -> Eff es ()

163+threadWaitRead = unsafeEff_ . C.threadWaitRead

164+

165+-- | Lifted 'C.threadWaitWrite'.

166+threadWaitWrite :: Concurrent :> es => Fd -> Eff es ()

167+threadWaitWrite = unsafeEff_ . C.threadWaitWrite

168+

169+-- | Lifted 'C.threadWaitReadSTM'.

170+threadWaitReadSTM :: Concurrent :> es => Fd -> Eff es (STM (), Eff es ())

171+threadWaitReadSTM fd = unsafeEff_ $ do

172+ second unsafeEff_ <$> C.threadWaitReadSTM fd

173+

174+-- | Lifted 'C.threadWaitWriteSTM'.

175+threadWaitWriteSTM :: Concurrent :> es => Fd -> Eff es (STM (), Eff es ())

176+threadWaitWriteSTM fd = unsafeEff_ $ do

177+ second unsafeEff_ <$> C.threadWaitWriteSTM fd

178+

179+----------------------------------------

180+-- Bound threads

181+

182+-- | Lifted 'C.forkOS'.

183+forkOS :: Concurrent :> es => Eff es () -> Eff es C.ThreadId

184+forkOS k = unsafeEff $ \es -> do

185+ esF <- cloneEnv es

186+ C.forkOS $ unEff k esF

187+

188+-- | Lifted 'E.forkOSWithUnmask'.

189+forkOSWithUnmask

190+ :: Concurrent :> es

191+ => ((forall a es'. IOE :> es' => Eff es' a -> Eff es' a) -> Eff es ())

192+ -> Eff es C.ThreadId

193+forkOSWithUnmask f = unsafeEff $ \es -> do

194+ esF <- cloneEnv es

195+ C.forkOSWithUnmask (\restore -> unEff (f (unsafeLiftMapIO restore)) esF)

196+

197+-- | Lifted 'C.isCurrentThreadBound'.

198+isCurrentThreadBound :: Concurrent :> es => Eff es Bool

199+isCurrentThreadBound = unsafeEff_ C.isCurrentThreadBound

200+

201+-- | Lifted 'C.runInBoundThread'.

202+runInBoundThread :: Concurrent :> es => Eff es a -> Eff es a

203+runInBoundThread k = unsafeEff $ \es -> do

204+ esF <- cloneEnv es

205+ C.runInBoundThread $ unEff k esF

206+

207+-- | Lifted 'C.runInUnboundThread'.

208+runInUnboundThread :: Concurrent :> es => Eff es a -> Eff es a

209+runInUnboundThread k = unsafeEff $ \es -> do

210+ esF <- cloneEnv es

211+ C.runInUnboundThread $ unEff k esF

212+

213+----------------------------------------

214+-- Weak references to ThreadIds

215+

216+-- | Lifted 'C.mkWeakThreadId'.

217+mkWeakThreadId :: Concurrent :> es => C.ThreadId -> Eff es (Weak C.ThreadId)

218+mkWeakThreadId = unsafeEff_ . C.mkWeakThreadId

effectful/src/Effectful/Async.hs → effectful/src/Effectful/Concurrent/Async.hsrenamed+65−79

@@ -1,8 +1,8 @@

1{-# LANGUAGE UndecidableInstances #-}

2−module Effectful.Async

2+-- | Lifted version of "Control.Concurrent.Async".

3− ( -- * Async effect

3+module Effectful.Concurrent.Async

4− AsyncE

4+ ( Concurrent

5− , runAsyncE

5+ , runConcurrent

6

7 -- * Asynchronous actions

8 , Async

@@ -76,51 +76,37 @@ import Control.Concurrent (threadDelay)

76import Control.Concurrent.Async (Async)

77import Control.Exception (Exception, SomeException)

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.Internal.Effect

84+import Effectful.Concurrent.Effect

84−import Effectful.Internal.Env

85+import Effectful.Dispatch.Static

85−import Effectful.Internal.Monad

86+import Effectful.Monad

86−

87−-- | Run 'Eff' operations asynchronously via the @async@ library.

88−--

89−-- /Note:/ thread local state changes in 'Eff' operations run asynchronously

90−-- will not affect the parent thread.

91−--

92−-- /TODO:/ write about 'AsyncE' not respecting scoped operations.

93−data AsyncE :: Effect where

94− AsyncE :: AsyncE m r

95−

96−runAsyncE :: IOE :> es => Eff (AsyncE : es) a -> Eff es a

97−runAsyncE = evalEffect (IdE AsyncE)

98−

99−----------------------------------------

100−-- Operations

101

87

102-- | Lifted 'A.async'.

88-- | Lifted 'A.async'.

103−async :: AsyncE :> es => Eff es a -> Eff es (Async a)

89+async :: Concurrent :> es => Eff es a -> Eff es (Async a)

104async = liftAsync A.async

90async = liftAsync A.async

105

91

106-- | Lifted 'A.asyncBound'.

92-- | Lifted 'A.asyncBound'.

107−asyncBound :: AsyncE :> es => Eff es a -> Eff es (Async a)

93+asyncBound :: Concurrent :> es => Eff es a -> Eff es (Async a)

108asyncBound = liftAsync A.asyncBound

94asyncBound = liftAsync A.asyncBound

109

95

110-- | Lifted 'A.asyncOn'.

96-- | Lifted 'A.asyncOn'.

111−asyncOn :: AsyncE :> es => Int -> Eff es a -> Eff es (Async a)

97+asyncOn :: Concurrent :> es => Int -> Eff es a -> Eff es (Async a)

112asyncOn cpu = liftAsync (A.asyncOn cpu)

98asyncOn cpu = liftAsync (A.asyncOn cpu)

113

99

114-- | Lifted 'A.asyncWithUnmask'.

100-- | Lifted 'A.asyncWithUnmask'.

115asyncWithUnmask

101asyncWithUnmask

116− :: AsyncE :> es

102+ :: Concurrent :> es

117 => ((forall b. Eff es b -> Eff es b) -> Eff es a)

103 => ((forall b. Eff es b -> Eff es b) -> Eff es a)

118 -> Eff es (Async a)

104 -> Eff es (Async a)

119asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask

105asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask

120

106

121-- | Lifted 'A.asyncOnWithUnmask'.

107-- | Lifted 'A.asyncOnWithUnmask'.

122asyncOnWithUnmask

108asyncOnWithUnmask

123− :: AsyncE :> es

109+ :: Concurrent :> es

124 => Int

110 => Int

125 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)

111 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)

126 -> Eff es (Async a)

112 -> Eff es (Async a)

@@ -128,7 +114,7 @@ asyncOnWithUnmask cpu = liftAsyncWithUnmask (A.asyncOnWithUnmask cpu)

128

114

129-- | Lifted 'A.withAsync'.

115-- | Lifted 'A.withAsync'.

130withAsync

116withAsync

131− :: AsyncE :> es

117+ :: Concurrent :> es

132 => Eff es a

118 => Eff es a

133 -> (Async a -> Eff es b)

119 -> (Async a -> Eff es b)

134 -> Eff es b

120 -> Eff es b

@@ -136,7 +122,7 @@ withAsync = liftWithAsync A.withAsync

136

122

137-- | Lifted 'A.withAsyncBound'.

123-- | Lifted 'A.withAsyncBound'.

138withAsyncBound

124withAsyncBound

139− :: AsyncE :> es

125+ :: Concurrent :> es

140 => Eff es a

126 => Eff es a

141 -> (Async a -> Eff es b)

127 -> (Async a -> Eff es b)

142 -> Eff es b

128 -> Eff es b

@@ -144,7 +130,7 @@ withAsyncBound = liftWithAsync A.withAsyncBound

144

130

145-- | Lifted 'A.withAsyncOn'.

131-- | Lifted 'A.withAsyncOn'.

146withAsyncOn

132withAsyncOn

147− :: AsyncE :> es

133+ :: Concurrent :> es

148 => Int

134 => Int

149 -> Eff es a

135 -> Eff es a

150 -> (Async a -> Eff es b)

136 -> (Async a -> Eff es b)

@@ -153,7 +139,7 @@ withAsyncOn cpu = liftWithAsync (A.withAsyncOn cpu)

153

139

154-- | Lifted 'A.withAsyncWithUnmask'.

140-- | Lifted 'A.withAsyncWithUnmask'.

155withAsyncWithUnmask

141withAsyncWithUnmask

156− :: AsyncE :> es

142+ :: Concurrent :> es

157 => ((forall c. Eff es c -> Eff es c) -> Eff es a)

143 => ((forall c. Eff es c -> Eff es c) -> Eff es a)

158 -> (Async a -> Eff es b)

144 -> (Async a -> Eff es b)

159 -> Eff es b

145 -> Eff es b

@@ -161,7 +147,7 @@ withAsyncWithUnmask = liftWithAsyncWithUnmask A.withAsyncWithUnmask

161

147

162-- | Lifted 'A.withAsyncOnWithUnmask'.

148-- | Lifted 'A.withAsyncOnWithUnmask'.

163withAsyncOnWithUnmask

149withAsyncOnWithUnmask

164− :: AsyncE :> es

150+ :: Concurrent :> es

165 => Int

151 => Int

166 -> ((forall c. Eff es c -> Eff es c) -> Eff es a)

152 -> ((forall c. Eff es c -> Eff es c) -> Eff es a)

167 -> (Async a -> Eff es b)

153 -> (Async a -> Eff es b)

@@ -169,60 +155,60 @@ withAsyncOnWithUnmask

169withAsyncOnWithUnmask cpu = liftWithAsyncWithUnmask (A.withAsyncOnWithUnmask cpu)

155withAsyncOnWithUnmask cpu = liftWithAsyncWithUnmask (A.withAsyncOnWithUnmask cpu)

170

156

171-- | Lifted 'A.wait'.

157-- | Lifted 'A.wait'.

172−wait :: AsyncE :> es => Async a -> Eff es a

158+wait :: Concurrent :> es => Async a -> Eff es a

173wait = unsafeEff_ . A.wait

159wait = unsafeEff_ . A.wait

174

160

175-- | Lifted 'A.poll'.

161-- | Lifted 'A.poll'.

176poll

162poll

177− :: AsyncE :> es

163+ :: Concurrent :> es

178 => Async a

164 => Async a

179 -> Eff es (Maybe (Either SomeException a))

165 -> Eff es (Maybe (Either SomeException a))

180poll = unsafeEff_ . A.poll

166poll = unsafeEff_ . A.poll

181

167

182-- | Lifted 'A.cancel'.

168-- | Lifted 'A.cancel'.

183−cancel :: AsyncE :> es => Async a -> Eff es ()

169+cancel :: Concurrent :> es => Async a -> Eff es ()

184cancel = unsafeEff_ . A.cancel

170cancel = unsafeEff_ . A.cancel

185

171

186-- | Lifted 'A.cancelWith'.

172-- | Lifted 'A.cancelWith'.

187−cancelWith :: (Exception e, AsyncE :> es) => Async a -> e -> Eff es ()

173+cancelWith :: (Exception e, Concurrent :> es) => Async a -> e -> Eff es ()

188cancelWith a = unsafeEff_ . A.cancelWith a

174cancelWith a = unsafeEff_ . A.cancelWith a

189

175

190-- | Lifted 'A.uninterruptibleCancel'.

176-- | Lifted 'A.uninterruptibleCancel'.

191−uninterruptibleCancel :: AsyncE :> es => Async a -> Eff es ()

177+uninterruptibleCancel :: Concurrent :> es => Async a -> Eff es ()

192uninterruptibleCancel = unsafeEff_ . A.uninterruptibleCancel

178uninterruptibleCancel = unsafeEff_ . A.uninterruptibleCancel

193

179

194-- | Lifted 'A.waitCatch'.

180-- | Lifted 'A.waitCatch'.

195waitCatch

181waitCatch

196− :: AsyncE :> es

182+ :: Concurrent :> es

197 => Async a

183 => Async a

198 -> Eff es (Either SomeException a)

184 -> Eff es (Either SomeException a)

199waitCatch = unsafeEff_ . A.waitCatch

185waitCatch = unsafeEff_ . A.waitCatch

200

186

201-- | Lifted 'A.waitAny'.

187-- | Lifted 'A.waitAny'.

202−waitAny :: AsyncE :> es => [Async a] -> Eff es (Async a, a)

188+waitAny :: Concurrent :> es => [Async a] -> Eff es (Async a, a)

203waitAny = unsafeEff_ . A.waitAny

189waitAny = unsafeEff_ . A.waitAny

204

190

205-- | Lifted 'A.waitAnyCatch'.

191-- | Lifted 'A.waitAnyCatch'.

206waitAnyCatch

192waitAnyCatch

207− :: AsyncE :> es

193+ :: Concurrent :> es

208 => [Async a]

194 => [Async a]

209 -> Eff es (Async a, Either SomeException a)

195 -> Eff es (Async a, Either SomeException a)

210waitAnyCatch = unsafeEff_ . A.waitAnyCatch

196waitAnyCatch = unsafeEff_ . A.waitAnyCatch

211

197

212-- | Lifted 'A.waitAnyCancel'.

198-- | Lifted 'A.waitAnyCancel'.

213−waitAnyCancel :: AsyncE :> es => [Async a] -> Eff es (Async a, a)

199+waitAnyCancel :: Concurrent :> es => [Async a] -> Eff es (Async a, a)

214waitAnyCancel = unsafeEff_ . A.waitAnyCancel

200waitAnyCancel = unsafeEff_ . A.waitAnyCancel

215

201

216-- | Lifted 'A.waitAnyCatchCancel'.

202-- | Lifted 'A.waitAnyCatchCancel'.

217waitAnyCatchCancel

203waitAnyCatchCancel

218− :: AsyncE :> es

204+ :: Concurrent :> es

219 => [Async a]

205 => [Async a]

220 -> Eff es (Async a, Either SomeException a)

206 -> Eff es (Async a, Either SomeException a)

221waitAnyCatchCancel = unsafeEff_ . A.waitAnyCatchCancel

207waitAnyCatchCancel = unsafeEff_ . A.waitAnyCatchCancel

222

208

223-- | Lifted 'A.waitEither'.

209-- | Lifted 'A.waitEither'.

224waitEither

210waitEither

225− :: AsyncE :> es

211+ :: Concurrent :> es

226 => Async a

212 => Async a

227 -> Async b

213 -> Async b

228 -> Eff es (Either a b)

214 -> Eff es (Either a b)

@@ -230,7 +216,7 @@ waitEither a b = unsafeEff_ $ A.waitEither a b

230

216

231-- | Lifted 'A.waitEitherCatch'.

217-- | Lifted 'A.waitEitherCatch'.

232waitEitherCatch

218waitEitherCatch

233− :: AsyncE :> es

219+ :: Concurrent :> es

234 => Async a

220 => Async a

235 -> Async b

221 -> Async b

236 -> Eff es (Either (Either SomeException a) (Either SomeException b))

222 -> Eff es (Either (Either SomeException a) (Either SomeException b))

@@ -238,7 +224,7 @@ waitEitherCatch a b = unsafeEff_ $ A.waitEitherCatch a b

238

224

239-- | Lifted 'A.waitEitherCancel'.

225-- | Lifted 'A.waitEitherCancel'.

240waitEitherCancel

226waitEitherCancel

241− :: AsyncE :> es

227+ :: Concurrent :> es

242 => Async a

228 => Async a

243 -> Async b

229 -> Async b

244 -> Eff es (Either a b)

230 -> Eff es (Either a b)

@@ -246,53 +232,53 @@ waitEitherCancel a b = unsafeEff_ $ A.waitEitherCancel a b

246

232

247-- | Lifted 'A.waitEitherCatchCancel'.

233-- | Lifted 'A.waitEitherCatchCancel'.

248waitEitherCatchCancel

234waitEitherCatchCancel

249− :: AsyncE :> es

235+ :: Concurrent :> es

250 => Async a

236 => Async a

251 -> Async b

237 -> Async b

252 -> Eff es (Either (Either SomeException a) (Either SomeException b))

238 -> Eff es (Either (Either SomeException a) (Either SomeException b))

253waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatch a b

239waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatch a b

254

240

255-- | Lifted 'A.waitEither_'.

241-- | Lifted 'A.waitEither_'.

256−waitEither_ :: AsyncE :> es => Async a -> Async b -> Eff es ()

242+waitEither_ :: Concurrent :> es => Async a -> Async b -> Eff es ()

257waitEither_ a b = unsafeEff_ $ A.waitEither_ a b

243waitEither_ a b = unsafeEff_ $ A.waitEither_ a b

258

244

259-- | Lifted 'A.waitBoth'.

245-- | Lifted 'A.waitBoth'.

260−waitBoth :: AsyncE :> es => Async a -> Async b -> Eff es (a, b)

246+waitBoth :: Concurrent :> es => Async a -> Async b -> Eff es (a, b)

261waitBoth a b = unsafeEff_ $ A.waitBoth a b

247waitBoth a b = unsafeEff_ $ A.waitBoth a b

262

248

263-- | Lifted 'A.link'.

249-- | Lifted 'A.link'.

264−link :: AsyncE :> es => Async a -> Eff es ()

250+link :: Concurrent :> es => Async a -> Eff es ()

265link = unsafeEff_ . A.link

251link = unsafeEff_ . A.link

266

252

267-- | Lifted 'A.linkOnly'.

253-- | Lifted 'A.linkOnly'.

268−linkOnly :: AsyncE :> es => (SomeException -> Bool) -> Async a -> Eff es ()

254+linkOnly :: Concurrent :> es => (SomeException -> Bool) -> Async a -> Eff es ()

269linkOnly f = unsafeEff_ . A.linkOnly f

255linkOnly f = unsafeEff_ . A.linkOnly f

270

256

271-- | Lifted 'A.link2'.

257-- | Lifted 'A.link2'.

272−link2 :: AsyncE :> es => Async a -> Async b -> Eff es ()

258+link2 :: Concurrent :> es => Async a -> Async b -> Eff es ()

273link2 a b = unsafeEff_ $ A.link2 a b

259link2 a b = unsafeEff_ $ A.link2 a b

274

260

275-- | Lifted 'A.link2Only'.

261-- | Lifted 'A.link2Only'.

276−link2Only :: AsyncE :> es => (SomeException -> Bool) -> Async a -> Async b -> Eff es ()

262+link2Only :: Concurrent :> es => (SomeException -> Bool) -> Async a -> Async b -> Eff es ()

277link2Only f a b = unsafeEff_ $ A.link2Only f a b

263link2Only f a b = unsafeEff_ $ A.link2Only f a b

278

264

279-- | Lifted 'A.race'.

265-- | Lifted 'A.race'.

280−race :: AsyncE :> es => Eff es a -> Eff es b -> Eff es (Either a b)

266+race :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (Either a b)

281race ma mb = unsafeEff $ \es -> do

267race ma mb = unsafeEff $ \es -> do

282 A.race (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

268 A.race (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

283

269

284-- | Lifted 'A.race_'.

270-- | Lifted 'A.race_'.

285−race_ :: AsyncE :> es => Eff es a -> Eff es b -> Eff es ()

271+race_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es ()

286race_ ma mb = unsafeEff $ \es -> do

272race_ ma mb = unsafeEff $ \es -> do

287 A.race_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

273 A.race_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

288

274

289-- | Lifted 'A.concurrently'.

275-- | Lifted 'A.concurrently'.

290−concurrently :: AsyncE :> es => Eff es a -> Eff es b -> Eff es (a, b)

276+concurrently :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (a, b)

291concurrently ma mb = unsafeEff $ \es -> do

277concurrently ma mb = unsafeEff $ \es -> do

292 A.concurrently (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

278 A.concurrently (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

293

279

294-- | Lifted 'A.concurrently_'.

280-- | Lifted 'A.concurrently_'.

295−concurrently_ :: AsyncE :> es => Eff es a -> Eff es b -> Eff es ()

281+concurrently_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es ()

296concurrently_ ma mb = unsafeEff $ \es -> do

282concurrently_ ma mb = unsafeEff $ \es -> do

297 A.concurrently_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

283 A.concurrently_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

298

284

@@ -302,7 +288,7 @@ concurrently_ ma mb = unsafeEff $ \es -> do

302

288

303-- | Lifted 'A.mapConcurrently'.

289-- | Lifted 'A.mapConcurrently'.

304mapConcurrently

290mapConcurrently

305− :: (Traversable f, AsyncE :> es)

291+ :: (Traversable f, Concurrent :> es)

306 => (a -> Eff es b)

292 => (a -> Eff es b)

307 -> f a

293 -> f a

308 -> Eff es (f b)

294 -> Eff es (f b)

@@ -311,7 +297,7 @@ mapConcurrently f t = unsafeEff $ \es -> do

311

297

312-- | Lifted 'A.mapConcurrently_'.

298-- | Lifted 'A.mapConcurrently_'.

313mapConcurrently_

299mapConcurrently_

314− :: (Foldable f, AsyncE :> es)

300+ :: (Foldable f, Concurrent :> es)

315 => (a -> Eff es b)

301 => (a -> Eff es b)

316 -> f a

302 -> f a

317 -> Eff es ()

303 -> Eff es ()

@@ -320,7 +306,7 @@ mapConcurrently_ f t = unsafeEff $ \es -> do

320

306

321-- | Lifted 'A.forConcurrently'.

307-- | Lifted 'A.forConcurrently'.

322forConcurrently

308forConcurrently

323− :: (Traversable f, AsyncE :> es)

309+ :: (Traversable f, Concurrent :> es)

324 => f a

310 => f a

325 -> (a -> Eff es b)

311 -> (a -> Eff es b)

326 -> Eff es (f b)

312 -> Eff es (f b)

@@ -329,7 +315,7 @@ forConcurrently t f = unsafeEff $ \es -> do

329

315

330-- | Lifted 'A.forConcurrently_'.

316-- | Lifted 'A.forConcurrently_'.

331forConcurrently_

317forConcurrently_

332− :: (Foldable f, AsyncE :> es)

318+ :: (Foldable f, Concurrent :> es)

333 => f a

319 => f a

334 -> (a -> Eff es b)

320 -> (a -> Eff es b)

335 -> Eff es ()

321 -> Eff es ()

@@ -337,12 +323,12 @@ forConcurrently_ t f = unsafeEff $ \es -> do

337 U.forConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)

323 U.forConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)

338

324

339-- | Lifted 'A.replicateConcurrently'.

325-- | Lifted 'A.replicateConcurrently'.

340−replicateConcurrently :: AsyncE :> es => Int -> Eff es a -> Eff es [a]

326+replicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a]

341replicateConcurrently n f = unsafeEff $ \es -> do

327replicateConcurrently n f = unsafeEff $ \es -> do

342 U.replicateConcurrently n (unEff f =<< cloneEnv es)

328 U.replicateConcurrently n (unEff f =<< cloneEnv es)

343

329

344-- | Lifted 'A.replicateConcurrently_'.

330-- | Lifted 'A.replicateConcurrently_'.

345−replicateConcurrently_ :: AsyncE :> es => Int -> Eff es a -> Eff es ()

331+replicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es ()

346replicateConcurrently_ n f = unsafeEff $ \es -> do

332replicateConcurrently_ n f = unsafeEff $ \es -> do

347 U.replicateConcurrently_ n (unEff f =<< cloneEnv es)

333 U.replicateConcurrently_ n (unEff f =<< cloneEnv es)

348

334

@@ -351,7 +337,7 @@ replicateConcurrently_ n f = unsafeEff $ \es -> do

351

337

352-- | Lifted 'U.pooledMapConcurrentlyN'.

338-- | Lifted 'U.pooledMapConcurrentlyN'.

353pooledMapConcurrentlyN

339pooledMapConcurrentlyN

354− :: (AsyncE :> es, Traversable t)

340+ :: (Concurrent :> es, Traversable t)

355 => Int

341 => Int

356 -> (a -> Eff es b)

342 -> (a -> Eff es b)

357 -> t a

343 -> t a

@@ -361,7 +347,7 @@ pooledMapConcurrentlyN threads f t = unsafeEff $ \es -> do

361

347

362-- | Lifted 'U.pooledMapConcurrently'.

348-- | Lifted 'U.pooledMapConcurrently'.

363pooledMapConcurrently

349pooledMapConcurrently

364− :: (AsyncE :> es, Traversable t)

350+ :: (Concurrent :> es, Traversable t)

365 => (a -> Eff es b)

351 => (a -> Eff es b)

366 -> t a

352 -> t a

367 -> Eff es (t b)

353 -> Eff es (t b)

@@ -370,7 +356,7 @@ pooledMapConcurrently f t = unsafeEff $ \es -> do

370

356

371-- | Lifted 'U.pooledMapConcurrentlyN'.

357-- | Lifted 'U.pooledMapConcurrentlyN'.

372pooledMapConcurrentlyN_

358pooledMapConcurrentlyN_

373− :: (AsyncE :> es, Foldable f)

359+ :: (Concurrent :> es, Foldable f)

374 => Int

360 => Int

375 -> (a -> Eff es b)

361 -> (a -> Eff es b)

376 -> f a

362 -> f a

@@ -380,7 +366,7 @@ pooledMapConcurrentlyN_ threads f t = unsafeEff $ \es -> do

380

366

381-- | Lifted 'U.pooledMapConcurrently_'.

367-- | Lifted 'U.pooledMapConcurrently_'.

382pooledMapConcurrently_

368pooledMapConcurrently_

383− :: (AsyncE :> es, Foldable f)

369+ :: (Concurrent :> es, Foldable f)

384 => (a -> Eff es b)

370 => (a -> Eff es b)

385 -> f a

371 -> f a

386 -> Eff es ()

372 -> Eff es ()

@@ -389,7 +375,7 @@ pooledMapConcurrently_ f t = unsafeEff $ \es -> do

389

375

390-- | Lifted 'U.pooledForConcurrentlyN'.

376-- | Lifted 'U.pooledForConcurrentlyN'.

391pooledForConcurrentlyN

377pooledForConcurrentlyN

392− :: (AsyncE :> es, Traversable t)

378+ :: (Concurrent :> es, Traversable t)

393 => Int

379 => Int

394 -> t a

380 -> t a

395 -> (a -> Eff es b)

381 -> (a -> Eff es b)

@@ -399,7 +385,7 @@ pooledForConcurrentlyN threads t f = unsafeEff $ \es -> do

399

385

400-- | Lifted 'U.pooledForConcurrently'.

386-- | Lifted 'U.pooledForConcurrently'.

401pooledForConcurrently

387pooledForConcurrently

402− :: (AsyncE :> es, Traversable t)

388+ :: (Concurrent :> es, Traversable t)

403 => t a

389 => t a

404 -> (a -> Eff es b)

390 -> (a -> Eff es b)

405 -> Eff es (t b)

391 -> Eff es (t b)

@@ -408,7 +394,7 @@ pooledForConcurrently t f = unsafeEff $ \es -> do

408

394

409-- | Lifted 'U.pooledForConcurrentlyN'.

395-- | Lifted 'U.pooledForConcurrentlyN'.

410pooledForConcurrentlyN_

396pooledForConcurrentlyN_

411− :: (AsyncE :> es, Foldable f)

397+ :: (Concurrent :> es, Foldable f)

412 => Int

398 => Int

413 -> f a

399 -> f a

414 -> (a -> Eff es b)

400 -> (a -> Eff es b)

@@ -418,7 +404,7 @@ pooledForConcurrentlyN_ threads t f = unsafeEff $ \es -> do

418

404

419-- | Lifted 'U.pooledForConcurrently_'.

405-- | Lifted 'U.pooledForConcurrently_'.

420pooledForConcurrently_

406pooledForConcurrently_

421− :: (AsyncE :> es, Foldable f)

407+ :: (Concurrent :> es, Foldable f)

422 => f a

408 => f a

423 -> (a -> Eff es b)

409 -> (a -> Eff es b)

424 -> Eff es ()

410 -> Eff es ()

@@ -426,22 +412,22 @@ pooledForConcurrently_ t f = unsafeEff $ \es -> do

426 U.pooledForConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)

412 U.pooledForConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)

427

413

428-- | Lifted 'U.pooledReplicateConcurrentlyN'.

414-- | Lifted 'U.pooledReplicateConcurrentlyN'.

429−pooledReplicateConcurrentlyN :: AsyncE :> es => Int -> Int -> Eff es a -> Eff es [a]

415+pooledReplicateConcurrentlyN :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es [a]

430pooledReplicateConcurrentlyN threads n f = unsafeEff $ \es -> do

416pooledReplicateConcurrentlyN threads n f = unsafeEff $ \es -> do

431 U.pooledReplicateConcurrentlyN threads n (unEff f =<< cloneEnv es)

417 U.pooledReplicateConcurrentlyN threads n (unEff f =<< cloneEnv es)

432

418

433-- | Lifted 'U.pooledReplicateConcurrently'.

419-- | Lifted 'U.pooledReplicateConcurrently'.

434−pooledReplicateConcurrently :: AsyncE :> es => Int -> Eff es a -> Eff es [a]

420+pooledReplicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a]

435pooledReplicateConcurrently n f = unsafeEff $ \es -> do

421pooledReplicateConcurrently n f = unsafeEff $ \es -> do

436 U.pooledReplicateConcurrently n (unEff f =<< cloneEnv es)

422 U.pooledReplicateConcurrently n (unEff f =<< cloneEnv es)

437

423

438-- | Lifted 'U.pooledReplicateConcurrentlyN_'.

424-- | Lifted 'U.pooledReplicateConcurrentlyN_'.

439−pooledReplicateConcurrentlyN_ :: AsyncE :> es => Int -> Int -> Eff es a -> Eff es ()

425+pooledReplicateConcurrentlyN_ :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es ()

440pooledReplicateConcurrentlyN_ threads n f = unsafeEff $ \es -> do

426pooledReplicateConcurrentlyN_ threads n f = unsafeEff $ \es -> do

441 U.pooledReplicateConcurrentlyN_ threads n (unEff f =<< cloneEnv es)

427 U.pooledReplicateConcurrentlyN_ threads n (unEff f =<< cloneEnv es)

442

428

443-- | Lifted 'U.pooledReplicateConcurrently_'.

429-- | Lifted 'U.pooledReplicateConcurrently_'.

444−pooledReplicateConcurrently_ :: AsyncE :> es => Int -> Eff es a -> Eff es ()

430+pooledReplicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es ()

445pooledReplicateConcurrently_ n f = unsafeEff $ \es -> do

431pooledReplicateConcurrently_ n f = unsafeEff $ \es -> do

446 U.pooledReplicateConcurrently_ n (unEff f =<< cloneEnv es)

432 U.pooledReplicateConcurrently_ n (unEff f =<< cloneEnv es)

447

433

@@ -481,7 +467,7 @@ conc :: Eff es a -> Conc es a

481conc = Action

467conc = Action

482

468

483-- | Lifted 'U.runConc'.

469-- | Lifted 'U.runConc'.

484−runConc :: AsyncE :> es => Conc es a -> Eff es a

470+runConc :: Concurrent :> es => Conc es a -> Eff es a

485runConc m = unsafeEff $ \es -> U.runConc (unliftConc es m)

471runConc m = unsafeEff $ \es -> U.runConc (unliftConc es m)

486 where

472 where

487 unliftConc :: Env es -> Conc es a -> U.Conc IO a

473 unliftConc :: Env es -> Conc es a -> U.Conc IO a

@@ -502,20 +488,20 @@ newtype Concurrently es a = Concurrently { runConcurrently :: Eff es a }

502instance Functor (Concurrently es) where

488instance Functor (Concurrently es) where

503 fmap f (Concurrently a) = Concurrently (fmap f a)

489 fmap f (Concurrently a) = Concurrently (fmap f a)

504

490

505−instance AsyncE :> es => Applicative (Concurrently es) where

491+instance Concurrent :> es => Applicative (Concurrently es) where

506 pure = Concurrently . pure

492 pure = Concurrently . pure

507 Concurrently fs <*> Concurrently as =

493 Concurrently fs <*> Concurrently as =

508 Concurrently ((\(f, a) -> f a) <$> concurrently fs as)

494 Concurrently ((\(f, a) -> f a) <$> concurrently fs as)

509

495

510−instance AsyncE :> es => Alternative (Concurrently es) where

496+instance Concurrent :> es => Alternative (Concurrently es) where

511 empty = Concurrently . unsafeEff_ . forever $ threadDelay maxBound

497 empty = Concurrently . unsafeEff_ . forever $ threadDelay maxBound

512 Concurrently as <|> Concurrently bs =

498 Concurrently as <|> Concurrently bs =

513 Concurrently (either id id <$> race as bs)

499 Concurrently (either id id <$> race as bs)

514

500

515−instance (AsyncE :> es, Semigroup a) => Semigroup (Concurrently es a) where

501+instance (Concurrent :> es, Semigroup a) => Semigroup (Concurrently es a) where

516 (<>) = liftA2 (<>)

502 (<>) = liftA2 (<>)

517

503

518−instance (AsyncE :> es, Monoid a) => Monoid (Concurrently es a) where

504+instance (Concurrent :> es, Monoid a) => Monoid (Concurrently es a) where

519 mempty = pure mempty

505 mempty = pure mempty

520

506

521----------------------------------------

507----------------------------------------

effectful/src/Effectful/Concurrent/Chan.hsnew file+45

@@ -0,0 +1,45 @@

1+-- | Lifted version of "Control.Concurrent.Chan".

2+module Effectful.Concurrent.Chan

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * Chan

7+ , Chan

8+ , newChan

9+ , writeChan

10+ , readChan

11+ , dupChan

12+ , getChanContents

13+ , writeList2Chan

14+ ) where

15+

16+import Control.Concurrent.Chan (Chan)

17+import qualified Control.Concurrent.Chan as C

18+

19+import Effectful.Concurrent.Effect

20+import Effectful.Dispatch.Static

21+import Effectful.Monad

22+

23+-- | Lifted 'C.newChan'.

24+newChan :: Concurrent :> es => Eff es (Chan a)

25+newChan = unsafeEff_ C.newChan

26+

27+-- | Lifted 'C.writeChan'.

28+writeChan :: Concurrent :> es => Chan a -> a -> Eff es ()

29+writeChan c = unsafeEff_ . C.writeChan c

30+

31+-- | Lifted 'C.readChan'.

32+readChan :: Concurrent :> es => Chan a -> Eff es a

33+readChan = unsafeEff_ . C.readChan

34+

35+-- | Lifted 'C.dupChan'.

36+dupChan :: Concurrent :> es => Chan a -> Eff es (Chan a)

37+dupChan = unsafeEff_ . C.dupChan

38+

39+-- | Lifted 'C.getChanContents'.

40+getChanContents :: Concurrent :> es => Chan a -> Eff es [a]

41+getChanContents = unsafeEff_ . C.getChanContents

42+

43+-- | Lifted 'C.writeList2Chan'.

44+writeList2Chan :: Concurrent :> es => Chan a -> [a] -> Eff es ()

45+writeList2Chan c = unsafeEff_ . C.writeList2Chan c

effectful/src/Effectful/Concurrent/Effect.hsnew file+79

@@ -0,0 +1,79 @@

1+module Effectful.Concurrent.Effect

2+ ( Concurrent

3+ , runConcurrent

4+ ) where

5+

6+import Effectful.Dispatch.Static

7+import Effectful.Monad

8+

9+-- | Provide the ability to run 'Eff' computations concurrently in multiple

10+-- threads and communicate between them.

11+--

12+-- /Warning:/ unless you stick to high level functions from the

13+-- 'Effectful.Concurrent.Async.withAsync' family, the 'Concurrent' effect makes

14+-- it possible to escape the scope of any scoped effect operation. Consider the

15+-- following:

16+--

17+-- >>> import qualified Effectful.Reader as R

18+-- >>> let printAsk msg = liftIO . putStrLn . (msg ++) . (": " ++) =<< R.ask

19+-- >>> :{

20+-- runEff . R.runReader "GLOBAL" . runConcurrent $ do

21+-- a <- R.local (const "LOCAL") $ do

22+-- a <- async $ do

23+-- printAsk "child (first)"

24+-- threadDelay 20000

25+-- printAsk "child (second)"

26+-- threadDelay 10000

27+-- printAsk "parent (inside)"

28+-- pure a

29+-- printAsk "parent (outside)"

30+-- wait a

31+-- :}

32+-- child (first): LOCAL

33+-- parent (inside): LOCAL

34+-- parent (outside): GLOBAL

35+-- child (second): LOCAL

36+--

37+-- Note that the asynchronous computation doesn't respect the scope of

38+-- 'Effectful.Reader.local', i.e. the child thread still behaves like it's

39+-- inside the 'Effectful.Reader.local' block, even though the parent thread

40+-- already got out of it.

41+--

42+-- This is because the value provided by the 'Effectful.Reader.Reader' effect is

43+-- thread local, i.e. each thread manages its own version of it. For the

44+-- 'Effectful.Reader.Reader' it is the only reasonable behavior, it wouldn't be

45+-- very useful if its "read only" value was affected by calls to

46+-- 'Effectful.Reader.local' from its parent or child threads.

47+--

48+-- However, the cut isn't so clear if it comes to effects that provide access to

49+-- a mutable state. That's why primitive @State@ and @Writer@ effects come in

50+-- two flavors, local and shared:

51+--

52+-- >>> import qualified Effectful.State.Local as SL

53+-- >>> :{

54+-- runEff . SL.execState "Hi" . runConcurrent $ do

55+-- replicateConcurrently_ 3 $ SL.modify (++ "!")

56+-- :}

57+-- "Hi"

58+--

59+-- >>> import qualified Effectful.State.Shared as SS

60+-- >>> :{

61+-- runEff . SS.execState "Hi" . runConcurrent $ do

62+-- replicateConcurrently_ 3 $ SS.modify (++ "!")

63+-- :}

64+-- "Hi!!!"

65+--

66+-- In the first example state modification made concurrently are not reflected

67+-- in the parent thread because the value is thread local, but in the second

68+-- example they are, because the value is shared.

69+--

70+data Concurrent :: Effect where

71+ Concurrent :: Concurrent m r

72+

73+-- | Run the 'Concurrent' effect.

74+runConcurrent :: IOE :> es => Eff (Concurrent : es) a -> Eff es a

75+runConcurrent = evalData (DataA Concurrent)

76+

77+-- $setup

78+-- >>> import Effectful.Concurrent

79+-- >>> import Effectful.Concurrent.Async

effectful/src/Effectful/Concurrent/MVar.hsnew file+108

@@ -0,0 +1,108 @@

1+-- | Lifted version of "Control.Concurrent.MVar".

2+module Effectful.Concurrent.MVar

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * MVar

7+ , MVar

8+ , newEmptyMVar

9+ , newMVar

10+ , takeMVar

11+ , putMVar

12+ , readMVar

13+ , swapMVar

14+ , tryTakeMVar

15+ , tryPutMVar

16+ , isEmptyMVar

17+ , withMVar

18+ , withMVarMasked

19+ , modifyMVar

20+ , modifyMVar_

21+ , modifyMVarMasked

22+ , modifyMVarMasked_

23+ , tryReadMVar

24+ , mkWeakMVar

25+ ) where

26+

27+import System.Mem.Weak (Weak)

28+import Control.Concurrent.MVar (MVar)

29+import qualified Control.Concurrent.MVar as M

30+

31+import Effectful.Concurrent.Effect

32+import Effectful.Dispatch.Static

33+import Effectful.Monad

34+

35+-- | Lifted 'M.newEmptyMVar'.

36+newEmptyMVar :: Concurrent :> es => Eff es (MVar a)

37+newEmptyMVar = unsafeEff_ M.newEmptyMVar

38+

39+-- | Lifted 'M.newMVar'.

40+newMVar :: Concurrent :> es => a -> Eff es (MVar a)

41+newMVar = unsafeEff_ . M.newMVar

42+

43+-- | Lifted 'M.takeMVar'.

44+takeMVar :: Concurrent :> es => MVar a -> Eff es a

45+takeMVar = unsafeEff_ . M.takeMVar

46+

47+-- | Lifted 'M.putMVar'.

48+putMVar :: Concurrent :> es => MVar a -> a -> Eff es ()

49+putMVar var = unsafeEff_ . M.putMVar var

50+

51+-- | Lifted 'M.readMVar'.

52+readMVar :: Concurrent :> es => MVar a -> Eff es a

53+readMVar = unsafeEff_ . M.readMVar

54+

55+-- | Lifted 'M.swapMVar'.

56+swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a

57+swapMVar var = unsafeEff_ . M.swapMVar var

58+

59+-- | Lifted 'M.tryTakeMVar'.

60+tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)

61+tryTakeMVar = unsafeEff_ . M.tryTakeMVar

62+

63+-- | Lifted 'M.tryPutMVar'.

64+tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool

65+tryPutMVar var = unsafeEff_ . M.tryPutMVar var

66+

67+-- | Lifted 'M.isEmptyMVar'.

68+isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool

69+isEmptyMVar = unsafeEff_ . M.isEmptyMVar

70+

71+-- | Lifted 'M.tryReadMVar'.

72+tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)

73+tryReadMVar = unsafeEff_ . M.tryReadMVar

74+

75+-- | Lifted 'M.withMVar'.

76+withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b

77+withMVar var f = unsafeUnliftIO $ \unlift -> do

78+ M.withMVar var $ unlift . f

79+

80+-- | Lifted 'M.withMVarMasked'.

81+withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b

82+withMVarMasked var f = unsafeUnliftIO $ \unlift -> do

83+ M.withMVarMasked var $ unlift . f

84+

85+-- | Lifted 'M.modifyMVar_'.

86+modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es ()

87+modifyMVar_ var f = unsafeUnliftIO $ \unlift -> do

88+ M.modifyMVar_ var $ unlift . f

89+

90+-- | Lifted 'M.modifyMVar'.

91+modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b

92+modifyMVar var f = unsafeUnliftIO $ \unlift -> do

93+ M.modifyMVar var $ unlift . f

94+

95+-- | Lifted 'M.modifyMVarMasked_'.

96+modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es ()

97+modifyMVarMasked_ var f = unsafeUnliftIO $ \unlift -> do

98+ M.modifyMVarMasked_ var $ unlift . f

99+

100+-- | Lifted 'M.modifyMVarMasked'.

101+modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b

102+modifyMVarMasked var f = unsafeUnliftIO $ \unlift -> do

103+ M.modifyMVarMasked var $ unlift . f

104+

105+-- | Lifted 'M.mkWeakMVar'.

106+mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a))

107+mkWeakMVar var f = unsafeUnliftIO $ \unlift -> do

108+ M.mkWeakMVar var $ unlift f

effectful/src/Effectful/Concurrent/QSem.hsnew file+30

@@ -0,0 +1,30 @@

1+-- | Lifted version of "Control.Concurrent.QSem".

2+module Effectful.Concurrent.QSem

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * QSem

7+ , QSem

8+ , newQSem

9+ , waitQSem

10+ , signalQSem

11+ ) where

12+

13+import Control.Concurrent.QSem (QSem)

14+import qualified Control.Concurrent.QSem as Q

15+

16+import Effectful.Concurrent.Effect

17+import Effectful.Dispatch.Static

18+import Effectful.Monad

19+

20+-- | Lifted 'Q.newQSem'.

21+newQSem :: Concurrent :> es => Int -> Eff es QSem

22+newQSem = unsafeEff_ . Q.newQSem

23+

24+-- | Lifted 'Q.waitQSem'.

25+waitQSem :: Concurrent :> es => QSem -> Eff es ()

26+waitQSem = unsafeEff_ . Q.waitQSem

27+

28+-- | Lifted 'Q.signalQSem'.

29+signalQSem :: Concurrent :> es => QSem -> Eff es ()

30+signalQSem = unsafeEff_ . Q.signalQSem

effectful/src/Effectful/Concurrent/QSemN.hsnew file+30

@@ -0,0 +1,30 @@

1+-- | Lifted version of "Control.Concurrent.QSemN".

2+module Effectful.Concurrent.QSemN

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * QSemN

7+ , QSemN

8+ , newQSemN

9+ , waitQSemN

10+ , signalQSemN

11+ ) where

12+

13+import Control.Concurrent.QSemN (QSemN)

14+import qualified Control.Concurrent.QSemN as Q

15+

16+import Effectful.Concurrent.Effect

17+import Effectful.Dispatch.Static

18+import Effectful.Monad

19+

20+-- | Lifted 'Q.newQSemN'.

21+newQSemN :: Concurrent :> es => Int -> Eff es QSemN

22+newQSemN = unsafeEff_ . Q.newQSemN

23+

24+-- | Lifted 'Q.waitQSemN'.

25+waitQSemN :: Concurrent :> es => QSemN -> Int -> Eff es ()

26+waitQSemN x = unsafeEff_ . Q.waitQSemN x

27+

28+-- | Lifted 'Q.signalQSemN'.

29+signalQSemN :: Concurrent :> es => QSemN -> Int -> Eff es ()

30+signalQSemN x = unsafeEff_ . Q.signalQSemN x

effectful/src/Effectful/Concurrent/STM.hsnew file+146

@@ -0,0 +1,146 @@

1+-- | Lifted version of "Control.Concurrent.STM".

2+module Effectful.Concurrent.STM

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * Core

7+ , STM.STM

8+ , atomically

9+ , STM.retry

10+ , STM.orElse

11+ , STM.check

12+ , STM.throwSTM

13+ , STM.catchSTM

14+

15+ -- * TVar

16+ , STM.TVar

17+ , newTVarIO

18+ , readTVarIO

19+ , STM.newTVar

20+ , STM.readTVar

21+ , STM.writeTVar

22+ , STM.modifyTVar

23+ , STM.modifyTVar'

24+ , STM.swapTVar

25+ , registerDelay

26+ , mkWeakTVar

27+

28+ -- * TMVar

29+ , STM.TMVar

30+ , STM.newTMVar

31+ , STM.newEmptyTMVar

32+ , newTMVarIO

33+ , newEmptyTMVarIO

34+ , STM.takeTMVar

35+ , STM.putTMVar

36+ , STM.readTMVar

37+ , STM.tryReadTMVar

38+ , STM.swapTMVar

39+ , STM.tryTakeTMVar

40+ , STM.tryPutTMVar

41+ , STM.isEmptyTMVar

42+ , mkWeakTMVar

43+

44+ -- * TChan

45+ , STM.TChan

46+ , STM.newTChan

47+ , newTChanIO

48+ , STM.newBroadcastTChan

49+ , newBroadcastTChanIO

50+ , STM.dupTChan

51+ , STM.cloneTChan

52+ , STM.readTChan

53+ , STM.tryReadTChan

54+ , STM.peekTChan

55+ , STM.tryPeekTChan

56+ , STM.writeTChan

57+ , STM.unGetTChan

58+ , STM.isEmptyTChan

59+

60+ -- * TQueue

61+ , STM.TQueue

62+ , STM.newTQueue

63+ , newTQueueIO

64+ , STM.readTQueue

65+ , STM.tryReadTQueue

66+ , STM.peekTQueue

67+ , STM.tryPeekTQueue

68+ , STM.flushTQueue

69+ , STM.writeTQueue

70+ , STM.unGetTQueue

71+ , STM.isEmptyTQueue

72+

73+ -- * TBQueue

74+ , STM.TBQueue

75+ , STM.newTBQueue

76+ , newTBQueueIO

77+ , STM.readTBQueue

78+ , STM.tryReadTBQueue

79+ , STM.peekTBQueue

80+ , STM.tryPeekTBQueue

81+ , STM.flushTBQueue

82+ , STM.writeTBQueue

83+ , STM.unGetTBQueue

84+ , STM.lengthTBQueue

85+ , STM.isEmptyTBQueue

86+ , STM.isFullTBQueue

87+ ) where

88+

89+import Control.Concurrent.STM (STM, TVar, TMVar, TChan, TQueue, TBQueue)

90+import qualified Control.Concurrent.STM as STM

91+import System.Mem.Weak (Weak)

92+import GHC.Natural (Natural)

93+

94+import Effectful.Concurrent.Effect

95+import Effectful.Dispatch.Static

96+import Effectful.Monad

97+

98+-- | Lifted version of 'STM.atomically'

99+atomically :: Concurrent :> es => STM a -> Eff es a

100+atomically = unsafeEff_ . STM.atomically

101+

102+-- | Lifted version of 'STM.newTVarIO'

103+newTVarIO :: Concurrent :> es => a -> Eff es (TVar a)

104+newTVarIO = unsafeEff_ . STM.newTVarIO

105+

106+-- | Lifted version of 'STM.readTVarIO'

107+readTVarIO :: Concurrent :> es => TVar a -> Eff es a

108+readTVarIO = unsafeEff_ . STM.readTVarIO

109+

110+-- | Lifted version of 'STM.registerDelay'

111+registerDelay :: Concurrent :> es => Int -> Eff es (TVar Bool)

112+registerDelay = unsafeEff_ . STM.registerDelay

113+

114+-- | Lifted version of 'STM.mkWeakTVar'

115+mkWeakTVar :: Concurrent :> es => TVar a -> Eff es () -> Eff es (Weak (TVar a))

116+mkWeakTVar var final = unsafeUnliftIO $ \unlift -> do

117+ STM.mkWeakTVar var $ unlift final

118+

119+-- | Lifted version of 'STM.newTMVarIO'

120+newTMVarIO :: Concurrent :> es => a -> Eff es (TMVar a)

121+newTMVarIO = unsafeEff_ . STM.newTMVarIO

122+

123+-- | Lifted version of 'STM.newEmptyTMVarIO'

124+newEmptyTMVarIO :: Concurrent :> es => Eff es (TMVar a)

125+newEmptyTMVarIO = unsafeEff_ STM.newEmptyTMVarIO

126+

127+-- | Lifted version of 'STM.mkWeakTMVar'

128+mkWeakTMVar :: Concurrent :> es => TMVar a -> Eff es () -> Eff es (Weak (TMVar a))

129+mkWeakTMVar var final = unsafeUnliftIO $ \unlift -> do

130+ STM.mkWeakTMVar var $ unlift final

131+

132+-- | Lifted version of 'STM.newTChanIO'

133+newTChanIO :: Concurrent :> es => Eff es (TChan a)

134+newTChanIO = unsafeEff_ STM.newTChanIO

135+

136+-- | Lifted version of 'STM.newBroadcastTChanIO'

137+newBroadcastTChanIO :: Concurrent :> es => Eff es (TChan a)

138+newBroadcastTChanIO = unsafeEff_ STM.newBroadcastTChanIO

139+

140+-- | Lifted version of 'STM.newTQueueIO'

141+newTQueueIO :: Concurrent :> es => Eff es (TQueue a)

142+newTQueueIO = unsafeEff_ STM.newTQueueIO

143+

144+-- | Lifted version of 'STM.newTBQueueIO'

145+newTBQueueIO :: Concurrent :> es => Natural -> Eff es (TBQueue a)

146+newTBQueueIO = unsafeEff_ . STM.newTBQueueIO

effectful/src/Effectful/Environment.hs+7−11

@@ -1,6 +1,5 @@

1module Effectful.Environment

2− ( -- * Environment effect

2+ ( Environment

3− 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

31−runEnvironment = evalEffect (IdE Environment)

31+runEnvironment = evalData (DataA Environment)

32

33-- | Lifted 'E.getArgs'.

34getArgs :: Environment :> es => Eff es [String]

@@ -64,12 +64,8 @@ unsetEnv = unsafeEff_ . E.unsetEnv

64

65-- | Lifted 'E.withArgs'.

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

71+withProgName = unsafeLiftMapIO . E.withProgName

74− seqUnliftEff es $ \runInIO -> do

75− E.withProgName n (runInIO k)

effectful/src/Effectful/FileSystem.hsnew file+347

@@ -0,0 +1,347 @@

1+module Effectful.FileSystem

2+ ( FileSystem

3+ , runFileSystem

4+

5+ -- * Actions on directories

6+ , createDirectory

7+ , createDirectoryIfMissing

8+ , removeDirectory

9+ , removeDirectoryRecursive

10+ , removePathForcibly

11+ , renameDirectory

12+ , listDirectory

13+ , getDirectoryContents

14+

15+ -- ** Current working directory

16+ , getCurrentDirectory

17+ , setCurrentDirectory

18+ , withCurrentDirectory

19+

20+ -- * Pre-defined directories

21+ , getHomeDirectory

22+ , getXdgDirectory

23+ , getXdgDirectoryList

24+ , getAppUserDataDirectory

25+ , getUserDocumentsDirectory

26+ , getTemporaryDirectory

27+

28+ -- * Actions on files

29+ , removeFile

30+ , renameFile

31+ , renamePath

32+ , copyFile

33+ , copyFileWithMetadata

34+ , getFileSize

35+ , canonicalizePath

36+ , makeAbsolute

37+ , makeRelativeToCurrentDirectory

38+

39+ -- * Existence tests

40+ , doesPathExist

41+ , doesFileExist

42+ , doesDirectoryExist

43+ , findExecutable

44+ , findExecutables

45+ , findExecutablesInDirectories

46+ , findFile

47+ , findFiles

48+ , findFileWith

49+ , findFilesWith

50+

51+ -- * Symbolic links

52+ , createFileLink

53+ , createDirectoryLink

54+ , removeDirectoryLink

55+ , pathIsSymbolicLink

56+ , getSymbolicLinkTarget

57+

58+ -- * Permissions

59+ , getPermissions

60+ , setPermissions

61+ , copyPermissions

62+

63+ -- * Timestamps

64+ , getAccessTime

65+ , getModificationTime

66+ , setAccessTime

67+ , setModificationTime

68+

69+ -- * Re-exports

70+

71+ -- ** Pre-defined directories

72+ , D.XdgDirectory(..)

73+ , D.XdgDirectoryList(..)

74+

75+ -- ** Existence tests

76+ , D.exeExtension

77+

78+ -- ** Permissions

79+ , D.Permissions

80+ , D.emptyPermissions

81+ , D.readable

82+ , D.writable

83+ , D.executable

84+ , D.searchable

85+ , D.setOwnerReadable

86+ , D.setOwnerWritable

87+ , D.setOwnerExecutable

88+ , D.setOwnerSearchable

89+ ) where

90+

91+import Data.Time (UTCTime)

92+import qualified System.Directory as D

93+

94+import Effectful.Dispatch.Static

95+import Effectful.Monad

96+

97+-- | An effect for interacting with the filesystem.

98+data FileSystem :: Effect where

99+ FileSystem :: FileSystem m r

100+

101+-- | Run the 'FileSystem' effect.

102+runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a

103+runFileSystem = evalData (DataA FileSystem)

104+

105+----------------------------------------

106+-- Actions on directories

107+

108+-- | Lifted 'D.createDirectory'.

109+createDirectory :: FileSystem :> es => FilePath -> Eff es ()

110+createDirectory = unsafeEff_ . D.createDirectory

111+

112+-- | Lifted 'D.createDirectoryIfMissing'.

113+createDirectoryIfMissing :: FileSystem :> es => Bool -> FilePath -> Eff es ()

114+createDirectoryIfMissing doCreateParents =

115+ unsafeEff_ . D.createDirectoryIfMissing doCreateParents

116+

117+-- | Lifted 'D.removeDirectory'.

118+removeDirectory :: FileSystem :> es => FilePath -> Eff es ()

119+removeDirectory = unsafeEff_ . D.removeDirectory

120+

121+-- | Lifted 'D.removeDirectoryRecursive'.

122+removeDirectoryRecursive :: FileSystem :> es => FilePath -> Eff es ()

123+removeDirectoryRecursive = unsafeEff_ . D.removeDirectoryRecursive

124+

125+-- | Lifted 'D.removePathForcibly'.

126+removePathForcibly :: FileSystem :> es => FilePath -> Eff es ()

127+removePathForcibly = unsafeEff_ . D.removePathForcibly

128+

129+-- | Lifted 'D.renameDirectory'.

130+renameDirectory :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

131+renameDirectory old = unsafeEff_ . D.renameDirectory old

132+

133+-- | Lifted 'D.listDirectory'.

134+listDirectory :: FileSystem :> es => FilePath -> Eff es [FilePath]

135+listDirectory = unsafeEff_ . D.listDirectory

136+

137+-- | Lifted 'D.getDirectoryContents'.

138+getDirectoryContents :: FileSystem :> es => FilePath -> Eff es [FilePath]

139+getDirectoryContents = unsafeEff_ . D.getDirectoryContents

140+

141+----------------------------------------

142+-- Current working directory

143+

144+-- | Lifted 'D.getCurrentDirectory'.

145+getCurrentDirectory :: FileSystem :> es => Eff es FilePath

146+getCurrentDirectory = unsafeEff_ D.getCurrentDirectory

147+

148+-- | Lifted 'D.setCurrentDirectory'.

149+setCurrentDirectory :: FileSystem :> es => FilePath -> Eff es ()

150+setCurrentDirectory = unsafeEff_ . D.setCurrentDirectory

151+

152+-- | Lifted 'D.withCurrentDirectory'.

153+withCurrentDirectory :: FileSystem :> es => FilePath -> Eff es a -> Eff es a

154+withCurrentDirectory path = unsafeLiftMapIO (D.withCurrentDirectory path)

155+

156+----------------------------------------

157+-- Pre-defined directories

158+

159+-- | Lifted 'D.getHomeDirectory'.

160+getHomeDirectory :: FileSystem :> es => Eff es FilePath

161+getHomeDirectory = unsafeEff_ D.getHomeDirectory

162+

163+-- | Lifted 'D.getXdgDirectory'.

164+getXdgDirectory

165+ :: FileSystem :> es

166+ => D.XdgDirectory

167+ -> FilePath

168+ -> Eff es FilePath

169+getXdgDirectory xdgDir = unsafeEff_ . D.getXdgDirectory xdgDir

170+

171+-- | Lifted 'D.getXdgDirectoryList'.

172+getXdgDirectoryList

173+ :: FileSystem :> es

174+ => D.XdgDirectoryList

175+ -> Eff es [FilePath]

176+getXdgDirectoryList = unsafeEff_ . D.getXdgDirectoryList

177+

178+-- | Lifted 'D.getAppUserDataDirectory'.

179+getAppUserDataDirectory :: FileSystem :> es => FilePath -> Eff es FilePath

180+getAppUserDataDirectory = unsafeEff_ . D.getAppUserDataDirectory

181+

182+-- | Lifted 'D.getUserDocumentsDirectory'.

183+getUserDocumentsDirectory :: FileSystem :> es => Eff es FilePath

184+getUserDocumentsDirectory = unsafeEff_ D.getUserDocumentsDirectory

185+

186+-- | Lifted 'D.getTemporaryDirectory'.

187+getTemporaryDirectory :: FileSystem :> es => Eff es FilePath

188+getTemporaryDirectory = unsafeEff_ D.getTemporaryDirectory

189+

190+----------------------------------------

191+-- Actions on files

192+

193+-- | Lifted 'D.removeFile'.

194+removeFile :: FileSystem :> es => FilePath -> Eff es ()

195+removeFile = unsafeEff_ . D.removeFile

196+

197+-- | Lifted 'D.renameFile'.

198+renameFile :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

199+renameFile old = unsafeEff_ . D.renameFile old

200+

201+-- | Lifted 'D.renamePath'.

202+renamePath :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

203+renamePath old = unsafeEff_ . D.renamePath old

204+

205+-- | Lifted 'D.copyFile'.

206+copyFile :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

207+copyFile src = unsafeEff_ . D.copyFile src

208+

209+-- | Lifted 'D.copyFileWithMetadata'.

210+copyFileWithMetadata :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

211+copyFileWithMetadata src = unsafeEff_ . D.copyFileWithMetadata src

212+

213+-- | Lifted 'D.getFileSize'.

214+getFileSize :: FileSystem :> es => FilePath -> Eff es Integer

215+getFileSize = unsafeEff_ . D.getFileSize

216+

217+-- | Lifted 'D.canonicalizePath'.

218+canonicalizePath :: FileSystem :> es => FilePath -> Eff es FilePath

219+canonicalizePath = unsafeEff_ . D.canonicalizePath

220+

221+-- | Lifted 'D.makeAbsolute'.

222+makeAbsolute :: FileSystem :> es => FilePath -> Eff es FilePath

223+makeAbsolute = unsafeEff_ . D.makeAbsolute

224+

225+-- | Lifted 'D.makeRelativeToCurrentDirectory'.

226+makeRelativeToCurrentDirectory

227+ :: FileSystem :> es

228+ => FilePath

229+ -> Eff es FilePath

230+makeRelativeToCurrentDirectory = unsafeEff_ . D.makeRelativeToCurrentDirectory

231+

232+----------------------------------------

233+-- Existence tests

234+

235+-- | Lifted 'D.doesPathExist'.

236+doesPathExist :: FileSystem :> es => FilePath -> Eff es Bool

237+doesPathExist = unsafeEff_ . D.doesPathExist

238+

239+-- | Lifted 'D.doesFileExist'.

240+doesFileExist :: FileSystem :> es => FilePath -> Eff es Bool

241+doesFileExist = unsafeEff_ . D.doesFileExist

242+

243+-- | Lifted 'D.doesDirectoryExist'.

244+doesDirectoryExist :: FileSystem :> es => FilePath -> Eff es Bool

245+doesDirectoryExist = unsafeEff_ . D.doesDirectoryExist

246+

247+-- | Lifted 'D.findExecutable'.

248+findExecutable :: FileSystem :> es => String -> Eff es (Maybe FilePath)

249+findExecutable = unsafeEff_ . D.findExecutable

250+

251+-- | Lifted 'D.findExecutables'.

252+findExecutables :: FileSystem :> es => String -> Eff es [FilePath]

253+findExecutables = unsafeEff_ . D.findExecutables

254+

255+-- | Lifted 'D.findExecutablesInDirectories'.

256+findExecutablesInDirectories

257+ :: FileSystem :> es

258+ => [FilePath]

259+ -> String

260+ -> Eff es [FilePath]

261+findExecutablesInDirectories dirs =

262+ unsafeEff_ . D.findExecutablesInDirectories dirs

263+

264+-- | Lifted 'D.findFile'.

265+findFile :: FileSystem :> es => [FilePath] -> String -> Eff es (Maybe FilePath)

266+findFile dirs = unsafeEff_ . D.findFile dirs

267+

268+-- | Lifted 'D.findFiles'.

269+findFiles :: FileSystem :> es => [FilePath] -> String -> Eff es [FilePath]

270+findFiles dirs = unsafeEff_ . D.findFiles dirs

271+

272+-- | Lifted 'D.findFileWith'.

273+findFileWith

274+ :: FileSystem :> es

275+ => (FilePath -> Eff es Bool)

276+ -> [FilePath]

277+ -> String

278+ -> Eff es (Maybe FilePath)

279+findFileWith p dirs n = unsafeUnliftIO $ \unlift -> do

280+ D.findFileWith (unlift . p) dirs n

281+

282+-- | Lifted 'D.findFilesWith'.

283+findFilesWith

284+ :: FileSystem :> es

285+ => (FilePath -> Eff es Bool)

286+ -> [FilePath]

287+ -> String

288+ -> Eff es [FilePath]

289+findFilesWith p dirs ns = unsafeUnliftIO $ \unlift -> do

290+ D.findFilesWith (unlift . p) dirs ns

291+

292+----------------------------------------

293+-- Symbolic links

294+

295+-- | Lifted 'D.createFileLink'.

296+createFileLink :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

297+createFileLink target = unsafeEff_ . D.createFileLink target

298+

299+-- | Lifted 'D.createDirectoryLink'.

300+createDirectoryLink :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

301+createDirectoryLink target = unsafeEff_ . D.createDirectoryLink target

302+

303+-- | Lifted 'D.removeDirectoryLink'.

304+removeDirectoryLink :: FileSystem :> es => FilePath -> Eff es ()

305+removeDirectoryLink = unsafeEff_ . D.removeDirectoryLink

306+

307+-- | Lifted 'D.pathIsSymbolicLink'.

308+pathIsSymbolicLink :: FileSystem :> es => FilePath -> Eff es Bool

309+pathIsSymbolicLink = unsafeEff_ . D.pathIsSymbolicLink

310+

311+-- | Lifted 'D.getSymbolicLinkTarget'.

312+getSymbolicLinkTarget :: FileSystem :> es => FilePath -> Eff es FilePath

313+getSymbolicLinkTarget = unsafeEff_ . D.getSymbolicLinkTarget

314+

315+----------------------------------------

316+-- Permissions

317+

318+-- | Lifted 'D.getPermissions'.

319+getPermissions :: FileSystem :> es => FilePath -> Eff es D.Permissions

320+getPermissions = unsafeEff_ . D.getPermissions

321+

322+-- | Lifted 'D.setPermissions'.

323+setPermissions :: FileSystem :> es => FilePath -> D.Permissions -> Eff es ()

324+setPermissions path = unsafeEff_ . D.setPermissions path

325+

326+-- | Lifted 'D.copyPermissions'.

327+copyPermissions :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

328+copyPermissions src = unsafeEff_ . D.copyPermissions src

329+

330+----------------------------------------

331+-- Timestamps

332+

333+-- | Lifted 'D.getAccessTime'.

334+getAccessTime :: FileSystem :> es => FilePath -> Eff es UTCTime

335+getAccessTime = unsafeEff_ . D.getAccessTime

336+

337+-- | Lifted 'D.getModificationTime'.

338+getModificationTime :: FileSystem :> es => FilePath -> Eff es UTCTime

339+getModificationTime = unsafeEff_ . D.getModificationTime

340+

341+-- | Lifted 'D.setAccessTime'.

342+setAccessTime :: FileSystem :> es => FilePath -> UTCTime -> Eff es ()

343+setAccessTime path = unsafeEff_ . D.setAccessTime path

344+

345+-- | Lifted 'D.setModificationTime'.

346+setModificationTime :: FileSystem :> es => FilePath -> UTCTime -> Eff es ()

347+setModificationTime path = unsafeEff_ . D.setModificationTime path

effectful/src/Effectful/FileSystem/Effect.hsnew file+15

@@ -0,0 +1,15 @@

1+module Effectful.FileSystem.Effect

2+ ( FileSystem

3+ , runFileSystem

4+ ) where

5+

6+import Effectful.Dispatch.Static

7+import Effectful.Monad

8+

9+-- | An effect for interacting with the filesystem.

10+data FileSystem :: Effect where

11+ FileSystem :: FileSystem m r

12+

13+-- | Run the 'FileSystem' effect.

14+runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a

15+runFileSystem = evalData (DataA FileSystem)

effectful/src/Effectful/FileSystem/IO.hsnew file+143

@@ -0,0 +1,143 @@

1+-- | Lifted version of "System.IO".

2+module Effectful.FileSystem.IO

3+ ( FileSystem

4+ , runFileSystem

5+

6+ -- * IO

7+ , IOMode (..)

8+ , Handle

9+ , IO.stdin

10+ , IO.stdout

11+ , IO.stderr

12+ , withFile

13+ , withBinaryFile

14+ , openFile

15+ , hClose

16+ , hFlush

17+ , hFileSize

18+ , hSetFileSize

19+ , hIsEOF

20+ , IO.BufferMode (..)

21+ , hSetBuffering

22+ , hGetBuffering

23+ , hSeek

24+ , IO.SeekMode (..)

25+ , hTell

26+ , hIsOpen

27+ , hIsClosed

28+ , hIsReadable

29+ , hIsWritable

30+ , hIsSeekable

31+ , hIsTerminalDevice

32+ , hSetEcho

33+ , hGetEcho

34+ , hWaitForInput

35+ , hReady

36+ ) where

37+

38+import qualified System.IO as IO

39+import System.IO (Handle, IOMode (..))

40+

41+import Effectful.Dispatch.Static

42+import Effectful.FileSystem.Effect

43+import Effectful.Monad

44+

45+-- | Lifted version of 'IO.withFile'.

46+withFile

47+ :: FileSystem :> es

48+ => FilePath

49+ -> IOMode

50+ -> (Handle -> Eff es a)

51+ -> Eff es a

52+withFile fp mode inner = unsafeUnliftIO $ \unlift -> do

53+ IO.withFile fp mode $ unlift . inner

54+

55+-- | Lifted version of 'IO.withBinaryFile'.

56+withBinaryFile

57+ :: FileSystem :> es

58+ => FilePath

59+ -> IOMode

60+ -> (Handle -> Eff es a)

61+ -> Eff es a

62+withBinaryFile fp mode inner = unsafeUnliftIO $ \unlift -> do

63+ IO.withBinaryFile fp mode $ unlift . inner

64+

65+-- | Lifted version of 'IO.openFile'

66+openFile :: FileSystem :> es => FilePath -> IOMode -> Eff es Handle

67+openFile fp = unsafeEff_ . IO.openFile fp

68+

69+-- | Lifted version of 'IO.hClose'

70+hClose :: FileSystem :> es => Handle -> Eff es ()

71+hClose = unsafeEff_ . IO.hClose

72+

73+-- | Lifted version of 'IO.hFlush'

74+hFlush :: FileSystem :> es => Handle -> Eff es ()

75+hFlush = unsafeEff_ . IO.hFlush

76+

77+-- | Lifted version of 'IO.hFileSize'

78+hFileSize :: FileSystem :> es => Handle -> Eff es Integer

79+hFileSize = unsafeEff_ . IO.hFileSize

80+

81+-- | Lifted version of 'IO.hSetFileSize'

82+hSetFileSize :: FileSystem :> es => Handle -> Integer -> Eff es ()

83+hSetFileSize h = unsafeEff_ . IO.hSetFileSize h

84+

85+-- | Lifted version of 'IO.hIsEOF'

86+hIsEOF :: FileSystem :> es => Handle -> Eff es Bool

87+hIsEOF = unsafeEff_ . IO.hIsEOF

88+

89+-- | Lifted version of 'IO.hSetBuffering'

90+hSetBuffering :: FileSystem :> es => Handle -> IO.BufferMode -> Eff es ()

91+hSetBuffering h = unsafeEff_ . IO.hSetBuffering h

92+

93+-- | Lifted version of 'IO.hGetBuffering'

94+hGetBuffering :: FileSystem :> es => Handle -> Eff es IO.BufferMode

95+hGetBuffering = unsafeEff_ . IO.hGetBuffering

96+

97+-- | Lifted version of 'IO.hSeek'

98+hSeek :: FileSystem :> es => Handle -> IO.SeekMode -> Integer -> Eff es ()

99+hSeek h s = unsafeEff_ . IO.hSeek h s

100+

101+-- | Lifted version of 'IO.hTell'

102+hTell :: FileSystem :> es => Handle -> Eff es Integer

103+hTell = unsafeEff_ . IO.hTell

104+

105+-- | Lifted version of 'IO.hIsOpen'

106+hIsOpen :: FileSystem :> es => Handle -> Eff es Bool

107+hIsOpen = unsafeEff_ . IO.hIsOpen

108+

109+-- | Lifted version of 'IO.hIsClosed'

110+hIsClosed :: FileSystem :> es => Handle -> Eff es Bool

111+hIsClosed = unsafeEff_ . IO.hIsClosed

112+

113+-- | Lifted version of 'IO.hIsReadable'

114+hIsReadable :: FileSystem :> es => Handle -> Eff es Bool

115+hIsReadable = unsafeEff_ . IO.hIsReadable

116+

117+-- | Lifted version of 'IO.hIsWritable'

118+hIsWritable :: FileSystem :> es => Handle -> Eff es Bool

119+hIsWritable = unsafeEff_ . IO.hIsWritable

120+

121+-- | Lifted version of 'IO.hIsSeekable'

122+hIsSeekable :: FileSystem :> es => Handle -> Eff es Bool

123+hIsSeekable = unsafeEff_ . IO.hIsSeekable

124+

125+-- | Lifted version of 'IO.hIsTerminalDevice'

126+hIsTerminalDevice :: FileSystem :> es => Handle -> Eff es Bool

127+hIsTerminalDevice = unsafeEff_ . IO.hIsTerminalDevice

128+

129+-- | Lifted version of 'IO.hSetEcho'

130+hSetEcho :: FileSystem :> es => Handle -> Bool -> Eff es ()

131+hSetEcho h = unsafeEff_ . IO.hSetEcho h

132+

133+-- | Lifted version of 'IO.hGetEcho'

134+hGetEcho :: FileSystem :> es => Handle -> Eff es Bool

135+hGetEcho = unsafeEff_ . IO.hGetEcho

136+

137+-- | Lifted version of 'IO.hWaitForInput'

138+hWaitForInput :: FileSystem :> es => Handle -> Int -> Eff es Bool

139+hWaitForInput h = unsafeEff_ . IO.hWaitForInput h

140+

141+-- | Lifted version of 'IO.hReady'

142+hReady :: FileSystem :> es => Handle -> Eff es Bool

143+hReady = unsafeEff_ . IO.hReady

effectful/src/Effectful/Process.hs+7−9

@@ -1,8 +1,7 @@

1{-# LANGUAGE CPP #-}

2−

2+-- | Lifted version of "System.Process".

3module Effectful.Process

4− ( -- * Process effect

4+ ( Process

5− 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

132+ P.withCreateProcess cp $ \inh outh errh ph -> unlift $ cb inh outh errh ph

134− P.withCreateProcess cp (\inh outh errh ph -> runInIO $ 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

25import qualified Control.Monad.Trans.Resource.Internal as RI

26

27−import Effectful.Internal.Effect

27+import Effectful.Dispatch.Static

28−import Effectful.Internal.Env

28+import Effectful.Monad

29−import Effectful.Internal.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

11import qualified UnliftIO.Temporary as T

12

13−import Effectful.Internal.Effect

13+import Effectful.Dispatch.Static

14−import Effectful.Internal.Monad

14+import Effectful.Monad

15

16-- | An effect for interacting with temporary files.

17data Temporary :: Effect where

@@ -19,7 +19,7 @@ data Temporary :: Effect where

19

20-- | Run the 'Temporary' effect.

21runTemporary :: IOE :> es => Eff (Temporary : es) a -> Eff es a

22−runTemporary = evalEffect (IdE Temporary)

22+runTemporary = evalData (DataA Temporary)

23

24-- | Lifted 'T.withSystemTempFile'.

25withSystemTempFile

@@ -29,9 +29,8 @@ withSystemTempFile

29 -> (FilePath -> Handle -> Eff es a)

30 -- ^ Callback that can use the file.

31 -> Eff es a

32−withSystemTempFile template action = unsafeEff $ \es -> do

32+withSystemTempFile template action = unsafeUnliftIO $ \unlift -> do

33− seqUnliftEff es $ \unlift -> do

33+ T.withSystemTempFile template $ \fp handle -> unlift $ action fp handle

34− 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

44+ T.withSystemTempDirectory template $ \fp -> unlift $ action fp

46− 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

57+ T.withTempFile tmpDir template $ \fp handle -> unlift $ action fp handle

60− 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

70+ T.withTempDirectory tmpDir template $ \fp -> unlift $ action fp

74− T.withTempDirectory tmpDir template $ \fp -> unlift (action fp)

effectful/src/Effectful/Timeout.hs+4−6

@@ -6,8 +6,8 @@ module Effectful.Timeout

6

7import qualified System.Timeout as T

8

9−import Effectful.Internal.Effect

9+import Effectful.Dispatch.Static

10−import Effectful.Internal.Monad

10+import Effectful.Monad

11

12-- | An effect for timing out computations.

13data Timeout :: Effect where

@@ -15,7 +15,7 @@ data Timeout :: Effect where

15

16-- | Run the 'Timeout' effect.

17runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a

18−runTimeout = evalEffect (IdE Timeout)

18+runTimeout = evalData (DataA Timeout)

19

20-- | Lifted 'T.timeout'.

21timeout

@@ -25,6 +25,4 @@ timeout

25 -> Eff es a

26 -- ^ The computation the timeout applies to.

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/AsyncTests.hs+6−6

@@ -7,7 +7,7 @@ import Test.Tasty.HUnit

7import qualified Data.Set as S

8

9import Effectful

10−import Effectful.Async

10+import Effectful.Concurrent.Async

11import Effectful.Error

12import Effectful.State.Dynamic

13

@@ -23,7 +23,7 @@ asyncTests = testGroup "Async"

23 ]

24

25test_localState :: Assertion

26−test_localState = runEff . runAsyncE . evalLocalState x $ do

26+test_localState = runEff . runConcurrent . evalLocalState x $ do

27 replicateConcurrently_ 2 $ do

28 r <- goDownward 0

29 U.assertEqual "expected result" x r

@@ -41,7 +41,7 @@ test_localState = runEff . runAsyncE . evalLocalState x $ do

41 else goDownward $ acc + 1

42

43test_sharedState :: Assertion

44−test_sharedState = runEff . runAsyncE . evalSharedState (S.empty @Int) $ do

44+test_sharedState = runEff . runConcurrent . evalSharedState (S.empty @Int) $ do

45 concurrently_ (addWhen even x) (addWhen odd x)

46 U.assertEqual "expected result" (S.fromList [1..x]) =<< get

47 where

@@ -57,7 +57,7 @@ test_sharedState = runEff . runAsyncE . evalSharedState (S.empty @Int) $ do

57 addWhen f $ n - 1

58

59test_errorHandling :: Assertion

60−test_errorHandling = runEff . runAsyncE . evalSharedState (0::Int) $ do

60+test_errorHandling = runEff . runConcurrent . evalSharedState (0::Int) $ do

61 r <- runError $ concurrently_

62 (liftIO (threadDelay 10000) >> throwError err)

63 (modify (+x))

@@ -73,7 +73,7 @@ test_errorHandling = runEff . runAsyncE . evalSharedState (0::Int) $ do

73 err = "thrown from async"

74

75test_asyncWithUnmask :: Assertion

76−test_asyncWithUnmask = runEff . runAsyncE . evalLocalState "initial" $ do

76+test_asyncWithUnmask = runEff . runConcurrent . evalLocalState "initial" $ do

77 x <- asyncWithUnmask $ \unmask -> do

78 liftIO $ threadDelay 10000

79 r1 <- get @String -- 2

@@ -88,7 +88,7 @@ test_asyncWithUnmask = runEff . runAsyncE . evalLocalState "initial" $ do

88 (inner1, inner2, outer)

89

90test_pooledWorkers :: Assertion

91−test_pooledWorkers = runEff . runAsyncE . evalLocalState (0::Int) $ do

91+test_pooledWorkers = runEff . runConcurrent . evalLocalState (0::Int) $ do

92 x <- pooledForConcurrentlyN threads [1..n] $ \k -> do

93 r <- get @Int

94 modify @Int (+1)

effectful/tests/EnvironmentTests.hs+17−11

@@ -9,19 +9,25 @@ import Effectful.Environment

9import qualified Utils as U

10

11environmentTests :: TestTree

12−environmentTests = testGroup "Environment"

12+environmentTests = testCaseSteps "Environment" $ \step -> do

13− [ testCase "set and get an environment variable" test_setAndGet

13+ -- These tests need to be run sequentially because of

14− , testCase "unset and try to get an environment variable" test_unsetAndGet

14+ -- https://github.com/arybczak/effectful/issues/39.

15− , testCase "execute effects with custom arguments" test_withArgs

15+ step "set and get an environment variable"

16− , testCase "execute effects with custom program name" test_withProg

16+ test_setAndGet

17− ]

17+ step "unset and try to get an environment variable"

18+ test_unsetAndGet

19+ step "execute effects with custom arguments"

20+ test_withArgs

21+ step "execute effects with custom program name"

22+ test_withProg

18

23

19test_setAndGet :: Assertion

24test_setAndGet :: Assertion

20test_setAndGet = runEff . runEnvironment $ do

25test_setAndGet = runEff . runEnvironment $ do

21− let n = "EFFECTFUL_TEST1"

26+ let expected = "value"

22− setEnv n "value"

27+ n = "EFFECTFUL_TEST1"

28+ setEnv n expected

23 v <- getEnv n

29 v <- getEnv n

24− U.assertEqual "environment variable not set" v "value"

30+ U.assertEqual "environment variable not set" expected v

25

31

26test_unsetAndGet :: Assertion

32test_unsetAndGet :: Assertion

27test_unsetAndGet = runEff . runEnvironment $ do

33test_unsetAndGet = runEff . runEnvironment $ do

@@ -33,10 +39,10 @@ test_withArgs :: Assertion

33test_withArgs = runEff . runEnvironment $ do

39test_withArgs = runEff . runEnvironment $ do

34 let expected = ["effectful-test"]

40 let expected = ["effectful-test"]

35 args <- withArgs expected getArgs

41 args <- withArgs expected getArgs

36− U.assertEqual "correct arguments" args expected

42+ U.assertEqual "correct arguments" expected args

37

43

38test_withProg :: Assertion

44test_withProg :: Assertion

39test_withProg = runEff . runEnvironment $ do

45test_withProg = runEff . runEnvironment $ do

40 let expected = "effectful-test"

46 let expected = "effectful-test"

41 n <- withProgName expected getProgName

47 n <- withProgName expected getProgName

42− U.assertEqual "correct program name" n expected

48+ U.assertEqual "correct program name" expected n

effectful/tests/Main.hs+2

@@ -8,6 +8,7 @@ import EnvironmentTests

8import ErrorTests

9import StateTests

10import TimeoutTests

11+import UnliftTests

11

12

12main :: IO ()

13main :: IO ()

13main = defaultMain $ testGroup "effectful"

14main = defaultMain $ testGroup "effectful"

@@ -17,4 +18,5 @@ main = defaultMain $ testGroup "effectful"

17 , errorTests

18 , errorTests

18 , stateTests

19 , stateTests

19 , timeoutTests

20 , timeoutTests

21+ , unliftTests

20 ]

22 ]

effectful/tests/StateTests.hs+1

@@ -97,6 +97,7 @@ test_localEffects = runEff $ do

97 where

98 expected :: Int

99 expected = 4

100+

100----------------------------------------

101----------------------------------------

101-- Helpers

102-- Helpers

102

103

effectful/tests/UnliftTests.hsnew file+93

@@ -0,0 +1,93 @@

1+module UnliftTests (unliftTests) where

2+

3+import Control.Exception

4+import Test.Tasty

5+import Test.Tasty.HUnit

6+import qualified UnliftIO.Async as A

7+

8+import Effectful

9+import qualified Utils as U

10+

11+unliftTests :: TestTree

12+unliftTests = testGroup "Unlift"

13+ [ testCase "Reset strategy in new thread" test_resetStrategy

14+ , testCase "SeqUnlift in new thread" test_seqUnliftInNewThread

15+ , testGroup "Ephemeral strategy"

16+ [ testCase "Invalid limit" test_ephemeralInvalid

17+ , testCase "Uses in same thread" test_ephemeralSameThread

18+ , testCase "Uses in multiple threads" test_ephemeralMultipleThreads

19+ ]

20+ , testGroup "Persistent strategy"

21+ [ testCase "Invalid limit" test_persistentInvalid

22+ , testCase "Uses in same thread" test_persistentSameThread

23+ , testCase "Uses in multiple threads" test_persistentMultipleThreads

24+ ]

25+ ]

26+

27+test_resetStrategy :: Assertion

28+test_resetStrategy = runEff $ do

29+ s <- withUnliftStrategy (ConcUnlift Ephemeral Unlimited) $ do

30+ withEffToIO $ \runInIO -> do

31+ inThread $ runInIO unliftStrategy

32+ U.assertEqual "correct strategy" SeqUnlift s

33+

34+test_seqUnliftInNewThread :: Assertion

35+test_seqUnliftInNewThread = runEff $ do

36+ assertThrowsUnliftError "InvalidUseOfSeqUnlift error" $ do

37+ withUnliftStrategy SeqUnlift $ do

38+ withEffToIO $ \runInIO -> do

39+ inThread $ runInIO $ return ()

40+

41+test_ephemeralInvalid :: Assertion

42+test_ephemeralInvalid = runEff $ do

43+ assertThrowsUnliftError "InvalidNumberOfUses error" $ do

44+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 0) $ do

45+ withEffToIO $ \_ -> return ()

46+

47+test_ephemeralSameThread :: Assertion

48+test_ephemeralSameThread = runEff $ do

49+ assertThrowsUnliftError "ExceededNumberOfUses error" $ do

50+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do

51+ withEffToIO $ \runInIO -> inThread $ do

52+ runInIO $ return ()

53+ runInIO $ return ()

54+

55+test_ephemeralMultipleThreads :: Assertion

56+test_ephemeralMultipleThreads = runEff $ do

57+ assertThrowsUnliftError "ExceededNumberOfUses error" $ do

58+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do

59+ withEffToIO $ \runInIO -> do

60+ inThread $ runInIO $ return ()

61+ inThread $ runInIO $ return ()

62+

63+test_persistentInvalid :: Assertion

64+test_persistentInvalid = runEff $ do

65+ assertThrowsUnliftError "InvalidNumberOfThreads error" $ do

66+ withUnliftStrategy (ConcUnlift Persistent $ Limited 0) $ do

67+ withEffToIO $ \_ -> return ()

68+

69+test_persistentSameThread :: Assertion

70+test_persistentSameThread = runEff $ do

71+ withUnliftStrategy (ConcUnlift Persistent $ Limited 1) $ do

72+ withEffToIO $ \runInIO -> inThread $ do

73+ runInIO $ return ()

74+ runInIO $ return ()

75+

76+test_persistentMultipleThreads :: Assertion

77+test_persistentMultipleThreads = runEff $ do

78+ assertThrowsUnliftError "ExceededNumberOfThreads error" $ do

79+ withUnliftStrategy (ConcUnlift Persistent $ Limited 1) $ do

80+ withEffToIO $ \runInIO -> do

81+ inThread $ runInIO $ return ()

82+ inThread $ runInIO $ return ()

83+

84+----------------------------------------

85+-- Helpers

86+

87+assertThrowsUnliftError

88+ :: IOE :> es

89+ => String -> Eff es a -> Eff es ()

90+assertThrowsUnliftError err = U.assertThrows err (\ErrorCall{} -> True)

91+

92+inThread :: IO a -> IO a

93+inThread k = A.async k >>= A.wait