50cdcbf..master · effectful

.github/workflows/haskell-ci.yml+30−37

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

11+# version: 0.13.20211116

12#

13−# REGENDATA ("0.13.20210621",["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,26 +24,23 @@ 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.20210422

35+ - compiler: ghc-9.2.1

34 compilerKind: ghc

36 compilerKind: ghc

35− compilerVersion: 9.2.0.20210422

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

40+ - compiler: ghc-8.10.7

44 compilerKind: ghc

41 compilerKind: ghc

45− compilerVersion: 8.10.4

42+ compilerVersion: 8.10.7

46− setup-method: hvr-ppa

43+ setup-method: ghcup

47 allow-failure: false

44 allow-failure: false

48 - compiler: ghc-8.8.4

45 - compiler: ghc-8.8.4

49 compilerKind: ghc

46 compilerKind: ghc

@@ -58,14 +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.14.1/x86_64-linux-ghcup-0.1.14.1 > "$HOME/.ghcup/bin/ghcup"

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

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.4.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" cabal-install-3.4

65+ apt-get install -y "$HCNAME"

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

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

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

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

69 fi

70 fi

70 env:

71 env:

71 HCKIND: ${{ matrix.compilerKind }}

72 HCKIND: ${{ matrix.compilerKind }}

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

83 echo "HC=$HC" >> "$GITHUB_ENV"

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

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

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

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

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

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

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

87 else

88 else

88 HC=$HCDIR/bin/$HCKIND

89 HC=$HCDIR/bin/$HCKIND

89 echo "HC=$HC" >> "$GITHUB_ENV"

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

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

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

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

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

92− echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> "$GITHUB_ENV"

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

93 fi

94 fi

94

95

95 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))')

96 echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"

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

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

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

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

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

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

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

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

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

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

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

102 env:

103 env:

@@ -125,17 +126,10 @@ jobs:

125 repository hackage.haskell.org

126 repository hackage.haskell.org

126 url: http://hackage.haskell.org/

127 url: http://hackage.haskell.org/

127 EOF

128 EOF

128− if $HEADHACKAGE; then

129 cat >> $CABAL_CONFIG <<EOF

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

130+ program-default-options

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

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

132− secure: True

133− root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d

134− 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329

135− f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89

136− key-threshold: 3

137 EOF

132 EOF

138− fi

139 cat $CABAL_CONFIG

133 cat $CABAL_CONFIG

140 - name: versions

134 - name: versions

141 run: |

135 run: |

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

148 - name: cache (tools)

142 - name: cache (tools)

149 uses: actions/cache@v2

143 uses: actions/cache@v2

150 with:

144 with:

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

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

152 path: ~/.haskell-ci-tools

146 path: ~/.haskell-ci-tools

153 - name: install cabal-plan

147 - name: install cabal-plan

154 run: |

148 run: |

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

161 cabal-plan --version

155 cabal-plan --version

162 - name: install doctest

156 - name: install doctest

163 run: |

157 run: |

164− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.18' ; fi

158+ $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.20'

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

159+ doctest --version

166 - name: checkout

160 - name: checkout

167 uses: actions/checkout@v2

161 uses: actions/checkout@v2

168 with:

162 with:

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

200 package effectful

194 package effectful

201 flags: +benchmark-foreign-libraries

195 flags: +benchmark-foreign-libraries

202 EOF

196 EOF

203− if $HEADHACKAGE; then

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

205− fi

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

207 cat cabal.project

198 cat cabal.project

208 cat cabal.project.local

199 cat cabal.project.local

@@ -231,10 +222,12 @@ jobs:

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

232 - name: doctest

223 - name: doctest

233 run: |

224 run: |

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

225+ cd ${PKGDIR_effectful} || false

235− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XStrictData -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi

226+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src

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

227+ cd ${PKGDIR_effectful_core} || false

228+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src

229+ cd ${PKGDIR_effectful_core} || false

237− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XStrictData -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src ; fi

230+ doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators utils

238 - name: cabal check

231 - name: cabal check

239 run: |

232 run: |

240 cd ${PKGDIR_effectful} || false

233 cd ${PKGDIR_effectful} || false

README.md+10−3

@@ -1,7 +1,10 @@

1# effectful

2

3[![Build Status](https://github.com/arybczak/effectful/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/arybczak/effectful/actions?query=branch%3Amaster)

4+[![Documentation](https://img.shields.io/static/v1?label=docs&message=effectful-core-0.1&color=informational)](https://rybczak.net/files/effectful/effectful-core-0.1-docs)

4−[![Documentation](https://img.shields.io/static/v1?label=docs&message=0.0.0.0&color=informational)](https://rybczak.net/files/effectful/effectful-0.0.0.0-docs)

5+[![Documentation](https://img.shields.io/static/v1?label=docs&message=effectful-0.1&color=informational)](https://rybczak.net/files/effectful/effectful-0.1-docs)

6+

7+<img src="https://user-images.githubusercontent.com/387658/127747903-f728437f-2ee4-47b8-9f0c-5102fd44c8e4.png" width="128">

5

8

6*Note:* this is a pre-release.

9*Note:* this is a pre-release.

7

10

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

17

20

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

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

19

22

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

21− discarded state).

24+ modifications).

22

25

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

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

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

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

@@ -136,3 +139,7 @@ Blog posts:

136* [ReaderT design pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/) by Michael Snoyman.

139* [ReaderT design pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/) by Michael Snoyman.

137

140

138* [Exceptions Best Practices](https://www.fpcomplete.com/blog/2016/11/exceptions-best-practices-haskell/) by Michael Snoyman.

141* [Exceptions Best Practices](https://www.fpcomplete.com/blog/2016/11/exceptions-best-practices-haskell/) by Michael Snoyman.

142+

143+----------------------------------------

144+

145+<div>Icons made by <a href="https://www.freepik.com" title="Freepik">Freepik</a> from <a href="https://www.flaticon.com/" title="Flaticon">www.flaticon.com</a></div>

cabal.haskell-ci+1−3

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

1branches: master

2

3−doctest: <9.2

3+doctest: <9.3

4tests: True

5benchmarks: True

6

7−ghcup-jobs: >=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−2

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

@@ -29,7 +30,6 @@ run_doctest() {

29 -XRoleAnnotations \

30 -XRoleAnnotations \

30 -XScopedTypeVariables \

31 -XScopedTypeVariables \

31 -XStandaloneDeriving \

32 -XStandaloneDeriving \

32− -XStrictData \

33 -XTupleSections \

34 -XTypeApplications \

35 -XTypeFamilies \

@@ -37,5 +37,5 @@ run_doctest() {

37 popd

38}

39

40−run_doctest effectful src

41run_doctest effectful-core src

40run_doctest effectful-core src

41+run_doctest effectful src

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

@@ -1,7 +1,7 @@

1cabal-version: 2.4

2build-type: Simple

3name: effectful-core

4−version: 0.0.0.0

4+version: 0.1

5license: BSD-3-Clause

6license-file: LICENSE

7category: Control

@@ -12,14 +12,13 @@ synopsis: An easy to use, performant extensible effects library.

12description: An easy to use, performant extensible effects library with seamless

13 integration with the existing Haskell ecosystem.

14 .

15− This library provides the core of the effect system and is quiet

15+ This library provides core definitions with a minimal dependency

16− minimal. If you look for something more sophisticated have a look

17− at the @<https://hackage.haskell.org/package/effectful effectful>@

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

18− package.

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

19

18

20extra-source-files: CHANGELOG.md

19extra-source-files: CHANGELOG.md

21

20

22−tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210422

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

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

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

47 RoleAnnotations

48 ScopedTypeVariables

49 StandaloneDeriving

50− StrictData

51 TupleSections

50 TupleSections

52 TypeApplications

51 TypeApplications

53 TypeFamilies

52 TypeFamilies

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

68

67

69 ghc-options: -O2

68 ghc-options: -O2

70

69

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

70+ build-depends: effectful-internal-utils

71+

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

72− , containers

73+ , containers >= 0.6

73− , effectful-internal-utils

74− , exceptions

74+ , exceptions >= 0.10.4

75− , monad-control

75+ , monad-control >= 1.0.3

76− , primitive

76+ , primitive >= 0.7.3.0

77− , transformers-base

77+ , transformers-base >= 0.4.6

78− , unliftio-core

78+ , unliftio-core >= 0.2.0.1

79

80 hs-source-dirs: src

81

82− exposed-modules: Effectful.Error

82+ exposed-modules: Effectful

83+ Effectful.Dispatch.Dynamic

84+ Effectful.Dispatch.Static

85+ Effectful.Error

83 Effectful.Error.Dynamic

86 Effectful.Error.Dynamic

84 Effectful.Fail

87 Effectful.Fail

85− Effectful.Handler

86 Effectful.Internal.Effect

88 Effectful.Internal.Effect

87 Effectful.Internal.Env

89 Effectful.Internal.Env

88 Effectful.Internal.Monad

90 Effectful.Internal.Monad

effectful/src/Effectful.hs → effectful-core/src/Effectful.hsrenamed+8−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

@@ -48,7 +48,11 @@ module Effectful

48 -- *** Bidirectional lifts

49 , localLiftUnlift

50 , localLiftUnliftIO

51+

52+ -- * Re-exports

53+ , MonadIO(..)

54+ , MonadUnliftIO(..)

51 ) where

55 ) where

52

56

53−import Effectful.Handler

57+import Effectful.Dispatch.Dynamic

54import Effectful.Monad

58import Effectful.Monad

effectful-core/src/Effectful/Handler.hs → effectful-core/src/Effectful/Dispatch/Dynamic.hsrenamed+81−104

@@ -1,12 +1,13 @@

1−module Effectful.Handler

1+module Effectful.Dispatch.Dynamic

2 ( -- * Sending operations to the handler

3 send

4

5 -- * Handling effects

6+ , EffectHandler

6 , interpret

7 , interpret

7 , reinterpret

8 , reinterpret

8

9

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

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

10 , LocalEnv

11 , LocalEnv

11

12

12 -- *** Unlifts

13 -- *** Unlifts

@@ -23,89 +24,46 @@ module Effectful.Handler

23 , localLiftUnlift

24 , localLiftUnlift

24 , localLiftUnliftIO

25 , localLiftUnliftIO

25

26

27+ -- *** Utils

28+ , SuffixOf

29+

26 -- * Re-exports

30 -- * Re-exports

27 , HasCallStack

31 , HasCallStack

28 ) where

32 ) where

29

33

30import Control.Monad.IO.Unlift

34import Control.Monad.IO.Unlift

31−import GHC.Stack

35+import Data.Kind

32−import qualified Control.Exception as E

36+import GHC.Stack (HasCallStack)

33

37

34import Effectful.Internal.Effect

38import Effectful.Internal.Effect

35import Effectful.Internal.Env

39import Effectful.Internal.Env

36import Effectful.Internal.Monad

40import Effectful.Internal.Monad

37

41

38----------------------------------------

42----------------------------------------

39−-- Handler

43+-- Handling effects

40−

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

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

43−-- handler.

44−newtype LocalEnv es = LocalEnv (Env es)

45−

46−data Handler (e :: Effect) = forall handlerEs. Handler

47− { _env :: Env handlerEs

48− , _handle :: forall a localEs. HasCallStack

49− => LocalEnv localEs

50− -> e (Eff localEs) a

51− -> Eff handlerEs a

52− }

53−

54−runHandler :: Env es -> Handler e -> Eff (e : es) a -> IO a

55−runHandler es0 e m = do

56− size0 <- sizeEnv es0

57− E.bracket (unsafeConsEnv e relinker es0)

58− (unsafeTailEnv size0)

59− (\es -> unEff m es)

60− where

61− relinker :: Relinker Handler e

62− relinker = Relinker $ \relink Handler{..} -> do

63− env <- relink _env

64− pure Handler { _env = env, .. }

65−

66−----------------------------------------

67−-- Sending operations

68−

69−-- | Send an operation of a given effect to its handler for execution.

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

71−send op = unsafeEff $ \es -> do

72− Handler{..} <- getEnv es

73− unEff (_handle (LocalEnv es) op) _env

74−

75−----------------------------------------

76−-- Interpretation

77

44

78-- | Interpret an effect.

45-- | Interpret an effect.

79−--

80−-- /Note:/ 'LocalEnv' is for handling local 'Eff' operations using a function

81−-- from the 'localUnlift' family.

82interpret

46interpret

83− :: (forall r localEs. HasCallStack => LocalEnv localEs -> e (Eff localEs) r -> Eff es r)

47+ :: EffectHandler e es

84 -- ^ The effect handler.

48 -- ^ The effect handler.

85 -> Eff (e : es) a

49 -> Eff (e : es) a

86 -> Eff es a

50 -> Eff es a

87interpret handler m = unsafeEff $ \es -> do

51interpret handler m = unsafeEff $ \es -> do

88 les <- forkEnv es

52 les <- forkEnv es

89− runHandler es (Handler les handler) m

53+ (`unEff` es) $ runHandler (HandlerA les handler) m

90−

91−----------------------------------------

92−-- Reinterpretation

93

54

94-- | Interpret an effect using other effects.

55-- | Interpret an effect using other effects.

95−--

96−-- /Note:/ 'LocalEnv' is for handling local 'Eff' operations using a function

97−-- from the 'localUnlift' family.

98reinterpret

56reinterpret

99 :: (Eff handlerEs a -> Eff es b)

57 :: (Eff handlerEs a -> Eff es b)

100 -- ^ Introduction of effects encapsulated within the handler.

58 -- ^ Introduction of effects encapsulated within the handler.

101− -> (forall r localEs. HasCallStack => LocalEnv localEs -> e (Eff localEs) r -> Eff handlerEs r)

59+ -> EffectHandler e handlerEs

102 -- ^ The effect handler.

60 -- ^ The effect handler.

103 -> Eff (e : es) a

61 -> Eff (e : es) a

104 -> Eff es b

62 -> Eff es b

105reinterpret runHandlerEs handler m = unsafeEff $ \es -> do

63reinterpret runHandlerEs handler m = unsafeEff $ \es -> do

106 les0 <- forkEnv es

64 les0 <- forkEnv es

107 (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do

65 (`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do

108− runHandler es (Handler les handler) m

66+ (`unEff` es) $ runHandler (HandlerA les handler) m

109

67

110----------------------------------------

68----------------------------------------

111-- Unlifts

69-- Unlifts

@@ -113,31 +71,31 @@ reinterpret runHandlerEs handler m = unsafeEff $ \es -> do

113-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the

71-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the

114-- general version see 'localUnlift'.

72-- general version see 'localUnlift'.

115localSeqUnlift

73localSeqUnlift

116− :: HasCallStack

74+ :: (HasCallStack, SuffixOf es handlerEs)

117− => LocalEnv localEs

75+ => LocalEnv localEs handlerEs

118 -- ^ Local environment.

76 -- ^ Local environment.

119 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)

77 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)

120 -- ^ Continuation with the unlifting function in scope.

78 -- ^ Continuation with the unlifting function in scope.

121 -> Eff es a

79 -> Eff es a

122localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do

80localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do

123− unsafeSeqUnliftEff les $ \unlift -> do

81+ seqUnliftIO les $ \unlift -> do

124 (`unEff` es) $ k $ unsafeEff_ . unlift

82 (`unEff` es) $ k $ unsafeEff_ . unlift

125

83

126-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the

84-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the

127-- general version see 'localUnliftIO'.

85-- general version see 'localUnliftIO'.

128localSeqUnliftIO

86localSeqUnliftIO

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

87+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)

130− => LocalEnv localEs

88+ => LocalEnv localEs handlerEs

131 -- ^ Local environment.

89 -- ^ Local environment.

132 -> ((forall r. Eff localEs r -> IO r) -> IO a)

90 -> ((forall r. Eff localEs r -> IO r) -> IO a)

133 -- ^ Continuation with the unlifting function in scope.

91 -- ^ Continuation with the unlifting function in scope.

134 -> Eff es a

92 -> Eff es a

135−localSeqUnliftIO (LocalEnv les) k = liftIO $ unsafeSeqUnliftEff les k

93+localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k

136

94

137-- | Create a local unlifting function with the given strategy.

95-- | Create a local unlifting function with the given strategy.

138localUnlift

96localUnlift

139− :: HasCallStack

97+ :: (HasCallStack, SuffixOf es handlerEs)

140− => LocalEnv localEs

98+ => LocalEnv localEs handlerEs

141 -- ^ Local environment.

99 -- ^ Local environment.

142 -> UnliftStrategy

100 -> UnliftStrategy

143 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)

101 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)

@@ -145,58 +103,62 @@ localUnlift

145 -> Eff es a

103 -> Eff es a

146localUnlift (LocalEnv les) strategy k = case strategy of

104localUnlift (LocalEnv les) strategy k = case strategy of

147 SeqUnlift -> unsafeEff $ \es -> do

105 SeqUnlift -> unsafeEff $ \es -> do

148− unsafeSeqUnliftEff les $ \unlift -> do

106+ seqUnliftIO les $ \unlift -> do

149 (`unEff` es) $ k $ unsafeEff_ . unlift

107 (`unEff` es) $ k $ unsafeEff_ . unlift

150 ConcUnlift p l -> unsafeEff $ \es -> do

108 ConcUnlift p l -> unsafeEff $ \es -> do

151− unsafeConcUnliftEff les p l $ \unlift -> do

109+ concUnliftIO les p l $ \unlift -> do

152 (`unEff` es) $ k $ unsafeEff_ . unlift

110 (`unEff` es) $ k $ unsafeEff_ . unlift

153

111

154-- | Create a local unlifting function with the given strategy.

112-- | Create a local unlifting function with the given strategy.

155localUnliftIO

113localUnliftIO

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

114+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)

157− => LocalEnv localEs

115+ => LocalEnv localEs handlerEs

158 -- ^ Local environment.

116 -- ^ Local environment.

159 -> UnliftStrategy

117 -> UnliftStrategy

160 -> ((forall r. Eff localEs r -> IO r) -> IO a)

118 -> ((forall r. Eff localEs r -> IO r) -> IO a)

161 -- ^ Continuation with the unlifting function in scope.

119 -- ^ Continuation with the unlifting function in scope.

162 -> Eff es a

120 -> Eff es a

163localUnliftIO (LocalEnv les) strategy k = case strategy of

121localUnliftIO (LocalEnv les) strategy k = case strategy of

164− SeqUnlift -> liftIO $ unsafeSeqUnliftEff les k

122+ SeqUnlift -> liftIO $ seqUnliftIO les k

165− ConcUnlift p l -> liftIO $ unsafeConcUnliftEff les p l k

123+ ConcUnlift p l -> liftIO $ concUnliftIO les p l k

166

124

167−-- | Utility for lifting 'Eff' operations of type

125+-- | Utility for lifting 'Eff' computations of type

168--

126--

169-- @'Eff' es a -> 'Eff' es b@

127-- @'Eff' es a -> 'Eff' es b@

170--

128--

171-- to

129-- to

172--

130--

173−-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@

131+-- @'Eff' localEs a -> 'Eff' localEs b@

174--

132--

175−-- /Note:/ the operation must not run its argument in a separate thread,

133+-- /Note:/ the computation must not run its argument in a separate thread,

176-- attempting to do so will result in a runtime error.

134-- attempting to do so will result in a runtime error.

177withLiftMap

135withLiftMap

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

136+ :: (HasCallStack, SuffixOf es handlerEs)

137+ => LocalEnv localEs handlerEs

138+ -- ^ Local environment.

179− => ((forall a b localEs. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)

139+ -> ((forall a b. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)

180 -- ^ Continuation with the lifting function in scope.

140 -- ^ Continuation with the lifting function in scope.

181 -> Eff es r

141 -> Eff es r

182−withLiftMap k = unsafeEff $ \es -> do

142+withLiftMap !_ k = unsafeEff $ \es -> do

143+ -- The LocalEnv parameter is not used, but we need it to constraint the

144+ -- localEs type variable. It's also strict so that callers don't cheat.

183 (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do

145 (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do

184− unsafeSeqUnliftEff localEs $ \unlift -> do

146+ seqUnliftIO localEs $ \unlift -> do

185− (`unEff` es) . mapEff . liftIO $ unlift m

147+ (`unEff` es) . mapEff . unsafeEff_ $ unlift m

186

148

187−-- | Utility for lifting 'IO' operations of type

149+-- | Utility for lifting 'IO' computations of type

188--

150--

189-- @'IO' a -> 'IO' b@

151-- @'IO' a -> 'IO' b@

190--

152--

191-- to

153-- to

192--

154--

193−-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@

155+-- @'Eff' localEs a -> 'Eff' localEs b@

194--

156--

195−-- /Note:/ the operation must not run its argument in a separate thread,

157+-- /Note:/ the computation must not run its argument in a separate thread,

196-- attempting to do so will result in a runtime error.

158-- attempting to do so will result in a runtime error.

197--

159--

198-- Useful e.g. for lifting the unmasking function in

160-- Useful e.g. for lifting the unmasking function in

199−-- 'Control.Exception.mask'-like operations:

161+-- 'Control.Exception.mask'-like computations:

200--

162--

201-- >>> :{

163-- >>> :{

202-- data Fork :: Effect where

164-- data Fork :: Effect where

@@ -205,31 +167,35 @@ withLiftMap k = unsafeEff $ \es -> do

205--

167--

206-- >>> :{

168-- >>> :{

207-- runFork :: IOE :> es => Eff (Fork : es) a -> Eff es a

169-- runFork :: IOE :> es => Eff (Fork : es) a -> Eff es a

208−-- runFork = interpret $ \env (ForkWithUnmask m) -> withLiftMapIO $ \liftMap -> do

170+-- runFork = interpret $ \env (ForkWithUnmask m) -> withLiftMapIO env $ \liftMap -> do

209-- localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

171-- localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

210-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

172-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

211-- :}

173-- :}

212withLiftMapIO

174withLiftMapIO

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

175+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)

176+ => LocalEnv localEs handlerEs

177+ -- ^ Local environment.

214− => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)

178+ -> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)

215 -- ^ Continuation with the lifting function in scope.

179 -- ^ Continuation with the lifting function in scope.

216 -> Eff es r

180 -> Eff es r

217−withLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do

181+withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do

182+ -- The LocalEnv parameter is not used, but we need it to constraint the

183+ -- localEs type variable. It's also strict so that callers don't cheat.

218− unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m

184+ seqUnliftIO es $ \unlift -> mapIO $ unlift m

219

185

220----------------------------------------

186----------------------------------------

221-- Bidirectional lifts

187-- Bidirectional lifts

222

188

223-- | Create a local lifting and unlifting function with the given strategy.

189-- | Create a local lifting and unlifting function with the given strategy.

224--

190--

225−-- Useful for lifting complicated 'Eff' operations where the monadic action

191+-- Useful for lifting complicated 'Eff' computations where the monadic action

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

227--

193--

228−-- /Note:/ depending on the operation you're lifting 'localUnlift' along with

194+-- /Note:/ depending on the computation you're lifting 'localUnlift' along with

229-- 'withLiftMap' might be enough and is more efficient.

195-- 'withLiftMap' might be enough and is more efficient.

230localLiftUnlift

196localLiftUnlift

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

197+ :: (HasCallStack, SuffixOf es handlerEs)

232− => LocalEnv localEs

198+ => LocalEnv localEs handlerEs

233 -- ^ Local environment.

199 -- ^ Local environment.

234 -> UnliftStrategy

200 -> UnliftStrategy

235 -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a)

201 -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a)

@@ -237,33 +203,44 @@ localLiftUnlift

237 -> Eff es a

203 -> Eff es a

238localLiftUnlift (LocalEnv les) strategy k = case strategy of

204localLiftUnlift (LocalEnv les) strategy k = case strategy of

239 SeqUnlift -> unsafeEff $ \es -> do

205 SeqUnlift -> unsafeEff $ \es -> do

240− unsafeSeqUnliftEff es $ \unliftEs -> do

206+ seqUnliftIO es $ \unliftEs -> do

241− unsafeSeqUnliftEff les $ \unliftLocalEs -> do

207+ seqUnliftIO les $ \unliftLocalEs -> do

242− (`unEff` es) $ k (unsafeEff_ . unliftEs) (liftIO . unliftLocalEs)

208+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)

243 ConcUnlift p l -> unsafeEff $ \es -> do

209 ConcUnlift p l -> unsafeEff $ \es -> do

244− unsafeConcUnliftEff es p l $ \unliftEs -> do

210+ concUnliftIO es p l $ \unliftEs -> do

245− unsafeConcUnliftEff les p l $ \unliftLocalEs -> do

211+ concUnliftIO les p l $ \unliftLocalEs -> do

246− (`unEff` es) $ k (unsafeEff_ . unliftEs) (liftIO . unliftLocalEs)

212+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)

247

213

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

249-- unrestricted lifting function.

215-- unrestricted lifting function.

250--

216--

251−-- Useful for lifting complicated 'IO' operations where the monadic action shows

217+-- Useful for lifting complicated 'IO' computations where the monadic action

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

253--

219--

254−-- /Note:/ depending on the operation you're lifting 'localUnliftIO' along with

220+-- /Note:/ depending on the computation you're lifting 'localUnliftIO' along

255−-- 'withLiftMapIO' might be enough and is more efficient.

221+-- with 'withLiftMapIO' might be enough and is more efficient.

256localLiftUnliftIO

222localLiftUnliftIO

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

223+ :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)

258− => LocalEnv localEs

224+ => LocalEnv localEs handlerEs

259 -- ^ Local environment.

225 -- ^ Local environment.

260 -> UnliftStrategy

226 -> UnliftStrategy

261 -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a)

227 -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a)

262 -- ^ Continuation with the lifting and unlifting function in scope.

228 -- ^ Continuation with the lifting and unlifting function in scope.

263 -> Eff es a

229 -> Eff es a

264localLiftUnliftIO (LocalEnv les) strategy k = case strategy of

230localLiftUnliftIO (LocalEnv les) strategy k = case strategy of

265− SeqUnlift -> liftIO $ unsafeSeqUnliftEff les $ k unsafeEff_

231+ SeqUnlift -> liftIO $ seqUnliftIO les $ k unsafeEff_

266− ConcUnlift p l -> liftIO $ unsafeConcUnliftEff 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

267

244

268-- $setup

245-- $setup

269-- >>> 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+99−30

@@ -1,29 +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

9−'Control.Exception.SomeException' or 'Control.Exception.ErrorCall' you could use

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

10−'Control.Monad.Catch.catch':

17+-- 'Control.Monad.Catch.catch' (or a similar function):

11−

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

12−>>> import qualified Control.Monad.Catch as E

24+-- 'Control.Monad.Catch.bracket' work as expected:

25+--

26+-- >>> let msg = liftIO . putStrLn

13−>>> :{

27+-- >>> :{

14− let boom :: Eff es String

28+-- runEff . fmap (either (Left . snd) Right) . runError @String $ do

15− boom = error "BOOM!"

29+-- E.bracket_ (msg "Beginning.")

16− in

30+-- (msg "Cleaning up.")

17− runEff $ boom `E.catch` \(e :: ErrorCall) -> pure "caught some error"

31+-- (msg "Computing." >> throwError "oops" >> msg "More.")

18−:}

32+-- :}

19−"caught some error"

33+-- Beginning.

20−

34+-- Computing.

21−-}

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.

22module Effectful.Error

70module Effectful.Error

23 ( Error

71 ( Error

24 , runError

72 , runError

25 , throwError

73 , throwError

26 , catchError

74 , catchError

75+ , handleError

27 , tryError

76 , tryError

28

77

29 -- * Re-exports

78 -- * Re-exports

@@ -38,13 +87,14 @@ import Data.Typeable

38import Data.Unique

87import Data.Unique

39import GHC.Stack

88import GHC.Stack

40

89

41−import Effectful.Internal.Effect

90+import Effectful.Dispatch.Static

42−import Effectful.Internal.Env

43−import Effectful.Internal.Monad

91+import Effectful.Monad

44

92

93+-- | Provide the ability to handle errors of type @e@.

45−data Error e :: Effect where

94+newtype Error e :: Effect where

46 Error :: ErrorId -> Error e m r

95 Error :: ErrorId -> Error e m r

47

96

97+-- | Handle errors of type @e@.

48runError

98runError

49 :: forall e es a. Typeable e

99 :: forall e es a. Typeable e

50 => Eff (Error e : es) a

100 => Eff (Error e : es) a

@@ -52,9 +102,9 @@ runError

52runError m = unsafeEff $ \es0 -> mask $ \release -> do

102runError m = unsafeEff $ \es0 -> mask $ \release -> do

53 eid <- newErrorId

103 eid <- newErrorId

54 size0 <- sizeEnv es0

104 size0 <- sizeEnv es0

55− es <- unsafeConsEnv (IdE (Error @e eid)) noRelinker es0

105+ es <- unsafeConsEnv (DataA (Error @e eid)) noRelinker es0

56 r <- tryErrorIO release eid es `onException` unsafeTailEnv size0 es

106 r <- tryErrorIO release eid es `onException` unsafeTailEnv size0 es

57− _ <- unsafeTailEnv size0 es

107+ unsafeTailEnv size0 es

58 pure r

108 pure r

59 where

109 where

60 tryErrorIO release eid es = try (release $ unEff m es) >>= \case

110 tryErrorIO release eid es = try (release $ unEff m es) >>= \case

@@ -62,29 +112,48 @@ runError m = unsafeEff $ \es0 -> mask $ \release -> do

62 Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))

112 Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))

63 $ throwIO ex

113 $ throwIO ex

64

114

115+-- | Throw an error of type @e@.

65throwError

116throwError

66 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)

117 :: forall e es a. (HasCallStack, Typeable e, Error e :> es)

67 => e

118 => e

119+ -- ^ The error.

68 -> Eff es a

120 -> Eff es a

69throwError e = unsafeEff $ \es -> do

121throwError e = unsafeEff $ \es -> do

70− IdE (Error eid) <- getEnv @(Error e) es

122+ DataA (Error eid) <- getEnv @(Error e) es

71 throwIO $ ErrorEx eid callStack e

123 throwIO $ ErrorEx eid callStack e

72

124

125+-- | Handle an error of type @e@.

73catchError

126catchError

74 :: forall e es a. (Typeable e, Error e :> es)

127 :: forall e es a. (Typeable e, Error e :> es)

75 => Eff es a

128 => Eff es a

129+ -- ^ The inner computation.

76 -> (CallStack -> e -> Eff es a)

130 -> (CallStack -> e -> Eff es a)

131+ -- ^ A handler for errors in the inner computation.

77 -> Eff es a

132 -> Eff es a

78catchError m handler = unsafeEff $ \es -> do

133catchError m handler = unsafeEff $ \es -> do

79− IdE (Error eid) <- getEnv @(Error e) es

134+ DataA (Error eid) <- getEnv @(Error e) es

80 size <- sizeEnv es

135 size <- sizeEnv es

81 catchErrorIO eid (unEff m es) $ \cs e -> do

136 catchErrorIO eid (unEff m es) $ \cs e -> do

82 checkSizeEnv size es

137 checkSizeEnv size es

83 unEff (handler cs e) es

138 unEff (handler cs e) es

84

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.

85tryError

153tryError

86 :: forall e es a. (Typeable e, Error e :> es)

154 :: forall e es a. (Typeable e, Error e :> es)

87 => Eff es a

155 => Eff es a

156+ -- ^ The inner computation.

88 -> Eff es (Either (CallStack, e) a)

157 -> Eff es (Either (CallStack, e) a)

89tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)

158tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)

90

159

@@ -112,7 +181,7 @@ tryHandler ex eid0 handler next = case fromException ex of

112 | otherwise -> next

181 | otherwise -> next

113 Nothing -> next

182 Nothing -> next

114

183

115−data ErrorEx e = ErrorEx ErrorId CallStack e

184+data ErrorEx e = ErrorEx !ErrorId CallStack e

116instance Typeable e => Show (ErrorEx e) where

185instance Typeable e => Show (ErrorEx e) where

117 showsPrec p (ErrorEx _ cs e)

186 showsPrec p (ErrorEx _ cs e)

118 = ("Effectful.Error.ErrorEx (" ++)

187 = ("Effectful.Error.ErrorEx (" ++)

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+11−1

@@ -1,6 +1,16 @@

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

8+import Effectful.Error

6import Effectful.Internal.Monad

9import Effectful.Internal.Monad

10+

11+-- | Run the 'Fail' effect via 'Error'.

12+runFail :: Eff (Fail : es) a -> Eff es (Either String a)

13+runFail = reinterpret eff $ \_ -> \case

14+ Fail msg -> throwError msg

15+ where

16+ eff = fmap (either (Left . snd) Right) . runError

effectful-core/src/Effectful/Internal/Effect.hs+10−12

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

8module Effectful.Internal.Effect

9 ( Effect

10 , (:>)(..)

11− , IdE(..)

11+

12+ -- * Re-exports

13+ , Type

12 ) where

14 ) where

13

15

14import Data.Kind

16import Data.Kind

@@ -17,20 +19,16 @@ import GHC.TypeLits

17-- | The kind of effects.

19-- | The kind of effects.

18type Effect = (Type -> Type) -> Type -> Type

20type Effect = (Type -> Type) -> Type -> Type

19

21

20−-- | Adapter for statically dispatched effects.

21−newtype IdE :: Effect -> Type where

22− IdE :: (forall m r. e m r) -> IdE e

23−

24−-- | A constraint that requires that a particular effect, @e@, is a member of

22+-- | A constraint that requires that a particular effect @e@ is a member of the

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

26−-- '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/

27−-- @e@ is /somewhere/ in the list.

25+-- in the list.

28--

26--

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

30−-- containing an 'Integer' would likely use the following type:

28+-- 'Integer' would likely use the following type:

31--

29--

32-- @

30-- @

33−-- 'Effectful.State.State' 'Integer' ':>' es => 'Effectful.Monad.Eff' es ()

31+-- 'Effectful.State.Local.State' 'Integer' ':>' es => 'Effectful.Monad.Eff' es ()

34-- @

32-- @

35class (e :: Effect) :> (es :: [Effect]) where

33class (e :: Effect) :> (es :: [Effect]) where

36 -- | Get the position of @e@ in @es@.

34 -- | Get the position of @e@ in @es@.

effectful-core/src/Effectful/Internal/Env.hs+103−84

@@ -1,26 +1,38 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE MagicHash #-}

2{-# OPTIONS_HADDOCK not-home #-}

3-- | The environment for the 'Effectful.Internal.Monad.Eff' monad.

4--

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

6-- in subsequent releases.

7module Effectful.Internal.Env

8+ ( -- * The environment

8− ( Env

9+ Env(..)

10+ , Forks(..)

11+ , EnvRef(..)

12+

13+ -- ** ForkId

14+ , ForkId(..)

15+ , ForkIdGen(..)

16+ , newForkIdGen

17+ , cloneForkIdGen

18+ , newForkId

19+

20+ -- ** Relinker

9 , Relinker(..)

21 , Relinker(..)

10 , noRelinker

22 , noRelinker

11

23

12− -- * Operations

24+ -- * Operations

13 , emptyEnv

25 , emptyEnv

14 , cloneEnv

26 , cloneEnv

15 , forkEnv

27 , forkEnv

16 , sizeEnv

28 , sizeEnv

17 , checkSizeEnv

29 , checkSizeEnv

18

30

19− -- ** Extending and shrinking

31+ -- ** Extending and shrinking

20 , unsafeConsEnv

32 , unsafeConsEnv

21 , unsafeTailEnv

33 , unsafeTailEnv

22

34

23− -- ** Data retrieval and update

35+ -- ** Data retrieval and update

24 , getEnv

36 , getEnv

25 , putEnv

37 , putEnv

26 , stateEnv

38 , stateEnv

@@ -30,9 +42,8 @@ module Effectful.Internal.Env

30import Control.Monad

42import Control.Monad

31import Control.Monad.Primitive

43import Control.Monad.Primitive

32import Data.IORef

44import Data.IORef

33−import Data.Kind

34import Data.Primitive.SmallArray

45import Data.Primitive.SmallArray

35−import GHC.Exts (Any)

46+import GHC.Exts (Any, SmallMutableArray#)

36import GHC.Stack (HasCallStack)

47import GHC.Stack (HasCallStack)

37import Unsafe.Coerce

48import Unsafe.Coerce

38import qualified Data.IntMap.Strict as IM

49import qualified Data.IntMap.Strict as IM

@@ -70,17 +81,17 @@ type role Env nominal

70-- @

81-- @

71--

82--

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

73−-- currently:

84+-- currently (brackets represent forks):

74--

85--

75-- - Mainline sees @[e00, e01, e05, e07]@.

86-- - Mainline sees @[e00, e01, e05, e07]@.

76--

87--

77−-- - @e01@ is an interpreted effect, its handler sees @[e00, e02, e03]@.

88+-- - @e01@ is an interpreted effect, its handler sees @[e00][e02, e03]@.

78--

89--

79−-- - @e03@ is an interpreted effect, its handler sees @[e00, e02, e04]@.

90+-- - @e03@ is an interpreted effect, its handler sees @[e00][e02][e04]@.

80--

91--

81−-- - @e05@ is an interpreted effect, its handler sees @[e00, e01, e06]@.

92+-- - @e05@ is an interpreted effect, its handler sees @[e00, e01][e06]@.

82--

93--

83−-- - @e07@ is an interpreted effect, its handler sees @[e00, e01, e05, e08,

94+-- - @e07@ is an interpreted effect, its handler sees @[e00, e01, e05][e08,

84-- e09]@.

95-- e09]@.

85--

96--

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

@@ -103,30 +114,32 @@ type role Env nominal

103-- introduced @e12@), so its local environment was temporarily extended with

114-- introduced @e12@), so its local environment was temporarily extended with

104-- it. Moreover, currently:

115-- it. Moreover, currently:

105--

116--

106−-- - Handler of @e01@ sees @[e00, e02, e03, e10]@.

117+-- - Handler of @e01@ sees @[e00][e02, e03, e10]@.

107--

118--

108−-- - Handler of @e10@ sees @[e00, e02, e03, e11]@.

119+-- - Handler of @e10@ sees @[e00][e02, e03][e11]@.

109--

120--

110−-- - Handler of @e11@ sees @[e00, e02, e03, e12]@.

121+-- - Handler of @e11@ sees @[e00][e02, e03][e12]@.

111--

122--

112data Env (es :: [Effect]) = Env

123data Env (es :: [Effect]) = Env

113− { _forks :: Forks

124+ { _forks :: !Forks

114− , _globalRef :: IORef EnvRef

125+ , _globalRef :: !(IORef EnvRef)

115− , _forkIdGen :: ForkIdGen

126+ , _forkIdGen :: !ForkIdGen

116 }

127 }

117

128

118-- | Local forks of the environment.

129-- | Local forks of the environment.

119−data Forks = Forks ForkId Int (IORef EnvRef) Forks | NoFork

130+data Forks = Forks !ForkId !Int !(IORef EnvRef) Forks | NoFork

120

131

132+-- | Data held in the environment.

121data EnvRef = EnvRef

133data EnvRef = EnvRef

122− { _size :: Int

134+ { _size :: !Int

123− , _data :: SmallMutableArray RealWorld Any

135+ , _data :: !(SmallMutableArray RealWorld Any)

124− , _relinkers :: SmallMutableArray RealWorld Any

136+ , _relinkers :: !(SmallMutableArray RealWorld Any)

125 }

137 }

126

138

127----------------------------------------

139----------------------------------------

128-- ForkId

140-- ForkId

129

141

142+-- | Internal id of the fork.

130newtype ForkId = ForkId { unForkId :: Int }

143newtype ForkId = ForkId { unForkId :: Int }

131

144

132-- | 'ForkId' generation.

145-- | 'ForkId' generation.

@@ -150,12 +163,15 @@ newForkId (ForkIdGen ref) = do

150----------------------------------------

163----------------------------------------

151-- Relinker

164-- Relinker

152

165

166+-- | A function for relinking 'Env' objects stored in the handlers when cloning

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

173+-- | A dummy 'Relinker' that does nothing.

158−noRelinker :: Relinker handler e

174+noRelinker :: Relinker adapter e

159noRelinker = Relinker $ \_ -> pure

175noRelinker = Relinker $ \_ -> pure

160

176

161----------------------------------------

177----------------------------------------

@@ -173,8 +189,8 @@ cloneEnv (Env NoFork gref0 gen0) = do

173 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

189 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

174 gen <- cloneForkIdGen gen0

190 gen <- cloneForkIdGen gen0

175 gref <- newIORef $ EnvRef n es fs

191 gref <- newIORef $ EnvRef n es fs

176− cache <- newIORef IM.empty

192+ store <- newIORef IM.empty

177− relinkData gref gen cache es fs n

193+ relinkData gref gen store es fs n

178 pure $ Env NoFork gref gen

194 pure $ Env NoFork gref gen

179cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do

195cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do

180 EnvRef _ es0 fs0 <- readIORef gref0

196 EnvRef _ es0 fs0 <- readIORef gref0

@@ -187,8 +203,8 @@ cloneEnv (Env forks@(Forks _ baseIx lref0 _) gref0 gen0) = do

187 copySmallMutableArray fs 0 fs0 0 baseN

203 copySmallMutableArray fs 0 fs0 0 baseN

188 gen <- cloneForkIdGen gen0

204 gen <- cloneForkIdGen gen0

189 gref <- newIORef $ EnvRef len es fs

205 gref <- newIORef $ EnvRef len es fs

190− cache <- newIORef IM.empty

206+ store <- newIORef IM.empty

191− relinkData gref gen cache es fs n

207+ relinkData gref gen store es fs n

192 -- The forked environment is flattened and becomes the global one.

208 -- The forked environment is flattened and becomes the global one.

193 pure $ Env NoFork gref gen

209 pure $ Env NoFork gref gen

194{-# NOINLINE cloneEnv #-}

210{-# NOINLINE cloneEnv #-}

@@ -238,18 +254,18 @@ copyForks es fs len = \case

238 copySmallMutableArray fs baseIx fs0 0 n

254 copySmallMutableArray fs baseIx fs0 0 n

239 copyForks es fs baseIx forks

255 copyForks es fs baseIx forks

240

256

241−type EnvRefCache = IORef (IM.IntMap (IORef EnvRef))

257+type EnvRefStore = IORef (IM.IntMap (IORef EnvRef))

242

258

243-- | Relink local environments hiding in the handlers.

259-- | Relink local environments hiding in the handlers.

244relinkData

260relinkData

245 :: IORef EnvRef

261 :: IORef EnvRef

246 -> ForkIdGen

262 -> ForkIdGen

247− -> EnvRefCache

263+ -> EnvRefStore

248 -> SmallMutableArray RealWorld Any

264 -> SmallMutableArray RealWorld Any

249 -> SmallMutableArray RealWorld Any

265 -> SmallMutableArray RealWorld Any

250 -> Int

266 -> Int

251 -> IO ()

267 -> IO ()

252−relinkData gref gen cache es fs = \case

268+relinkData gref gen store es fs = \case

253 0 -> pure ()

269 0 -> pure ()

254 n -> do

270 n -> do

255 let i = n - 1

271 let i = n - 1

@@ -257,41 +273,41 @@ relinkData gref gen cache es fs = \case

257 readSmallArray es i

273 readSmallArray es i

258 >>= f relinkEnv . fromAny

274 >>= f relinkEnv . fromAny

259 >>= writeSmallArray es i . toAny

275 >>= writeSmallArray es i . toAny

260− relinkData gref gen cache es fs i

276+ relinkData gref gen store es fs i

261 where

277 where

262 relinkEnv :: Env es -> IO (Env es)

278 relinkEnv :: Env es -> IO (Env es)

263− relinkEnv (Env forks _ _) = Env <$> relinkForks gref gen cache forks

279+ relinkEnv (Env forks _ _) = Env <$> relinkForks gref gen store forks

264 <*> pure gref

280 <*> pure gref

265 <*> pure gen

281 <*> pure gen

266

282

267−relinkForks :: IORef EnvRef -> ForkIdGen -> EnvRefCache -> Forks -> IO Forks

283+relinkForks :: IORef EnvRef -> ForkIdGen -> EnvRefStore -> Forks -> IO Forks

268−relinkForks gref gen cache = \case

284+relinkForks gref gen store = \case

269 NoFork -> pure NoFork

285 NoFork -> pure NoFork

270 Forks fid baseIx lref0 forks -> do

286 Forks fid baseIx lref0 forks -> do

271 -- A specific IORef EnvRef can be held by more than one local environment

287 -- A specific IORef EnvRef can be held by more than one local environment

272 -- and we need to replace all its occurences with the same, new value

288 -- and we need to replace all its occurences with the same, new value

273 -- containing its clone.

289 -- containing its clone.

274− readIORef cache >>= pure . IM.lookup (unForkId fid) >>= \case

290+ readIORef store >>= pure . IM.lookup (unForkId fid) >>= \case

275 Just lref -> Forks fid baseIx <$> pure lref

291 Just lref -> Forks fid baseIx <$> pure lref

276− <*> relinkForks gref gen cache forks

292+ <*> relinkForks gref gen store forks

277− Nothing -> Forks fid baseIx <$> cloneEnvRef gref gen cache fid lref0

293+ Nothing -> Forks fid baseIx <$> cloneEnvRef gref gen store fid lref0

278− <*> relinkForks gref gen cache forks

294+ <*> relinkForks gref gen store forks

279

295

280−-- | Clone the local 'EnvRef' and put it in a cache.

296+-- | Clone the local 'EnvRef' and put it in a store.

281cloneEnvRef

297cloneEnvRef

282 :: IORef EnvRef

298 :: IORef EnvRef

283 -> ForkIdGen

299 -> ForkIdGen

284− -> EnvRefCache

300+ -> EnvRefStore

285 -> ForkId

301 -> ForkId

286 -> IORef EnvRef

302 -> IORef EnvRef

287 -> IO (IORef EnvRef)

303 -> IO (IORef EnvRef)

288−cloneEnvRef gref gen cache fid lref0 = do

304+cloneEnvRef gref gen store fid lref0 = do

289 EnvRef n es0 fs0 <- readIORef lref0

305 EnvRef n es0 fs0 <- readIORef lref0

290 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)

306 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)

291 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

307 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

292 ref <- newIORef $ EnvRef n es fs

308 ref <- newIORef $ EnvRef n es fs

293− modifyIORef' cache $ IM.insert (unForkId fid) ref

309+ modifyIORef' store $ IM.insert (unForkId fid) ref

294− relinkData gref gen cache es fs n

310+ relinkData gref gen store es fs n

295 pure ref

311 pure ref

296

312

297----------------------------------------

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

@@ -340,10 +356,10 @@ checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do

340

356

341-- | Extend the environment with a new data type (in place).

357-- | Extend the environment with a new data type (in place).

342--

358--

343−-- /Note:/ this function is __unsafe__ because it renders the input 'Env'

359+-- This function is __highly unsafe__ because it renders the input 'Env'

344−-- unusable until the corresponding 'unsafeTailEnv' call, but it's not checked

360+-- unusable until the corresponding 'unsafeTailEnv' call is made, but it's not

345−-- anywhere.

361+-- checked anywhere.

346−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))

347unsafeConsEnv e f (Env fork gref gen) = case fork of

363unsafeConsEnv e f (Env fork gref gen) = case fork of

348 NoFork -> do

364 NoFork -> do

349 extendEnvRef gref

365 extendEnvRef gref

@@ -379,16 +395,12 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of

379-- | Shrink the environment by one data type (in place). Makes sure the size of

395-- | Shrink the environment by one data type (in place). Makes sure the size of

380-- the environment is as expected.

396-- the environment is as expected.

381--

397--

382−-- /Note:/ this function is __unsafe__ because it renders the input 'Env'

398+-- This function is __highly unsafe__ because it renders the input 'Env'

383-- unusable, but it's not checked anywhere.

399-- unusable, but it's not checked anywhere.

384−unsafeTailEnv :: Int -> Env (e : es) -> IO (Env es)

400+unsafeTailEnv :: Int -> Env (e : es) -> IO ()

385−unsafeTailEnv len (Env fork gref gen) = case fork of

401+unsafeTailEnv len (Env fork gref _) = case fork of

386− NoFork -> do

387− shrinkEnvRef len gref

402+ NoFork -> shrinkEnvRef len gref

388− pure $ Env NoFork gref gen

389− Forks _ baseIx lref _ -> do

390− shrinkEnvRef (len - baseIx) lref

403+ Forks _ baseIx lref _ -> shrinkEnvRef (len - baseIx) lref

391− pure $ Env fork gref gen

392 where

404 where

393 shrinkEnvRef :: Int -> IORef EnvRef -> IO ()

405 shrinkEnvRef :: Int -> IORef EnvRef -> IO ()

394 shrinkEnvRef k ref = do

406 shrinkEnvRef k ref = do

@@ -405,41 +417,44 @@ unsafeTailEnv len (Env fork gref gen) = case fork of

405-- Data retrieval and update

417-- Data retrieval and update

406

418

407-- | Extract a specific data type from the environment.

419-- | Extract a specific data type from the environment.

420+getEnv

408−getEnv :: forall e es handler. e :> es => Env es -> IO (handler e)

421+ :: forall e adapter es. e :> es

422+ => Env es

423+ -> IO (adapter e)

409getEnv env = do

424getEnv env = do

410− (i, es) <- getLocation @e 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 @e 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 @e 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 @e 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− :: forall e es. e :> es

479+ :: Int

461− => Env es

480+ -> Env es

462− -> IO (Int, SmallMutableArray RealWorld Any)

481+ -> IO Location

463−getLocation (Env fork ref _) = do

482+getLocation 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,28 +489,28 @@ getLocation (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 - reifyIndex @e @es - 1

513+ ix n = n - ixE - 1

495

514

496toAny :: a -> Any

515toAny :: a -> Any

497toAny = unsafeCoerce

516toAny = unsafeCoerce

effectful-core/src/Effectful/Internal/Monad.hs+206−241

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

@@ -16,18 +16,17 @@ module Effectful.Internal.Monad

16 , unsafeEff_

17

18 -- * Fail

19− , Fail

19+ , Fail(..)

20− , runFail

21

20

22 -- * IO

21 -- * IO

23 , IOE

22 , IOE

24 , runEff

23 , runEff

25

24

26− -- * Primitive

25+ -- * Prim

27 , Prim

26 , Prim

28 , runPrim

27 , runPrim

29

28

30− -- ** Unlift strategies

29+ -- * Unlift strategies

31 , UnliftStrategy(..)

30 , UnliftStrategy(..)

32 , Persistence(..)

31 , Persistence(..)

33 , Limit(..)

32 , Limit(..)

@@ -35,87 +34,88 @@ module Effectful.Internal.Monad

35 , withUnliftStrategy

34 , withUnliftStrategy

36 , withEffToIO

35 , withEffToIO

37

36

38− --- *** Low-level helpers

37+ -- ** Low-level unlifts

39− , unsafeWithLiftMapIO

38+ , seqUnliftIO

40− , unsafeSeqUnliftEff

39+ , concUnliftIO

41− , unsafeConcUnliftEff

40+

42−

41+ -- * Effects

43− -- * Primitive effects

42+

44−

43+ -- ** Dynamic dispatch

45− -- ** Running

44+ , EffectHandler

46− , runEffect

45+ , LocalEnv(..)

47− , evalEffect

46+ , HandlerA(..)

48− , execEffect

47+ , runHandler

49−

48+ , send

50− -- ** Modification

49+

51− , getEffect

50+ -- ** Static dispatch

52− , putEffect

51+ , DataA(..)

53− , stateEffect

52+ , runData

54− , stateEffectM

53+ , evalData

55− , localEffect

54+ , execData

55+ , getData

56+ , putData

57+ , stateData

58+ , stateDataM

59+ , localData

56 ) where

60 ) where

57

61

58import Control.Applicative (liftA2)

62import Control.Applicative (liftA2)

59−import Control.Concurrent (myThreadId)

60−import Control.Exception

61import Control.Monad.Base

63import Control.Monad.Base

62import Control.Monad.Fix

64import Control.Monad.Fix

63import Control.Monad.IO.Class

65import Control.Monad.IO.Class

64import Control.Monad.IO.Unlift

66import Control.Monad.IO.Unlift

65import Control.Monad.Primitive

67import Control.Monad.Primitive

66import Control.Monad.Trans.Control

68import Control.Monad.Trans.Control

67−import Data.Unique

68import GHC.Exts (oneShot)

69import GHC.Exts (oneShot)

69import GHC.IO (IO(..))

70import GHC.IO (IO(..))

70import GHC.Stack (HasCallStack)

71import GHC.Stack (HasCallStack)

71import System.IO.Unsafe (unsafeDupablePerformIO)

72import System.IO.Unsafe (unsafeDupablePerformIO)

72−import qualified Control.Monad.Catch as E

73+import qualified Control.Exception as E

74+import qualified Control.Monad.Catch as C

73

75

74import Effectful.Internal.Effect

76import Effectful.Internal.Effect

75import Effectful.Internal.Env

77import Effectful.Internal.Env

76import Effectful.Internal.Unlift

78import Effectful.Internal.Unlift

77−import Effectful.Internal.Utils

78

79

79type role Eff nominal representational

80type role Eff nominal representational

80

81

81−-- | The 'Eff' monad provides the implementation of an operation that performs

82+-- | The 'Eff' monad provides the implementation of a computation that performs

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

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

84−-- operation that produces an 'Integer' by consuming a 'String' from the global

85+-- computation that produces an 'Integer' by consuming a 'String' from the

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

86−-- have the following type:

87+-- would have the following type:

87--

88--

88-- @

89-- @

89−-- 'Eff' '['Effectful.Reader.Reader' 'String', 'Effectful.State.State' 'Bool'] 'Integer'

90+-- 'Eff' '['Effectful.Reader.Reader' 'String', 'Effectful.State.Local.State' 'Bool'] 'Integer'

90-- @

91-- @

91--

92--

92-- 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'.

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

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

95−-- example, the above example would more commonly be expressed with the

96+-- example, the above example would be expressed with the following type:

96−-- following type:

97--

98-- @

99−-- ('Effectful.Reader.Reader' 'String' ':>' es, 'Effectful.State.State' 'Bool' ':>' es) => 'Eff' es 'Integer'

99+-- ('Effectful.Reader.Reader' 'String' ':>' es, 'Effectful.State.Local.State' 'Bool' ':>' es) => 'Eff' es 'Integer'

100-- @

101--

102−-- This abstraction allows the operation to be used in functions that may

102+-- This abstraction allows the computation to be used in functions that may

103-- perform other effects, and it also allows the effects to be handled in any

104-- order.

105newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a)

106 deriving (Monoid, Semigroup)

107

108−-- | Run a pure 'Eff' operation.

108+-- | Run a pure 'Eff' computation.

109--

110−-- For running operations with side effects see 'runEff'.

110+-- For running computations with side effects see 'runEff'.

111runPureEff :: Eff '[] a -> a

112runPureEff (Eff m) =

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

114− -- side effects was performed (unless someone sneakily introduced side effects

114+ -- IO with side effects was performed (unless someone sneakily introduced side

115− -- with unsafeEff, but then all bets are off).

115+ -- effects with unsafeEff, but then all bets are off).

116 --

117 -- Moreover, internals don't allocate any resources that require explicit

118− -- cleanup actions to run, so the "Dupable" part should also be just fine.

118+ -- cleanup actions to run.

119 unsafeDupablePerformIO $ m =<< emptyEnv

120

121----------------------------------------

@@ -126,62 +126,70 @@ unEff :: Eff es a -> Env es -> IO a

126unEff (Eff m) = m

127

128-- | Access the underlying 'IO' monad along with the environment.

129+--

130+-- This function is __unsafe__ because it can be used to introduce arbitrary

131+-- 'IO' actions into pure 'Eff' computations.

129unsafeEff :: (Env es -> IO a) -> Eff es a

132unsafeEff :: (Env es -> IO a) -> Eff es a

130unsafeEff m = Eff (oneShot m)

133unsafeEff m = Eff (oneShot m)

131

134

132-- | Access the underlying 'IO' monad.

135-- | Access the underlying 'IO' monad.

136+--

137+-- This function is __unsafe__ because it can be used to introduce arbitrary

138+-- 'IO' actions into pure 'Eff' computations.

133unsafeEff_ :: IO a -> Eff es a

139unsafeEff_ :: IO a -> Eff es a

134unsafeEff_ m = unsafeEff $ \_ -> m

140unsafeEff_ m = unsafeEff $ \_ -> m

135

141

136−-- | Utility for lifting 'IO' operations of type

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

137−--

143+-- Unlifting IO

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

144+

139−--

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

140−-- to

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

147+unliftStrategy = do

148+ DataA (IOE unlift) <- getData

149+ pure unlift

150+

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

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

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

154+

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

141--

156--

142−-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@

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

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

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

143--

160--

144−-- /Note:/ the 'IO' operation must not run its argument in a separate thread,

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

145−-- attempting to do so will result in a runtime error.

162+withEffToIO

146−unsafeWithLiftMapIO

147− :: HasCallStack

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

148− => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)

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

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

149− -> Eff es r

166+ -> Eff es a

150−unsafeWithLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do

167+withEffToIO f = unliftStrategy >>= \case

151− unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m

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

169+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do

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

152

171

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

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

154−unsafeSeqUnliftEff

173+seqUnliftIO

155 :: HasCallStack

174 :: HasCallStack

156 => Env es

175 => Env es

176+ -- ^ The environment.

157 -> ((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.

158 -> IO a

179 -> IO a

159−unsafeSeqUnliftEff es k = do

180+seqUnliftIO es k = seqUnlift k es unEff

160− tid0 <- myThreadId

181+

161− k $ \m -> do

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

162− tid <- myThreadId

183+concUnliftIO

163− if tid `eqThreadId` tid0

164− then unEff m es

165− else error

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

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

168−

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

170−unsafeConcUnliftEff

171 :: HasCallStack

184 :: HasCallStack

172 => Env es

185 => Env es

186+ -- ^ The environment.

173 -> Persistence

187 -> Persistence

174 -> Limit

188 -> Limit

175 -> ((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.

176 -> IO a

191 -> IO a

177−unsafeConcUnliftEff es Ephemeral (Limited uses) k =

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

178− unsafeEphemeralConcUnliftIO uses k es unEff

179−unsafeConcUnliftEff es Ephemeral Unlimited k =

180− unsafeEphemeralConcUnliftIO maxBound k es unEff

181−unsafeConcUnliftEff es Persistent (Limited threads) k =

182− unsafePersistentConcUnliftIO False threads k es unEff

183−unsafeConcUnliftEff es Persistent Unlimited k =

184− unsafePersistentConcUnliftIO True maxBound k es unEff

185

193

186----------------------------------------

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

187-- Base

195-- Base

@@ -209,84 +217,56 @@ instance MonadFix (Eff es) where

209----------------------------------------

217----------------------------------------

210-- Exception

218-- Exception

211

219

212−instance E.MonadThrow (Eff es) where

220+instance C.MonadThrow (Eff es) where

213− throwM = unsafeEff_ . throwIO

221+ throwM = unsafeEff_ . E.throwIO

214

222

215−instance E.MonadCatch (Eff es) where

223+instance C.MonadCatch (Eff es) where

216 catch m handler = unsafeEff $ \es -> do

224 catch m handler = unsafeEff $ \es -> do

217 size <- sizeEnv es

225 size <- sizeEnv es

218− unEff m es `catch` \e -> do

226+ unEff m es `E.catch` \e -> do

219 checkSizeEnv size es

227 checkSizeEnv size es

220 unEff (handler e) es

228 unEff (handler e) es

221

229

222−instance E.MonadMask (Eff es) where

230+instance C.MonadMask (Eff es) where

223− mask k = unsafeEff $ \es -> mask $ \restore ->

231+ mask k = unsafeEff $ \es -> E.mask $ \restore ->

224 unEff (k $ \m -> unsafeEff $ restore . unEff m) es

232 unEff (k $ \m -> unsafeEff $ restore . unEff m) es

225

233

226− uninterruptibleMask k = unsafeEff $ \es -> uninterruptibleMask $ \restore ->

234+ uninterruptibleMask k = unsafeEff $ \es -> E.uninterruptibleMask $ \restore ->

227 unEff (k $ \m -> unsafeEff $ restore . unEff m) es

235 unEff (k $ \m -> unsafeEff $ restore . unEff m) es

228

236

229− generalBracket acquire release use = unsafeEff $ \es -> mask $ \restore -> do

237+ generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \restore -> do

230 size <- sizeEnv es

238 size <- sizeEnv es

231 resource <- unEff acquire es

239 resource <- unEff acquire es

232− b <- restore (unEff (use resource) es) `catch` \e -> do

240+ b <- restore (unEff (use resource) es) `E.catch` \e -> do

233 checkSizeEnv size es

241 checkSizeEnv size es

234− _ <- unEff (release resource $ E.ExitCaseException e) es

242+ _ <- unEff (release resource $ C.ExitCaseException e) es

235− throwIO e

243+ E.throwIO e

236 checkSizeEnv size es

244 checkSizeEnv size es

237− c <- unEff (release resource $ E.ExitCaseSuccess b) es

245+ c <- unEff (release resource $ C.ExitCaseSuccess b) es

238 pure (b, c)

246 pure (b, c)

239

247

240----------------------------------------

248----------------------------------------

241-- Fail

249-- Fail

242

250

251+-- | Provide the ability to use the 'MonadFail' instance of 'Eff'.

243data Fail :: Effect where

252data Fail :: Effect where

244− Fail :: Unique -> Fail m r

253+ Fail :: String -> Fail m a

245−

246−runFail :: Eff (Fail : es) a -> Eff es (Either String a)

247−runFail m = unsafeEff $ \es0 -> mask $ \release -> do

248− -- A unique tag is picked so that different runFail handlers don't catch each

249− -- other's exceptions.

250− tag <- newUnique

251− size0 <- sizeEnv es0

252− es <- unsafeConsEnv (IdE (Fail tag)) noRelinker es0

253− r <- tryFailIO tag (release $ unEff m es) `onException` unsafeTailEnv size0 es

254− _ <- unsafeTailEnv size0 es

255− pure r

256

254

257instance Fail :> es => MonadFail (Eff es) where

255instance Fail :> es => MonadFail (Eff es) where

258− fail msg = do

256+ fail = send . Fail

259− IdE (Fail tag) <- getEffect

260− unsafeEff_ . throwIO $ FailEx tag msg

261−

262−--------------------

263−

264−data FailEx = FailEx Unique String

265−instance Show FailEx where

266− showsPrec p (FailEx _ msg)

267− = ("Effectful.Internal.Monad.FailEx " ++)

268− . showsPrec p msg

269−instance Exception FailEx

270−

271−tryFailIO :: Unique -> IO a -> IO (Either String a)

272−tryFailIO tag m =

273− (Right <$> m) `catch` \err@(FailEx etag msg) -> do

274− if tag == etag

275− then pure $ Left msg

276− else throwIO err

277

257

278----------------------------------------

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

279-- IO

259-- IO

280

260

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

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

282newtype IOE :: Effect where

262newtype IOE :: Effect where

283 IOE :: UnliftStrategy -> IOE m r

263 IOE :: UnliftStrategy -> IOE m r

284

264

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

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

286--

266--

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

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

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

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

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

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

290

270

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

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

292 liftIO = unsafeEff_

272 liftIO = unsafeEff_

@@ -310,141 +290,126 @@ instance IOE :> es => MonadBaseControl IO (Eff es) where

310----------------------------------------

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

311-- Primitive

291-- Primitive

312

292

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

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

314data Prim :: Effect where

294data Prim :: Effect where

315 Prim :: Prim m r

295 Prim :: Prim m r

316

296

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

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

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

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

319−runPrim = evalEffect (IdE Prim)

299+runPrim = evalData (DataA Prim)

320

300

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

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

322 type PrimState (Eff es) = RealWorld

302 type PrimState (Eff es) = RealWorld

323 primitive = unsafeEff_ . IO

303 primitive = unsafeEff_ . IO

324

304

325----------------------------------------

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

326−-- Unlift strategies

306+-- Dynamic dispatch

327−

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

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

330−data UnliftStrategy

331− = SeqUnlift

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

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

334− -- a runtime error.

335− | ConcUnlift Persistence Limit

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

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

338− -- settings for more information.

339− deriving (Eq, Ord, Show)

340−

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

342−--

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

344−--

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

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

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

348−--

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

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

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

352−data Persistence

353− = Ephemeral

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

355− -- threads distinct from its creator.

356− | Persistent

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

358− -- particular thread.

359− deriving (Eq, Ord, Show)

360−

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

362−data Limit

363− = Limited Int

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

365− --

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

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

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

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

370− --

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

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

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

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

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

376− | Unlimited

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

378− deriving (Eq, Ord, Show)

379

307

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

308+type role LocalEnv nominal nominal

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

382−unliftStrategy = do

383− IdE (IOE unlift) <- getEffect

384− pure unlift

385

309

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

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

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

312+-- handler.

387--

313--

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

314+-- The second type variable represents effects of a handler and is needed for

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

315+-- technical reasons to guarantee soundness.

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

316+newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env localEs)

317+

318+-- | Type signature of the effect handler.

319+type EffectHandler e es

320+ = forall a localEs. HasCallStack

321+ => LocalEnv localEs es

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

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

324+ -> e (Eff localEs) a

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

326+ -> Eff es a

391

327

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

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

393--

329--

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

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

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

331+data HandlerA :: Effect -> Type where

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

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

397−withEffToIO

333+

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

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

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

337+ size0 <- sizeEnv es0

338+ E.bracket (unsafeConsEnv e relinker es0)

339+ (unsafeTailEnv size0)

340+ (\es -> unEff m es)

341+ where

342+ relinker :: Relinker HandlerA e

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

344+ newHandlerEs <- relink handlerEs

345+ pure $ HandlerA newHandlerEs handle

346+

347+-- | Send an operation of the given effect to its handler for execution.

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

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

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

349+send op = unsafeEff $ \es -> do

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

350+ HandlerA handlerEs handle <- getEnv es

401− -> Eff es a

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

402−withEffToIO f = unliftStrategy >>= \case

403− SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f

404− ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do

405− unsafeEff $ \es -> unsafeConcUnliftEff es p b f

406

352

407----------------------------------------

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

408−-- Helpers

354+-- Static dispatch

409

355

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

357+--

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

359+-- parameters.

360+newtype DataA :: Effect -> Type where

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

362+

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

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

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

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

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

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

412 size0 <- sizeEnv es0

367 size0 <- sizeEnv es0

413− bracket (unsafeConsEnv e0 noRelinker es0)

368+ E.bracket (unsafeConsEnv e0 noRelinker es0)

414− (unsafeTailEnv size0)

369+ (unsafeTailEnv size0)

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

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

416−

371+

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

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

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

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

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

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

419 size0 <- sizeEnv es0

376 size0 <- sizeEnv es0

420− bracket (unsafeConsEnv e noRelinker es0)

377+ E.bracket (unsafeConsEnv e noRelinker es0)

421− (unsafeTailEnv size0)

378+ (unsafeTailEnv size0)

422− (\es -> unEff m es)

379+ (\es -> unEff m es)

423−

380+

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

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

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

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

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

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

426 size0 <- sizeEnv es0

385 size0 <- sizeEnv es0

427− bracket (unsafeConsEnv e0 noRelinker es0)

386+ E.bracket (unsafeConsEnv e0 noRelinker es0)

428− (unsafeTailEnv size0)

387+ (unsafeTailEnv size0)

429− (\es -> unEff m es *> getEnv es)

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

430−

389+

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

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

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

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

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

433−

393+

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

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

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

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

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

436−

397+

437−stateEffect :: e :> es => (handler e -> (a, handler e)) -> Eff es a

398+-- | Apply the function to the current state of the effect and return a value.

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

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

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

439−

401+

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

403+-- value.

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

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

441−stateEffectM f = unsafeEff $ \es -> mask $ \release -> do

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

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

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

443 putEnv es e

407 putEnv es e

444 pure a

408 pure a

445

409

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

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

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

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

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

448− bracket (stateEnv es $ \e -> (e, f e))

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

449− (\e -> putEnv es e)

414+ (\e -> putEnv es e)

450− (\_ -> unEff m es)

415+ (\_ -> unEff m es)

effectful-core/src/Effectful/Internal/Unlift.hs+119−14

@@ -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− ( unsafeEphemeralConcUnliftIO

9+ ( -- * Unlifting strategies

10− , unsafePersistentConcUnliftIO

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

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−unsafeEphemeralConcUnliftIO 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 @@ unsafeEphemeralConcUnliftIO 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−unsafePersistentConcUnliftIO

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−unsafePersistentConcUnliftIO 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 @@ unsafePersistentConcUnliftIO 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

@@ -120,17 +225,17 @@ nextEntryId :: EntryId -> EntryId

120nextEntryId (EntryId i) = EntryId (i + 1)

225nextEntryId (EntryId i) = EntryId (i + 1)

121

226

122data ThreadEntries es = ThreadEntries

227data ThreadEntries es = ThreadEntries

123− { teCapacity :: Int

228+ { teCapacity :: !Int

124− , teEntries :: IM.IntMap (ThreadEntry es)

229+ , teEntries :: !(IM.IntMap (ThreadEntry es))

125 }

230 }

126

231

127-- | In GHC < 9 weak thread ids are 32bit long, while ThreadIdS are 64bit long,

232-- | In GHC < 9 weak thread ids are 32bit long, while ThreadIdS are 64bit long,

128-- so there is potential for collisions. This is solved by keeping, for a

233-- so there is potential for collisions. This is solved by keeping, for a

129-- particular weak thread id, a list of ThreadIdS with unique EntryIdS.

234-- particular weak thread id, a list of ThreadIdS with unique EntryIdS.

130−data ThreadEntry es = ThreadEntry EntryId (ThreadData es)

235+data ThreadEntry es = ThreadEntry !EntryId !(ThreadData es)

131

236

132data ThreadData es

237data ThreadData es

133− = ThreadData EntryId (Weak (ThreadId, Env es)) (ThreadData es)

238+ = ThreadData !EntryId !(Weak (ThreadId, Env es)) (ThreadData es)

134 | NoThreadData

239 | NoThreadData

135

240

136----------------------------------------

241----------------------------------------

effectful-core/src/Effectful/Monad.hs+7

@@ -18,7 +18,14 @@ module Effectful.Monad

18 , unliftStrategy

19 , withUnliftStrategy

20 , withEffToIO

21+

22+ -- * Re-exports

23+ , MonadIO(..)

24+ , MonadUnliftIO(..)

21 ) where

25 ) where

22

26

27+import Control.Monad.IO.Class

28+import Control.Monad.IO.Unlift

29+

23import Effectful.Internal.Effect

30import Effectful.Internal.Effect

24import Effectful.Internal.Monad

31import Effectful.Internal.Monad

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+29−12

@@ -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,26 +7,43 @@ 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@.

15newtype Reader r :: Effect where

16 Reader :: r -> Reader r m a

17

18+-- | Run a 'Reader' effect with the given initial environment.

19+runReader

20+ :: r -- ^ An initial environment.

18−runReader :: r -> Eff (Reader r : es) a -> Eff es a

21+ -> Eff (Reader r : es) a

22+ -> Eff es a

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

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

20

24

25+-- | Fetch the value of the environment.

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

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

22ask = do

27ask = do

23− IdE (Reader r) <- getEffect

28+ DataA (Reader r) <- getData

24 pure r

29 pure r

25

30

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

32+--

33+-- @'asks' f ≡ f '<$>' 'ask'@

34+asks

26−asks :: Reader r :> es => (r -> a) -> Eff es a

35+ :: Reader r :> es

36+ => (r -> a) -- ^ The function to apply to the environment.

37+ -> Eff es a

27−asks f = do

38+asks f = f <$> ask

28− IdE (Reader r) <- getEffect

29− pure $ f r

30

39

40+-- | Execute a computation in a modified environment.

41+--

42+-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@

43+--

44+local

31−local :: Reader r :> es => (r -> r) -> Eff es a -> Eff es a

45+ :: Reader r :> es

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

47+ -> Eff es a

48+ -> Eff es a

32−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+5−16

@@ -1,13 +1,4 @@

1-- | The 'State' effect with dynamic dispatch.

2−--

3−-- It's not clear in which situation it's beneficial to use this instead of

4−-- "Effectful.State.Local" or "Effectful.State.Shared" as you either:

5−--

6−-- - Share state between threads and need the shared version.

7−--

8−-- - Don't share state between threads (or want it to be thread local) and are

9−-- free to use the faster, local version.

10−--

11module Effectful.State.Dynamic

2module Effectful.State.Dynamic

12 ( State(..)

3 ( State(..)

13

4

@@ -31,17 +22,15 @@ module Effectful.State.Dynamic

31 , modifyM

22 , modifyM

32 ) where

23 ) where

33

24

34−import Effectful.Handler

25+import Effectful.Dispatch.Dynamic

35import Effectful.Monad

26import Effectful.Monad

36import qualified Effectful.State.Local as L

27import qualified Effectful.State.Local as L

37import qualified Effectful.State.Shared as S

28import qualified Effectful.State.Shared as S

38

29

39−-- | Provide access to a mutable state of type @s@.

30+-- | Provide access to a mutable value of type @s@.

40−--

41−-- Whether the state is local or shared depends on the interpretation.

42data State s :: Effect where

31data State s :: Effect where

43 Get :: State s m s

32 Get :: State s m s

44− Put :: ~s -> State s m ()

33+ Put :: s -> State s m ()

45 State :: (s -> (a, s)) -> State s m a

34 State :: (s -> (a, s)) -> State s m a

46 StateM :: (s -> m (a, s)) -> State s m a

35 StateM :: (s -> m (a, s)) -> State s m a

47

36

@@ -59,7 +48,7 @@ execLocalState s0 = reinterpret (L.execState s0) localState

59

48

60localState

49localState

61 :: L.State s :> es

50 :: L.State s :> es

62− => LocalEnv localEs

51+ => LocalEnv localEs es

63 -> State s (Eff localEs) a

52 -> State s (Eff localEs) a

64 -> Eff es a

53 -> Eff es a

65localState env = \case

54localState env = \case

@@ -82,7 +71,7 @@ execSharedState s0 = reinterpret (S.execState s0) sharedState

82

71

83sharedState

72sharedState

84 :: S.State s :> es

73 :: S.State s :> es

85− => LocalEnv localEs

74+ => LocalEnv localEs es

86 -> State s (Eff localEs) a

75 -> State s (Eff localEs) a

87 -> Eff es a

76 -> Eff es a

88sharedState env = \case

77sharedState env = \case

effectful-core/src/Effectful/State/Local.hs+88−24

@@ -1,12 +1,29 @@

1−-- | The 'State' effect.

1+-- | Support for access to a mutable value of a particular type, which is:

2--

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

4−--

5−-- - thread local (if you need the state to be shared between threads, have a

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

6-- look at "Effectful.State.Shared"),

4-- look at "Effectful.State.Shared"),

7--

5--

8-- - very fast.

6-- - very fast.

9--

7--

8+-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from

9+-- the @transformers@ library, the 'State' effect doesn't lose state

10+-- modifications when an exception is received:

11+--

12+-- >>> import qualified Control.Monad.Trans.State.Strict as S

13+--

14+-- >>> :{

15+-- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do

16+-- S.modify (++ " there!")

17+-- error "oops"

18+-- :}

19+-- "Hi"

20+--

21+-- >>> :{

22+-- runEff . execState "Hi" . handle (\(_::ErrorCall) -> pure ()) $ do

23+-- modify (++ " there!")

24+-- error "oops"

25+-- :}

26+-- "Hi there!"

10module Effectful.State.Local

27module Effectful.State.Local

11 ( State

28 ( State

12 , runState

29 , runState

@@ -21,47 +38,94 @@ 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

48+-- | Run a 'State' effect with the given initial state and return the final

49+-- value along with the final state.

50+runState

51+ :: s -- ^ An initial state.

31−runState :: s -> Eff (State s : es) a -> Eff es (a, s)

52+ -> Eff (State s : es) a

53+ -> Eff es (a, s)

32runState s0 m = do

54runState s0 m = do

33− (a, IdE (State s)) <- runEffect (IdE (State s0)) m

55+ (a, DataA (State s)) <- runData (DataA (State s0)) m

34 pure (a, s)

56 pure (a, s)

35

57

58+-- | Run a 'State' effect with the given initial state and return the final

59+-- value, discarding the final state.

60+evalState

61+ :: s -- ^ An initial state.

36−evalState :: s -> Eff (State s : es) a -> Eff es a

62+ -> Eff (State s : es) a

63+ -> Eff es a -- ^ A return value.

37−evalState s = evalEffect (IdE (State s))

64+evalState s = evalData (DataA (State s))

38

65

66+-- | Run a 'State' effect with the given initial state and return the final

67+-- state, discarding the final value.

68+execState

69+ :: s -- ^ An initial state.

39−execState :: s -> Eff (State s : es) a -> Eff es s

70+ -> Eff (State s : es) a

71+ -> Eff es s

40execState s0 m = do

72execState s0 m = do

41− IdE (State s) <- execEffect (IdE (State s0)) m

73+ DataA (State s) <- execData (DataA (State s0)) m

42 pure s

74 pure s

43

75

76+-- | Fetch the current value of the state.

44get :: State s :> es => Eff es s

77get :: State s :> es => Eff es s

45get = do

78get = do

46− IdE (State s) <- getEffect

79+ DataA (State s) <- getData

47 pure s

80 pure s

48

81

82+-- | Get a function of the current state.

83+--

84+-- @'gets' f ≡ f '<$>' 'get'@

85+gets

49−gets :: State s :> es => (s -> a) -> Eff es a

86+ :: State s :> es

87+ => (s -> a) -- ^ The function to apply to the state.

88+ -> Eff es a

50gets f = f <$> get

89gets f = f <$> get

51

90

91+-- | Set the current state to the given value.

52put :: State s :> es => s -> Eff es ()

92put :: State s :> es => s -> Eff es ()

53−put s = putEffect (IdE (State s))

93+put s = putData (DataA (State s))

54

94

95+-- | Apply the function to the current state and return a value.

96+state

55−state :: State s :> es => (s -> (a, s)) -> Eff es a

97+ :: State s :> es

98+ => (s -> (a, s)) -- ^ The function to modify the state.

99+ -> Eff es a

56−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))

57

101

102+-- | Apply the function to the current state.

103+--

104+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@

105+modify

58−modify :: State s :> es => (s -> s) -> Eff es ()

106+ :: State s :> es

107+ => (s -> s) -- ^ The function to modify the state.

108+ -> Eff es ()

59−modify f = state (\s -> ((), f s))

109+modify f = state $ \s -> ((), f s)

60

110

111+-- | Apply the monadic function to the current state and return a value.

112+stateM

61−stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a

113+ :: State s :> es

114+ => (s -> Eff es (a, s)) -- ^ The function to modify the state.

115+ -> Eff es a

62−stateM f = stateEffectM $ \(IdE (State s0)) -> do

116+stateM f = stateDataM $ \(DataA (State s0)) -> do

63 (a, s) <- f s0

117 (a, s) <- f s0

64− pure (a, IdE (State s))

118+ pure (a, DataA (State s))

65

119

120+-- | Apply the monadic function to the current state.

121+--

122+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@

123+modifyM

66−modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()

124+ :: State s :> es

125+ => (s -> Eff es s) -- ^ The monadic function to modify the state.

126+ -> Eff es ()

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

27−import Effectful.Internal.Monad

44+import Effectful.Monad

28

45

29−-- | Provide access to a strict (WHNF), shareable, mutable state of type @s@.

46+-- | Provide access to a strict (WHNF), shared, mutable value of type @s@.

30newtype State s :: Effect where

47newtype State s :: Effect where

31 State :: MVar s -> State s m r

48 State :: MVar s -> State s m r

32

49

50+-- | Run a 'State' effect with the given initial state and return the final

51+-- value along with the final state.

33runState :: s -> Eff (State s : es) a -> Eff es (a, s)

52runState :: s -> Eff (State s : es) a -> Eff es (a, s)

34runState s m = do

53runState s m = do

35 v <- unsafeEff_ $ newMVar s

54 v <- unsafeEff_ $ newMVar s

36− a <- evalEffect (IdE (State v)) m

55+ a <- evalData (DataA (State v)) m

37 (a, ) <$> unsafeEff_ (readMVar v)

56 (a, ) <$> unsafeEff_ (readMVar v)

38

57

58+-- | Run a 'State' effect with the given initial state and return the final

59+-- value, discarding the final state.

39evalState :: s -> Eff (State s : es) a -> Eff es a

60evalState :: s -> Eff (State s : es) a -> Eff es a

40evalState s m = do

61evalState s m = do

41 v <- unsafeEff_ $ newMVar s

62 v <- unsafeEff_ $ newMVar s

42− evalEffect (IdE (State v)) m

63+ evalData (DataA (State v)) m

43

64

65+-- | Run a 'State' effect with the given initial state and return the final

66+-- state, discarding the final value.

44execState :: s -> Eff (State s : es) a -> Eff es s

67execState :: s -> Eff (State s : es) a -> Eff es s

45execState s m = do

68execState s m = do

46 v <- unsafeEff_ $ newMVar s

69 v <- unsafeEff_ $ newMVar s

47− _ <- evalEffect (IdE (State v)) m

70+ _ <- evalData (DataA (State v)) m

48 unsafeEff_ $ readMVar v

71 unsafeEff_ $ readMVar v

49

72

73+-- | Fetch the current value of the state.

50get :: State s :> es => Eff es s

74get :: State s :> es => Eff es s

51get = unsafeEff $ \es -> do

75get = unsafeEff $ \es -> do

52− IdE (State v) <- getEnv es

76+ DataA (State v) <- getEnv es

53 readMVar v

77 readMVar v

54

78

79+-- | Get a function of the current state.

80+--

81+-- @'gets' f ≡ f '<$>' 'get'@

55gets :: State s :> es => (s -> a) -> Eff es a

82gets :: State s :> es => (s -> a) -> Eff es a

56gets f = f <$> get

83gets f = f <$> get

57

84

85+-- | Set the current state to the given value.

58put :: State s :> es => s -> Eff es ()

86put :: State s :> es => s -> Eff es ()

59put s = unsafeEff $ \es -> do

87put s = unsafeEff $ \es -> do

60− IdE (State v) <- getEnv es

88+ DataA (State v) <- getEnv es

61 modifyMVar_ v $ \_ -> s `seq` pure s

89 modifyMVar_ v $ \_ -> s `seq` pure s

62

90

91+-- | Apply the function to the current state and return a value.

92+--

93+-- /Note:/ this function gets an exclusive access to the state for its duration.

63state :: State s :> es => (s -> (a, s)) -> Eff es a

94state :: State s :> es => (s -> (a, s)) -> Eff es a

64state f = unsafeEff $ \es -> do

95state f = unsafeEff $ \es -> do

65− IdE (State v) <- getEnv es

96+ DataA (State v) <- getEnv es

66 modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)

97 modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)

67

98

99+-- | Apply the function to the current state.

100+--

101+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@

102+--

103+-- /Note:/ this function gets an exclusive access to the state for its duration.

68modify :: State s :> es => (s -> s) -> Eff es ()

104modify :: State s :> es => (s -> s) -> Eff es ()

69modify f = state (\s -> ((), f s))

105modify f = state (\s -> ((), f s))

70

106

107+-- | Apply the monadic function to the current state and return a value.

108+--

109+-- /Note:/ this function gets an exclusive access to the state for its duration.

71stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a

110stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a

72stateM f = unsafeEff $ \es -> do

111stateM f = unsafeEff $ \es -> do

73− IdE (State v) <- getEnv es

112+ DataA (State v) <- getEnv es

74 modifyMVar v $ \s0 -> do

113 modifyMVar v $ \s0 -> do

75 (a, s) <- unEff (f s0) es

114 (a, s) <- unEff (f s0) es

76 s `seq` pure (s, a)

115 s `seq` pure (s, a)

77

116

117+-- | Apply the monadic function to the current state.

118+--

119+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@

120+--

121+-- /Note:/ this function gets an exclusive access to the state for its duration.

78modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()

122modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()

79modifyM f = stateM (\s -> ((), ) <$> f s)

123modifyM f = stateM (\s -> ((), ) <$> f s)

124+

125+-- $setup

126+-- >>> import Control.Exception (ErrorCall)

127+-- >>> import Control.Monad.Catch

effectful-core/src/Effectful/Writer/Dynamic.hs+7−7

@@ -15,13 +15,13 @@ 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

22

23data Writer w :: Effect where

24− Tell :: ~w -> Writer w m ()

24+ Tell :: w -> Writer w m ()

25 Listen :: m a -> Writer w m (a, w)

26

27----------------------------------------

@@ -35,7 +35,7 @@ execLocalWriter = reinterpret L.execWriter localWriter

35

36localWriter

37 :: (L.Writer w :> es, Monoid w)

38− => LocalEnv localEs

38+ => LocalEnv localEs es

39 -> Writer w (Eff localEs) a

40 -> Eff es a

41localWriter env = \case

@@ -53,7 +53,7 @@ execSharedWriter = reinterpret S.execWriter sharedWriter

53

54sharedWriter

55 :: (S.Writer w :> es, Monoid w)

56− => LocalEnv localEs

56+ => LocalEnv localEs es

57 -> Writer w (Eff localEs) a

58 -> Eff es a

59sharedWriter env = \case

@@ -64,19 +64,19 @@ sharedWriter env = \case

64-- Operations

65

66tell

67− :: (HasCallStack, Writer w :> es, Monoid w)

67+ :: (HasCallStack, Writer w :> es)

68 => w

69 -> Eff es ()

70tell = send . Tell

71

72listen

73− :: (HasCallStack, Writer w :> es, Monoid w)

73+ :: (HasCallStack, Writer w :> es)

74 => Eff es a

75 -> Eff es (a, w)

76listen = send . Listen

77

78listens

79− :: (HasCallStack, Writer w :> es, Monoid w)

79+ :: (HasCallStack, Writer w :> es)

80 => (w -> b)

81 -> Eff es a

82 -> Eff es (a, b)

effectful-core/src/Effectful/Writer/Local.hs+56−10

@@ -1,4 +1,20 @@

1+-- | Support for access to a write only value of a particular type, which is:

2+--

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

4+-- look at "Effectful.Writer.Shared"),

5+--

6+-- - very fast.

7+--

8+-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses

9+-- of '<>', which makes it unsuitable for use with types for which such pattern

10+-- is inefficient. __This applies, in particular, to the standard list type__,

1−-- | The 'Writer' effect.

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.

2module Effectful.Writer.Local

18module Effectful.Writer.Local

3 ( Writer

19 ( Writer

4 , runWriter

20 , runWriter

@@ -8,41 +24,71 @@ module Effectful.Writer.Local

8 , listens

24 , listens

9 ) where

25 ) where

10

26

11−import Control.Exception

27+import Control.Exception (onException, mask)

12

28

13−import Effectful.Internal.Effect

29+import Effectful.Dispatch.Static

14−import Effectful.Internal.Env

15−import Effectful.Internal.Monad

30+import Effectful.Monad

16

31

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

18-- @w@.

33-- @w@.

19newtype Writer w :: Effect where

34newtype Writer w :: Effect where

20 Writer :: w -> Writer w m r

35 Writer :: w -> Writer w m r

21

36

37+-- | Run a 'Writer' effect and return the final value along with the final

38+-- output.

22runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

39runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

23runWriter m = do

40runWriter m = do

24− (a, IdE (Writer w)) <- runEffect (IdE (Writer mempty)) m

41+ (a, DataA (Writer w)) <- runData (DataA (Writer mempty)) m

25 pure (a, w)

42 pure (a, w)

26

43

44+-- | Run a 'Writer' effect and return the final output, discarding the final

45+-- value.

27execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

46execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

28execWriter m = do

47execWriter m = do

29− IdE (Writer w) <- execEffect (IdE (Writer mempty)) m

48+ DataA (Writer w) <- execData (DataA (Writer mempty)) m

30 pure w

49 pure w

31

50

51+-- | Append the given output to the overall output of the 'Writer'.

32tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

52tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

33−tell w = stateEffect $ \(IdE (Writer w0)) -> ((), IdE (Writer (w0 <> w)))

53+tell w = stateData $ \(DataA (Writer w0)) -> ((), DataA (Writer (w0 <> w)))

34

54

55+-- | Execute an action and append its output to the overall output of the

56+-- 'Writer'.

57+--

58+-- /Note:/ if an exception is received while the action is executed, the partial

59+-- output of the action will still be appended to the overall output of the

60+-- 'Writer':

61+--

62+-- >>> :{

63+-- runEff . execWriter @String $ do

64+-- tell "Hi"

65+-- handle (\(_::ErrorCall) -> pure ((), "")) $ do

66+-- tell " there"

67+-- listen $ do

68+-- tell "!"

69+-- error "oops"

70+-- :}

71+-- "Hi there!"

35listen :: (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)

36listen m = unsafeEff $ \es -> mask $ \restore -> do

73listen m = unsafeEff $ \es -> mask $ \restore -> do

37− w0 <- stateEnv es $ \(IdE (Writer w)) -> (w, IdE (Writer mempty))

74+ w0 <- stateEnv es $ \(DataA (Writer w)) -> (w, DataA (Writer mempty))

38 a <- restore (unEff m es) `onException` merge es w0

75 a <- restore (unEff m es) `onException` merge es w0

39 (a, ) <$> merge es w0

76 (a, ) <$> merge es w0

40 where

77 where

41 merge es w0 =

78 merge es w0 =

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

43− stateEnv es $ \(IdE (Writer w1)) -> (w1, IdE (Writer (w0 <> w1)))

80+ stateEnv es $ \(DataA (Writer w1)) -> (w1, DataA (Writer (w0 <> w1)))

44

81

82+-- | Execute an action and append its output to the overall output of the

83+-- 'Writer', then return the final value along with a function of the recorded

84+-- output.

85+--

86+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@

45listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

87listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

46listens f m = do

88listens f m = do

47 (a, w) <- listen m

89 (a, w) <- listen m

48 pure (a, f w)

90 pure (a, f w)

91+

92+-- $setup

93+-- >>> import Control.Exception (ErrorCall)

94+-- >>> import Control.Monad.Catch

effectful-core/src/Effectful/Writer/Shared.hs+57−10

@@ -1,3 +1,20 @@

1+-- | Support for access to a write only value of a particular type, which is:

2+--

3+-- - shared between multiple threads (if you want each thead to manage its own

4+-- version of the value, see "Effectful.Writer.Local").

5+--

6+-- - slightly slower than "Effectful.Writer.Local".

7+--

8+-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses

9+-- of '<>', which makes it unsuitable for use with types for which such pattern

10+-- is inefficient. __This applies, in particular, to the standard list type__,

11+-- which makes the 'Writer' effect pretty niche.

12+--

13+-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the

14+-- @transformers@ package includes additional operations

15+-- 'Control.Monad.Trans.Writer.Strict.pass' and

16+-- 'Control.Monad.Trans.Writer.Strict.censor', they don't cooperate with runtime

17+-- exceptions very well, so they're deliberately omitted here.

1module Effectful.Writer.Shared

18module Effectful.Writer.Shared

2 ( Writer

19 ( Writer

3 , runWriter

20 , runWriter

@@ -8,33 +25,54 @@ module Effectful.Writer.Shared

8 ) where

25 ) where

9

26

10import Control.Concurrent.MVar

27import Control.Concurrent.MVar

11−import Control.Exception

28+import Control.Exception (onException, uninterruptibleMask)

12

29

13−import Effectful.Internal.Effect

30+import Effectful.Dispatch.Static

14−import Effectful.Internal.Env

15−import Effectful.Internal.Monad

31+import Effectful.Monad

16

32

17−-- | Provide access to a strict (WHNF), shareable, write only value of type @w@.

33+-- | Provide access to a strict (WHNF), shared, write only value of type @w@.

18newtype Writer w :: Effect where

34newtype Writer w :: Effect where

19 Writer :: MVar w -> Writer w m r

35 Writer :: MVar w -> Writer w m r

20

36

37+-- | Run a 'Writer' effect and return the final value along with the final

38+-- output.

21runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

39runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

22runWriter m = do

40runWriter m = do

23 v <- unsafeEff_ $ newMVar mempty

41 v <- unsafeEff_ $ newMVar mempty

24− a <- evalEffect (IdE (Writer v)) m

42+ a <- evalData (DataA (Writer v)) m

25 (a, ) <$> unsafeEff_ (readMVar v)

43 (a, ) <$> unsafeEff_ (readMVar v)

26

44

45+-- | Run a 'Writer' effect and return the final output, discarding the final

46+-- value.

27execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

47execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

28execWriter m = do

48execWriter m = do

29 v <- unsafeEff_ $ newMVar mempty

49 v <- unsafeEff_ $ newMVar mempty

30− _ <- evalEffect (IdE (Writer v)) m

50+ _ <- evalData (DataA (Writer v)) m

31 unsafeEff_ $ readMVar v

51 unsafeEff_ $ readMVar v

32

52

53+-- | Append the given output to the overall output of the 'Writer'.

33tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

54tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

34tell w1 = unsafeEff $ \es -> do

55tell w1 = unsafeEff $ \es -> do

35− IdE (Writer v) <- getEnv es

56+ DataA (Writer v) <- getEnv es

36 modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w

57 modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w

37

58

59+-- | Execute an action and append its output to the overall output of the

60+-- 'Writer'.

61+--

62+-- /Note:/ if an exception is received while the action is executed, the partial

63+-- output of the action will still be appended to the overall output of the

64+-- 'Writer':

65+--

66+-- >>> :{

67+-- runEff . execWriter @String $ do

68+-- tell "Hi"

69+-- handle (\(_::ErrorCall) -> pure ((), "")) $ do

70+-- tell " there"

71+-- listen $ do

72+-- tell "!"

73+-- error "oops"

74+-- :}

75+-- "Hi there!"

38listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

76listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

39listen m = unsafeEff $ \es -> do

77listen m = unsafeEff $ \es -> do

40 -- The mask is uninterruptible because modifyMVar_ v0 in the merge function

78 -- The mask is uninterruptible because modifyMVar_ v0 in the merge function

@@ -43,19 +81,28 @@ listen m = unsafeEff $ \es -> do

43 uninterruptibleMask $ \restore -> do

81 uninterruptibleMask $ \restore -> do

44 v1 <- newMVar mempty

82 v1 <- newMVar mempty

45 -- Replace thread local MVar with a fresh one for isolated listening.

83 -- Replace thread local MVar with a fresh one for isolated listening.

46− v0 <- stateEnv es $ \(IdE (Writer v)) -> (v, IdE (Writer v1))

84+ v0 <- stateEnv es $ \(DataA (Writer v)) -> (v, DataA (Writer v1))

47 a <- restore (unEff m es) `onException` merge es v0 v1

85 a <- restore (unEff m es) `onException` merge es v0 v1

48 (a, ) <$> merge es v0 v1

86 (a, ) <$> merge es v0 v1

49 where

87 where

50 -- Merge results accumulated in the local MVar with the mainline. If an

88 -- Merge results accumulated in the local MVar with the mainline. If an

51 -- exception was received while listening, merge results recorded so far.

89 -- exception was received while listening, merge results recorded so far.

52 merge es v0 v1 = do

90 merge es v0 v1 = do

53− putEnv es $ IdE (Writer v0)

91+ putEnv es $ DataA (Writer v0)

54 w1 <- readMVar v1

92 w1 <- readMVar v1

55 modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w

93 modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w

56 pure w1

94 pure w1

57

95

96+-- | Execute an action and append its output to the overall output of the

97+-- 'Writer', then return the final value along with a function of the recorded

98+-- output.

99+--

100+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@

58listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

101listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

59listens f m = do

102listens f m = do

60 (a, w) <- listen m

103 (a, w) <- listen m

61 pure (a, f w)

104 pure (a, f w)

105+

106+-- $setup

107+-- >>> import Control.Exception (ErrorCall)

108+-- >>> import Control.Monad.Catch

effectful/bench/Concurrency.hs+8−9

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

11

12import Control.Concurrent.Async

13import Control.Monad

14−import Control.Monad.IO.Class

15−import qualified Effectful.Async as A

14+import qualified Effectful.Concurrent.Async as A

16

15

17import Effectful

16import Effectful

18import Utils

17import Utils

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

26shallowBench :: Int -> Benchmark

25shallowBench :: Int -> Benchmark

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

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

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

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

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

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

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

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

31 nfAppIO (runShallow . runFork1 . forkBench n) op

30 nfAppIO (runShallow . runFork1 . forkBench n) op

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

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

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

39

38

40deepBench :: Int -> Benchmark

39deepBench :: Int -> Benchmark

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

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

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

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

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

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

44 nfAppIO (runDeep . runFork1 . forkBench n) op

43 nfAppIO (runDeep . runFork1 . forkBench n) op

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

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

@@ -61,14 +60,14 @@ data Fork :: Effect where

61-- | Uses 'localUnliftIO' and 'withLiftMapIO'.

60-- | Uses 'localUnliftIO' and 'withLiftMapIO'.

62runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a

61runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a

63runFork1 = interpret $ \env -> \case

62runFork1 = interpret $ \env -> \case

64− ForkWithUnmask m -> withLiftMapIO $ \liftMap -> do

63+ ForkWithUnmask m -> withLiftMapIO env $ \liftMap -> do

65 localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

64 localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

66 asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

65 asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

67

66

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

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

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

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

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

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

71− ForkWithUnmask m -> withLiftMap $ \liftMap -> do

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

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

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

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

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

74

73

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

81

80

82-- | Uses 'localLiftUnlift'.

81-- | Uses 'localLiftUnlift'.

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

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

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

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

85 ForkWithUnmask m -> do

84 ForkWithUnmask m -> do

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

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

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

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

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

95 wait a

94 wait a

96{-# NOINLINE asyncBenchIO #-}

95{-# NOINLINE asyncBenchIO #-}

97

96

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

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

99asyncBench n f = do

98asyncBench n f = do

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

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

101 sum <$> replicateM n (unmask f)

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+14−14

@@ -9,12 +9,12 @@ import Criterion

9import Test.Tasty.Bench

10#endif

11

12−import UnliftIO

12+import qualified UnliftIO as U

13

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

@@ -92,19 +92,19 @@ benchDummy :: MonadUnliftIO m => m ()

92benchDummy = withRunInIO $ \runIO -> runIO $ pure ()

93

94benchAsync :: MonadUnliftIO m => m ()

95−benchAsync = withAsync (pure ()) wait

95+benchAsync = U.withAsync (pure ()) U.wait

96

97benchConcurrently :: MonadUnliftIO m => m ()

98−benchConcurrently = concurrently_ (pure ()) (pure ())

98+benchConcurrently = U.concurrently_ (pure ()) (pure ())

99

100benchDummyE :: 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+44−25

@@ -1,7 +1,7 @@

1cabal-version: 2.4

2build-type: Simple

3name: effectful

4−version: 0.0.0.0

4+version: 0.1

5license: BSD-3-Clause

6license-file: LICENSE

7category: Control

@@ -10,16 +10,17 @@ author: Andrzej Rybczak

10synopsis: An easy to use, performant extensible effects library.

11

12description: An easy to use, performant extensible effects library with seamless

13− integration with the existing Haskell ecosystem.

13+ integration with the existing Haskell ecosystem. See the main

14+ module "Effectful" for the documentation.

14 .

15 .

15− This is the "batteries included" variant; See the

16+ This is the "batteries-included" variant with many dependencies;

16− @<https://hackage.haskell.org/package/effectful-core effectful-core>@

17+ See the @<https://hackage.haskell.org/package/effectful-core

17− package for the effect system itself as well as the various other

18+ effectful-core>@ package and other @effectful-*@ packages if you

18− @effectful-*@ packages if you need a smaller dependency footprint.

19+ need a more limited dependency footprint.

19

20

20extra-source-files: CHANGELOG.md

21extra-source-files: CHANGELOG.md

21

22

22−tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210422

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

23

24

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

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

25source-repository head

26source-repository head

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

39 ConstraintKinds

40 ConstraintKinds

40 DataKinds

41 DataKinds

41 DeriveFunctor

42 DeriveFunctor

43+ DeriveGeneric

42 FlexibleContexts

44 FlexibleContexts

43 FlexibleInstances

45 FlexibleInstances

44 GADTs

46 GADTs

@@ -51,7 +53,6 @@ common language

51 RoleAnnotations

53 RoleAnnotations

52 ScopedTypeVariables

54 ScopedTypeVariables

53 StandaloneDeriving

55 StandaloneDeriving

54− StrictData

55 TupleSections

56 TupleSections

56 TypeApplications

57 TypeApplications

57 TypeFamilies

58 TypeFamilies

@@ -60,30 +61,44 @@ common language

60library

61library

61 import: language

62 import: language

62

63

63− ghc-options: -O2

64−

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

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

66− , async

65+ , async >= 2.2.2

66+ , directory >= 1.3.2

67− , effectful-core

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

68+ , process >= 1.6.9

68− , resourcet

69+ , resourcet >= 1.2.4.3

70+ , time >= 1.9.2

71+ , stm >= 2.5.0.0

69− , unliftio

72+ , unliftio >= 0.2.20

70

73

71 hs-source-dirs: src

74 hs-source-dirs: src

72

75

73− exposed-modules: Effectful

76+ exposed-modules: Effectful.Concurrent

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

83+ Effectful.Environment

84+ Effectful.FileSystem

85+ Effectful.FileSystem.IO

86+ Effectful.Process

75 Effectful.Resource

87 Effectful.Resource

88+ Effectful.Temporary

89+ Effectful.Timeout

76

90

91+ other-modules: Effectful.Concurrent.Effect

92+ Effectful.FileSystem.Effect

93+

77− reexported-modules: Effectful.Error

94+ reexported-modules: Effectful

95+ , Effectful.Dispatch.Dynamic

96+ , Effectful.Dispatch.Static

97+ , Effectful.Error

78 , Effectful.Error.Dynamic

98 , Effectful.Error.Dynamic

79 , Effectful.Fail

99 , Effectful.Fail

80− , Effectful.Handler

81− , Effectful.Internal.Effect

82− , Effectful.Internal.Env

83− , Effectful.Internal.Monad

84− , Effectful.Internal.Unlift

85− , Effectful.Internal.Utils

86 , Effectful.Monad

100 , Effectful.Monad

101+ , Effectful.Prim

87 , Effectful.Reader

102 , Effectful.Reader

88 , Effectful.Reader.Dynamic

103 , Effectful.Reader.Dynamic

89 , Effectful.State.Dynamic

104 , Effectful.State.Dynamic

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

101 build-depends: base

116 build-depends: base

102 , containers

117 , containers

103 , effectful

118 , effectful

119+ , effectful-core

104 , exceptions

120 , exceptions

105 , lifted-base

121 , lifted-base

106 , tasty

122 , tasty

@@ -114,8 +130,11 @@ test-suite test

114

130

115 other-modules: AsyncTests

131 other-modules: AsyncTests

116 ConcurrencyTests

132 ConcurrencyTests

133+ EnvironmentTests

117 ErrorTests

134 ErrorTests

118 StateTests

135 StateTests

136+ TimeoutTests

137+ UnliftTests

119 Utils

138 Utils

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

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

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

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

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

135 if impl(ghc < 9.2)

154 if impl(ghc < 9.2)

136 build-depends: fused-effects

155 build-depends: fused-effects

137

156

138− if impl(ghc < 9.2)

157+ if impl(ghc < 9.3)

139 build-depends: polysemy

158 build-depends: polysemy

140

159

141 build-depends: base

160 build-depends: base

effectful/examples/FileSystem.hs−1

@@ -9,7 +9,6 @@ module FileSystem

9

10import Control.Exception (IOException)

11import Control.Monad.Catch

12−import Control.Monad.IO.Class

13import Prelude hiding (readFile, writeFile)

12import Prelude hiding (readFile, writeFile)

14import qualified Data.Map.Strict as M

13import qualified Data.Map.Strict as M

15import qualified System.IO as IO

14import qualified System.IO as IO

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

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

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

2+--

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

4+-- recommended as follows:

5+--

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

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

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

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

10+--

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

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

13+--

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

15+module Effectful.Concurrent

16+ ( Concurrent

17+ , runConcurrent

18+

19+ -- * Basic concurrency operations

20+ , myThreadId

21+ , forkIO

22+ , forkFinally

23+ , forkIOWithUnmask

24+ , killThread

25+ , throwTo

26+

27+ -- ** Threads with affinity

28+ , forkOn

29+ , forkOnWithUnmask

30+ , getNumCapabilities

31+ , setNumCapabilities

32+ , getNumProcessors

33+ , threadCapability

34+

35+ -- * Scheduling

36+ , yield

37+

38+ -- ** Waiting

39+ , threadDelay

40+ , threadWaitRead

41+ , threadWaitWrite

42+ , threadWaitReadSTM

43+ , threadWaitWriteSTM

44+

45+ -- * Bound threads

46+ , forkOS

47+ , forkOSWithUnmask

48+ , isCurrentThreadBound

49+ , runInBoundThread

50+ , runInUnboundThread

51+

52+ -- * Weak references to ThreadIds

53+ , mkWeakThreadId

54+

55+ -- * Re-exports

56+ , C.rtsSupportsBoundThreads

57+ ) where

58+

59+import Control.Exception (Exception, SomeException)

60+import Data.Bifunctor (second)

61+import System.Mem.Weak (Weak)

62+import System.Posix.Types (Fd)

63+import UnliftIO.STM (STM)

64+import qualified Control.Concurrent as C

65+import qualified GHC.Conc as GHC

66+

67+import Effectful.Concurrent.Effect

68+import Effectful.Dispatch.Static

69+import Effectful.Monad

70+

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

72+-- Basic concurrency operations

73+

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

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

76+myThreadId = unsafeEff_ C.myThreadId

77+

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

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

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

81+ esF <- cloneEnv es

82+ C.forkIO $ unEff k esF

83+

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

85+forkFinally

86+ :: Concurrent :> es

87+ => Eff es a

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

89+ -> Eff es C.ThreadId

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

91+ esF <- cloneEnv es

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

93+

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

95+forkIOWithUnmask

96+ :: Concurrent :> es

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

98+ -> Eff es ())

99+ -> Eff es C.ThreadId

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

101+ esF <- cloneEnv es

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

103+

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

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

106+killThread = unsafeEff_ . C.killThread

107+

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

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

110+throwTo tid = unsafeEff_ . C.throwTo tid

111+

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

113+-- Threads with affinity

114+

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

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

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

118+ esF <- cloneEnv es

119+ C.forkOn n (unEff k esF)

120+

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

122+forkOnWithUnmask

123+ :: Concurrent :> es

124+ => Int

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

126+ -> Eff es C.ThreadId

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

128+ esF <- cloneEnv es

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

130+

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

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

133+getNumCapabilities = unsafeEff_ C.getNumCapabilities

134+

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

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

137+setNumCapabilities = unsafeEff_ . C.setNumCapabilities

138+

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

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

141+getNumProcessors = unsafeEff_ GHC.getNumProcessors

142+

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

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

145+threadCapability = unsafeEff_ . C.threadCapability

146+

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

148+-- Scheduling

149+

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

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

152+yield = unsafeEff_ C.yield

153+

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

155+-- Waiting

156+

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

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

159+threadDelay = unsafeEff_ . C.threadDelay

160+

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

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

163+threadWaitRead = unsafeEff_ . C.threadWaitRead

164+

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

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

167+threadWaitWrite = unsafeEff_ . C.threadWaitWrite

168+

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

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

171+threadWaitReadSTM fd = unsafeEff_ $ do

172+ second unsafeEff_ <$> C.threadWaitReadSTM fd

173+

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

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

176+threadWaitWriteSTM fd = unsafeEff_ $ do

177+ second unsafeEff_ <$> C.threadWaitWriteSTM fd

178+

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

180+-- Bound threads

181+

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

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

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

185+ esF <- cloneEnv es

186+ C.forkOS $ unEff k esF

187+

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

189+forkOSWithUnmask

190+ :: Concurrent :> es

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

192+ -> Eff es C.ThreadId

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

194+ esF <- cloneEnv es

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

196+

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

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

199+isCurrentThreadBound = unsafeEff_ C.isCurrentThreadBound

200+

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

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

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

204+ esF <- cloneEnv es

205+ C.runInBoundThread $ unEff k esF

206+

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

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

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

210+ esF <- cloneEnv es

211+ C.runInUnboundThread $ unEff k esF

212+

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

214+-- Weak references to ThreadIds

215+

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

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

218+mkWeakThreadId = unsafeEff_ . C.mkWeakThreadId

effectful/src/Effectful/Async.hs → effectful/src/Effectful/Concurrent/Async.hsrenamed+72−89

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

1{-# LANGUAGE UndecidableInstances #-}

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

2−module Effectful.Async

3+module Effectful.Concurrent.Async

3− ( -- * Async effect

4+ ( Concurrent

4− AsyncE

5+ , runConcurrent

5− , runAsyncE

6

7 -- * Asynchronous actions

8 , Async

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

76import Control.Concurrent.Async (Async)

77import Control.Exception (Exception, SomeException)

78import Control.Monad (forever)

79−import Data.Kind

79+import Data.Kind (Type)

80import qualified Control.Concurrent.Async as A

81import qualified UnliftIO.Async as U

82import qualified UnliftIO.Internals.Async as I

83

84−import Effectful.Internal.Effect

84+import Effectful.Concurrent.Effect

85−import Effectful.Internal.Env

85+import Effectful.Dispatch.Static

86−import Effectful.Internal.Monad

86+import Effectful.Monad

87−

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

89−--

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

91−-- will not affect the parent thread.

92−--

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

94−data AsyncE :: Effect where

95− AsyncE :: AsyncE m r

96−

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

98−runAsyncE = evalEffect (IdE AsyncE)

99−

100−----------------------------------------

101−-- Operations

102

87

103-- | Lifted 'A.async'.

88-- | Lifted 'A.async'.

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

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

105async = liftAsync A.async

90async = liftAsync A.async

106

91

107-- | Lifted 'A.asyncBound'.

92-- | Lifted 'A.asyncBound'.

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

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

109asyncBound = liftAsync A.asyncBound

94asyncBound = liftAsync A.asyncBound

110

95

111-- | Lifted 'A.asyncOn'.

96-- | Lifted 'A.asyncOn'.

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

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

113asyncOn cpu = liftAsync (A.asyncOn cpu)

98asyncOn cpu = liftAsync (A.asyncOn cpu)

114

99

115-- | Lifted 'A.asyncWithUnmask'.

100-- | Lifted 'A.asyncWithUnmask'.

116asyncWithUnmask

101asyncWithUnmask

117− :: AsyncE :> es

102+ :: Concurrent :> es

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

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

119 -> Eff es (Async a)

104 -> Eff es (Async a)

120asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask

105asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask

121

106

122-- | Lifted 'A.asyncOnWithUnmask'.

107-- | Lifted 'A.asyncOnWithUnmask'.

123asyncOnWithUnmask

108asyncOnWithUnmask

124− :: AsyncE :> es

109+ :: Concurrent :> es

125 => Int

110 => Int

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

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

127 -> Eff es (Async a)

112 -> Eff es (Async a)

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

129

114

130-- | Lifted 'A.withAsync'.

115-- | Lifted 'A.withAsync'.

131withAsync

116withAsync

132− :: AsyncE :> es

117+ :: Concurrent :> es

133 => Eff es a

118 => Eff es a

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

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

135 -> Eff es b

120 -> Eff es b

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

137

122

138-- | Lifted 'A.withAsyncBound'.

123-- | Lifted 'A.withAsyncBound'.

139withAsyncBound

124withAsyncBound

140− :: AsyncE :> es

125+ :: Concurrent :> es

141 => Eff es a

126 => Eff es a

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

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

143 -> Eff es b

128 -> Eff es b

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

145

130

146-- | Lifted 'A.withAsyncOn'.

131-- | Lifted 'A.withAsyncOn'.

147withAsyncOn

132withAsyncOn

148− :: AsyncE :> es

133+ :: Concurrent :> es

149 => Int

134 => Int

150 -> Eff es a

135 -> Eff es a

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

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

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

154

139

155-- | Lifted 'A.withAsyncWithUnmask'.

140-- | Lifted 'A.withAsyncWithUnmask'.

156withAsyncWithUnmask

141withAsyncWithUnmask

157− :: AsyncE :> es

142+ :: Concurrent :> es

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

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

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

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

160 -> Eff es b

145 -> Eff es b

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

162

147

163-- | Lifted 'A.withAsyncOnWithUnmask'.

148-- | Lifted 'A.withAsyncOnWithUnmask'.

164withAsyncOnWithUnmask

149withAsyncOnWithUnmask

165− :: AsyncE :> es

150+ :: Concurrent :> es

166 => Int

151 => Int

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

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

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

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

@@ -170,60 +155,60 @@ withAsyncOnWithUnmask

170withAsyncOnWithUnmask cpu = liftWithAsyncWithUnmask (A.withAsyncOnWithUnmask cpu)

155withAsyncOnWithUnmask cpu = liftWithAsyncWithUnmask (A.withAsyncOnWithUnmask cpu)

171

156

172-- | Lifted 'A.wait'.

157-- | Lifted 'A.wait'.

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

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

174wait = unsafeEff_ . A.wait

159wait = unsafeEff_ . A.wait

175

160

176-- | Lifted 'A.poll'.

161-- | Lifted 'A.poll'.

177poll

162poll

178− :: AsyncE :> es

163+ :: Concurrent :> es

179 => Async a

164 => Async a

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

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

181poll = unsafeEff_ . A.poll

166poll = unsafeEff_ . A.poll

182

167

183-- | Lifted 'A.cancel'.

168-- | Lifted 'A.cancel'.

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

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

185cancel = unsafeEff_ . A.cancel

170cancel = unsafeEff_ . A.cancel

186

171

187-- | Lifted 'A.cancelWith'.

172-- | Lifted 'A.cancelWith'.

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

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

189cancelWith a = unsafeEff_ . A.cancelWith a

174cancelWith a = unsafeEff_ . A.cancelWith a

190

175

191-- | Lifted 'A.uninterruptibleCancel'.

176-- | Lifted 'A.uninterruptibleCancel'.

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

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

193uninterruptibleCancel = unsafeEff_ . A.uninterruptibleCancel

178uninterruptibleCancel = unsafeEff_ . A.uninterruptibleCancel

194

179

195-- | Lifted 'A.waitCatch'.

180-- | Lifted 'A.waitCatch'.

196waitCatch

181waitCatch

197− :: AsyncE :> es

182+ :: Concurrent :> es

198 => Async a

183 => Async a

199 -> Eff es (Either SomeException a)

184 -> Eff es (Either SomeException a)

200waitCatch = unsafeEff_ . A.waitCatch

185waitCatch = unsafeEff_ . A.waitCatch

201

186

202-- | Lifted 'A.waitAny'.

187-- | Lifted 'A.waitAny'.

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

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

204waitAny = unsafeEff_ . A.waitAny

189waitAny = unsafeEff_ . A.waitAny

205

190

206-- | Lifted 'A.waitAnyCatch'.

191-- | Lifted 'A.waitAnyCatch'.

207waitAnyCatch

192waitAnyCatch

208− :: AsyncE :> es

193+ :: Concurrent :> es

209 => [Async a]

194 => [Async a]

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

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

211waitAnyCatch = unsafeEff_ . A.waitAnyCatch

196waitAnyCatch = unsafeEff_ . A.waitAnyCatch

212

197

213-- | Lifted 'A.waitAnyCancel'.

198-- | Lifted 'A.waitAnyCancel'.

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

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

215waitAnyCancel = unsafeEff_ . A.waitAnyCancel

200waitAnyCancel = unsafeEff_ . A.waitAnyCancel

216

201

217-- | Lifted 'A.waitAnyCatchCancel'.

202-- | Lifted 'A.waitAnyCatchCancel'.

218waitAnyCatchCancel

203waitAnyCatchCancel

219− :: AsyncE :> es

204+ :: Concurrent :> es

220 => [Async a]

205 => [Async a]

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

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

222waitAnyCatchCancel = unsafeEff_ . A.waitAnyCatchCancel

207waitAnyCatchCancel = unsafeEff_ . A.waitAnyCatchCancel

223

208

224-- | Lifted 'A.waitEither'.

209-- | Lifted 'A.waitEither'.

225waitEither

210waitEither

226− :: AsyncE :> es

211+ :: Concurrent :> es

227 => Async a

212 => Async a

228 -> Async b

213 -> Async b

229 -> Eff es (Either a b)

214 -> Eff es (Either a b)

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

231

216

232-- | Lifted 'A.waitEitherCatch'.

217-- | Lifted 'A.waitEitherCatch'.

233waitEitherCatch

218waitEitherCatch

234− :: AsyncE :> es

219+ :: Concurrent :> es

235 => Async a

220 => Async a

236 -> Async b

221 -> Async b

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

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

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

239

224

240-- | Lifted 'A.waitEitherCancel'.

225-- | Lifted 'A.waitEitherCancel'.

241waitEitherCancel

226waitEitherCancel

242− :: AsyncE :> es

227+ :: Concurrent :> es

243 => Async a

228 => Async a

244 -> Async b

229 -> Async b

245 -> Eff es (Either a b)

230 -> Eff es (Either a b)

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

247

232

248-- | Lifted 'A.waitEitherCatchCancel'.

233-- | Lifted 'A.waitEitherCatchCancel'.

249waitEitherCatchCancel

234waitEitherCatchCancel

250− :: AsyncE :> es

235+ :: Concurrent :> es

251 => Async a

236 => Async a

252 -> Async b

237 -> Async b

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

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

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

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

255

240

256-- | Lifted 'A.waitEither_'.

241-- | Lifted 'A.waitEither_'.

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

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

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

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

259

244

260-- | Lifted 'A.waitBoth'.

245-- | Lifted 'A.waitBoth'.

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

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

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

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

263

248

264-- | Lifted 'A.link'.

249-- | Lifted 'A.link'.

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

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

266link = unsafeEff_ . A.link

251link = unsafeEff_ . A.link

267

252

268-- | Lifted 'A.linkOnly'.

253-- | Lifted 'A.linkOnly'.

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

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

270linkOnly f = unsafeEff_ . A.linkOnly f

255linkOnly f = unsafeEff_ . A.linkOnly f

271

256

272-- | Lifted 'A.link2'.

257-- | Lifted 'A.link2'.

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

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

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

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

275

260

276-- | Lifted 'A.link2Only'.

261-- | Lifted 'A.link2Only'.

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

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

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

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

279

264

280-- | Lifted 'A.race'.

265-- | Lifted 'A.race'.

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

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

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

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

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

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

284

269

285-- | Lifted 'A.race_'.

270-- | Lifted 'A.race_'.

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

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

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

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

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

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

289

274

290-- | Lifted 'A.concurrently'.

275-- | Lifted 'A.concurrently'.

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

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

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

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

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

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

294

279

295-- | Lifted 'A.concurrently_'.

280-- | Lifted 'A.concurrently_'.

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

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

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

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

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

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

299

284

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

303

288

304-- | Lifted 'A.mapConcurrently'.

289-- | Lifted 'A.mapConcurrently'.

305mapConcurrently

290mapConcurrently

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

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

307 => (a -> Eff es b)

292 => (a -> Eff es b)

308 -> f a

293 -> f a

309 -> Eff es (f b)

294 -> Eff es (f b)

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

312

297

313-- | Lifted 'A.mapConcurrently_'.

298-- | Lifted 'A.mapConcurrently_'.

314mapConcurrently_

299mapConcurrently_

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

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

316 => (a -> Eff es b)

301 => (a -> Eff es b)

317 -> f a

302 -> f a

318 -> Eff es ()

303 -> Eff es ()

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

321

306

322-- | Lifted 'A.forConcurrently'.

307-- | Lifted 'A.forConcurrently'.

323forConcurrently

308forConcurrently

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

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

325 => f a

310 => f a

326 -> (a -> Eff es b)

311 -> (a -> Eff es b)

327 -> Eff es (f b)

312 -> Eff es (f b)

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

330

315

331-- | Lifted 'A.forConcurrently_'.

316-- | Lifted 'A.forConcurrently_'.

332forConcurrently_

317forConcurrently_

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

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

334 => f a

319 => f a

335 -> (a -> Eff es b)

320 -> (a -> Eff es b)

336 -> Eff es ()

321 -> Eff es ()

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

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

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

339

324

340-- | Lifted 'A.replicateConcurrently'.

325-- | Lifted 'A.replicateConcurrently'.

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

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

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

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

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

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

344

329

345-- | Lifted 'A.replicateConcurrently_'.

330-- | Lifted 'A.replicateConcurrently_'.

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

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

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

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

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

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

349

334

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

352

337

353-- | Lifted 'U.pooledMapConcurrentlyN'.

338-- | Lifted 'U.pooledMapConcurrentlyN'.

354pooledMapConcurrentlyN

339pooledMapConcurrentlyN

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

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

356 => Int

341 => Int

357 -> (a -> Eff es b)

342 -> (a -> Eff es b)

358 -> t a

343 -> t a

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

362

347

363-- | Lifted 'U.pooledMapConcurrently'.

348-- | Lifted 'U.pooledMapConcurrently'.

364pooledMapConcurrently

349pooledMapConcurrently

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

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

366 => (a -> Eff es b)

351 => (a -> Eff es b)

367 -> t a

352 -> t a

368 -> Eff es (t b)

353 -> Eff es (t b)

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

371

356

372-- | Lifted 'U.pooledMapConcurrentlyN'.

357-- | Lifted 'U.pooledMapConcurrentlyN'.

373pooledMapConcurrentlyN_

358pooledMapConcurrentlyN_

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

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

375 => Int

360 => Int

376 -> (a -> Eff es b)

361 -> (a -> Eff es b)

377 -> f a

362 -> f a

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

381

366

382-- | Lifted 'U.pooledMapConcurrently_'.

367-- | Lifted 'U.pooledMapConcurrently_'.

383pooledMapConcurrently_

368pooledMapConcurrently_

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

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

385 => (a -> Eff es b)

370 => (a -> Eff es b)

386 -> f a

371 -> f a

387 -> Eff es ()

372 -> Eff es ()

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

390

375

391-- | Lifted 'U.pooledForConcurrentlyN'.

376-- | Lifted 'U.pooledForConcurrentlyN'.

392pooledForConcurrentlyN

377pooledForConcurrentlyN

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

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

394 => Int

379 => Int

395 -> t a

380 -> t a

396 -> (a -> Eff es b)

381 -> (a -> Eff es b)

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

400

385

401-- | Lifted 'U.pooledForConcurrently'.

386-- | Lifted 'U.pooledForConcurrently'.

402pooledForConcurrently

387pooledForConcurrently

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

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

404 => t a

389 => t a

405 -> (a -> Eff es b)

390 -> (a -> Eff es b)

406 -> Eff es (t b)

391 -> Eff es (t b)

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

409

394

410-- | Lifted 'U.pooledForConcurrentlyN'.

395-- | Lifted 'U.pooledForConcurrentlyN'.

411pooledForConcurrentlyN_

396pooledForConcurrentlyN_

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

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

413 => Int

398 => Int

414 -> f a

399 -> f a

415 -> (a -> Eff es b)

400 -> (a -> Eff es b)

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

419

404

420-- | Lifted 'U.pooledForConcurrently_'.

405-- | Lifted 'U.pooledForConcurrently_'.

421pooledForConcurrently_

406pooledForConcurrently_

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

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

423 => f a

408 => f a

424 -> (a -> Eff es b)

409 -> (a -> Eff es b)

425 -> Eff es ()

410 -> Eff es ()

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

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

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

428

413

429-- | Lifted 'U.pooledReplicateConcurrentlyN'.

414-- | Lifted 'U.pooledReplicateConcurrentlyN'.

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

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

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

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

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

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

433

418

434-- | Lifted 'U.pooledReplicateConcurrently'.

419-- | Lifted 'U.pooledReplicateConcurrently'.

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

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

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

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

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

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

438

423

439-- | Lifted 'U.pooledReplicateConcurrentlyN_'.

424-- | Lifted 'U.pooledReplicateConcurrentlyN_'.

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

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

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

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

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

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

443

428

444-- | Lifted 'U.pooledReplicateConcurrently_'.

429-- | Lifted 'U.pooledReplicateConcurrently_'.

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

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

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

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

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

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

448

433

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

482conc = Action

467conc = Action

483

468

484-- | Lifted 'U.runConc'.

469-- | Lifted 'U.runConc'.

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

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

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

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

487 where

472 where

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

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

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

503instance Functor (Concurrently es) where

488instance Functor (Concurrently es) where

504 fmap f (Concurrently a) = Concurrently (fmap f a)

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

505

490

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

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

507 pure = Concurrently . pure

492 pure = Concurrently . pure

508 Concurrently fs <*> Concurrently as =

493 Concurrently fs <*> Concurrently as =

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

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

510

495

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

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

512 empty = Concurrently . unsafeEff_ . forever $ threadDelay maxBound

497 empty = Concurrently . unsafeEff_ . forever $ threadDelay maxBound

513 Concurrently as <|> Concurrently bs =

498 Concurrently as <|> Concurrently bs =

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

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

515

500

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

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

517 (<>) = liftA2 (<>)

502 (<>) = liftA2 (<>)

518

503

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

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

520 mempty = pure mempty

505 mempty = pure mempty

521

506

522----------------------------------------

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

@@ -534,10 +519,9 @@ liftAsyncWithUnmask

534 :: (((forall b. IO b -> IO b) -> IO a) -> IO (Async a))

519 :: (((forall b. IO b -> IO b) -> IO a) -> IO (Async a))

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

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

536 -> Eff es (Async a)

521 -> Eff es (Async a)

537−liftAsyncWithUnmask fork action = do

522+liftAsyncWithUnmask fork action = unsafeEff $ \es -> do

538− unsafeWithLiftMapIO $ \liftMap -> unsafeEff $ \es -> do

539− esA <- cloneEnv es

523+ esA <- cloneEnv es

540− fork $ \unmask -> unEff (action $ liftMap unmask) esA

524+ fork $ \unmask -> unEff (action $ unsafeLiftMapIO unmask) esA

541

525

542liftWithAsync

526liftWithAsync

543 :: (IO a -> (Async a -> IO b) -> IO b)

527 :: (IO a -> (Async a -> IO b) -> IO b)

@@ -554,8 +538,7 @@ liftWithAsyncWithUnmask

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

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

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

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

556 -> Eff es b

540 -> Eff es b

557−liftWithAsyncWithUnmask withA action k = do

541+liftWithAsyncWithUnmask withA action k = unsafeEff $ \es -> do

558− unsafeWithLiftMapIO $ \liftMap -> unsafeEff $ \es -> do

559− esA <- cloneEnv es

542+ esA <- cloneEnv es

560− withA (\unmask -> unEff (action $ liftMap unmask) esA)

543+ withA (\unmask -> unEff (action $ unsafeLiftMapIO unmask) esA)

561− (\a -> unEff (k a) es)

544+ (\a -> unEff (k a) es)

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

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

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

2+module Effectful.Concurrent.Chan

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * Chan

7+ , Chan

8+ , newChan

9+ , writeChan

10+ , readChan

11+ , dupChan

12+ , getChanContents

13+ , writeList2Chan

14+ ) where

15+

16+import Control.Concurrent.Chan (Chan)

17+import qualified Control.Concurrent.Chan as C

18+

19+import Effectful.Concurrent.Effect

20+import Effectful.Dispatch.Static

21+import Effectful.Monad

22+

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

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

25+newChan = unsafeEff_ C.newChan

26+

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

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

29+writeChan c = unsafeEff_ . C.writeChan c

30+

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

32+readChan :: Concurrent :> es => Chan a -> Eff es a

33+readChan = unsafeEff_ . C.readChan

34+

35+-- | Lifted 'C.dupChan'.

36+dupChan :: Concurrent :> es => Chan a -> Eff es (Chan a)

37+dupChan = unsafeEff_ . C.dupChan

38+

39+-- | Lifted 'C.getChanContents'.

40+getChanContents :: Concurrent :> es => Chan a -> Eff es [a]

41+getChanContents = unsafeEff_ . C.getChanContents

42+

43+-- | Lifted 'C.writeList2Chan'.

44+writeList2Chan :: Concurrent :> es => Chan a -> [a] -> Eff es ()

45+writeList2Chan c = unsafeEff_ . C.writeList2Chan c

effectful/src/Effectful/Concurrent/Effect.hsnew file+79

@@ -0,0 +1,79 @@

1+module Effectful.Concurrent.Effect

2+ ( Concurrent

3+ , runConcurrent

4+ ) where

5+

6+import Effectful.Dispatch.Static

7+import Effectful.Monad

8+

9+-- | Provide the ability to run 'Eff' computations concurrently in multiple

10+-- threads and communicate between them.

11+--

12+-- /Warning:/ unless you stick to high level functions from the

13+-- 'Effectful.Concurrent.Async.withAsync' family, the 'Concurrent' effect makes

14+-- it possible to escape the scope of any scoped effect operation. Consider the

15+-- following:

16+--

17+-- >>> import qualified Effectful.Reader as R

18+-- >>> let printAsk msg = liftIO . putStrLn . (msg ++) . (": " ++) =<< R.ask

19+-- >>> :{

20+-- runEff . R.runReader "GLOBAL" . runConcurrent $ do

21+-- a <- R.local (const "LOCAL") $ do

22+-- a <- async $ do

23+-- printAsk "child (first)"

24+-- threadDelay 20000

25+-- printAsk "child (second)"

26+-- threadDelay 10000

27+-- printAsk "parent (inside)"

28+-- pure a

29+-- printAsk "parent (outside)"

30+-- wait a

31+-- :}

32+-- child (first): LOCAL

33+-- parent (inside): LOCAL

34+-- parent (outside): GLOBAL

35+-- child (second): LOCAL

36+--

37+-- Note that the asynchronous computation doesn't respect the scope of

38+-- 'Effectful.Reader.local', i.e. the child thread still behaves like it's

39+-- inside the 'Effectful.Reader.local' block, even though the parent thread

40+-- already got out of it.

41+--

42+-- This is because the value provided by the 'Effectful.Reader.Reader' effect is

43+-- thread local, i.e. each thread manages its own version of it. For the

44+-- 'Effectful.Reader.Reader' it is the only reasonable behavior, it wouldn't be

45+-- very useful if its "read only" value was affected by calls to

46+-- 'Effectful.Reader.local' from its parent or child threads.

47+--

48+-- However, the cut isn't so clear if it comes to effects that provide access to

49+-- a mutable state. That's why primitive @State@ and @Writer@ effects come in

50+-- two flavors, local and shared:

51+--

52+-- >>> import qualified Effectful.State.Local as SL

53+-- >>> :{

54+-- runEff . SL.execState "Hi" . runConcurrent $ do

55+-- replicateConcurrently_ 3 $ SL.modify (++ "!")

56+-- :}

57+-- "Hi"

58+--

59+-- >>> import qualified Effectful.State.Shared as SS

60+-- >>> :{

61+-- runEff . SS.execState "Hi" . runConcurrent $ do

62+-- replicateConcurrently_ 3 $ SS.modify (++ "!")

63+-- :}

64+-- "Hi!!!"

65+--

66+-- In the first example state modification made concurrently are not reflected

67+-- in the parent thread because the value is thread local, but in the second

68+-- example they are, because the value is shared.

69+--

70+data Concurrent :: Effect where

71+ Concurrent :: Concurrent m r

72+

73+-- | Run the 'Concurrent' effect.

74+runConcurrent :: IOE :> es => Eff (Concurrent : es) a -> Eff es a

75+runConcurrent = evalData (DataA Concurrent)

76+

77+-- $setup

78+-- >>> import Effectful.Concurrent

79+-- >>> import Effectful.Concurrent.Async

effectful/src/Effectful/Concurrent/MVar.hsnew file+108

@@ -0,0 +1,108 @@

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

2+module Effectful.Concurrent.MVar

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * MVar

7+ , MVar

8+ , newEmptyMVar

9+ , newMVar

10+ , takeMVar

11+ , putMVar

12+ , readMVar

13+ , swapMVar

14+ , tryTakeMVar

15+ , tryPutMVar

16+ , isEmptyMVar

17+ , withMVar

18+ , withMVarMasked

19+ , modifyMVar

20+ , modifyMVar_

21+ , modifyMVarMasked

22+ , modifyMVarMasked_

23+ , tryReadMVar

24+ , mkWeakMVar

25+ ) where

26+

27+import System.Mem.Weak (Weak)

28+import Control.Concurrent.MVar (MVar)

29+import qualified Control.Concurrent.MVar as M

30+

31+import Effectful.Concurrent.Effect

32+import Effectful.Dispatch.Static

33+import Effectful.Monad

34+

35+-- | Lifted 'M.newEmptyMVar'.

36+newEmptyMVar :: Concurrent :> es => Eff es (MVar a)

37+newEmptyMVar = unsafeEff_ M.newEmptyMVar

38+

39+-- | Lifted 'M.newMVar'.

40+newMVar :: Concurrent :> es => a -> Eff es (MVar a)

41+newMVar = unsafeEff_ . M.newMVar

42+

43+-- | Lifted 'M.takeMVar'.

44+takeMVar :: Concurrent :> es => MVar a -> Eff es a

45+takeMVar = unsafeEff_ . M.takeMVar

46+

47+-- | Lifted 'M.putMVar'.

48+putMVar :: Concurrent :> es => MVar a -> a -> Eff es ()

49+putMVar var = unsafeEff_ . M.putMVar var

50+

51+-- | Lifted 'M.readMVar'.

52+readMVar :: Concurrent :> es => MVar a -> Eff es a

53+readMVar = unsafeEff_ . M.readMVar

54+

55+-- | Lifted 'M.swapMVar'.

56+swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a

57+swapMVar var = unsafeEff_ . M.swapMVar var

58+

59+-- | Lifted 'M.tryTakeMVar'.

60+tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)

61+tryTakeMVar = unsafeEff_ . M.tryTakeMVar

62+

63+-- | Lifted 'M.tryPutMVar'.

64+tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool

65+tryPutMVar var = unsafeEff_ . M.tryPutMVar var

66+

67+-- | Lifted 'M.isEmptyMVar'.

68+isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool

69+isEmptyMVar = unsafeEff_ . M.isEmptyMVar

70+

71+-- | Lifted 'M.tryReadMVar'.

72+tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)

73+tryReadMVar = unsafeEff_ . M.tryReadMVar

74+

75+-- | Lifted 'M.withMVar'.

76+withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b

77+withMVar var f = unsafeUnliftIO $ \unlift -> do

78+ M.withMVar var $ unlift . f

79+

80+-- | Lifted 'M.withMVarMasked'.

81+withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b

82+withMVarMasked var f = unsafeUnliftIO $ \unlift -> do

83+ M.withMVarMasked var $ unlift . f

84+

85+-- | Lifted 'M.modifyMVar_'.

86+modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es ()

87+modifyMVar_ var f = unsafeUnliftIO $ \unlift -> do

88+ M.modifyMVar_ var $ unlift . f

89+

90+-- | Lifted 'M.modifyMVar'.

91+modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b

92+modifyMVar var f = unsafeUnliftIO $ \unlift -> do

93+ M.modifyMVar var $ unlift . f

94+

95+-- | Lifted 'M.modifyMVarMasked_'.

96+modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es ()

97+modifyMVarMasked_ var f = unsafeUnliftIO $ \unlift -> do

98+ M.modifyMVarMasked_ var $ unlift . f

99+

100+-- | Lifted 'M.modifyMVarMasked'.

101+modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b

102+modifyMVarMasked var f = unsafeUnliftIO $ \unlift -> do

103+ M.modifyMVarMasked var $ unlift . f

104+

105+-- | Lifted 'M.mkWeakMVar'.

106+mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a))

107+mkWeakMVar var f = unsafeUnliftIO $ \unlift -> do

108+ M.mkWeakMVar var $ unlift f

effectful/src/Effectful/Concurrent/QSem.hsnew file+30

@@ -0,0 +1,30 @@

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

2+module Effectful.Concurrent.QSem

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * QSem

7+ , QSem

8+ , newQSem

9+ , waitQSem

10+ , signalQSem

11+ ) where

12+

13+import Control.Concurrent.QSem (QSem)

14+import qualified Control.Concurrent.QSem as Q

15+

16+import Effectful.Concurrent.Effect

17+import Effectful.Dispatch.Static

18+import Effectful.Monad

19+

20+-- | Lifted 'Q.newQSem'.

21+newQSem :: Concurrent :> es => Int -> Eff es QSem

22+newQSem = unsafeEff_ . Q.newQSem

23+

24+-- | Lifted 'Q.waitQSem'.

25+waitQSem :: Concurrent :> es => QSem -> Eff es ()

26+waitQSem = unsafeEff_ . Q.waitQSem

27+

28+-- | Lifted 'Q.signalQSem'.

29+signalQSem :: Concurrent :> es => QSem -> Eff es ()

30+signalQSem = unsafeEff_ . Q.signalQSem

effectful/src/Effectful/Concurrent/QSemN.hsnew file+30

@@ -0,0 +1,30 @@

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

2+module Effectful.Concurrent.QSemN

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * QSemN

7+ , QSemN

8+ , newQSemN

9+ , waitQSemN

10+ , signalQSemN

11+ ) where

12+

13+import Control.Concurrent.QSemN (QSemN)

14+import qualified Control.Concurrent.QSemN as Q

15+

16+import Effectful.Concurrent.Effect

17+import Effectful.Dispatch.Static

18+import Effectful.Monad

19+

20+-- | Lifted 'Q.newQSemN'.

21+newQSemN :: Concurrent :> es => Int -> Eff es QSemN

22+newQSemN = unsafeEff_ . Q.newQSemN

23+

24+-- | Lifted 'Q.waitQSemN'.

25+waitQSemN :: Concurrent :> es => QSemN -> Int -> Eff es ()

26+waitQSemN x = unsafeEff_ . Q.waitQSemN x

27+

28+-- | Lifted 'Q.signalQSemN'.

29+signalQSemN :: Concurrent :> es => QSemN -> Int -> Eff es ()

30+signalQSemN x = unsafeEff_ . Q.signalQSemN x

effectful/src/Effectful/Concurrent/STM.hsnew file+146

@@ -0,0 +1,146 @@

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

2+module Effectful.Concurrent.STM

3+ ( Concurrent

4+ , runConcurrent

5+

6+ -- * Core

7+ , STM.STM

8+ , atomically

9+ , STM.retry

10+ , STM.orElse

11+ , STM.check

12+ , STM.throwSTM

13+ , STM.catchSTM

14+

15+ -- * TVar

16+ , STM.TVar

17+ , newTVarIO

18+ , readTVarIO

19+ , STM.newTVar

20+ , STM.readTVar

21+ , STM.writeTVar

22+ , STM.modifyTVar

23+ , STM.modifyTVar'

24+ , STM.swapTVar

25+ , registerDelay

26+ , mkWeakTVar

27+

28+ -- * TMVar

29+ , STM.TMVar

30+ , STM.newTMVar

31+ , STM.newEmptyTMVar

32+ , newTMVarIO

33+ , newEmptyTMVarIO

34+ , STM.takeTMVar

35+ , STM.putTMVar

36+ , STM.readTMVar

37+ , STM.tryReadTMVar

38+ , STM.swapTMVar

39+ , STM.tryTakeTMVar

40+ , STM.tryPutTMVar

41+ , STM.isEmptyTMVar

42+ , mkWeakTMVar

43+

44+ -- * TChan

45+ , STM.TChan

46+ , STM.newTChan

47+ , newTChanIO

48+ , STM.newBroadcastTChan

49+ , newBroadcastTChanIO

50+ , STM.dupTChan

51+ , STM.cloneTChan

52+ , STM.readTChan

53+ , STM.tryReadTChan

54+ , STM.peekTChan

55+ , STM.tryPeekTChan

56+ , STM.writeTChan

57+ , STM.unGetTChan

58+ , STM.isEmptyTChan

59+

60+ -- * TQueue

61+ , STM.TQueue

62+ , STM.newTQueue

63+ , newTQueueIO

64+ , STM.readTQueue

65+ , STM.tryReadTQueue

66+ , STM.peekTQueue

67+ , STM.tryPeekTQueue

68+ , STM.flushTQueue

69+ , STM.writeTQueue

70+ , STM.unGetTQueue

71+ , STM.isEmptyTQueue

72+

73+ -- * TBQueue

74+ , STM.TBQueue

75+ , STM.newTBQueue

76+ , newTBQueueIO

77+ , STM.readTBQueue

78+ , STM.tryReadTBQueue

79+ , STM.peekTBQueue

80+ , STM.tryPeekTBQueue

81+ , STM.flushTBQueue

82+ , STM.writeTBQueue

83+ , STM.unGetTBQueue

84+ , STM.lengthTBQueue

85+ , STM.isEmptyTBQueue

86+ , STM.isFullTBQueue

87+ ) where

88+

89+import Control.Concurrent.STM (STM, TVar, TMVar, TChan, TQueue, TBQueue)

90+import qualified Control.Concurrent.STM as STM

91+import System.Mem.Weak (Weak)

92+import GHC.Natural (Natural)

93+

94+import Effectful.Concurrent.Effect

95+import Effectful.Dispatch.Static

96+import Effectful.Monad

97+

98+-- | Lifted version of 'STM.atomically'

99+atomically :: Concurrent :> es => STM a -> Eff es a

100+atomically = unsafeEff_ . STM.atomically

101+

102+-- | Lifted version of 'STM.newTVarIO'

103+newTVarIO :: Concurrent :> es => a -> Eff es (TVar a)

104+newTVarIO = unsafeEff_ . STM.newTVarIO

105+

106+-- | Lifted version of 'STM.readTVarIO'

107+readTVarIO :: Concurrent :> es => TVar a -> Eff es a

108+readTVarIO = unsafeEff_ . STM.readTVarIO

109+

110+-- | Lifted version of 'STM.registerDelay'

111+registerDelay :: Concurrent :> es => Int -> Eff es (TVar Bool)

112+registerDelay = unsafeEff_ . STM.registerDelay

113+

114+-- | Lifted version of 'STM.mkWeakTVar'

115+mkWeakTVar :: Concurrent :> es => TVar a -> Eff es () -> Eff es (Weak (TVar a))

116+mkWeakTVar var final = unsafeUnliftIO $ \unlift -> do

117+ STM.mkWeakTVar var $ unlift final

118+

119+-- | Lifted version of 'STM.newTMVarIO'

120+newTMVarIO :: Concurrent :> es => a -> Eff es (TMVar a)

121+newTMVarIO = unsafeEff_ . STM.newTMVarIO

122+

123+-- | Lifted version of 'STM.newEmptyTMVarIO'

124+newEmptyTMVarIO :: Concurrent :> es => Eff es (TMVar a)

125+newEmptyTMVarIO = unsafeEff_ STM.newEmptyTMVarIO

126+

127+-- | Lifted version of 'STM.mkWeakTMVar'

128+mkWeakTMVar :: Concurrent :> es => TMVar a -> Eff es () -> Eff es (Weak (TMVar a))

129+mkWeakTMVar var final = unsafeUnliftIO $ \unlift -> do

130+ STM.mkWeakTMVar var $ unlift final

131+

132+-- | Lifted version of 'STM.newTChanIO'

133+newTChanIO :: Concurrent :> es => Eff es (TChan a)

134+newTChanIO = unsafeEff_ STM.newTChanIO

135+

136+-- | Lifted version of 'STM.newBroadcastTChanIO'

137+newBroadcastTChanIO :: Concurrent :> es => Eff es (TChan a)

138+newBroadcastTChanIO = unsafeEff_ STM.newBroadcastTChanIO

139+

140+-- | Lifted version of 'STM.newTQueueIO'

141+newTQueueIO :: Concurrent :> es => Eff es (TQueue a)

142+newTQueueIO = unsafeEff_ STM.newTQueueIO

143+

144+-- | Lifted version of 'STM.newTBQueueIO'

145+newTBQueueIO :: Concurrent :> es => Natural -> Eff es (TBQueue a)

146+newTBQueueIO = unsafeEff_ . STM.newTBQueueIO

effectful/src/Effectful/Environment.hsnew file+71

@@ -0,0 +1,71 @@

1+module Effectful.Environment

2+ ( Environment

3+ , runEnvironment

4+

5+ -- * Querying the environment

6+ , getArgs

7+ , getProgName

8+ , getExecutablePath

9+ , getEnv

10+ , getEnvironment

11+ , lookupEnv

12+

13+ -- * Modifying the environment

14+ , setEnv

15+ , unsetEnv

16+ , withArgs

17+ , withProgName

18+ ) where

19+

20+import qualified System.Environment as E

21+

22+import Effectful.Dispatch.Static hiding (getEnv)

23+import Effectful.Monad

24+

25+-- | An effect for querying and modifying the system environment.

26+data Environment :: Effect where

27+ Environment :: Environment m r

28+

29+-- | Run the 'Environment' effect.

30+runEnvironment :: IOE :> es => Eff (Environment : es) a -> Eff es a

31+runEnvironment = evalData (DataA Environment)

32+

33+-- | Lifted 'E.getArgs'.

34+getArgs :: Environment :> es => Eff es [String]

35+getArgs = unsafeEff_ E.getArgs

36+

37+-- | Lifted 'E.getEnv'.

38+getEnv :: Environment :> es => String -> Eff es String

39+getEnv = unsafeEff_ . E.getEnv

40+

41+-- | Lifted 'E.getEnvironment'.

42+getEnvironment :: Environment :> es => Eff es [(String, String)]

43+getEnvironment = unsafeEff_ E.getEnvironment

44+

45+-- | Lifted 'E.getExecutablePath'.

46+getExecutablePath :: Environment :> es => Eff es FilePath

47+getExecutablePath = unsafeEff_ E.getExecutablePath

48+

49+-- | Lifted 'E.getProgName'.

50+getProgName :: Environment :> es => Eff es String

51+getProgName = unsafeEff_ E.getProgName

52+

53+-- | Lifted 'E.lookupEnv'.

54+lookupEnv :: Environment :> es => String -> Eff es (Maybe String)

55+lookupEnv = unsafeEff_ . E.lookupEnv

56+

57+-- | Lifted 'E.setEnv'.

58+setEnv :: Environment :> es => String -> String -> Eff es ()

59+setEnv n = unsafeEff_ . E.setEnv n

60+

61+-- | Lifted 'E.unsetEnv'.

62+unsetEnv :: Environment :> es => String -> Eff es ()

63+unsetEnv = unsafeEff_ . E.unsetEnv

64+

65+-- | Lifted 'E.withArgs'.

66+withArgs :: Environment :> es => [String] -> Eff es a -> Eff es a

67+withArgs = unsafeLiftMapIO . E.withArgs

68+

69+-- | Lifted 'E.withProgName'.

70+withProgName :: Environment :> es => String -> Eff es a -> Eff es a

71+withProgName = unsafeLiftMapIO . E.withProgName

effectful/src/Effectful/FileSystem.hsnew file+347

@@ -0,0 +1,347 @@

1+module Effectful.FileSystem

2+ ( FileSystem

3+ , runFileSystem

4+

5+ -- * Actions on directories

6+ , createDirectory

7+ , createDirectoryIfMissing

8+ , removeDirectory

9+ , removeDirectoryRecursive

10+ , removePathForcibly

11+ , renameDirectory

12+ , listDirectory

13+ , getDirectoryContents

14+

15+ -- ** Current working directory

16+ , getCurrentDirectory

17+ , setCurrentDirectory

18+ , withCurrentDirectory

19+

20+ -- * Pre-defined directories

21+ , getHomeDirectory

22+ , getXdgDirectory

23+ , getXdgDirectoryList

24+ , getAppUserDataDirectory

25+ , getUserDocumentsDirectory

26+ , getTemporaryDirectory

27+

28+ -- * Actions on files

29+ , removeFile

30+ , renameFile

31+ , renamePath

32+ , copyFile

33+ , copyFileWithMetadata

34+ , getFileSize

35+ , canonicalizePath

36+ , makeAbsolute

37+ , makeRelativeToCurrentDirectory

38+

39+ -- * Existence tests

40+ , doesPathExist

41+ , doesFileExist

42+ , doesDirectoryExist

43+ , findExecutable

44+ , findExecutables

45+ , findExecutablesInDirectories

46+ , findFile

47+ , findFiles

48+ , findFileWith

49+ , findFilesWith

50+

51+ -- * Symbolic links

52+ , createFileLink

53+ , createDirectoryLink

54+ , removeDirectoryLink

55+ , pathIsSymbolicLink

56+ , getSymbolicLinkTarget

57+

58+ -- * Permissions

59+ , getPermissions

60+ , setPermissions

61+ , copyPermissions

62+

63+ -- * Timestamps

64+ , getAccessTime

65+ , getModificationTime

66+ , setAccessTime

67+ , setModificationTime

68+

69+ -- * Re-exports

70+

71+ -- ** Pre-defined directories

72+ , D.XdgDirectory(..)

73+ , D.XdgDirectoryList(..)

74+

75+ -- ** Existence tests

76+ , D.exeExtension

77+

78+ -- ** Permissions

79+ , D.Permissions

80+ , D.emptyPermissions

81+ , D.readable

82+ , D.writable

83+ , D.executable

84+ , D.searchable

85+ , D.setOwnerReadable

86+ , D.setOwnerWritable

87+ , D.setOwnerExecutable

88+ , D.setOwnerSearchable

89+ ) where

90+

91+import Data.Time (UTCTime)

92+import qualified System.Directory as D

93+

94+import Effectful.Dispatch.Static

95+import Effectful.Monad

96+

97+-- | An effect for interacting with the filesystem.

98+data FileSystem :: Effect where

99+ FileSystem :: FileSystem m r

100+

101+-- | Run the 'FileSystem' effect.

102+runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a

103+runFileSystem = evalData (DataA FileSystem)

104+

105+----------------------------------------

106+-- Actions on directories

107+

108+-- | Lifted 'D.createDirectory'.

109+createDirectory :: FileSystem :> es => FilePath -> Eff es ()

110+createDirectory = unsafeEff_ . D.createDirectory

111+

112+-- | Lifted 'D.createDirectoryIfMissing'.

113+createDirectoryIfMissing :: FileSystem :> es => Bool -> FilePath -> Eff es ()

114+createDirectoryIfMissing doCreateParents =

115+ unsafeEff_ . D.createDirectoryIfMissing doCreateParents

116+

117+-- | Lifted 'D.removeDirectory'.

118+removeDirectory :: FileSystem :> es => FilePath -> Eff es ()

119+removeDirectory = unsafeEff_ . D.removeDirectory

120+

121+-- | Lifted 'D.removeDirectoryRecursive'.

122+removeDirectoryRecursive :: FileSystem :> es => FilePath -> Eff es ()

123+removeDirectoryRecursive = unsafeEff_ . D.removeDirectoryRecursive

124+

125+-- | Lifted 'D.removePathForcibly'.

126+removePathForcibly :: FileSystem :> es => FilePath -> Eff es ()

127+removePathForcibly = unsafeEff_ . D.removePathForcibly

128+

129+-- | Lifted 'D.renameDirectory'.

130+renameDirectory :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

131+renameDirectory old = unsafeEff_ . D.renameDirectory old

132+

133+-- | Lifted 'D.listDirectory'.

134+listDirectory :: FileSystem :> es => FilePath -> Eff es [FilePath]

135+listDirectory = unsafeEff_ . D.listDirectory

136+

137+-- | Lifted 'D.getDirectoryContents'.

138+getDirectoryContents :: FileSystem :> es => FilePath -> Eff es [FilePath]

139+getDirectoryContents = unsafeEff_ . D.getDirectoryContents

140+

141+----------------------------------------

142+-- Current working directory

143+

144+-- | Lifted 'D.getCurrentDirectory'.

145+getCurrentDirectory :: FileSystem :> es => Eff es FilePath

146+getCurrentDirectory = unsafeEff_ D.getCurrentDirectory

147+

148+-- | Lifted 'D.setCurrentDirectory'.

149+setCurrentDirectory :: FileSystem :> es => FilePath -> Eff es ()

150+setCurrentDirectory = unsafeEff_ . D.setCurrentDirectory

151+

152+-- | Lifted 'D.withCurrentDirectory'.

153+withCurrentDirectory :: FileSystem :> es => FilePath -> Eff es a -> Eff es a

154+withCurrentDirectory path = unsafeLiftMapIO (D.withCurrentDirectory path)

155+

156+----------------------------------------

157+-- Pre-defined directories

158+

159+-- | Lifted 'D.getHomeDirectory'.

160+getHomeDirectory :: FileSystem :> es => Eff es FilePath

161+getHomeDirectory = unsafeEff_ D.getHomeDirectory

162+

163+-- | Lifted 'D.getXdgDirectory'.

164+getXdgDirectory

165+ :: FileSystem :> es

166+ => D.XdgDirectory

167+ -> FilePath

168+ -> Eff es FilePath

169+getXdgDirectory xdgDir = unsafeEff_ . D.getXdgDirectory xdgDir

170+

171+-- | Lifted 'D.getXdgDirectoryList'.

172+getXdgDirectoryList

173+ :: FileSystem :> es

174+ => D.XdgDirectoryList

175+ -> Eff es [FilePath]

176+getXdgDirectoryList = unsafeEff_ . D.getXdgDirectoryList

177+

178+-- | Lifted 'D.getAppUserDataDirectory'.

179+getAppUserDataDirectory :: FileSystem :> es => FilePath -> Eff es FilePath

180+getAppUserDataDirectory = unsafeEff_ . D.getAppUserDataDirectory

181+

182+-- | Lifted 'D.getUserDocumentsDirectory'.

183+getUserDocumentsDirectory :: FileSystem :> es => Eff es FilePath

184+getUserDocumentsDirectory = unsafeEff_ D.getUserDocumentsDirectory

185+

186+-- | Lifted 'D.getTemporaryDirectory'.

187+getTemporaryDirectory :: FileSystem :> es => Eff es FilePath

188+getTemporaryDirectory = unsafeEff_ D.getTemporaryDirectory

189+

190+----------------------------------------

191+-- Actions on files

192+

193+-- | Lifted 'D.removeFile'.

194+removeFile :: FileSystem :> es => FilePath -> Eff es ()

195+removeFile = unsafeEff_ . D.removeFile

196+

197+-- | Lifted 'D.renameFile'.

198+renameFile :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

199+renameFile old = unsafeEff_ . D.renameFile old

200+

201+-- | Lifted 'D.renamePath'.

202+renamePath :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

203+renamePath old = unsafeEff_ . D.renamePath old

204+

205+-- | Lifted 'D.copyFile'.

206+copyFile :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

207+copyFile src = unsafeEff_ . D.copyFile src

208+

209+-- | Lifted 'D.copyFileWithMetadata'.

210+copyFileWithMetadata :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

211+copyFileWithMetadata src = unsafeEff_ . D.copyFileWithMetadata src

212+

213+-- | Lifted 'D.getFileSize'.

214+getFileSize :: FileSystem :> es => FilePath -> Eff es Integer

215+getFileSize = unsafeEff_ . D.getFileSize

216+

217+-- | Lifted 'D.canonicalizePath'.

218+canonicalizePath :: FileSystem :> es => FilePath -> Eff es FilePath

219+canonicalizePath = unsafeEff_ . D.canonicalizePath

220+

221+-- | Lifted 'D.makeAbsolute'.

222+makeAbsolute :: FileSystem :> es => FilePath -> Eff es FilePath

223+makeAbsolute = unsafeEff_ . D.makeAbsolute

224+

225+-- | Lifted 'D.makeRelativeToCurrentDirectory'.

226+makeRelativeToCurrentDirectory

227+ :: FileSystem :> es

228+ => FilePath

229+ -> Eff es FilePath

230+makeRelativeToCurrentDirectory = unsafeEff_ . D.makeRelativeToCurrentDirectory

231+

232+----------------------------------------

233+-- Existence tests

234+

235+-- | Lifted 'D.doesPathExist'.

236+doesPathExist :: FileSystem :> es => FilePath -> Eff es Bool

237+doesPathExist = unsafeEff_ . D.doesPathExist

238+

239+-- | Lifted 'D.doesFileExist'.

240+doesFileExist :: FileSystem :> es => FilePath -> Eff es Bool

241+doesFileExist = unsafeEff_ . D.doesFileExist

242+

243+-- | Lifted 'D.doesDirectoryExist'.

244+doesDirectoryExist :: FileSystem :> es => FilePath -> Eff es Bool

245+doesDirectoryExist = unsafeEff_ . D.doesDirectoryExist

246+

247+-- | Lifted 'D.findExecutable'.

248+findExecutable :: FileSystem :> es => String -> Eff es (Maybe FilePath)

249+findExecutable = unsafeEff_ . D.findExecutable

250+

251+-- | Lifted 'D.findExecutables'.

252+findExecutables :: FileSystem :> es => String -> Eff es [FilePath]

253+findExecutables = unsafeEff_ . D.findExecutables

254+

255+-- | Lifted 'D.findExecutablesInDirectories'.

256+findExecutablesInDirectories

257+ :: FileSystem :> es

258+ => [FilePath]

259+ -> String

260+ -> Eff es [FilePath]

261+findExecutablesInDirectories dirs =

262+ unsafeEff_ . D.findExecutablesInDirectories dirs

263+

264+-- | Lifted 'D.findFile'.

265+findFile :: FileSystem :> es => [FilePath] -> String -> Eff es (Maybe FilePath)

266+findFile dirs = unsafeEff_ . D.findFile dirs

267+

268+-- | Lifted 'D.findFiles'.

269+findFiles :: FileSystem :> es => [FilePath] -> String -> Eff es [FilePath]

270+findFiles dirs = unsafeEff_ . D.findFiles dirs

271+

272+-- | Lifted 'D.findFileWith'.

273+findFileWith

274+ :: FileSystem :> es

275+ => (FilePath -> Eff es Bool)

276+ -> [FilePath]

277+ -> String

278+ -> Eff es (Maybe FilePath)

279+findFileWith p dirs n = unsafeUnliftIO $ \unlift -> do

280+ D.findFileWith (unlift . p) dirs n

281+

282+-- | Lifted 'D.findFilesWith'.

283+findFilesWith

284+ :: FileSystem :> es

285+ => (FilePath -> Eff es Bool)

286+ -> [FilePath]

287+ -> String

288+ -> Eff es [FilePath]

289+findFilesWith p dirs ns = unsafeUnliftIO $ \unlift -> do

290+ D.findFilesWith (unlift . p) dirs ns

291+

292+----------------------------------------

293+-- Symbolic links

294+

295+-- | Lifted 'D.createFileLink'.

296+createFileLink :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

297+createFileLink target = unsafeEff_ . D.createFileLink target

298+

299+-- | Lifted 'D.createDirectoryLink'.

300+createDirectoryLink :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

301+createDirectoryLink target = unsafeEff_ . D.createDirectoryLink target

302+

303+-- | Lifted 'D.removeDirectoryLink'.

304+removeDirectoryLink :: FileSystem :> es => FilePath -> Eff es ()

305+removeDirectoryLink = unsafeEff_ . D.removeDirectoryLink

306+

307+-- | Lifted 'D.pathIsSymbolicLink'.

308+pathIsSymbolicLink :: FileSystem :> es => FilePath -> Eff es Bool

309+pathIsSymbolicLink = unsafeEff_ . D.pathIsSymbolicLink

310+

311+-- | Lifted 'D.getSymbolicLinkTarget'.

312+getSymbolicLinkTarget :: FileSystem :> es => FilePath -> Eff es FilePath

313+getSymbolicLinkTarget = unsafeEff_ . D.getSymbolicLinkTarget

314+

315+----------------------------------------

316+-- Permissions

317+

318+-- | Lifted 'D.getPermissions'.

319+getPermissions :: FileSystem :> es => FilePath -> Eff es D.Permissions

320+getPermissions = unsafeEff_ . D.getPermissions

321+

322+-- | Lifted 'D.setPermissions'.

323+setPermissions :: FileSystem :> es => FilePath -> D.Permissions -> Eff es ()

324+setPermissions path = unsafeEff_ . D.setPermissions path

325+

326+-- | Lifted 'D.copyPermissions'.

327+copyPermissions :: FileSystem :> es => FilePath -> FilePath -> Eff es ()

328+copyPermissions src = unsafeEff_ . D.copyPermissions src

329+

330+----------------------------------------

331+-- Timestamps

332+

333+-- | Lifted 'D.getAccessTime'.

334+getAccessTime :: FileSystem :> es => FilePath -> Eff es UTCTime

335+getAccessTime = unsafeEff_ . D.getAccessTime

336+

337+-- | Lifted 'D.getModificationTime'.

338+getModificationTime :: FileSystem :> es => FilePath -> Eff es UTCTime

339+getModificationTime = unsafeEff_ . D.getModificationTime

340+

341+-- | Lifted 'D.setAccessTime'.

342+setAccessTime :: FileSystem :> es => FilePath -> UTCTime -> Eff es ()

343+setAccessTime path = unsafeEff_ . D.setAccessTime path

344+

345+-- | Lifted 'D.setModificationTime'.

346+setModificationTime :: FileSystem :> es => FilePath -> UTCTime -> Eff es ()

347+setModificationTime path = unsafeEff_ . D.setModificationTime path

effectful/src/Effectful/FileSystem/Effect.hsnew file+15

@@ -0,0 +1,15 @@

1+module Effectful.FileSystem.Effect

2+ ( FileSystem

3+ , runFileSystem

4+ ) where

5+

6+import Effectful.Dispatch.Static

7+import Effectful.Monad

8+

9+-- | An effect for interacting with the filesystem.

10+data FileSystem :: Effect where

11+ FileSystem :: FileSystem m r

12+

13+-- | Run the 'FileSystem' effect.

14+runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a

15+runFileSystem = evalData (DataA FileSystem)

effectful/src/Effectful/FileSystem/IO.hsnew file+143

@@ -0,0 +1,143 @@

1+-- | Lifted version of "System.IO".

2+module Effectful.FileSystem.IO

3+ ( FileSystem

4+ , runFileSystem

5+

6+ -- * IO

7+ , IOMode (..)

8+ , Handle

9+ , IO.stdin

10+ , IO.stdout

11+ , IO.stderr

12+ , withFile

13+ , withBinaryFile

14+ , openFile

15+ , hClose

16+ , hFlush

17+ , hFileSize

18+ , hSetFileSize

19+ , hIsEOF

20+ , IO.BufferMode (..)

21+ , hSetBuffering

22+ , hGetBuffering

23+ , hSeek

24+ , IO.SeekMode (..)

25+ , hTell

26+ , hIsOpen

27+ , hIsClosed

28+ , hIsReadable

29+ , hIsWritable

30+ , hIsSeekable

31+ , hIsTerminalDevice

32+ , hSetEcho

33+ , hGetEcho

34+ , hWaitForInput

35+ , hReady

36+ ) where

37+

38+import qualified System.IO as IO

39+import System.IO (Handle, IOMode (..))

40+

41+import Effectful.Dispatch.Static

42+import Effectful.FileSystem.Effect

43+import Effectful.Monad

44+

45+-- | Lifted version of 'IO.withFile'.

46+withFile

47+ :: FileSystem :> es

48+ => FilePath

49+ -> IOMode

50+ -> (Handle -> Eff es a)

51+ -> Eff es a

52+withFile fp mode inner = unsafeUnliftIO $ \unlift -> do

53+ IO.withFile fp mode $ unlift . inner

54+

55+-- | Lifted version of 'IO.withBinaryFile'.

56+withBinaryFile

57+ :: FileSystem :> es

58+ => FilePath

59+ -> IOMode

60+ -> (Handle -> Eff es a)

61+ -> Eff es a

62+withBinaryFile fp mode inner = unsafeUnliftIO $ \unlift -> do

63+ IO.withBinaryFile fp mode $ unlift . inner

64+

65+-- | Lifted version of 'IO.openFile'

66+openFile :: FileSystem :> es => FilePath -> IOMode -> Eff es Handle

67+openFile fp = unsafeEff_ . IO.openFile fp

68+

69+-- | Lifted version of 'IO.hClose'

70+hClose :: FileSystem :> es => Handle -> Eff es ()

71+hClose = unsafeEff_ . IO.hClose

72+

73+-- | Lifted version of 'IO.hFlush'

74+hFlush :: FileSystem :> es => Handle -> Eff es ()

75+hFlush = unsafeEff_ . IO.hFlush

76+

77+-- | Lifted version of 'IO.hFileSize'

78+hFileSize :: FileSystem :> es => Handle -> Eff es Integer

79+hFileSize = unsafeEff_ . IO.hFileSize

80+

81+-- | Lifted version of 'IO.hSetFileSize'

82+hSetFileSize :: FileSystem :> es => Handle -> Integer -> Eff es ()

83+hSetFileSize h = unsafeEff_ . IO.hSetFileSize h

84+

85+-- | Lifted version of 'IO.hIsEOF'

86+hIsEOF :: FileSystem :> es => Handle -> Eff es Bool

87+hIsEOF = unsafeEff_ . IO.hIsEOF

88+

89+-- | Lifted version of 'IO.hSetBuffering'

90+hSetBuffering :: FileSystem :> es => Handle -> IO.BufferMode -> Eff es ()

91+hSetBuffering h = unsafeEff_ . IO.hSetBuffering h

92+

93+-- | Lifted version of 'IO.hGetBuffering'

94+hGetBuffering :: FileSystem :> es => Handle -> Eff es IO.BufferMode

95+hGetBuffering = unsafeEff_ . IO.hGetBuffering

96+

97+-- | Lifted version of 'IO.hSeek'

98+hSeek :: FileSystem :> es => Handle -> IO.SeekMode -> Integer -> Eff es ()

99+hSeek h s = unsafeEff_ . IO.hSeek h s

100+

101+-- | Lifted version of 'IO.hTell'

102+hTell :: FileSystem :> es => Handle -> Eff es Integer

103+hTell = unsafeEff_ . IO.hTell

104+

105+-- | Lifted version of 'IO.hIsOpen'

106+hIsOpen :: FileSystem :> es => Handle -> Eff es Bool

107+hIsOpen = unsafeEff_ . IO.hIsOpen

108+

109+-- | Lifted version of 'IO.hIsClosed'

110+hIsClosed :: FileSystem :> es => Handle -> Eff es Bool

111+hIsClosed = unsafeEff_ . IO.hIsClosed

112+

113+-- | Lifted version of 'IO.hIsReadable'

114+hIsReadable :: FileSystem :> es => Handle -> Eff es Bool

115+hIsReadable = unsafeEff_ . IO.hIsReadable

116+

117+-- | Lifted version of 'IO.hIsWritable'

118+hIsWritable :: FileSystem :> es => Handle -> Eff es Bool

119+hIsWritable = unsafeEff_ . IO.hIsWritable

120+

121+-- | Lifted version of 'IO.hIsSeekable'

122+hIsSeekable :: FileSystem :> es => Handle -> Eff es Bool

123+hIsSeekable = unsafeEff_ . IO.hIsSeekable

124+

125+-- | Lifted version of 'IO.hIsTerminalDevice'

126+hIsTerminalDevice :: FileSystem :> es => Handle -> Eff es Bool

127+hIsTerminalDevice = unsafeEff_ . IO.hIsTerminalDevice

128+

129+-- | Lifted version of 'IO.hSetEcho'

130+hSetEcho :: FileSystem :> es => Handle -> Bool -> Eff es ()

131+hSetEcho h = unsafeEff_ . IO.hSetEcho h

132+

133+-- | Lifted version of 'IO.hGetEcho'

134+hGetEcho :: FileSystem :> es => Handle -> Eff es Bool

135+hGetEcho = unsafeEff_ . IO.hGetEcho

136+

137+-- | Lifted version of 'IO.hWaitForInput'

138+hWaitForInput :: FileSystem :> es => Handle -> Int -> Eff es Bool

139+hWaitForInput h = unsafeEff_ . IO.hWaitForInput h

140+

141+-- | Lifted version of 'IO.hReady'

142+hReady :: FileSystem :> es => Handle -> Eff es Bool

143+hReady = unsafeEff_ . IO.hReady

effectful/src/Effectful/Process.hsnew file+182

@@ -0,0 +1,182 @@

1+{-# LANGUAGE CPP #-}

2+-- | Lifted version of "System.Process".

3+module Effectful.Process

4+ ( Process

5+ , runProcess

6+

7+ -- * Running sub-processes

8+ , createProcess

9+ , createProcess_

10+ , P.shell

11+ , P.proc

12+ , P.CreateProcess(..)

13+ , P.CmdSpec(..)

14+ , P.StdStream(..)

15+ , P.ProcessHandle

16+

17+ -- ** Simpler functions for common tasks

18+ , callProcess

19+ , callCommand

20+ , spawnProcess

21+ , spawnCommand

22+ , readCreateProcess

23+ , readProcess

24+ , readCreateProcessWithExitCode

25+ , readProcessWithExitCode

26+ , withCreateProcess

27+ , cleanupProcess

28+

29+ -- ** Related utilities

30+ , P.showCommandForUser

31+ , P.Pid

32+ , getPid

33+#if MIN_VERSION_process(1,6,12)

34+ , getCurrentPid

35+#endif

36+

37+ -- * Process completion

38+ , waitForProcess

39+ , getProcessExitCode

40+ , terminateProcess

41+ , interruptProcessGroupOf

42+

43+ -- * Interprocess communication

44+ , createPipe

45+ , createPipeFd

46+ ) where

47+

48+import System.Exit (ExitCode)

49+import System.IO (Handle)

50+import System.Posix.Internals (FD)

51+import qualified System.Process as P

52+

53+import Effectful.Dispatch.Static

54+import Effectful.Monad

55+

56+-- | An effect for running child processes using the @process@ library.

57+data Process :: Effect where

58+ Process :: Process m r

59+

60+runProcess :: IOE :> es => Eff (Process : es) a -> Eff es a

61+runProcess = evalData (DataA Process)

62+

63+----------------------------------------

64+-- Running sub-processes

65+

66+-- | Lifted 'P.createProcess'.

67+createProcess

68+ :: Process :> es

69+ => P.CreateProcess

70+ -> Eff es (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)

71+createProcess = unsafeEff_ . P.createProcess

72+

73+-- | Lifted 'P.createProcess_'.

74+createProcess_

75+ :: Process :> es

76+ => String

77+ -> P.CreateProcess

78+ -> Eff es (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)

79+createProcess_ msg = unsafeEff_ . P.createProcess_ msg

80+

81+----------------------------------------

82+-- Simpler functions for common tasks

83+

84+-- | Lifted 'P.callProcess'.

85+callProcess :: Process :> es => FilePath -> [String] -> Eff es ()

86+callProcess fp = unsafeEff_ . P.callProcess fp

87+

88+-- | Lifted 'P.callCommand'.

89+callCommand :: Process :> es => String -> Eff es ()

90+callCommand = unsafeEff_ . P.callCommand

91+

92+-- | Lifted 'P.spawnProcess'.

93+spawnProcess :: Process :> es => FilePath -> [String] -> Eff es P.ProcessHandle

94+spawnProcess fp = unsafeEff_ . P.spawnProcess fp

95+

96+-- | Lifted 'P.spawnCommand'.

97+spawnCommand :: Process :> es => String -> Eff es P.ProcessHandle

98+spawnCommand = unsafeEff_ . P.spawnCommand

99+

100+-- | Lifted 'P.readCreateProcess'.

101+readCreateProcess :: Process :> es => P.CreateProcess -> String -> Eff es String

102+readCreateProcess cp = unsafeEff_ . P.readCreateProcess cp

103+

104+-- | Lifted 'P.readProcess'.

105+readProcess :: Process :> es => FilePath -> [String] -> String -> Eff es String

106+readProcess fp args = unsafeEff_ . P.readProcess fp args

107+

108+-- | Lifted 'P.readCreateProcessWithExitCode'.

109+readCreateProcessWithExitCode

110+ :: Process :> es

111+ => P.CreateProcess

112+ -> String

113+ -> Eff es (ExitCode, String, String)

114+readCreateProcessWithExitCode cp = unsafeEff_ . P.readCreateProcessWithExitCode cp

115+

116+-- | Lifted 'P.readProcessWithExitCode'.

117+readProcessWithExitCode

118+ :: Process :> es

119+ => FilePath

120+ -> [String]

121+ -> String

122+ -> Eff es (ExitCode, String, String)

123+readProcessWithExitCode fp args = unsafeEff_ . P.readProcessWithExitCode fp args

124+

125+-- | Lifted 'P.withCreateProcess'.

126+withCreateProcess

127+ :: Process :> es

128+ => P.CreateProcess

129+ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> P.ProcessHandle -> Eff es a)

130+ -> Eff es a

131+withCreateProcess cp cb = unsafeUnliftIO $ \unlift -> do

132+ P.withCreateProcess cp $ \inh outh errh ph -> unlift $ cb inh outh errh ph

133+

134+-- | Lifted 'P.cleanupProcess'.

135+cleanupProcess

136+ :: Process :> es

137+ => (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)

138+ -> Eff es ()

139+cleanupProcess = unsafeEff_ . P.cleanupProcess

140+

141+----------------------------------------

142+-- Related utilities

143+

144+-- | Lifted 'P.getPid'.

145+getPid :: Process :> es => P.ProcessHandle -> Eff es (Maybe P.Pid)

146+getPid = unsafeEff_ . P.getPid

147+

148+#if MIN_VERSION_process(1,6,12)

149+-- | Lifted 'P.getCurrentPid'.

150+getCurrentPid :: Process :> es => Eff es P.Pid

151+getCurrentPid = unsafeEff_ P.getCurrentPid

152+#endif

153+

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

155+-- Process completion

156+

157+-- | Lifted 'P.waitForProcess'.

158+waitForProcess :: Process :> es => P.ProcessHandle -> Eff es ExitCode

159+waitForProcess = unsafeEff_ . P.waitForProcess

160+

161+-- | Lifted 'P.getProcessExitCode'.

162+getProcessExitCode :: Process :> es => P.ProcessHandle -> Eff es (Maybe ExitCode)

163+getProcessExitCode = unsafeEff_ . P.getProcessExitCode

164+

165+-- | Lifted 'P.terminateProcess'.

166+terminateProcess :: Process :> es => P.ProcessHandle -> Eff es ()

167+terminateProcess = unsafeEff_ . P.terminateProcess

168+

169+-- | Lifted 'P.interruptProcessGroupOf'.

170+interruptProcessGroupOf :: Process :> es => P.ProcessHandle -> Eff es ()

171+interruptProcessGroupOf = unsafeEff_ . P.interruptProcessGroupOf

172+

173+----------------------------------------

174+-- Interprocess communication

175+

176+-- | Lifted 'P.createPipe'.

177+createPipe :: Process :> es => Eff es (Handle, Handle)

178+createPipe = unsafeEff_ P.createPipe

179+

180+-- | Lifted 'P.createPipeFd'.

181+createPipeFd :: Process :> es => Eff es (FD, FD)

182+createPipeFd = unsafeEff_ P.createPipeFd

effectful/src/Effectful/Resource.hs+31−7

@@ -11,15 +11,21 @@ module Effectful.Resource

11 , R.register

12 , R.release

13 , R.unprotect

14+

15+ -- * Internal state

16+ , R.InternalState

17+ , getInternalState

18+ , runInternalState

19+ , R.createInternalState

20+ , R.closeInternalState

14 ) where

21 ) where

15

22

16import Control.Exception

23import Control.Exception

17import qualified Control.Monad.Trans.Resource as R

24import qualified Control.Monad.Trans.Resource as R

18import qualified Control.Monad.Trans.Resource.Internal as RI

25import qualified Control.Monad.Trans.Resource.Internal as RI

19

26

20−import Effectful.Internal.Effect

27+import Effectful.Dispatch.Static

21−import Effectful.Internal.Env

22−import Effectful.Internal.Monad

28+import Effectful.Monad

23

29

24-- | Data tag for a resource effect.

30-- | Data tag for a resource effect.

25newtype Resource :: Effect where

31newtype Resource :: Effect where

@@ -31,15 +37,33 @@ runResource m = unsafeEff $ \es0 -> do

31 size0 <- sizeEnv es0

37 size0 <- sizeEnv es0

32 istate <- R.createInternalState

38 istate <- R.createInternalState

33 mask $ \restore -> do

39 mask $ \restore -> do

34− es <- unsafeConsEnv (IdE (Resource istate)) noRelinker es0

40+ es <- unsafeConsEnv (DataA (Resource istate)) noRelinker es0

35 a <- restore (unEff m es) `catch` \e -> do

41 a <- restore (unEff m es) `catch` \e -> do

36− _ <- unsafeTailEnv size0 es

42+ unsafeTailEnv size0 es

37 RI.stateCleanupChecked (Just e) istate

43 RI.stateCleanupChecked (Just e) istate

38 throwIO e

44 throwIO e

39− _ <- unsafeTailEnv size0 es

45+ unsafeTailEnv size0 es

40 RI.stateCleanupChecked Nothing istate

46 RI.stateCleanupChecked Nothing istate

41 pure a

47 pure a

42

48

49+----------------------------------------

50+-- Internal state

51+

52+-- | Get the 'R.InternalState' of the current 'Resource' effect.

53+getInternalState :: Resource :> es => Eff es R.InternalState

54+getInternalState = do

55+ DataA (Resource istate) <- getData

56+ pure istate

57+

58+-- | Run the 'Resource' effect with existing 'R.InternalState'.

59+--

60+-- /Note:/ the 'R.InternalState' will not be closed at the end.

61+runInternalState :: R.InternalState -> Eff (Resource : es) a -> Eff es a

62+runInternalState istate = evalData (DataA (Resource istate))

63+

64+----------------------------------------

65+-- Orphan instance

66+

43instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where

67instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where

44 liftResourceT (RI.ResourceT m) = unsafeEff $ \es -> do

68 liftResourceT (RI.ResourceT m) = unsafeEff $ \es -> do

45− getEnv es >>= \(IdE (Resource istate)) -> m istate

69+ getEnv es >>= \(DataA (Resource istate)) -> m istate

effectful/src/Effectful/Temporary.hsnew file+70

@@ -0,0 +1,70 @@

1+module Effectful.Temporary

2+ ( Temporary

3+ , runTemporary

4+ , withSystemTempFile

5+ , withSystemTempDirectory

6+ , withTempFile

7+ , withTempDirectory

8+ ) where

9+

10+import System.IO

11+import qualified UnliftIO.Temporary as T

12+

13+import Effectful.Dispatch.Static

14+import Effectful.Monad

15+

16+-- | An effect for interacting with temporary files.

17+data Temporary :: Effect where

18+ Temporary :: Temporary m r

19+

20+-- | Run the 'Temporary' effect.

21+runTemporary :: IOE :> es => Eff (Temporary : es) a -> Eff es a

22+runTemporary = evalData (DataA Temporary)

23+

24+-- | Lifted 'T.withSystemTempFile'.

25+withSystemTempFile

26+ :: Temporary :> es

27+ => String

28+ -- ^ File name template. See 'openTempFile'.

29+ -> (FilePath -> Handle -> Eff es a)

30+ -- ^ Callback that can use the file.

31+ -> Eff es a

32+withSystemTempFile template action = unsafeUnliftIO $ \unlift -> do

33+ T.withSystemTempFile template $ \fp handle -> unlift $ action fp handle

34+

35+-- | Lifted 'T.withSystemTempDirectory'.

36+withSystemTempDirectory

37+ :: Temporary :> es

38+ => String

39+ -- ^ Directory name template. See 'openTempFile'.

40+ -> (FilePath -> Eff es a)

41+ -- ^ Callback that can use the directory.

42+ -> Eff es a

43+withSystemTempDirectory template action = unsafeUnliftIO $ \unlift -> do

44+ T.withSystemTempDirectory template $ \fp -> unlift $ action fp

45+

46+-- | Lifted 'T.withTempFile'.

47+withTempFile

48+ :: Temporary :> es

49+ => FilePath

50+ -- ^ Temp dir to create the file in.

51+ -> String

52+ -- ^ File name template. See 'openTempFile'.

53+ -> (FilePath -> Handle -> Eff es a)

54+ -- ^ Callback that can use the file.

55+ -> Eff es a

56+withTempFile tmpDir template action = unsafeUnliftIO $ \unlift -> do

57+ T.withTempFile tmpDir template $ \fp handle -> unlift $ action fp handle

58+

59+-- | Lifted 'T.withTempDirectory'.

60+withTempDirectory

61+ :: Temporary :> es

62+ => FilePath

63+ -- ^ Temp directory to create the directory in.

64+ -> String

65+ -- ^ Directory name template. See 'openTempFile'.

66+ -> (FilePath -> Eff es a)

67+ -- ^ Callback that can use the directory.

68+ -> Eff es a

69+withTempDirectory tmpDir template action = unsafeUnliftIO $ \unlift -> do

70+ T.withTempDirectory tmpDir template $ \fp -> unlift $ action fp

effectful/src/Effectful/Timeout.hsnew file+28

@@ -0,0 +1,28 @@

1+module Effectful.Timeout

2+ ( Timeout

3+ , runTimeout

4+ , timeout

5+ ) where

6+

7+import qualified System.Timeout as T

8+

9+import Effectful.Dispatch.Static

10+import Effectful.Monad

11+

12+-- | An effect for timing out computations.

13+data Timeout :: Effect where

14+ Timeout :: Timeout m r

15+

16+-- | Run the 'Timeout' effect.

17+runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a

18+runTimeout = evalData (DataA Timeout)

19+

20+-- | Lifted 'T.timeout'.

21+timeout

22+ :: Timeout :> es

23+ => Int

24+ -- ^ The timeout in microseconds (1/10^6 seconds).

25+ -> Eff es a

26+ -- ^ The computation the timeout applies to.

27+ -> Eff es (Maybe a)

28+timeout = unsafeLiftMapIO . T.timeout

effectful/tests/AsyncTests.hs+6−7

@@ -2,13 +2,12 @@ module AsyncTests (asyncTests) where

2

3import Control.Concurrent (threadDelay)

4import Control.Monad

5−import Control.Monad.IO.Class

6import Test.Tasty

5import Test.Tasty

7import Test.Tasty.HUnit

6import Test.Tasty.HUnit

8import qualified Data.Set as S

7import qualified Data.Set as S

9

8

10import Effectful

9import Effectful

11−import Effectful.Async

10+import Effectful.Concurrent.Async

12import Effectful.Error

11import Effectful.Error

13import Effectful.State.Dynamic

12import Effectful.State.Dynamic

14

13

@@ -24,7 +23,7 @@ asyncTests = testGroup "Async"

24 ]

23 ]

25

24

26test_localState :: Assertion

25test_localState :: Assertion

27−test_localState = runEff . runAsyncE . evalLocalState x $ do

26+test_localState = runEff . runConcurrent . evalLocalState x $ do

28 replicateConcurrently_ 2 $ do

27 replicateConcurrently_ 2 $ do

29 r <- goDownward 0

28 r <- goDownward 0

30 U.assertEqual "expected result" x r

29 U.assertEqual "expected result" x r

@@ -42,7 +41,7 @@ test_localState = runEff . runAsyncE . evalLocalState x $ do

42 else goDownward $ acc + 1

41 else goDownward $ acc + 1

43

42

44test_sharedState :: Assertion

43test_sharedState :: Assertion

45−test_sharedState = runEff . runAsyncE . evalSharedState (S.empty @Int) $ do

44+test_sharedState = runEff . runConcurrent . evalSharedState (S.empty @Int) $ do

46 concurrently_ (addWhen even x) (addWhen odd x)

45 concurrently_ (addWhen even x) (addWhen odd x)

47 U.assertEqual "expected result" (S.fromList [1..x]) =<< get

46 U.assertEqual "expected result" (S.fromList [1..x]) =<< get

48 where

47 where

@@ -58,7 +57,7 @@ test_sharedState = runEff . runAsyncE . evalSharedState (S.empty @Int) $ do

58 addWhen f $ n - 1

57 addWhen f $ n - 1

59

58

60test_errorHandling :: Assertion

59test_errorHandling :: Assertion

61−test_errorHandling = runEff . runAsyncE . evalSharedState (0::Int) $ do

60+test_errorHandling = runEff . runConcurrent . evalSharedState (0::Int) $ do

62 r <- runError $ concurrently_

61 r <- runError $ concurrently_

63 (liftIO (threadDelay 10000) >> throwError err)

62 (liftIO (threadDelay 10000) >> throwError err)

64 (modify (+x))

63 (modify (+x))

@@ -74,7 +73,7 @@ test_errorHandling = runEff . runAsyncE . evalSharedState (0::Int) $ do

74 err = "thrown from async"

73 err = "thrown from async"

75

74

76test_asyncWithUnmask :: Assertion

75test_asyncWithUnmask :: Assertion

77−test_asyncWithUnmask = runEff . runAsyncE . evalLocalState "initial" $ do

76+test_asyncWithUnmask = runEff . runConcurrent . evalLocalState "initial" $ do

78 x <- asyncWithUnmask $ \unmask -> do

77 x <- asyncWithUnmask $ \unmask -> do

79 liftIO $ threadDelay 10000

78 liftIO $ threadDelay 10000

80 r1 <- get @String -- 2

79 r1 <- get @String -- 2

@@ -89,7 +88,7 @@ test_asyncWithUnmask = runEff . runAsyncE . evalLocalState "initial" $ do

89 (inner1, inner2, outer)

88 (inner1, inner2, outer)

90

89

91test_pooledWorkers :: Assertion

90test_pooledWorkers :: Assertion

92−test_pooledWorkers = runEff . runAsyncE . evalLocalState (0::Int) $ do

91+test_pooledWorkers = runEff . runConcurrent . evalLocalState (0::Int) $ do

93 x <- pooledForConcurrentlyN threads [1..n] $ \k -> do

92 x <- pooledForConcurrentlyN threads [1..n] $ \k -> do

94 r <- get @Int

93 r <- get @Int

95 modify @Int (+1)

94 modify @Int (+1)

effectful/tests/ConcurrencyTests.hs−1

@@ -2,7 +2,6 @@ module ConcurrencyTests (concurrencyTests) where

2

3import Control.Concurrent (threadDelay)

4import Control.Monad

5−import Control.Monad.IO.Class

6import Test.Tasty

5import Test.Tasty

7import Test.Tasty.HUnit

6import Test.Tasty.HUnit

8import UnliftIO

7import UnliftIO

effectful/tests/EnvironmentTests.hsnew file+48

@@ -0,0 +1,48 @@

1+module EnvironmentTests (environmentTests) where

2+

3+import Test.Tasty

4+import Test.Tasty.HUnit

5+import System.IO.Error (isDoesNotExistError)

6+

7+import Effectful

8+import Effectful.Environment

9+import qualified Utils as U

10+

11+environmentTests :: TestTree

12+environmentTests = testCaseSteps "Environment" $ \step -> do

13+ -- These tests need to be run sequentially because of

14+ -- https://github.com/arybczak/effectful/issues/39.

15+ step "set and get an environment variable"

16+ test_setAndGet

17+ step "unset and try to get an environment variable"

18+ test_unsetAndGet

19+ step "execute effects with custom arguments"

20+ test_withArgs

21+ step "execute effects with custom program name"

22+ test_withProg

23+

24+test_setAndGet :: Assertion

25+test_setAndGet = runEff . runEnvironment $ do

26+ let expected = "value"

27+ n = "EFFECTFUL_TEST1"

28+ setEnv n expected

29+ v <- getEnv n

30+ U.assertEqual "environment variable not set" expected v

31+

32+test_unsetAndGet :: Assertion

33+test_unsetAndGet = runEff . runEnvironment $ do

34+ let n = "EFFECTFUL_TEST2"

35+ unsetEnv n

36+ U.assertThrows "environment variable is set" isDoesNotExistError (getEnv n)

37+

38+test_withArgs :: Assertion

39+test_withArgs = runEff . runEnvironment $ do

40+ let expected = ["effectful-test"]

41+ args <- withArgs expected getArgs

42+ U.assertEqual "correct arguments" expected args

43+

44+test_withProg :: Assertion

45+test_withProg = runEff . runEnvironment $ do

46+ let expected = "effectful-test"

47+ n <- withProgName expected getProgName

48+ U.assertEqual "correct program name" expected n

effectful/tests/ErrorTests.hs−1

@@ -1,6 +1,5 @@

1module ErrorTests (errorTests) where

2

3−import Control.Monad.IO.Class

4import Test.Tasty

3import Test.Tasty

5import Test.Tasty.HUnit

4import Test.Tasty.HUnit

6

5

effectful/tests/Main.hs+6

@@ -4,13 +4,19 @@ import Test.Tasty

4

5import AsyncTests

6import ConcurrencyTests

7+import EnvironmentTests

7import ErrorTests

8import ErrorTests

8import StateTests

9import StateTests

10+import TimeoutTests

11+import UnliftTests

9

12

10main :: IO ()

13main :: IO ()

11main = defaultMain $ testGroup "effectful"

14main = defaultMain $ testGroup "effectful"

12 [ asyncTests

15 [ asyncTests

13 , concurrencyTests

16 , concurrencyTests

17+ , environmentTests

14 , errorTests

18 , errorTests

15 , stateTests

19 , stateTests

20+ , timeoutTests

21+ , unliftTests

16 ]

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/TimeoutTests.hsnew file+25

@@ -0,0 +1,25 @@

1+module TimeoutTests (timeoutTests) where

2+

3+import Control.Concurrent (threadDelay)

4+import Test.Tasty

5+import Test.Tasty.HUnit

6+

7+import Effectful

8+import Effectful.Timeout

9+import qualified Utils as U

10+

11+timeoutTests :: TestTree

12+timeoutTests = testGroup "Timeout"

13+ [ testCase "return before timeout" test_returnBeforeTimeout

14+ , testCase "timeout before return" test_timeoutBeforeReturn

15+ ]

16+

17+test_returnBeforeTimeout :: Assertion

18+test_returnBeforeTimeout = runEff $ do

19+ result <- runTimeout $ timeout 1000 $ return ()

20+ U.assertEqual "return value" (Just ()) result

21+

22+test_timeoutBeforeReturn :: Assertion

23+test_timeoutBeforeReturn = runEff $ do

24+ result <- runTimeout $ timeout 0 $ liftIO $ threadDelay 1000

25+ U.assertEqual "no return value" Nothing result

effectful/tests/UnliftTests.hsnew file+93

@@ -0,0 +1,93 @@

1+module UnliftTests (unliftTests) where

2+

3+import Control.Exception

4+import Test.Tasty

5+import Test.Tasty.HUnit

6+import qualified UnliftIO.Async as A

7+

8+import Effectful

9+import qualified Utils as U

10+

11+unliftTests :: TestTree

12+unliftTests = testGroup "Unlift"

13+ [ testCase "Reset strategy in new thread" test_resetStrategy

14+ , testCase "SeqUnlift in new thread" test_seqUnliftInNewThread

15+ , testGroup "Ephemeral strategy"

16+ [ testCase "Invalid limit" test_ephemeralInvalid

17+ , testCase "Uses in same thread" test_ephemeralSameThread

18+ , testCase "Uses in multiple threads" test_ephemeralMultipleThreads

19+ ]

20+ , testGroup "Persistent strategy"

21+ [ testCase "Invalid limit" test_persistentInvalid

22+ , testCase "Uses in same thread" test_persistentSameThread

23+ , testCase "Uses in multiple threads" test_persistentMultipleThreads

24+ ]

25+ ]

26+

27+test_resetStrategy :: Assertion

28+test_resetStrategy = runEff $ do

29+ s <- withUnliftStrategy (ConcUnlift Ephemeral Unlimited) $ do

30+ withEffToIO $ \runInIO -> do

31+ inThread $ runInIO unliftStrategy

32+ U.assertEqual "correct strategy" SeqUnlift s

33+

34+test_seqUnliftInNewThread :: Assertion

35+test_seqUnliftInNewThread = runEff $ do

36+ assertThrowsUnliftError "InvalidUseOfSeqUnlift error" $ do

37+ withUnliftStrategy SeqUnlift $ do

38+ withEffToIO $ \runInIO -> do

39+ inThread $ runInIO $ return ()

40+

41+test_ephemeralInvalid :: Assertion

42+test_ephemeralInvalid = runEff $ do

43+ assertThrowsUnliftError "InvalidNumberOfUses error" $ do

44+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 0) $ do

45+ withEffToIO $ \_ -> return ()

46+

47+test_ephemeralSameThread :: Assertion

48+test_ephemeralSameThread = runEff $ do

49+ assertThrowsUnliftError "ExceededNumberOfUses error" $ do

50+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do

51+ withEffToIO $ \runInIO -> inThread $ do

52+ runInIO $ return ()

53+ runInIO $ return ()

54+

55+test_ephemeralMultipleThreads :: Assertion

56+test_ephemeralMultipleThreads = runEff $ do

57+ assertThrowsUnliftError "ExceededNumberOfUses error" $ do

58+ withUnliftStrategy (ConcUnlift Ephemeral $ Limited 1) $ do

59+ withEffToIO $ \runInIO -> do

60+ inThread $ runInIO $ return ()

61+ inThread $ runInIO $ return ()

62+

63+test_persistentInvalid :: Assertion

64+test_persistentInvalid = runEff $ do

65+ assertThrowsUnliftError "InvalidNumberOfThreads error" $ do

66+ withUnliftStrategy (ConcUnlift Persistent $ Limited 0) $ do

67+ withEffToIO $ \_ -> return ()

68+

69+test_persistentSameThread :: Assertion

70+test_persistentSameThread = runEff $ do

71+ withUnliftStrategy (ConcUnlift Persistent $ Limited 1) $ do

72+ withEffToIO $ \runInIO -> inThread $ do

73+ runInIO $ return ()

74+ runInIO $ return ()

75+

76+test_persistentMultipleThreads :: Assertion

77+test_persistentMultipleThreads = runEff $ do

78+ assertThrowsUnliftError "ExceededNumberOfThreads error" $ do

79+ withUnliftStrategy (ConcUnlift Persistent $ Limited 1) $ do

80+ withEffToIO $ \runInIO -> do

81+ inThread $ runInIO $ return ()

82+ inThread $ runInIO $ return ()

83+

84+----------------------------------------

85+-- Helpers

86+

87+assertThrowsUnliftError

88+ :: IOE :> es

89+ => String -> Eff es a -> Eff es ()

90+assertThrowsUnliftError err = U.assertThrows err (\ErrorCall{} -> True)

91+

92+inThread :: IO a -> IO a

93+inThread k = A.async k >>= A.wait

effectful/tests/Utils.hs+17−1

@@ -2,11 +2,12 @@ module Utils

2 ( assertBool

3 , assertEqual

4 , assertFailure

5+ , assertThrows

5 , Ex(..)

6 , Ex(..)

6 ) where

7 ) where

7

8

8import Control.Exception

9import Control.Exception

9−import Control.Monad.IO.Class

10+import Control.Monad

10import GHC.Stack

11import GHC.Stack

11import qualified Test.Tasty.HUnit as T

12import qualified Test.Tasty.HUnit as T

12

13

@@ -26,5 +27,20 @@ assertEqual msg expected given = liftIO $ T.assertEqual msg expected given

26assertFailure :: (HasCallStack, IOE :> es) => String -> Eff es a

27assertFailure :: (HasCallStack, IOE :> es) => String -> Eff es a

27assertFailure msg = liftIO $ T.assertFailure msg

28assertFailure msg = liftIO $ T.assertFailure msg

28

29

30+assertThrows

31+ :: (Exception e, IOE :> es)

32+ => String

33+ -> (e -> Bool)

34+ -> Eff es a

35+ -> Eff es ()

36+assertThrows msg p k = withEffToIO $ \runInIO -> do

37+ let k' = do

38+ void $ runInIO k

39+ T.assertFailure msg

40+

41+ k' `catch` \e -> if p e

42+ then return ()

43+ else throwIO e

44+

29data Ex = Ex deriving (Eq, Show)

45data Ex = Ex deriving (Eq, Show)

30instance Exception Ex

46instance Exception Ex