master..c851bda · effectful

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

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

11+# version: 0.13.20210621

12#

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

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

14#

15name: Haskell-CI

16on:

@@ -24,23 +24,26 @@ jobs:

24 linux:

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

26 runs-on: ubuntu-18.04

27− timeout-minutes:

28− 60

29 container:

27 container:

30 image: buildpack-deps:bionic

28 image: buildpack-deps:bionic

31 continue-on-error: ${{ matrix.allow-failure }}

29 continue-on-error: ${{ matrix.allow-failure }}

32 strategy:

30 strategy:

33 matrix:

31 matrix:

34 include:

32 include:

35− - compiler: ghc-9.2.1

33+ - compiler: ghc-9.2.0.20210422

36 compilerKind: ghc

34 compilerKind: ghc

37− compilerVersion: 9.2.1

35+ compilerVersion: 9.2.0.20210422

38 setup-method: ghcup

36 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

39 allow-failure: false

42 allow-failure: false

40− - compiler: ghc-8.10.7

43+ - compiler: ghc-8.10.4

41 compilerKind: ghc

44 compilerKind: ghc

42− compilerVersion: 8.10.7

45+ compilerVersion: 8.10.4

43− setup-method: ghcup

46+ setup-method: hvr-ppa

44 allow-failure: false

47 allow-failure: false

45 - compiler: ghc-8.8.4

48 - compiler: ghc-8.8.4

46 compilerKind: ghc

49 compilerKind: ghc

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

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

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

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

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

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

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

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

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

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

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

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

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

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

64+ "$HOME/.ghcup/bin/ghcup" install cabal 3.4.0.0

62 else

65 else

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

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

64 apt-get update

67 apt-get update

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

68+ apt-get install -y "$HCNAME" cabal-install-3.4

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

70 fi

69 fi

71 env:

70 env:

72 HCKIND: ${{ matrix.compilerKind }}

71 HCKIND: ${{ matrix.compilerKind }}

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

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

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

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

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

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

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

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

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

88 else

87 else

89 HC=$HCDIR/bin/$HCKIND

88 HC=$HCDIR/bin/$HCKIND

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

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

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

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

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

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

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

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

94 fi

93 fi

95

94

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

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

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

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

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

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

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

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

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

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

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

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

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

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

103 env:

102 env:

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

126 repository hackage.haskell.org

125 repository hackage.haskell.org

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

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

128 EOF

127 EOF

128+ if $HEADHACKAGE; then

129 cat >> $CABAL_CONFIG <<EOF

130− program-default-options

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

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

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

132+ secure: True

133+ root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d

134+ 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329

135+ f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89

136+ key-threshold: 3

132 EOF

137 EOF

138+ fi

133 cat $CABAL_CONFIG

139 cat $CABAL_CONFIG

134 - name: versions

140 - name: versions

135 run: |

141 run: |

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

142 - name: cache (tools)

148 - name: cache (tools)

143 uses: actions/cache@v2

149 uses: actions/cache@v2

144 with:

150 with:

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

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

146 path: ~/.haskell-ci-tools

152 path: ~/.haskell-ci-tools

147 - name: install cabal-plan

153 - name: install cabal-plan

148 run: |

154 run: |

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

155 cabal-plan --version

161 cabal-plan --version

156 - name: install doctest

162 - name: install doctest

157 run: |

163 run: |

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

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

159− doctest --version

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

160 - name: checkout

166 - name: checkout

161 uses: actions/checkout@v2

167 uses: actions/checkout@v2

162 with:

168 with:

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

194 package effectful

200 package effectful

195 flags: +benchmark-foreign-libraries

201 flags: +benchmark-foreign-libraries

196 EOF

202 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

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

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

198 cat cabal.project

207 cat cabal.project

199 cat cabal.project.local

208 cat cabal.project.local

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

222 $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct

231 $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct

223 - name: doctest

232 - name: doctest

224 run: |

233 run: |

225− cd ${PKGDIR_effectful} || false

234+ if [ $((HCNUMVER < 90200)) -ne 0 ] ; then cd ${PKGDIR_effectful} || false ; 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

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

227− cd ${PKGDIR_effectful_core} || false

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

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

229− cd ${PKGDIR_effectful_core} || false

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

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

231 - name: cabal check

238 - name: cabal check

232 run: |

239 run: |

233 cd ${PKGDIR_effectful} || false

240 cd ${PKGDIR_effectful} || false

README.md+3−10

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

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

8

5

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

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

10

7

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

20

17

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

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

22

19

23−3. Correct semantics in presence of runtime exceptions (no more lost state

20+3. Correct semantics in presence of runtime exceptions (no more lost or

24− modifications).

21+ discarded state).

25

22

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

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

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

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

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

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

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

140

137

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

138* [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+3−1

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

1branches: master

2

3−doctest: <9.3

3+doctest: <9.2

4tests: True

5benchmarks: True

6

7+ghcup-jobs: >=9.2

8+

7raw-project

9raw-project

8 package effectful

10 package effectful

9 flags: +benchmark-foreign-libraries

11 flags: +benchmark-foreign-libraries

doctest.sh+2−2

@@ -17,7 +17,6 @@ run_doctest() {

17 -XConstraintKinds \

18 -XDataKinds \

19 -XDeriveFunctor \

20− -XDeriveGeneric \

21 -XFlexibleContexts \

20 -XFlexibleContexts \

22 -XFlexibleInstances \

21 -XFlexibleInstances \

23 -XGADTs \

22 -XGADTs \

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

30 -XRoleAnnotations \

29 -XRoleAnnotations \

31 -XScopedTypeVariables \

30 -XScopedTypeVariables \

32 -XStandaloneDeriving \

31 -XStandaloneDeriving \

32+ -XStrictData \

33 -XTupleSections \

34 -XTypeApplications \

35 -XTypeFamilies \

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

37 popd

38}

39

40−run_doctest effectful-core src

41run_doctest effectful src

40run_doctest effectful src

41+run_doctest effectful-core src

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

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

1cabal-version: 2.4

2build-type: Simple

3name: effectful-core

4−version: 0.1

4+version: 0.0.0.0

5license: BSD-3-Clause

6license-file: LICENSE

7category: Control

@@ -12,13 +12,14 @@ 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 core definitions with a minimal dependency

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

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

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

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

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

18+ package.

18

19

19extra-source-files: CHANGELOG.md

20extra-source-files: CHANGELOG.md

20

21

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

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

22

23

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

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

24source-repository head

25source-repository head

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

34 ConstraintKinds

35 ConstraintKinds

35 DataKinds

36 DataKinds

36 DeriveFunctor

37 DeriveFunctor

37− DeriveGeneric

38 FlexibleContexts

39 FlexibleInstances

40 GADTs

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

47 RoleAnnotations

48 ScopedTypeVariables

49 StandaloneDeriving

50+ StrictData

50 TupleSections

51 TupleSections

51 TypeApplications

52 TypeApplications

52 TypeFamilies

53 TypeFamilies

@@ -67,30 +68,26 @@ library

67

68

68 ghc-options: -O2

69 ghc-options: -O2

69

70

70− build-depends: effectful-internal-utils

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

71−

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

73− , containers >= 0.6

72+ , containers

73+ , effectful-internal-utils

74− , exceptions >= 0.10.4

74+ , exceptions

75− , monad-control >= 1.0.3

75+ , monad-control

76− , primitive >= 0.7.3.0

76+ , primitive

77− , transformers-base >= 0.4.6

77+ , transformers-base

78− , unliftio-core >= 0.2.0.1

78+ , unliftio-core

79

80 hs-source-dirs: src

81

82− exposed-modules: Effectful

82+ exposed-modules: Effectful.Error

83− Effectful.Dispatch.Dynamic

84− Effectful.Dispatch.Static

85− Effectful.Error

86 Effectful.Error.Dynamic

83 Effectful.Error.Dynamic

87 Effectful.Fail

84 Effectful.Fail

85+ Effectful.Handler

88 Effectful.Internal.Effect

86 Effectful.Internal.Effect

89 Effectful.Internal.Env

87 Effectful.Internal.Env

90 Effectful.Internal.Monad

88 Effectful.Internal.Monad

91 Effectful.Internal.Unlift

89 Effectful.Internal.Unlift

92 Effectful.Monad

90 Effectful.Monad

93− Effectful.Prim

94 Effectful.Reader

91 Effectful.Reader

95 Effectful.Reader.Dynamic

92 Effectful.Reader.Dynamic

96 Effectful.State.Dynamic

93 Effectful.State.Dynamic

effectful-core/src/Effectful/Dispatch/Static.hsdeleted−82

@@ -1,82 +0,0 @@

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

@@ -1,78 +1,29 @@

1−-- | Support for handling errors of a particular type, i.e. checked exceptions.

1+{- | Support for 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

3−-- The 'Error' effect is __not__ a general mechanism for handling regular

5+is __not__ intended to be a general mechanism for catching errors, that's what

4−-- exceptions, that's what functions from the @exceptions@ library are for (see

5−-- "Control.Monad.Catch" for more information).

6+functions from the "Control.Monad.Catch" module are for.

6−--

7+

7−-- In particular, regular exceptions of type @e@ are distinct from errors of

8+For example, if you want to catch an unchecked exception like

8−-- type @e@ and will __not__ be caught by functions from this module:

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

9−--

10−-- >>> import qualified Control.Monad.Catch as E

11−-- >>> let boom = error "BOOM!"

12−-- >>> runEff . runError @ErrorCall $ boom `catchError` \_ (_::ErrorCall) -> pure "caught"

13−-- *** Exception: BOOM!

14−-- ...

15−--

16−-- If you want to catch regular exceptions, you should use

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

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

18−--

11+

19−-- >>> runEff $ boom `E.catch` \(_::ErrorCall) -> pure "caught"

20−-- "caught"

21−--

22−-- On the other hand, functions for safe finalization and management of

23−-- resources such as 'Control.Monad.Catch.finally' and

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

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

25−--

13+>>> :{

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

14+ let boom :: Eff es String

27−-- >>> :{

15+ boom = error "BOOM!"

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

16+ in

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

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

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

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

32−-- :}

18+:}

33−-- Beginning.

19+"caught some error"

34−-- Computing.

20+

35−-- Cleaning up.

21+-}

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.

70module Effectful.Error

22module Effectful.Error

71 ( Error

23 ( Error

72 , runError

24 , runError

73 , throwError

25 , throwError

74 , catchError

26 , catchError

75− , handleError

76 , tryError

27 , tryError

77

28

78 -- * Re-exports

29 -- * Re-exports

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

87import Data.Unique

38import Data.Unique

88import GHC.Stack

39import GHC.Stack

89

40

90−import Effectful.Dispatch.Static

41+import Effectful.Internal.Effect

42+import Effectful.Internal.Env

91−import Effectful.Monad

43+import Effectful.Internal.Monad

92

44

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

94−newtype Error e :: Effect where

45+data Error e :: Effect where

95 Error :: ErrorId -> Error e m r

46 Error :: ErrorId -> Error e m r

96

47

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

98runError

48runError

99 :: forall e es a. Typeable e

49 :: forall e es a. Typeable e

100 => Eff (Error e : es) a

50 => Eff (Error e : es) a

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

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

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

103 eid <- newErrorId

53 eid <- newErrorId

104 size0 <- sizeEnv es0

54 size0 <- sizeEnv es0

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

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

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

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

107− unsafeTailEnv size0 es

57+ _ <- unsafeTailEnv size0 es

108 pure r

58 pure r

109 where

59 where

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

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

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

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

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

113 $ throwIO ex

63 $ throwIO ex

114

64

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

116throwError

65throwError

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

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

118 => e

67 => e

119− -- ^ The error.

120 -> Eff es a

68 -> Eff es a

121throwError e = unsafeEff $ \es -> do

69throwError e = unsafeEff $ \es -> do

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

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

123 throwIO $ ErrorEx eid callStack e

71 throwIO $ ErrorEx eid callStack e

124

72

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

126catchError

73catchError

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

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

128 => Eff es a

75 => Eff es a

129− -- ^ The inner computation.

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

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

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

132 -> Eff es a

77 -> Eff es a

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

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

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

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

135 size <- sizeEnv es

80 size <- sizeEnv es

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

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

137 checkSizeEnv size es

82 checkSizeEnv size es

138 unEff (handler cs e) es

83 unEff (handler cs e) es

139

84

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.

153tryError

85tryError

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

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

155 => Eff es a

87 => Eff es a

156− -- ^ The inner computation.

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

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

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

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

159

90

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

181 | otherwise -> next

112 | otherwise -> next

182 Nothing -> next

113 Nothing -> next

183

114

184−data ErrorEx e = ErrorEx !ErrorId CallStack e

115+data ErrorEx e = ErrorEx ErrorId CallStack e

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

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

186 showsPrec p (ErrorEx _ cs e)

117 showsPrec p (ErrorEx _ cs e)

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

118 = ("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.Dispatch.Dynamic

11+import Effectful.Handler

12import Effectful.Monad

13import qualified Effectful.Error as E

14

effectful-core/src/Effectful/Fail.hs+1−11

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

1−-- | Provider of the 'MonadFail' instance for 'Eff'.

2module Effectful.Fail

1module Effectful.Fail

3− ( Fail(..)

2+ ( Fail

4 , runFail

3 , runFail

5 ) where

4 ) where

6

5

7−import Effectful.Dispatch.Dynamic

8−import Effectful.Error

9import Effectful.Internal.Monad

6import 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/Dispatch/Dynamic.hs → effectful-core/src/Effectful/Handler.hsrenamed+104−81

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

1−module Effectful.Dispatch.Dynamic

1+module Effectful.Handler

2 ( -- * Sending operations to the handler

3 send

4

5 -- * Handling effects

6− , EffectHandler

7 , interpret

6 , interpret

8 , reinterpret

7 , reinterpret

9

8

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

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

11 , LocalEnv

10 , LocalEnv

12

11

13 -- *** Unlifts

12 -- *** Unlifts

@@ -24,46 +23,89 @@ module Effectful.Dispatch.Dynamic

24 , localLiftUnlift

23 , localLiftUnlift

25 , localLiftUnliftIO

24 , localLiftUnliftIO

26

25

27− -- *** Utils

28− , SuffixOf

29−

30 -- * Re-exports

26 -- * Re-exports

31 , HasCallStack

27 , HasCallStack

32 ) where

28 ) where

33

29

34import Control.Monad.IO.Unlift

30import Control.Monad.IO.Unlift

35−import Data.Kind

31+import GHC.Stack

36−import GHC.Stack (HasCallStack)

32+import qualified Control.Exception as E

37

33

38import Effectful.Internal.Effect

34import Effectful.Internal.Effect

39import Effectful.Internal.Env

35import Effectful.Internal.Env

40import Effectful.Internal.Monad

36import Effectful.Internal.Monad

41

37

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

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

43−-- Handling effects

39+-- Handler

40+

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

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

43+-- handler.

44+newtype LocalEnv es = LocalEnv (Env es)

45+

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

47+ { _env :: Env handlerEs

48+ , _handle :: forall a localEs. HasCallStack

49+ => LocalEnv localEs

50+ -> e (Eff localEs) a

51+ -> Eff handlerEs a

52+ }

53+

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

55+runHandler es0 e m = do

56+ size0 <- sizeEnv es0

57+ E.bracket (unsafeConsEnv e relinker es0)

58+ (unsafeTailEnv size0)

59+ (\es -> unEff m es)

60+ where

61+ relinker :: Relinker Handler e

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

63+ env <- relink _env

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

65+

66+----------------------------------------

67+-- Sending operations

68+

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

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

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

72+ Handler{..} <- getEnv es

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

74+

75+----------------------------------------

76+-- Interpretation

44

77

45-- | Interpret an effect.

78-- | Interpret an effect.

79+--

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

81+-- from the 'localUnlift' family.

46interpret

82interpret

47− :: EffectHandler e es

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

48 -- ^ The effect handler.

84 -- ^ The effect handler.

49 -> Eff (e : es) a

85 -> Eff (e : es) a

50 -> Eff es a

86 -> Eff es a

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

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

52 les <- forkEnv es

88 les <- forkEnv es

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

89+ runHandler es (Handler les handler) m

90+

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

92+-- Reinterpretation

54

93

55-- | Interpret an effect using other effects.

94-- | Interpret an effect using other effects.

95+--

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

97+-- from the 'localUnlift' family.

56reinterpret

98reinterpret

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

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

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

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

59− -> EffectHandler e handlerEs

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

60 -- ^ The effect handler.

102 -- ^ The effect handler.

61 -> Eff (e : es) a

103 -> Eff (e : es) a

62 -> Eff es b

104 -> Eff es b

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

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

64 les0 <- forkEnv es

106 les0 <- forkEnv es

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

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

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

108+ runHandler es (Handler les handler) m

67

109

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

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

69-- Unlifts

111-- Unlifts

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

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

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

72-- general version see 'localUnlift'.

114-- general version see 'localUnlift'.

73localSeqUnlift

115localSeqUnlift

74− :: (HasCallStack, SuffixOf es handlerEs)

116+ :: HasCallStack

75− => LocalEnv localEs handlerEs

117+ => LocalEnv localEs

76 -- ^ Local environment.

118 -- ^ Local environment.

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

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

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

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

79 -> Eff es a

121 -> Eff es a

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

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

81− seqUnliftIO les $ \unlift -> do

123+ unsafeSeqUnliftEff les $ \unlift -> do

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

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

83

125

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

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

85-- general version see 'localUnliftIO'.

127-- general version see 'localUnliftIO'.

86localSeqUnliftIO

128localSeqUnliftIO

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

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

88− => LocalEnv localEs handlerEs

130+ => LocalEnv localEs

89 -- ^ Local environment.

131 -- ^ Local environment.

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

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

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

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

92 -> Eff es a

134 -> Eff es a

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

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

94

136

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

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

96localUnlift

138localUnlift

97− :: (HasCallStack, SuffixOf es handlerEs)

139+ :: HasCallStack

98− => LocalEnv localEs handlerEs

140+ => LocalEnv localEs

99 -- ^ Local environment.

141 -- ^ Local environment.

100 -> UnliftStrategy

142 -> UnliftStrategy

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

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

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

103 -> Eff es a

145 -> Eff es a

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

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

105 SeqUnlift -> unsafeEff $ \es -> do

147 SeqUnlift -> unsafeEff $ \es -> do

106− seqUnliftIO les $ \unlift -> do

148+ unsafeSeqUnliftEff les $ \unlift -> do

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

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

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

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

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

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

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

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

111

153

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

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

113localUnliftIO

155localUnliftIO

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

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

115− => LocalEnv localEs handlerEs

157+ => LocalEnv localEs

116 -- ^ Local environment.

158 -- ^ Local environment.

117 -> UnliftStrategy

159 -> UnliftStrategy

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

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

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

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

120 -> Eff es a

162 -> Eff es a

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

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

122− SeqUnlift -> liftIO $ seqUnliftIO les k

164+ SeqUnlift -> liftIO $ unsafeSeqUnliftEff les k

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

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

124

166

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

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

126--

168--

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

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

128--

170--

129-- to

171-- to

130--

172--

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

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

132--

174--

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

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

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

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

135withLiftMap

177withLiftMap

136− :: (HasCallStack, SuffixOf es handlerEs)

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

137− => LocalEnv localEs handlerEs

138− -- ^ Local environment.

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

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

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

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

141 -> Eff es r

181 -> Eff es r

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

182+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.

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

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

146− seqUnliftIO localEs $ \unlift -> do

184+ unsafeSeqUnliftEff localEs $ \unlift -> do

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

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

148

186

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

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

150--

188--

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

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

152--

190--

153-- to

191-- to

154--

192--

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

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

156--

194--

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

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

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

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

159--

197--

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

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

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

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

162--

200--

163-- >>> :{

201-- >>> :{

164-- data Fork :: Effect where

202-- data Fork :: Effect where

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

167--

205--

168-- >>> :{

206-- >>> :{

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

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

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

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

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

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

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

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

173-- :}

211-- :}

174withLiftMapIO

212withLiftMapIO

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

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

176− => LocalEnv localEs handlerEs

177− -- ^ Local environment.

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

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

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

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

180 -> Eff es r

216 -> Eff es r

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

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

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

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

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

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

185

219

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

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

187-- Bidirectional lifts

221-- Bidirectional lifts

188

222

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

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

190--

224--

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

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

192-- shows in both positive (as a result) and negative (as an argument) position.

226-- shows in both positive (as a result) and negative (as an argument) position.

193--

227--

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

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

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

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

196localLiftUnlift

230localLiftUnlift

197− :: (HasCallStack, SuffixOf es handlerEs)

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

198− => LocalEnv localEs handlerEs

232+ => LocalEnv localEs

199 -- ^ Local environment.

233 -- ^ Local environment.

200 -> UnliftStrategy

234 -> UnliftStrategy

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

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

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

203 -> Eff es a

237 -> Eff es a

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

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

205 SeqUnlift -> unsafeEff $ \es -> do

239 SeqUnlift -> unsafeEff $ \es -> do

206− seqUnliftIO es $ \unliftEs -> do

240+ unsafeSeqUnliftEff es $ \unliftEs -> do

207− seqUnliftIO les $ \unliftLocalEs -> do

241+ unsafeSeqUnliftEff les $ \unliftLocalEs -> do

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

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

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

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

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

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

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

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

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

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

213

247

214-- | Create a local unlifting function with the given strategy along with an

248-- | Create a local unlifting function with the given strategy along with an

215-- unrestricted lifting function.

249-- unrestricted lifting function.

216--

250--

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

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

218−-- shows in both positive (as a result) and negative (as an argument) position.

252+-- in both positive (as a result) and negative (as an argument) position.

219--

253--

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

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

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

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

222localLiftUnliftIO

256localLiftUnliftIO

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

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

224− => LocalEnv localEs handlerEs

258+ => LocalEnv localEs

225 -- ^ Local environment.

259 -- ^ Local environment.

226 -> UnliftStrategy

260 -> UnliftStrategy

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

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

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

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

229 -> Eff es a

263 -> Eff es a

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

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

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

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

232− ConcUnlift p l -> liftIO $ concUnliftIO les p l $ k unsafeEff_

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

244

267

245-- $setup

268-- $setup

246-- >>> import Control.Concurrent

269-- >>> import Control.Concurrent

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

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

8module Effectful.Internal.Effect

9 ( Effect

10 , (:>)(..)

11−

11+ , IdE(..)

12− -- * Re-exports

13− , Type

14 ) where

12 ) where

15

13

16import Data.Kind

14import Data.Kind

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

19-- | The kind of effects.

17-- | The kind of effects.

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

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

21

19

20+-- | Adapter for statically dispatched effects.

21+newtype IdE :: Effect -> Type where

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

23+

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

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

23−-- type-level list @es@. This is used to parameterize an 'Effectful.Monad.Eff'

25+-- the type-level list @es@. This is used to parameterize an

24−-- computation over an arbitrary list of effects, so long as @e@ is /somewhere/

26+-- 'Effectful.Monad.Eff' operation over an arbitrary list of effects, so long as

25−-- in the list.

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

26--

28--

27−-- For example, a computation that only needs access to a mutable value of type

29+-- For example, an operation that only needs access to a cell of mutable state

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

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

29--

31--

30-- @

32-- @

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

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

32-- @

34-- @

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

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

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

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

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

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

1−{-# LANGUAGE MagicHash #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

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

9− Env(..)

8+ ( Env

10− , Forks(..)

11− , EnvRef(..)

12−

13− -- ** ForkId

14− , ForkId(..)

15− , ForkIdGen(..)

16− , newForkIdGen

17− , cloneForkIdGen

18− , newForkId

19−

20− -- ** Relinker

21 , Relinker(..)

9 , Relinker(..)

22 , noRelinker

10 , noRelinker

23

11

24− -- * Operations

12+ -- * Operations

25 , emptyEnv

13 , emptyEnv

26 , cloneEnv

14 , cloneEnv

27 , forkEnv

15 , forkEnv

28 , sizeEnv

16 , sizeEnv

29 , checkSizeEnv

17 , checkSizeEnv

30

18

31− -- ** Extending and shrinking

19+ -- ** Extending and shrinking

32 , unsafeConsEnv

20 , unsafeConsEnv

33 , unsafeTailEnv

21 , unsafeTailEnv

34

22

35− -- ** Data retrieval and update

23+ -- ** Data retrieval and update

36 , getEnv

24 , getEnv

37 , putEnv

25 , putEnv

38 , stateEnv

26 , stateEnv

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

42import Control.Monad

30import Control.Monad

43import Control.Monad.Primitive

31import Control.Monad.Primitive

44import Data.IORef

32import Data.IORef

33+import Data.Kind

45import Data.Primitive.SmallArray

34import Data.Primitive.SmallArray

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

35+import GHC.Exts (Any)

47import GHC.Stack (HasCallStack)

36import GHC.Stack (HasCallStack)

48import Unsafe.Coerce

37import Unsafe.Coerce

49import qualified Data.IntMap.Strict as IM

38import qualified Data.IntMap.Strict as IM

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

81-- @

70-- @

82--

71--

83-- The point of execution is currently at (*), i.e. the mainline. Moreover,

72-- The point of execution is currently at (*), i.e. the mainline. Moreover,

84−-- currently (brackets represent forks):

73+-- currently:

85--

74--

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

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

87--

76--

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

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

89--

78--

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

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

91--

80--

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

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

93--

82--

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

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

95-- e09]@.

84-- e09]@.

96--

85--

97-- If an operation from @e01@ is invoked, the environment in the middle of

86-- If an operation from @e01@ is invoked, the environment in the middle of

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

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

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

115-- it. Moreover, currently:

104-- it. Moreover, currently:

116--

105--

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

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

118--

107--

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

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

120--

109--

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

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

122--

111--

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

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

124− { _forks :: !Forks

113+ { _forks :: Forks

125− , _globalRef :: !(IORef EnvRef)

114+ , _globalRef :: IORef EnvRef

126− , _forkIdGen :: !ForkIdGen

115+ , _forkIdGen :: ForkIdGen

127 }

116 }

128

117

129-- | Local forks of the environment.

118-- | Local forks of the environment.

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

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

131

120

132−-- | Data held in the environment.

133data EnvRef = EnvRef

121data EnvRef = EnvRef

134− { _size :: !Int

122+ { _size :: Int

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

123+ , _data :: SmallMutableArray RealWorld Any

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

124+ , _relinkers :: SmallMutableArray RealWorld Any

137 }

125 }

138

126

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

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

140-- ForkId

128-- ForkId

141

129

142−-- | Internal id of the fork.

143newtype ForkId = ForkId { unForkId :: Int }

130newtype ForkId = ForkId { unForkId :: Int }

144

131

145-- | 'ForkId' generation.

132-- | 'ForkId' generation.

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

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

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

164-- Relinker

151-- Relinker

165

152

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

167−-- the environment.

168newtype Relinker :: (Effect -> Type) -> Effect -> Type where

153newtype Relinker :: (Effect -> Type) -> Effect -> Type where

169 Relinker

154 Relinker

170− :: ((forall es. Env es -> IO (Env es)) -> adapter e -> IO (adapter e))

155+ :: ((forall es. Env es -> IO (Env es)) -> handler e -> IO (handler e))

171− -> Relinker adapter e

156+ -> Relinker handler e

172

157

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

174−noRelinker :: Relinker adapter e

158+noRelinker :: Relinker handler e

175noRelinker = Relinker $ \_ -> pure

159noRelinker = Relinker $ \_ -> pure

176

160

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

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

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

189 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

173 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

190 gen <- cloneForkIdGen gen0

174 gen <- cloneForkIdGen gen0

191 gref <- newIORef $ EnvRef n es fs

175 gref <- newIORef $ EnvRef n es fs

192− store <- newIORef IM.empty

176+ cache <- newIORef IM.empty

193− relinkData gref gen store es fs n

177+ relinkData gref gen cache es fs n

194 pure $ Env NoFork gref gen

178 pure $ Env NoFork gref gen

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

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

196 EnvRef _ es0 fs0 <- readIORef gref0

180 EnvRef _ es0 fs0 <- readIORef gref0

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

203 copySmallMutableArray fs 0 fs0 0 baseN

187 copySmallMutableArray fs 0 fs0 0 baseN

204 gen <- cloneForkIdGen gen0

188 gen <- cloneForkIdGen gen0

205 gref <- newIORef $ EnvRef len es fs

189 gref <- newIORef $ EnvRef len es fs

206− store <- newIORef IM.empty

190+ cache <- newIORef IM.empty

207− relinkData gref gen store es fs n

191+ relinkData gref gen cache es fs n

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

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

209 pure $ Env NoFork gref gen

193 pure $ Env NoFork gref gen

210{-# NOINLINE cloneEnv #-}

194{-# NOINLINE cloneEnv #-}

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

254 copySmallMutableArray fs baseIx fs0 0 n

238 copySmallMutableArray fs baseIx fs0 0 n

255 copyForks es fs baseIx forks

239 copyForks es fs baseIx forks

256

240

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

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

258

242

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

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

260relinkData

244relinkData

261 :: IORef EnvRef

245 :: IORef EnvRef

262 -> ForkIdGen

246 -> ForkIdGen

263− -> EnvRefStore

247+ -> EnvRefCache

264 -> SmallMutableArray RealWorld Any

248 -> SmallMutableArray RealWorld Any

265 -> SmallMutableArray RealWorld Any

249 -> SmallMutableArray RealWorld Any

266 -> Int

250 -> Int

267 -> IO ()

251 -> IO ()

268−relinkData gref gen store es fs = \case

252+relinkData gref gen cache es fs = \case

269 0 -> pure ()

253 0 -> pure ()

270 n -> do

254 n -> do

271 let i = n - 1

255 let i = n - 1

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

273 readSmallArray es i

257 readSmallArray es i

274 >>= f relinkEnv . fromAny

258 >>= f relinkEnv . fromAny

275 >>= writeSmallArray es i . toAny

259 >>= writeSmallArray es i . toAny

276− relinkData gref gen store es fs i

260+ relinkData gref gen cache es fs i

277 where

261 where

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

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

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

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

280 <*> pure gref

264 <*> pure gref

281 <*> pure gen

265 <*> pure gen

282

266

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

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

284−relinkForks gref gen store = \case

268+relinkForks gref gen cache = \case

285 NoFork -> pure NoFork

269 NoFork -> pure NoFork

286 Forks fid baseIx lref0 forks -> do

270 Forks fid baseIx lref0 forks -> do

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

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

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

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

289 -- containing its clone.

273 -- containing its clone.

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

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

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

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

292− <*> relinkForks gref gen store forks

276+ <*> relinkForks gref gen cache forks

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

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

294− <*> relinkForks gref gen store forks

278+ <*> relinkForks gref gen cache forks

295

279

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

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

297cloneEnvRef

281cloneEnvRef

298 :: IORef EnvRef

282 :: IORef EnvRef

299 -> ForkIdGen

283 -> ForkIdGen

300− -> EnvRefStore

284+ -> EnvRefCache

301 -> ForkId

285 -> ForkId

302 -> IORef EnvRef

286 -> IORef EnvRef

303 -> IO (IORef EnvRef)

287 -> IO (IORef EnvRef)

304−cloneEnvRef gref gen store fid lref0 = do

288+cloneEnvRef gref gen cache fid lref0 = do

305 EnvRef n es0 fs0 <- readIORef lref0

289 EnvRef n es0 fs0 <- readIORef lref0

306 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)

290 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)

307 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

291 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

308 ref <- newIORef $ EnvRef n es fs

292 ref <- newIORef $ EnvRef n es fs

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

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

310− relinkData gref gen store es fs n

294+ relinkData gref gen cache es fs n

311 pure ref

295 pure ref

312

296

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

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

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

356

340

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

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

358--

342--

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

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

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

361−-- checked anywhere.

344+-- unusable, but it's not checked anywhere.

362−unsafeConsEnv :: adapter e -> Relinker adapter e -> Env es -> IO (Env (e : es))

345+unsafeConsEnv :: handler e -> Relinker handler e -> Env es -> IO (Env (e : es))

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

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

364 NoFork -> do

347 NoFork -> do

365 extendEnvRef gref

348 extendEnvRef gref

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

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

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

396-- the environment is as expected.

379-- the environment is as expected.

397--

380--

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

381+-- /Note:/ this function is __unsafe__ because it renders the input 'Env'

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

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

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

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

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

384+unsafeTailEnv len (Env fork gref gen) = case fork of

385+ NoFork -> do

402− NoFork -> shrinkEnvRef len gref

386+ shrinkEnvRef len gref

387+ pure $ Env NoFork gref gen

388+ Forks _ baseIx lref _ -> do

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

389+ shrinkEnvRef (len - baseIx) lref

390+ pure $ Env fork gref gen

404 where

391 where

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

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

406 shrinkEnvRef k ref = do

393 shrinkEnvRef k ref = do

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

417-- Data retrieval and update

404-- Data retrieval and update

418

405

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

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

420−getEnv

407+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)

424getEnv env = do

408getEnv env = do

425− Location i es <- getLocation (reifyIndex @e @es) env

409+ (i, es) <- getLocation @e env

426 fromAny <$> readSmallArray es i

410 fromAny <$> readSmallArray es i

427

411

428-- | Replace the data type in the environment with a new value (in place).

412-- | Replace the data type in the environment with a new value (in place).

429putEnv

413putEnv

430− :: forall e adapter es. e :> es

414+ :: forall e es handler. e :> es

431 => Env es

415 => Env es

432− -> adapter e

416+ -> handler e

433 -> IO ()

417 -> IO ()

434putEnv env e = do

418putEnv env e = do

435− Location i es <- getLocation (reifyIndex @e @es) env

419+ (i, es) <- getLocation @e env

436 e `seq` writeSmallArray es i (toAny e)

420 e `seq` writeSmallArray es i (toAny e)

437

421

438-- | Modify the data type in the environment (in place) and return a value.

422-- | Modify the data type in the environment (in place) and return a value.

439stateEnv

423stateEnv

440− :: forall e adapter es a. e :> es

424+ :: forall e es handler a. e :> es

441 => Env es

425 => Env es

442− -> (adapter e -> (a, adapter e))

426+ -> (handler e -> (a, handler e))

443 -> IO a

427 -> IO a

444stateEnv env f = do

428stateEnv env f = do

445− Location i es <- getLocation (reifyIndex @e @es) env

429+ (i, es) <- getLocation @e env

446 (a, e) <- f . fromAny <$> readSmallArray es i

430 (a, e) <- f . fromAny <$> readSmallArray es i

447 e `seq` writeSmallArray es i (toAny e)

431 e `seq` writeSmallArray es i (toAny e)

448 pure a

432 pure a

449

433

450-- | Modify the data type in the environment (in place).

434-- | Modify the data type in the environment (in place).

451modifyEnv

435modifyEnv

452− :: forall e adapter es. e :> es

436+ :: forall e es handler. e :> es

453 => Env es

437 => Env es

454− -> (adapter e -> adapter e)

438+ -> (handler e -> handler e)

455 -> IO ()

439 -> IO ()

456modifyEnv env f = do

440modifyEnv env f = do

457− Location i es <- getLocation (reifyIndex @e @es) env

441+ (i, es) <- getLocation @e env

458 e <- f . fromAny <$> readSmallArray es i

442 e <- f . fromAny <$> readSmallArray es i

459 e `seq` writeSmallArray es i (toAny e)

443 e `seq` writeSmallArray es i (toAny e)

460

444

@@ -470,17 +454,13 @@ emptyEnvRef = do

470 fs <- newSmallArray 0 undefinedData

454 fs <- newSmallArray 0 undefinedData

471 newIORef $ EnvRef 0 es fs

455 newIORef $ EnvRef 0 es fs

472

456

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−

477-- | Determine location of the data type in the environment.

457-- | Determine location of the data type in the environment.

478getLocation

458getLocation

479− :: Int

459+ :: forall e es. e :> es

480− -> Env es

460+ => Env es

481− -> IO Location

461+ -> IO (Int, SmallMutableArray RealWorld Any)

482−getLocation ixE (Env fork ref _) = do

462+getLocation (Env fork ref _) = do

483− EnvRef n es@(SmallMutableArray es#) _ <- readIORef ref

463+ EnvRef n es _ <- readIORef ref

484 -- Optimized for the common access pattern:

464 -- Optimized for the common access pattern:

485 --

465 --

486 -- - Most application code has no access to forks, in which case we look at

466 -- - Most application code has no access to forks, in which case we look at

@@ -489,28 +469,28 @@ getLocation ixE (Env fork ref _) = do

489 -- - Effect handlers will most likely access the newest fork with handler

469 -- - Effect handlers will most likely access the newest fork with handler

490 -- specific effects for reinterpretation.

470 -- specific effects for reinterpretation.

491 case fork of

471 case fork of

492− NoFork -> pure $ Location (ix n) es

472+ NoFork -> pure (ix n, es)

493 Forks _ baseIx lref forks -> do

473 Forks _ baseIx lref forks -> do

494 EnvRef ln les _ <- readIORef lref

474 EnvRef ln les _ <- readIORef lref

495 let i = ix (baseIx + ln)

475 let i = ix (baseIx + ln)

496 if i >= baseIx

476 if i >= baseIx

497− then pure $ Location (i - baseIx) les

477+ then pure (i - baseIx, les)

498− else go es# i forks

478+ else go es i forks

499 where

479 where

500− go :: SmallMutableArray# RealWorld Any

480+ go :: SmallMutableArray RealWorld Any

501 -> Int

481 -> Int

502 -> Forks

482 -> Forks

503− -> IO Location

483+ -> IO (Int, SmallMutableArray RealWorld Any)

504− go es# i = \case

484+ go es i = \case

505− NoFork -> pure $ Location i (SmallMutableArray es#)

485+ NoFork -> pure (i, es)

506 Forks _ baseIx lref forks -> do

486 Forks _ baseIx lref forks -> do

507 EnvRef _ les _ <- readIORef lref

487 EnvRef _ les _ <- readIORef lref

508 if i >= baseIx

488 if i >= baseIx

509− then pure $ Location (i - baseIx) les

489+ then pure (i - baseIx, les)

510− else go es# i forks

490+ else go es i forks

511

491

512 ix :: Int -> Int

492 ix :: Int -> Int

513− ix n = n - ixE - 1

493+ ix n = n - reifyIndex @e @es - 1

514

494

515toAny :: a -> Any

495toAny :: a -> Any

516toAny = unsafeCoerce

496toAny = unsafeCoerce

effectful-core/src/Effectful/Internal/Monad.hs+242−207

@@ -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− ( -- * The 'Eff' monad

9+ ( -- * Monad

10 Eff

11 , runPureEff

12

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

16 , unsafeEff_

17

18 -- * Fail

19− , Fail(..)

19+ , Fail

20+ , runFail

20

21

21 -- * IO

22 -- * IO

22 , IOE

23 , IOE

23 , runEff

24 , runEff

24

25

25− -- * Prim

26+ -- * Primitive

26 , Prim

27 , Prim

27 , runPrim

28 , runPrim

28

29

29− -- * Unlift strategies

30+ -- ** Unlift strategies

30 , UnliftStrategy(..)

31 , UnliftStrategy(..)

31 , Persistence(..)

32 , Persistence(..)

32 , Limit(..)

33 , Limit(..)

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

34 , withUnliftStrategy

35 , withUnliftStrategy

35 , withEffToIO

36 , withEffToIO

36

37

37− -- ** Low-level unlifts

38+ --- *** Low-level helpers

38− , seqUnliftIO

39+ , unsafeWithLiftMapIO

39− , concUnliftIO

40+ , unsafeSeqUnliftEff

40−

41+ , unsafeConcUnliftEff

41− -- * Effects

42+

42−

43+ -- * Primitive effects

43− -- ** Dynamic dispatch

44+

44− , EffectHandler

45+ -- ** Running

45− , LocalEnv(..)

46+ , runEffect

46− , HandlerA(..)

47+ , evalEffect

47− , runHandler

48+ , execEffect

48− , send

49+

49−

50+ -- ** Modification

50− -- ** Static dispatch

51+ , getEffect

51− , DataA(..)

52+ , putEffect

52− , runData

53+ , stateEffect

53− , evalData

54+ , stateEffectM

54− , execData

55+ , localEffect

55− , getData

56− , putData

57− , stateData

58− , stateDataM

59− , localData

60 ) where

56 ) where

61

57

62import Control.Applicative (liftA2)

58import Control.Applicative (liftA2)

59+import Control.Concurrent (myThreadId)

60+import Control.Exception

63import Control.Monad.Base

61import Control.Monad.Base

64import Control.Monad.Fix

62import Control.Monad.Fix

65import Control.Monad.IO.Class

63import Control.Monad.IO.Class

66import Control.Monad.IO.Unlift

64import Control.Monad.IO.Unlift

67import Control.Monad.Primitive

65import Control.Monad.Primitive

68import Control.Monad.Trans.Control

66import Control.Monad.Trans.Control

67+import Data.Unique

69import GHC.Exts (oneShot)

68import GHC.Exts (oneShot)

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

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

71import GHC.Stack (HasCallStack)

70import GHC.Stack (HasCallStack)

72import System.IO.Unsafe (unsafeDupablePerformIO)

71import System.IO.Unsafe (unsafeDupablePerformIO)

73−import qualified Control.Exception as E

72+import qualified Control.Monad.Catch as E

74−import qualified Control.Monad.Catch as C

75

73

76import Effectful.Internal.Effect

74import Effectful.Internal.Effect

77import Effectful.Internal.Env

75import Effectful.Internal.Env

78import Effectful.Internal.Unlift

76import Effectful.Internal.Unlift

77+import Effectful.Internal.Utils

79

78

80type role Eff nominal representational

79type role Eff nominal representational

81

80

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

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

83-- an arbitrary set of effects. In @'Eff' es a@, @es@ is a type-level list that

82-- an arbitrary set of effects. In @'Eff' es a@, @es@ is a type-level list that

84−-- contains all the effects that the computation may perform. For example, a

83+-- contains all the effects that the operation may perform. For example, an

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

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

86−-- global environment and acting upon a single mutable value of type 'Bool'

85+-- environment and acting upon a single mutable cell containing a 'Bool' would

87−-- would have the following type:

86+-- have the following type:

88--

87--

89-- @

88-- @

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

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

91-- @

90-- @

92--

91--

93-- Normally, a concrete list of effects is not used to parameterize 'Eff'.

92-- Normally, a concrete list of effects is not used to parameterize 'Eff'.

94-- Instead, the '(:>)' type class is used to express constraints on the list of

93-- Instead, the '(:>)' type class is used to express constraints on the list of

95−-- effects without coupling a computation to a concrete list of effects. For

94+-- effects without coupling an operation to a concrete list of effects. For

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

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

96+-- following type:

97--

98-- @

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

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

100-- @

101--

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

102+-- This abstraction allows the operation 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' computation.

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

109--

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

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

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

112runPureEff (Eff m) =

113− -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no

113+ -- unsafePerformIO is safe here since IOE was not on the stack, so no IO with

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

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

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

115+ -- 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.

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

119 unsafeDupablePerformIO $ m =<< emptyEnv

120

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

@@ -126,70 +126,62 @@ 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.

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

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

133unsafeEff m = Eff (oneShot m)

130unsafeEff m = Eff (oneShot m)

134

131

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

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

139unsafeEff_ :: IO a -> Eff es a

133unsafeEff_ :: IO a -> Eff es a

140unsafeEff_ m = unsafeEff $ \_ -> m

134unsafeEff_ m = unsafeEff $ \_ -> m

141

135

142−----------------------------------------

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

143−-- Unlifting IO

144−

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

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

147−unliftStrategy = do

148− DataA (IOE unlift) <- getData

149− pure unlift

150−

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

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

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

154−

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

156--

137--

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

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

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

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

160--

139--

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

140+-- to

162−withEffToIO

141+--

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

143+--

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

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

146+unsafeWithLiftMapIO

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

147+ :: HasCallStack

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

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

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

166− -> Eff es a

149+ -> Eff es r

167−withEffToIO f = unliftStrategy >>= \case

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

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

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

169− ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do

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

171

152

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

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

173−seqUnliftIO

154+unsafeSeqUnliftEff

174 :: HasCallStack

155 :: HasCallStack

175 => Env es

156 => Env es

176− -- ^ The environment.

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

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

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

179 -> IO a

158 -> IO a

180−seqUnliftIO es k = seqUnlift k es unEff

159+unsafeSeqUnliftEff es k = do

181−

160+ tid0 <- myThreadId

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

161+ k $ \m -> do

183−concUnliftIO

162+ tid <- myThreadId

163+ if tid `eqThreadId` tid0

164+ then unEff m es

165+ else error

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

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

168+

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

170+unsafeConcUnliftEff

184 :: HasCallStack

171 :: HasCallStack

185 => Env es

172 => Env es

186− -- ^ The environment.

187 -> Persistence

173 -> Persistence

188 -> Limit

174 -> Limit

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

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

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

191 -> IO a

176 -> IO a

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

177+unsafeConcUnliftEff es Ephemeral (Limited uses) k =

178+ unsafeEphemeralConcUnliftIO uses k es unEff

179+unsafeConcUnliftEff es Ephemeral Unlimited k =

180+ unsafeEphemeralConcUnliftIO maxBound k es unEff

181+unsafeConcUnliftEff es Persistent (Limited threads) k =

182+ unsafePersistentConcUnliftIO False threads k es unEff

183+unsafeConcUnliftEff es Persistent Unlimited k =

184+ unsafePersistentConcUnliftIO True maxBound k es unEff

193

185

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

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

195-- Base

187-- Base

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

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

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

218-- Exception

210-- Exception

219

211

220−instance C.MonadThrow (Eff es) where

212+instance E.MonadThrow (Eff es) where

221− throwM = unsafeEff_ . E.throwIO

213+ throwM = unsafeEff_ . throwIO

222

214

223−instance C.MonadCatch (Eff es) where

215+instance E.MonadCatch (Eff es) where

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

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

225 size <- sizeEnv es

217 size <- sizeEnv es

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

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

227 checkSizeEnv size es

219 checkSizeEnv size es

228 unEff (handler e) es

220 unEff (handler e) es

229

221

230−instance C.MonadMask (Eff es) where

222+instance E.MonadMask (Eff es) where

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

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

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

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

233

225

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

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

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

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

236

228

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

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

238 size <- sizeEnv es

230 size <- sizeEnv es

239 resource <- unEff acquire es

231 resource <- unEff acquire es

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

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

241 checkSizeEnv size es

233 checkSizeEnv size es

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

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

243− E.throwIO e

235+ throwIO e

244 checkSizeEnv size es

236 checkSizeEnv size es

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

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

246 pure (b, c)

238 pure (b, c)

247

239

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

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

249-- Fail

241-- Fail

250

242

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

252data Fail :: Effect where

243data Fail :: Effect where

253− Fail :: String -> Fail m a

244+ Fail :: Unique -> Fail m r

245+

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

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

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

249+ -- other's exceptions.

250+ tag <- newUnique

251+ size0 <- sizeEnv es0

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

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

254+ _ <- unsafeTailEnv size0 es

255+ pure r

254

256

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

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

256− fail = send . Fail

258+ fail msg = do

259+ IdE (Fail tag) <- getEffect

260+ unsafeEff_ . throwIO $ FailEx tag msg

261+

262+--------------------

263+

264+data FailEx = FailEx Unique String

265+instance Show FailEx where

266+ showsPrec p (FailEx _ msg)

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

268+ . showsPrec p msg

269+instance Exception FailEx

270+

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

272+tryFailIO tag m =

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

274+ if tag == etag

275+ then pure $ Left msg

276+ else throwIO err

257

277

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

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

259-- IO

279-- IO

260

280

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

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

262newtype IOE :: Effect where

282newtype IOE :: Effect where

263 IOE :: UnliftStrategy -> IOE m r

283 IOE :: UnliftStrategy -> IOE m r

264

284

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

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

266--

286--

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

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

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

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

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

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

270

290

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

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

272 liftIO = unsafeEff_

292 liftIO = unsafeEff_

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

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

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

291-- Primitive

311-- Primitive

292

312

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

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

294data Prim :: Effect where

314data Prim :: Effect where

295 Prim :: Prim m r

315 Prim :: Prim m r

296

316

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

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

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

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

299−runPrim = evalData (DataA Prim)

319+runPrim = evalEffect (IdE Prim)

300

320

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

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

302− type PrimState (Eff es) = RealWorld

322+ type PrimState (Eff es) = PrimState IO

303 primitive = unsafeEff_ . IO

323 primitive = unsafeEff_ . IO

304

324

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

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

306−-- Dynamic dispatch

326+-- Unlift strategies

327+

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

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

330+data UnliftStrategy

331+ = SeqUnlift

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

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

334+ -- a runtime error.

335+ | ConcUnlift Persistence Limit

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

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

338+ -- settings for more information.

339+ deriving (Eq, Ord, Show)

340+

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

342+--

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

344+--

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

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

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

348+--

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

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

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

352+data Persistence

353+ = Ephemeral

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

355+ -- threads distinct from its creator.

356+ | Persistent

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

358+ -- particular thread.

359+ deriving (Eq, Ord, Show)

360+

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

362+data Limit

363+ = Limited Int

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

365+ --

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

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

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

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

370+ --

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

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

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

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

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

376+ | Unlimited

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

378+ deriving (Eq, Ord, Show)

307

379

308−type role LocalEnv nominal nominal

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

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

382+unliftStrategy = do

383+ IdE (IOE unlift) <- getEffect

384+ pure unlift

309

385

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

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

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

312−-- handler.

313--

387--

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

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

315−-- technical reasons to guarantee soundness.

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

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

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

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

327

391

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

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

329--

393--

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

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

331−data HandlerA :: Effect -> Type where

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

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

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

333−

397+withEffToIO

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

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

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

337− size0 <- sizeEnv es0

338− E.bracket (unsafeConsEnv e relinker es0)

339− (unsafeTailEnv size0)

340− (\es -> unEff m es)

341− where

342− relinker :: Relinker HandlerA e

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

344− newHandlerEs <- relink handlerEs

345− pure $ HandlerA newHandlerEs handle

346−

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

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

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

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

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

350− HandlerA handlerEs handle <- getEnv es

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

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

401+ -> Eff es a

402+withEffToIO f = unliftStrategy >>= \case

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

404+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do

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

352

406

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

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

354−-- Static dispatch

408+-- Helpers

355

409

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

357−--

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

359−-- parameters.

360−newtype DataA :: Effect -> Type where

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

362−

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

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

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

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

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

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

367 size0 <- sizeEnv es0

412 size0 <- sizeEnv es0

368− E.bracket (unsafeConsEnv e0 noRelinker es0)

413+ bracket (unsafeConsEnv e0 noRelinker es0)

369− (unsafeTailEnv size0)

414+ (unsafeTailEnv size0)

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

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

371−

416+

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

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

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

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

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

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

376 size0 <- sizeEnv es0

419 size0 <- sizeEnv es0

377− E.bracket (unsafeConsEnv e noRelinker es0)

420+ bracket (unsafeConsEnv e noRelinker es0)

378− (unsafeTailEnv size0)

421+ (unsafeTailEnv size0)

379− (\es -> unEff m es)

422+ (\es -> unEff m es)

380−

423+

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

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

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

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

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

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

385 size0 <- sizeEnv es0

426 size0 <- sizeEnv es0

386− E.bracket (unsafeConsEnv e0 noRelinker es0)

427+ bracket (unsafeConsEnv e0 noRelinker es0)

387− (unsafeTailEnv size0)

428+ (unsafeTailEnv size0)

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

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

389−

430+

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

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

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

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

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

393−

433+

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

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

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

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

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

397−

436+

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

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

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

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

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

401−

439+

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

403−-- value.

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

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

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

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

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

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

407 putEnv es e

443 putEnv es e

408 pure a

444 pure a

409

445

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

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

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

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

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

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

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

414− (\e -> putEnv es e)

449+ (\e -> putEnv es e)

415− (\_ -> unEff m es)

450+ (\_ -> unEff m es)

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

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

1{-# LANGUAGE MagicHash #-}

2{-# LANGUAGE UnboxedTuples #-}

3{-# OPTIONS_HADDOCK not-home #-}

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

4+-- | Implementation of 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− ( -- * Unlifting strategies

9+ ( unsafeEphemeralConcUnliftIO

10− UnliftStrategy(..)

10+ , unsafePersistentConcUnliftIO

11− , Persistence(..)

12− , Limit(..)

13−

14− -- * Unlifting functions

15− , seqUnlift

16− , concUnlift

17− , ephemeralConcUnlift

18− , persistentConcUnlift

19 ) where

11 ) where

20

12

21import Control.Concurrent

13import Control.Concurrent

22import Control.Monad

14import Control.Monad

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

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

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

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

25−import GHC.Generics (Generic)

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

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

27import GHC.Stack (HasCallStack)

18import GHC.Stack (HasCallStack)

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

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

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

32import Effectful.Internal.Env

23import Effectful.Internal.Env

33import Effectful.Internal.Utils

24import Effectful.Internal.Utils

34

25

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−

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

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

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

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

131−ephemeralConcUnlift

28+unsafeEphemeralConcUnliftIO

132 :: HasCallStack

29 :: HasCallStack

133 => Int

30 => Int

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

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

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

136 -> Env es

32 -> Env es

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

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

138 -> IO a

34 -> IO a

139−ephemeralConcUnlift uses k es0 unEff = do

35+unsafeEphemeralConcUnliftIO uses k es0 unEff = do

140 unless (uses > 0) $ do

36 unless (uses > 0) $ do

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

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

142 tid0 <- myThreadId

38 tid0 <- myThreadId

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

162

58

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

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

164-- unlifting function within a particular thread.

60-- unlifting function within a particular thread.

165−persistentConcUnlift

61+unsafePersistentConcUnliftIO

166 :: HasCallStack

62 :: HasCallStack

167 => Bool

63 => Bool

168 -> Int

64 -> Int

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

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

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

171 -> Env es

66 -> Env es

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

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

173 -> IO a

68 -> IO a

174−persistentConcUnlift cleanUp threads k es0 unEff = do

69+unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do

175 unless (threads > 0) $ do

70 unless (threads > 0) $ do

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

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

177 tid0 <- myThreadId

72 tid0 <- myThreadId

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

192 Just es -> pure (te, es)

87 Just es -> pure (te, es)

193 Nothing -> case teCapacity te of

88 Nothing -> case teCapacity te of

194 0 -> error

89 0 -> error

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

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

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

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

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

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

198 1 -> do

93 1 -> do

199 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp

94 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp

200 let newEntries = ThreadEntries

95 let newEntries = ThreadEntries

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

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

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

226

121

227data ThreadEntries es = ThreadEntries

122data ThreadEntries es = ThreadEntries

228− { teCapacity :: !Int

123+ { teCapacity :: Int

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

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

230 }

125 }

231

126

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

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

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

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

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

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

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

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

236

131

237data ThreadData es

132data ThreadData es

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

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

239 | NoThreadData

134 | NoThreadData

240

135

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

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

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

@@ -11,6 +11,10 @@ module Effectful.Monad

11 , IOE

12 , runEff

13

14+ -- * Primitive actions

15+ , Prim

16+ , runPrim

17+

14 -- ** Unlift strategies

18 -- ** Unlift strategies

15 , UnliftStrategy(..)

19 , UnliftStrategy(..)

16 , Persistence(..)

20 , Persistence(..)

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

18 , unliftStrategy

22 , unliftStrategy

19 , withUnliftStrategy

23 , withUnliftStrategy

20 , withEffToIO

24 , withEffToIO

21−

22− -- * Re-exports

23− , MonadIO(..)

24− , MonadUnliftIO(..)

25 ) where

26

27−import Control.Monad.IO.Class

28−import Control.Monad.IO.Unlift

29−

30import Effectful.Internal.Effect

27import Effectful.Internal.Effect

31import Effectful.Internal.Monad

28import Effectful.Internal.Monad

effectful-core/src/Effectful/Prim.hsdeleted−7

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

1−-- | Provider of the 'MonadPrim' instance for 'Eff'.

2−module Effectful.Prim

3− ( Prim

4− , runPrim

5− ) where

6−

7−import Effectful.Internal.Monad

effectful-core/src/Effectful/Reader.hs+12−29

@@ -1,4 +1,4 @@

1−-- | Support for access to a read only value of a particular type.

1+-- | The 'Reader' effect.

2module Effectful.Reader

3 ( Reader

4 , runReader

@@ -7,43 +7,26 @@ module Effectful.Reader

7 , local

8 ) where

9

10−import Effectful.Dispatch.Static

10+import Effectful.Internal.Effect

11−import Effectful.Monad

11+import Effectful.Internal.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.

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

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

22− -> Eff es a

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

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

24

20

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

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

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

27ask = do

22ask = do

28− DataA (Reader r) <- getData

23+ IdE (Reader r) <- getEffect

29 pure r

24 pure r

30

25

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

32−--

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

34−asks

35− :: Reader r :> es

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

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

37− -> Eff es a

38−asks f = f <$> ask

27+asks f = do

28+ IdE (Reader r) <- getEffect

29+ pure $ f r

39

30

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

41−--

42−-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@

43−--

44−local

45− :: Reader r :> es

31+local :: Reader r :> es => (r -> r) -> Eff es a -> Eff es a

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

47− -> Eff es a

48− -> Eff es a

49−local f = localData $ \(DataA (Reader r)) -> DataA (Reader (f r))

32+local f = localEffect $ \(IdE (Reader r)) -> IdE (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.Dispatch.Dynamic

9+import Effectful.Handler

10import Effectful.Monad

11import qualified Effectful.Reader as R

12

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

@@ -1,4 +1,13 @@

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

2module Effectful.State.Dynamic

11module Effectful.State.Dynamic

3 ( State(..)

12 ( State(..)

4

13

@@ -22,15 +31,17 @@ module Effectful.State.Dynamic

22 , modifyM

31 , modifyM

23 ) where

32 ) where

24

33

25−import Effectful.Dispatch.Dynamic

34+import Effectful.Handler

26import Effectful.Monad

35import Effectful.Monad

27import qualified Effectful.State.Local as L

36import qualified Effectful.State.Local as L

28import qualified Effectful.State.Shared as S

37import qualified Effectful.State.Shared as S

29

38

30−-- | Provide access to a mutable value of type @s@.

39+-- | Provide access to a mutable state of type @s@.

40+--

41+-- Whether the state is local or shared depends on the interpretation.

31data State s :: Effect where

42data State s :: Effect where

32 Get :: State s m s

43 Get :: State s m s

33− Put :: s -> State s m ()

44+ Put :: ~s -> State s m ()

34 State :: (s -> (a, s)) -> State s m a

45 State :: (s -> (a, s)) -> State s m a

35 StateM :: (s -> m (a, s)) -> State s m a

46 StateM :: (s -> m (a, s)) -> State s m a

36

47

@@ -48,7 +59,7 @@ execLocalState s0 = reinterpret (L.execState s0) localState

48

59

49localState

60localState

50 :: L.State s :> es

61 :: L.State s :> es

51− => LocalEnv localEs es

62+ => LocalEnv localEs

52 -> State s (Eff localEs) a

63 -> State s (Eff localEs) a

53 -> Eff es a

64 -> Eff es a

54localState env = \case

65localState env = \case

@@ -71,7 +82,7 @@ execSharedState s0 = reinterpret (S.execState s0) sharedState

71

82

72sharedState

83sharedState

73 :: S.State s :> es

84 :: S.State s :> es

74− => LocalEnv localEs es

85+ => LocalEnv localEs

75 -> State s (Eff localEs) a

86 -> State s (Eff localEs) a

76 -> Eff es a

87 -> Eff es a

77sharedState env = \case

88sharedState env = \case

effectful-core/src/Effectful/State/Local.hs+24−88

@@ -1,29 +1,12 @@

1−-- | Support for access to a mutable value of a particular type, which is:

1+-- | The 'State' effect.

2--

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

4+--

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

5+-- - thread local (if you need the state to be shared between threads, have a

4-- look at "Effectful.State.Shared"),

6-- look at "Effectful.State.Shared"),

5--

7--

6-- - very fast.

8-- - very fast.

7--

9--

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

27module Effectful.State.Local

10module Effectful.State.Local

28 ( State

11 ( State

29 , runState

12 , runState

@@ -38,94 +21,47 @@ module Effectful.State.Local

38 , modifyM

21 , modifyM

39 ) where

22 ) where

40

23

41−import Effectful.Dispatch.Static

24+import Effectful.Internal.Effect

42−import Effectful.Monad

25+import Effectful.Internal.Monad

43

26

44−-- | Provide access to a strict (WHNF), thread local, mutable value of type @s@.

27+-- | Provide access to a strict (WHNF), thread local, mutable state of type @s@.

45newtype State s :: Effect where

28newtype State s :: Effect where

46 State :: s -> State s m r

29 State :: s -> State s m r

47

30

48−-- | Run a 'State' effect with the given initial state and return the final

49−-- value along with the final state.

50−runState

51− :: s -- ^ An initial state.

52− -> Eff (State s : es) a

31+runState :: s -> Eff (State s : es) a -> Eff es (a, s)

53− -> Eff es (a, s)

54runState s0 m = do

32runState s0 m = do

55− (a, DataA (State s)) <- runData (DataA (State s0)) m

33+ (a, IdE (State s)) <- runEffect (IdE (State s0)) m

56 pure (a, s)

34 pure (a, s)

57

35

58−-- | Run a 'State' effect with the given initial state and return the final

59−-- value, discarding the final state.

60−evalState

61− :: s -- ^ An initial state.

62− -> Eff (State s : es) a

36+evalState :: s -> Eff (State s : es) a -> Eff es a

63− -> Eff es a -- ^ A return value.

64−evalState s = evalData (DataA (State s))

37+evalState s = evalEffect (IdE (State s))

65

38

66−-- | Run a 'State' effect with the given initial state and return the final

67−-- state, discarding the final value.

68−execState

69− :: s -- ^ An initial state.

70− -> Eff (State s : es) a

39+execState :: s -> Eff (State s : es) a -> Eff es s

71− -> Eff es s

72execState s0 m = do

40execState s0 m = do

73− DataA (State s) <- execData (DataA (State s0)) m

41+ IdE (State s) <- execEffect (IdE (State s0)) m

74 pure s

42 pure s

75

43

76−-- | Fetch the current value of the state.

77get :: State s :> es => Eff es s

44get :: State s :> es => Eff es s

78get = do

45get = do

79− DataA (State s) <- getData

46+ IdE (State s) <- getEffect

80 pure s

47 pure s

81

48

82−-- | Get a function of the current state.

83−--

84−-- @'gets' f ≡ f '<$>' 'get'@

85−gets

86− :: State s :> es

49+gets :: State s :> es => (s -> a) -> Eff es a

87− => (s -> a) -- ^ The function to apply to the state.

88− -> Eff es a

89gets f = f <$> get

50gets f = f <$> get

90

51

91−-- | Set the current state to the given value.

92put :: State s :> es => s -> Eff es ()

52put :: State s :> es => s -> Eff es ()

93−put s = putData (DataA (State s))

53+put s = putEffect (IdE (State s))

94

54

95−-- | Apply the function to the current state and return a value.

96−state

97− :: State s :> es

55+state :: State s :> es => (s -> (a, s)) -> Eff es a

98− => (s -> (a, s)) -- ^ The function to modify the state.

99− -> Eff es a

100−state f = stateData $ \(DataA (State s0)) -> let (a, s) = f s0 in (a, DataA (State s))

56+state f = stateEffect $ \(IdE (State s0)) -> let (a, s) = f s0 in (a, IdE (State s))

101

57

102−-- | Apply the function to the current state.

103−--

104−-- @'modify' f ≡ 'state' (\\s -> ((), f s))@

105−modify

106− :: State s :> es

58+modify :: State s :> es => (s -> s) -> Eff es ()

107− => (s -> s) -- ^ The function to modify the state.

108− -> Eff es ()

109−modify f = state $ \s -> ((), f s)

59+modify f = state (\s -> ((), f s))

110

60

111−-- | Apply the monadic function to the current state and return a value.

112−stateM

113− :: State s :> es

61+stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a

114− => (s -> Eff es (a, s)) -- ^ The function to modify the state.

115− -> Eff es a

116−stateM f = stateDataM $ \(DataA (State s0)) -> do

62+stateM f = stateEffectM $ \(IdE (State s0)) -> do

117 (a, s) <- f s0

63 (a, s) <- f s0

118− pure (a, DataA (State s))

64+ pure (a, IdE (State s))

119

65

120−-- | Apply the monadic function to the current state.

121−--

122−-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@

123−modifyM

124− :: State s :> es

66+modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()

125− => (s -> Eff es s) -- ^ The monadic function to modify the state.

126− -> Eff es ()

127modifyM f = stateM (\s -> ((), ) <$> f s)

67modifyM 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+15−63

@@ -1,29 +1,11 @@

1−-- | Support for access to a mutable value of a particular type, which is:

1+-- | The 'State' effect.

2--

3−-- - shared between multiple threads (if you want each thead to manage its own

3+-- Represented as an 'MVar' underneath, therefore:

4−-- version of the value, see "Effectful.State.Local").

5--

4--

6−-- - slightly slower than "Effectful.State.Local".

5+-- - shareable between multiple threads,

7--

6--

8−-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from

7+-- - slower than "Effectful.State.Local".

9−-- the @transformers@ library, the 'State' effect doesn't lose state

10−-- modifications when an exception is received:

11--

8--

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

27module Effectful.State.Shared

9module Effectful.State.Shared

28 ( State

10 ( State

29 , runState

11 , runState

@@ -40,88 +22,58 @@ module Effectful.State.Shared

40

22

41import Control.Concurrent.MVar

23import Control.Concurrent.MVar

42

24

43−import Effectful.Dispatch.Static

25+import Effectful.Internal.Effect

26+import Effectful.Internal.Env

44−import Effectful.Monad

27+import Effectful.Internal.Monad

45

28

46−-- | Provide access to a strict (WHNF), shared, mutable value of type @s@.

29+-- | Provide access to a strict (WHNF), shareable, mutable state of type @s@.

47newtype State s :: Effect where

30newtype State s :: Effect where

48 State :: MVar s -> State s m r

31 State :: MVar s -> State s m r

49

32

50−-- | Run a 'State' effect with the given initial state and return the final

51−-- value along with the final state.

52runState :: s -> Eff (State s : es) a -> Eff es (a, s)

33runState :: s -> Eff (State s : es) a -> Eff es (a, s)

53runState s m = do

34runState s m = do

54 v <- unsafeEff_ $ newMVar s

35 v <- unsafeEff_ $ newMVar s

55− a <- evalData (DataA (State v)) m

36+ a <- evalEffect (IdE (State v)) m

56 (a, ) <$> unsafeEff_ (readMVar v)

37 (a, ) <$> unsafeEff_ (readMVar v)

57

38

58−-- | Run a 'State' effect with the given initial state and return the final

59−-- value, discarding the final state.

60evalState :: s -> Eff (State s : es) a -> Eff es a

39evalState :: s -> Eff (State s : es) a -> Eff es a

61evalState s m = do

40evalState s m = do

62 v <- unsafeEff_ $ newMVar s

41 v <- unsafeEff_ $ newMVar s

63− evalData (DataA (State v)) m

42+ evalEffect (IdE (State v)) m

64

43

65−-- | Run a 'State' effect with the given initial state and return the final

66−-- state, discarding the final value.

67execState :: s -> Eff (State s : es) a -> Eff es s

44execState :: s -> Eff (State s : es) a -> Eff es s

68execState s m = do

45execState s m = do

69 v <- unsafeEff_ $ newMVar s

46 v <- unsafeEff_ $ newMVar s

70− _ <- evalData (DataA (State v)) m

47+ _ <- evalEffect (IdE (State v)) m

71 unsafeEff_ $ readMVar v

48 unsafeEff_ $ readMVar v

72

49

73−-- | Fetch the current value of the state.

74get :: State s :> es => Eff es s

50get :: State s :> es => Eff es s

75get = unsafeEff $ \es -> do

51get = unsafeEff $ \es -> do

76− DataA (State v) <- getEnv es

52+ IdE (State v) <- getEnv es

77 readMVar v

53 readMVar v

78

54

79−-- | Get a function of the current state.

80−--

81−-- @'gets' f ≡ f '<$>' 'get'@

82gets :: State s :> es => (s -> a) -> Eff es a

55gets :: State s :> es => (s -> a) -> Eff es a

83gets f = f <$> get

56gets f = f <$> get

84

57

85−-- | Set the current state to the given value.

86put :: State s :> es => s -> Eff es ()

58put :: State s :> es => s -> Eff es ()

87put s = unsafeEff $ \es -> do

59put s = unsafeEff $ \es -> do

88− DataA (State v) <- getEnv es

60+ IdE (State v) <- getEnv es

89 modifyMVar_ v $ \_ -> s `seq` pure s

61 modifyMVar_ v $ \_ -> s `seq` pure s

90

62

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.

94state :: State s :> es => (s -> (a, s)) -> Eff es a

63state :: State s :> es => (s -> (a, s)) -> Eff es a

95state f = unsafeEff $ \es -> do

64state f = unsafeEff $ \es -> do

96− DataA (State v) <- getEnv es

65+ IdE (State v) <- getEnv es

97 modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)

66 modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)

98

67

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.

104modify :: State s :> es => (s -> s) -> Eff es ()

68modify :: State s :> es => (s -> s) -> Eff es ()

105modify f = state (\s -> ((), f s))

69modify f = state (\s -> ((), f s))

106

70

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.

110stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a

71stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a

111stateM f = unsafeEff $ \es -> do

72stateM f = unsafeEff $ \es -> do

112− DataA (State v) <- getEnv es

73+ IdE (State v) <- getEnv es

113 modifyMVar v $ \s0 -> do

74 modifyMVar v $ \s0 -> do

114 (a, s) <- unEff (f s0) es

75 (a, s) <- unEff (f s0) es

115 s `seq` pure (s, a)

76 s `seq` pure (s, a)

116

77

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.

122modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()

78modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()

123modifyM f = stateM (\s -> ((), ) <$> f s)

79modifyM 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.Dispatch.Dynamic

18+import Effectful.Handler

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 es

38+ => LocalEnv localEs

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 es

56+ => LocalEnv localEs

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)

67+ :: (HasCallStack, Writer w :> es, Monoid w)

68 => w

69 -> Eff es ()

70tell = send . Tell

71

72listen

73− :: (HasCallStack, Writer w :> es)

73+ :: (HasCallStack, Writer w :> es, Monoid w)

74 => Eff es a

75 -> Eff es (a, w)

76listen = send . Listen

77

78listens

79− :: (HasCallStack, Writer w :> es)

79+ :: (HasCallStack, Writer w :> es, Monoid w)

80 => (w -> b)

81 -> Eff es a

82 -> Eff es (a, b)

effectful-core/src/Effectful/Writer/Local.hs+10−56

@@ -1,20 +1,4 @@

1−-- | Support for access to a write only value of a particular type, which is:

2−--

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

4−-- look at "Effectful.Writer.Shared"),

5−--

6−-- - very fast.

7−--

8−-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses

9−-- of '<>', which makes it unsuitable for use with types for which such pattern

10−-- is inefficient. __This applies, in particular, to the standard list type__,

11−-- which makes the 'Writer' effect pretty niche.

1+-- | The 'Writer' effect.

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.

18module Effectful.Writer.Local

2module Effectful.Writer.Local

19 ( Writer

3 ( Writer

20 , runWriter

4 , runWriter

@@ -24,71 +8,41 @@ module Effectful.Writer.Local

24 , listens

8 , listens

25 ) where

9 ) where

26

10

27−import Control.Exception (onException, mask)

11+import Control.Exception

28

12

29−import Effectful.Dispatch.Static

13+import Effectful.Internal.Effect

14+import Effectful.Internal.Env

30−import Effectful.Monad

15+import Effectful.Internal.Monad

31

16

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

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

33-- @w@.

18-- @w@.

34newtype Writer w :: Effect where

19newtype Writer w :: Effect where

35 Writer :: w -> Writer w m r

20 Writer :: w -> Writer w m r

36

21

37−-- | Run a 'Writer' effect and return the final value along with the final

38−-- output.

39runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

22runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

40runWriter m = do

23runWriter m = do

41− (a, DataA (Writer w)) <- runData (DataA (Writer mempty)) m

24+ (a, IdE (Writer w)) <- runEffect (IdE (Writer mempty)) m

42 pure (a, w)

25 pure (a, w)

43

26

44−-- | Run a 'Writer' effect and return the final output, discarding the final

45−-- value.

46execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

27execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

47execWriter m = do

28execWriter m = do

48− DataA (Writer w) <- execData (DataA (Writer mempty)) m

29+ IdE (Writer w) <- execEffect (IdE (Writer mempty)) m

49 pure w

30 pure w

50

31

51−-- | Append the given output to the overall output of the 'Writer'.

52tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

32tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

53−tell w = stateData $ \(DataA (Writer w0)) -> ((), DataA (Writer (w0 <> w)))

33+tell w = stateEffect $ \(IdE (Writer w0)) -> ((), IdE (Writer (w0 <> w)))

54

34

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

72listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

35listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

73listen m = unsafeEff $ \es -> mask $ \restore -> do

36listen m = unsafeEff $ \es -> mask $ \restore -> do

74− w0 <- stateEnv es $ \(DataA (Writer w)) -> (w, DataA (Writer mempty))

37+ w0 <- stateEnv es $ \(IdE (Writer w)) -> (w, IdE (Writer mempty))

75 a <- restore (unEff m es) `onException` merge es w0

38 a <- restore (unEff m es) `onException` merge es w0

76 (a, ) <$> merge es w0

39 (a, ) <$> merge es w0

77 where

40 where

78 merge es w0 =

41 merge es w0 =

79 -- If an exception is thrown, restore w0 and keep parts of w1.

42 -- If an exception is thrown, restore w0 and keep parts of w1.

80− stateEnv es $ \(DataA (Writer w1)) -> (w1, DataA (Writer (w0 <> w1)))

43+ stateEnv es $ \(IdE (Writer w1)) -> (w1, IdE (Writer (w0 <> w1)))

81

44

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@

87listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

45listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

88listens f m = do

46listens f m = do

89 (a, w) <- listen m

47 (a, w) <- listen m

90 pure (a, f w)

48 pure (a, f w)

91−

92−-- $setup

93−-- >>> import Control.Exception (ErrorCall)

94−-- >>> import Control.Monad.Catch

effectful-core/src/Effectful/Writer/Shared.hs+10−57

@@ -1,20 +1,3 @@

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.

18module Effectful.Writer.Shared

1module Effectful.Writer.Shared

19 ( Writer

2 ( Writer

20 , runWriter

3 , runWriter

@@ -25,54 +8,33 @@ module Effectful.Writer.Shared

25 ) where

8 ) where

26

9

27import Control.Concurrent.MVar

10import Control.Concurrent.MVar

28−import Control.Exception (onException, uninterruptibleMask)

11+import Control.Exception

29

12

30−import Effectful.Dispatch.Static

13+import Effectful.Internal.Effect

14+import Effectful.Internal.Env

31−import Effectful.Monad

15+import Effectful.Internal.Monad

32

16

33−-- | Provide access to a strict (WHNF), shared, write only value of type @w@.

17+-- | Provide access to a strict (WHNF), shareable, write only value of type @w@.

34newtype Writer w :: Effect where

18newtype Writer w :: Effect where

35 Writer :: MVar w -> Writer w m r

19 Writer :: MVar w -> Writer w m r

36

20

37−-- | Run a 'Writer' effect and return the final value along with the final

38−-- output.

39runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

21runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

40runWriter m = do

22runWriter m = do

41 v <- unsafeEff_ $ newMVar mempty

23 v <- unsafeEff_ $ newMVar mempty

42− a <- evalData (DataA (Writer v)) m

24+ a <- evalEffect (IdE (Writer v)) m

43 (a, ) <$> unsafeEff_ (readMVar v)

25 (a, ) <$> unsafeEff_ (readMVar v)

44

26

45−-- | Run a 'Writer' effect and return the final output, discarding the final

46−-- value.

47execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

27execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

48execWriter m = do

28execWriter m = do

49 v <- unsafeEff_ $ newMVar mempty

29 v <- unsafeEff_ $ newMVar mempty

50− _ <- evalData (DataA (Writer v)) m

30+ _ <- evalEffect (IdE (Writer v)) m

51 unsafeEff_ $ readMVar v

31 unsafeEff_ $ readMVar v

52

32

53−-- | Append the given output to the overall output of the 'Writer'.

54tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

33tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

55tell w1 = unsafeEff $ \es -> do

34tell w1 = unsafeEff $ \es -> do

56− DataA (Writer v) <- getEnv es

35+ IdE (Writer v) <- getEnv es

57 modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w

36 modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w

58

37

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

76listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

38listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

77listen m = unsafeEff $ \es -> do

39listen m = unsafeEff $ \es -> do

78 -- The mask is uninterruptible because modifyMVar_ v0 in the merge function

40 -- The mask is uninterruptible because modifyMVar_ v0 in the merge function

@@ -81,28 +43,19 @@ listen m = unsafeEff $ \es -> do

81 uninterruptibleMask $ \restore -> do

43 uninterruptibleMask $ \restore -> do

82 v1 <- newMVar mempty

44 v1 <- newMVar mempty

83 -- Replace thread local MVar with a fresh one for isolated listening.

45 -- Replace thread local MVar with a fresh one for isolated listening.

84− v0 <- stateEnv es $ \(DataA (Writer v)) -> (v, DataA (Writer v1))

46+ v0 <- stateEnv es $ \(IdE (Writer v)) -> (v, IdE (Writer v1))

85 a <- restore (unEff m es) `onException` merge es v0 v1

47 a <- restore (unEff m es) `onException` merge es v0 v1

86 (a, ) <$> merge es v0 v1

48 (a, ) <$> merge es v0 v1

87 where

49 where

88 -- Merge results accumulated in the local MVar with the mainline. If an

50 -- Merge results accumulated in the local MVar with the mainline. If an

89 -- exception was received while listening, merge results recorded so far.

51 -- exception was received while listening, merge results recorded so far.

90 merge es v0 v1 = do

52 merge es v0 v1 = do

91− putEnv es $ DataA (Writer v0)

53+ putEnv es $ IdE (Writer v0)

92 w1 <- readMVar v1

54 w1 <- readMVar v1

93 modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w

55 modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w

94 pure w1

56 pure w1

95

57

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@

101listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

58listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

102listens f m = do

59listens f m = do

103 (a, w) <- listen m

60 (a, w) <- listen m

104 pure (a, f w)

61 pure (a, f w)

105−

106−-- $setup

107−-- >>> import Control.Exception (ErrorCall)

108−-- >>> import Control.Monad.Catch

effectful/bench/Concurrency.hs+9−8

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

11

12import Control.Concurrent.Async

13import Control.Monad

14+import Control.Monad.IO.Class

14−import qualified Effectful.Concurrent.Async as A

15+import qualified Effectful.Async as A

15

16

16import Effectful

17import Effectful

17import Utils

18import Utils

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

25shallowBench :: Int -> Benchmark

26shallowBench :: Int -> Benchmark

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

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

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

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

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

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

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

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

30 nfAppIO (runShallow . runFork1 . forkBench n) op

31 nfAppIO (runShallow . runFork1 . forkBench n) op

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

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

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

38

39

39deepBench :: Int -> Benchmark

40deepBench :: Int -> Benchmark

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

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

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

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

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

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

43 nfAppIO (runDeep . runFork1 . forkBench n) op

44 nfAppIO (runDeep . runFork1 . forkBench n) op

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

45 , bench "Fork (localUnlift/withLiftMap)" $

@@ -60,14 +61,14 @@ data Fork :: Effect where

60-- | Uses 'localUnliftIO' and 'withLiftMapIO'.

61-- | Uses 'localUnliftIO' and 'withLiftMapIO'.

61runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a

62runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a

62runFork1 = interpret $ \env -> \case

63runFork1 = interpret $ \env -> \case

63− ForkWithUnmask m -> withLiftMapIO env $ \liftMap -> do

64+ ForkWithUnmask m -> withLiftMapIO $ \liftMap -> do

64 localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

65 localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

65 asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

66 asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

66

67

67-- | Uses 'localUnlift' and 'withLiftMap'.

68-- | Uses 'localUnlift' and 'withLiftMap'.

68runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a

69runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a

69−runFork2 = reinterpret A.runConcurrent $ \env -> \case

70+runFork2 = reinterpret A.runAsyncE $ \env -> \case

70− ForkWithUnmask m -> withLiftMap env $ \liftMap -> do

71+ ForkWithUnmask m -> withLiftMap $ \liftMap -> do

71 localUnlift env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

72 localUnlift env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do

72 A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

73 A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask

73

74

@@ -80,7 +81,7 @@ runFork3 = interpret $ \env -> \case

80

81

81-- | Uses 'localLiftUnlift'.

82-- | Uses 'localLiftUnlift'.

82runFork4 :: IOE :> es => Eff (Fork : es) a -> Eff es a

83runFork4 :: IOE :> es => Eff (Fork : es) a -> Eff es a

83−runFork4 = reinterpret A.runConcurrent $ \env -> \case

84+runFork4 = reinterpret A.runAsyncE $ \env -> \case

84 ForkWithUnmask m -> do

85 ForkWithUnmask m -> do

85 localLiftUnlift env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do

86 localLiftUnlift env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do

86 A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift

87 A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift

@@ -94,7 +95,7 @@ asyncBenchIO n f = do

94 wait a

95 wait a

95{-# NOINLINE asyncBenchIO #-}

96{-# NOINLINE asyncBenchIO #-}

96

97

97−asyncBench :: A.Concurrent :> es => Int -> Eff es Int -> Eff es Int

98+asyncBench :: A.AsyncE :> es => Int -> Eff es Int -> Eff es Int

98asyncBench n f = do

99asyncBench n f = do

99 a <- A.asyncWithUnmask $ \unmask -> do

100 a <- A.asyncWithUnmask $ \unmask -> do

100 sum <$> replicateM n (unmask f)

101 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_mtl

101− , bench "mtl" $ nfAppIO mtl_calculateFileSizesDeep (take n files)

102−#endif

103#ifdef VERSION_polysemy

100#ifdef VERSION_polysemy

104 , bench "polysemy" $ nfAppIO poly_calculateFileSizesDeep (take n files)

101 , bench "polysemy" $ nfAppIO poly_calculateFileSizesDeep (take n files)

102+#endif

103+#ifdef VERSION_mtl

104+ , bench "mtl" $ nfAppIO mtl_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 qualified UnliftIO as U

12+import UnliftIO

13

14import Effectful

15import Effectful.State.Dynamic

16import Utils

17−import qualified Effectful.Concurrent.Async as A

17+import qualified Effectful.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 benchAsyncEff benchAsync

32+ , shallowConc "async" 1 benchAsyncE 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 benchAsyncEff benchAsync

41+ , deepConc "async" 1 benchAsyncE benchAsync

42 , deepConc "concurrently" 2 benchConcurrentlyE benchConcurrently

43 ]

44 ]

@@ -48,11 +48,11 @@ unliftBenchmark = bgroup "unlifting"

48shallowConc

49 :: String

50 -> Int

51− -> Eff '[A.Concurrent, IOE] ()

51+ -> Eff '[A.AsyncE, IOE] ()

52 -> Eff '[IOE] ()

53 -> Benchmark

54shallowConc name n r f = bgroup name

55− [ bench "Async" $ nfAppIO (runShallow . A.runConcurrent) r

55+ [ bench "AsyncE" $ nfAppIO (runShallow . A.runAsyncE) 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.Concurrent

69+ -> Eff '[ A.AsyncE

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 "Async" $ nfAppIO (runDeep . A.runConcurrent) r

78+ [ bench "AsyncE" $ nfAppIO (runDeep . A.runAsyncE) 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 = U.withAsync (pure ()) U.wait

95+benchAsync = withAsync (pure ()) wait

96

97benchConcurrently :: MonadUnliftIO m => m ()

98−benchConcurrently = U.concurrently_ (pure ()) (pure ())

98+benchConcurrently = concurrently_ (pure ()) (pure ())

99

100benchDummyE :: Eff es ()

101benchDummyE = pure ()

102{-# NOINLINE benchDummyE #-}

103

104−benchAsyncEff :: A.Concurrent :> es => Eff es ()

104+benchAsyncE :: A.AsyncE :> es => Eff es ()

105−benchAsyncEff = A.withAsync (pure ()) A.wait

105+benchAsyncE = A.withAsync (pure ()) A.wait

106−{-# NOINLINE benchAsyncEff #-}

106+{-# NOINLINE benchAsyncE #-}

107

108−benchConcurrentlyE :: A.Concurrent :> es => Eff es ()

108+benchConcurrentlyE :: A.AsyncE :> es => Eff es ()

109benchConcurrentlyE = A.concurrently_ (pure ()) (pure ())

110{-# NOINLINE benchConcurrentlyE #-}

effectful/effectful.cabal+25−44

@@ -1,7 +1,7 @@

1cabal-version: 2.4

2build-type: Simple

3name: effectful

4−version: 0.1

4+version: 0.0.0.0

5license: BSD-3-Clause

6license-file: LICENSE

7category: Control

@@ -10,17 +10,16 @@ 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. See the main

13+ integration with the existing Haskell ecosystem.

14− module "Effectful" for the documentation.

15 .

14 .

16− This is the "batteries-included" variant with many dependencies;

15+ This is the "batteries included" variant; See the

17− See the @<https://hackage.haskell.org/package/effectful-core

16+ @<https://hackage.haskell.org/package/effectful-core effectful-core>@

18− effectful-core>@ package and other @effectful-*@ packages if you

17+ package for the effect system itself as well as the various other

19− need a more limited dependency footprint.

18+ @effectful-*@ packages if you need a smaller dependency footprint.

20

19

21extra-source-files: CHANGELOG.md

20extra-source-files: CHANGELOG.md

22

21

23−tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1

22+tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210422

24

23

25bug-reports: https://github.com/arybczak/effectful/issues

24bug-reports: https://github.com/arybczak/effectful/issues

26source-repository head

25source-repository head

@@ -40,7 +39,6 @@ common language

40 ConstraintKinds

39 ConstraintKinds

41 DataKinds

40 DataKinds

42 DeriveFunctor

41 DeriveFunctor

43− DeriveGeneric

44 FlexibleContexts

42 FlexibleContexts

45 FlexibleInstances

43 FlexibleInstances

46 GADTs

44 GADTs

@@ -53,6 +51,7 @@ common language

53 RoleAnnotations

51 RoleAnnotations

54 ScopedTypeVariables

52 ScopedTypeVariables

55 StandaloneDeriving

53 StandaloneDeriving

54+ StrictData

56 TupleSections

55 TupleSections

57 TypeApplications

56 TypeApplications

58 TypeFamilies

57 TypeFamilies

@@ -61,44 +60,30 @@ common language

61library

60library

62 import: language

61 import: language

63

62

63+ ghc-options: -O2

64+

64− build-depends: base >= 4.13 && < 5

65+ build-depends: base >= 4.13 && <5

65− , async >= 2.2.2

66+ , async

66− , directory >= 1.3.2

67− , effectful-core >= 0.1 && < 0.1.1

67+ , effectful-core

68− , process >= 1.6.9

69− , resourcet >= 1.2.4.3

68+ , resourcet

70− , time >= 1.9.2

71− , stm >= 2.5.0.0

72− , unliftio >= 0.2.20

69+ , unliftio

73

70

74 hs-source-dirs: src

71 hs-source-dirs: src

75

72

76− exposed-modules: Effectful.Concurrent

73+ exposed-modules: Effectful

77− Effectful.Concurrent.Async

74+ Effectful.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

87 Effectful.Resource

75 Effectful.Resource

88− Effectful.Temporary

89− Effectful.Timeout

90

76

91− other-modules: Effectful.Concurrent.Effect

92− Effectful.FileSystem.Effect

93−

94− reexported-modules: Effectful

95− , Effectful.Dispatch.Dynamic

96− , Effectful.Dispatch.Static

97− , Effectful.Error

77+ reexported-modules: Effectful.Error

98 , Effectful.Error.Dynamic

78 , Effectful.Error.Dynamic

99 , Effectful.Fail

79 , 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

100 , Effectful.Monad

86 , Effectful.Monad

101− , Effectful.Prim

102 , Effectful.Reader

87 , Effectful.Reader

103 , Effectful.Reader.Dynamic

88 , Effectful.Reader.Dynamic

104 , Effectful.State.Dynamic

89 , Effectful.State.Dynamic

@@ -116,7 +101,6 @@ test-suite test

116 build-depends: base

101 build-depends: base

117 , containers

102 , containers

118 , effectful

103 , effectful

119− , effectful-core

120 , exceptions

104 , exceptions

121 , lifted-base

105 , lifted-base

122 , tasty

106 , tasty

@@ -130,11 +114,8 @@ test-suite test

130

114

131 other-modules: AsyncTests

115 other-modules: AsyncTests

132 ConcurrencyTests

116 ConcurrencyTests

133− EnvironmentTests

134 ErrorTests

117 ErrorTests

135 StateTests

118 StateTests

136− TimeoutTests

137− UnliftTests

138 Utils

119 Utils

139 -- These are examples; We do not actually run them but list

120 -- These are examples; We do not actually run them but list

140 -- them here in order to check if they compile.

121 -- them here in order to check if they compile.

@@ -154,7 +135,7 @@ benchmark bench

154 if impl(ghc < 9.2)

135 if impl(ghc < 9.2)

155 build-depends: fused-effects

136 build-depends: fused-effects

156

137

157− if impl(ghc < 9.3)

138+ if impl(ghc < 9.2)

158 build-depends: polysemy

139 build-depends: polysemy

159

140

160 build-depends: base

141 build-depends: base

effectful/examples/FileSystem.hs+1

@@ -9,6 +9,7 @@ module FileSystem

9

10import Control.Exception (IOException)

11import Control.Monad.Catch

12+import Control.Monad.IO.Class

12import Prelude hiding (readFile, writeFile)

13import Prelude hiding (readFile, writeFile)

13import qualified Data.Map.Strict as M

14import qualified Data.Map.Strict as M

14import qualified System.IO as IO

15import qualified System.IO as IO

effectful-core/src/Effectful.hs → effectful/src/Effectful.hsrenamed+4−8

@@ -8,10 +8,10 @@ module Effectful

8

9 -- * Running the 'Eff' monad

10

11− -- ** Pure computations

11+ -- ** Pure operations

12 , runPureEff

13

14− -- ** Computations with side effects

14+ -- ** Operations with side effects

15 , IOE

16 , runEff

17

@@ -32,7 +32,7 @@ module Effectful

32 , interpret

33 , reinterpret

34

35− -- ** Handling local 'Eff' computations

35+ -- ** Handling local 'Eff' operations

36 , LocalEnv

37

38 -- *** Unlifts

@@ -48,11 +48,7 @@ module Effectful

48 -- *** Bidirectional lifts

49 , localLiftUnlift

50 , localLiftUnliftIO

51−

52− -- * Re-exports

53− , MonadIO(..)

54− , MonadUnliftIO(..)

55 ) where

51 ) where

56

52

57−import Effectful.Dispatch.Dynamic

53+import Effectful.Handler

58import Effectful.Monad

54import Effectful.Monad

effectful/src/Effectful/Concurrent/Async.hs → effectful/src/Effectful/Async.hsrenamed+89−72

@@ -1,8 +1,8 @@

1{-# LANGUAGE UndecidableInstances #-}

2−-- | Lifted version of "Control.Concurrent.Async".

3−module Effectful.Concurrent.Async

2+module Effectful.Async

4− ( Concurrent

3+ ( -- * Async effect

5− , runConcurrent

4+ AsyncE

5+ , runAsyncE

6

7 -- * Asynchronous actions

8 , Async

@@ -76,37 +76,52 @@ import Control.Concurrent (threadDelay)

76import Control.Concurrent.Async (Async)

77import Control.Exception (Exception, SomeException)

78import Control.Monad (forever)

79−import Data.Kind (Type)

79+import Data.Kind

80import qualified Control.Concurrent.Async as A

81import qualified UnliftIO.Async as U

82import qualified UnliftIO.Internals.Async as I

83

84−import Effectful.Concurrent.Effect

84+import Effectful.Internal.Effect

85−import Effectful.Dispatch.Static

85+import Effectful.Internal.Env

86−import Effectful.Monad

86+import Effectful.Internal.Monad

87+

88+-- | Run 'Eff' operations asynchronously via the @async@ library.

89+--

90+-- /Note:/ thread local state changes in 'Eff' operations run asynchronously

91+-- will not affect the parent thread.

92+--

93+-- /TODO:/ write about 'AsyncE' not respecting scoped operations.

94+data AsyncE :: Effect where

95+ AsyncE :: AsyncE m r

96+

97+runAsyncE :: IOE :> es => Eff (AsyncE : es) a -> Eff es a

98+runAsyncE = evalEffect (IdE AsyncE)

99+

100+----------------------------------------

101+-- Operations

87

102

88-- | Lifted 'A.async'.

103-- | Lifted 'A.async'.

89−async :: Concurrent :> es => Eff es a -> Eff es (Async a)

104+async :: AsyncE :> es => Eff es a -> Eff es (Async a)

90async = liftAsync A.async

105async = liftAsync A.async

91

106

92-- | Lifted 'A.asyncBound'.

107-- | Lifted 'A.asyncBound'.

93−asyncBound :: Concurrent :> es => Eff es a -> Eff es (Async a)

108+asyncBound :: AsyncE :> es => Eff es a -> Eff es (Async a)

94asyncBound = liftAsync A.asyncBound

109asyncBound = liftAsync A.asyncBound

95

110

96-- | Lifted 'A.asyncOn'.

111-- | Lifted 'A.asyncOn'.

97−asyncOn :: Concurrent :> es => Int -> Eff es a -> Eff es (Async a)

112+asyncOn :: AsyncE :> es => Int -> Eff es a -> Eff es (Async a)

98asyncOn cpu = liftAsync (A.asyncOn cpu)

113asyncOn cpu = liftAsync (A.asyncOn cpu)

99

114

100-- | Lifted 'A.asyncWithUnmask'.

115-- | Lifted 'A.asyncWithUnmask'.

101asyncWithUnmask

116asyncWithUnmask

102− :: Concurrent :> es

117+ :: AsyncE :> es

103 => ((forall b. Eff es b -> Eff es b) -> Eff es a)

118 => ((forall b. Eff es b -> Eff es b) -> Eff es a)

104 -> Eff es (Async a)

119 -> Eff es (Async a)

105asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask

120asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask

106

121

107-- | Lifted 'A.asyncOnWithUnmask'.

122-- | Lifted 'A.asyncOnWithUnmask'.

108asyncOnWithUnmask

123asyncOnWithUnmask

109− :: Concurrent :> es

124+ :: AsyncE :> es

110 => Int

125 => Int

111 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)

126 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)

112 -> Eff es (Async a)

127 -> Eff es (Async a)

@@ -114,7 +129,7 @@ asyncOnWithUnmask cpu = liftAsyncWithUnmask (A.asyncOnWithUnmask cpu)

114

129

115-- | Lifted 'A.withAsync'.

130-- | Lifted 'A.withAsync'.

116withAsync

131withAsync

117− :: Concurrent :> es

132+ :: AsyncE :> es

118 => Eff es a

133 => Eff es a

119 -> (Async a -> Eff es b)

134 -> (Async a -> Eff es b)

120 -> Eff es b

135 -> Eff es b

@@ -122,7 +137,7 @@ withAsync = liftWithAsync A.withAsync

122

137

123-- | Lifted 'A.withAsyncBound'.

138-- | Lifted 'A.withAsyncBound'.

124withAsyncBound

139withAsyncBound

125− :: Concurrent :> es

140+ :: AsyncE :> es

126 => Eff es a

141 => Eff es a

127 -> (Async a -> Eff es b)

142 -> (Async a -> Eff es b)

128 -> Eff es b

143 -> Eff es b

@@ -130,7 +145,7 @@ withAsyncBound = liftWithAsync A.withAsyncBound

130

145

131-- | Lifted 'A.withAsyncOn'.

146-- | Lifted 'A.withAsyncOn'.

132withAsyncOn

147withAsyncOn

133− :: Concurrent :> es

148+ :: AsyncE :> es

134 => Int

149 => Int

135 -> Eff es a

150 -> Eff es a

136 -> (Async a -> Eff es b)

151 -> (Async a -> Eff es b)

@@ -139,7 +154,7 @@ withAsyncOn cpu = liftWithAsync (A.withAsyncOn cpu)

139

154

140-- | Lifted 'A.withAsyncWithUnmask'.

155-- | Lifted 'A.withAsyncWithUnmask'.

141withAsyncWithUnmask

156withAsyncWithUnmask

142− :: Concurrent :> es

157+ :: AsyncE :> es

143 => ((forall c. Eff es c -> Eff es c) -> Eff es a)

158 => ((forall c. Eff es c -> Eff es c) -> Eff es a)

144 -> (Async a -> Eff es b)

159 -> (Async a -> Eff es b)

145 -> Eff es b

160 -> Eff es b

@@ -147,7 +162,7 @@ withAsyncWithUnmask = liftWithAsyncWithUnmask A.withAsyncWithUnmask

147

162

148-- | Lifted 'A.withAsyncOnWithUnmask'.

163-- | Lifted 'A.withAsyncOnWithUnmask'.

149withAsyncOnWithUnmask

164withAsyncOnWithUnmask

150− :: Concurrent :> es

165+ :: AsyncE :> es

151 => Int

166 => Int

152 -> ((forall c. Eff es c -> Eff es c) -> Eff es a)

167 -> ((forall c. Eff es c -> Eff es c) -> Eff es a)

153 -> (Async a -> Eff es b)

168 -> (Async a -> Eff es b)

@@ -155,60 +170,60 @@ withAsyncOnWithUnmask

155withAsyncOnWithUnmask cpu = liftWithAsyncWithUnmask (A.withAsyncOnWithUnmask cpu)

170withAsyncOnWithUnmask cpu = liftWithAsyncWithUnmask (A.withAsyncOnWithUnmask cpu)

156

171

157-- | Lifted 'A.wait'.

172-- | Lifted 'A.wait'.

158−wait :: Concurrent :> es => Async a -> Eff es a

173+wait :: AsyncE :> es => Async a -> Eff es a

159wait = unsafeEff_ . A.wait

174wait = unsafeEff_ . A.wait

160

175

161-- | Lifted 'A.poll'.

176-- | Lifted 'A.poll'.

162poll

177poll

163− :: Concurrent :> es

178+ :: AsyncE :> es

164 => Async a

179 => Async a

165 -> Eff es (Maybe (Either SomeException a))

180 -> Eff es (Maybe (Either SomeException a))

166poll = unsafeEff_ . A.poll

181poll = unsafeEff_ . A.poll

167

182

168-- | Lifted 'A.cancel'.

183-- | Lifted 'A.cancel'.

169−cancel :: Concurrent :> es => Async a -> Eff es ()

184+cancel :: AsyncE :> es => Async a -> Eff es ()

170cancel = unsafeEff_ . A.cancel

185cancel = unsafeEff_ . A.cancel

171

186

172-- | Lifted 'A.cancelWith'.

187-- | Lifted 'A.cancelWith'.

173−cancelWith :: (Exception e, Concurrent :> es) => Async a -> e -> Eff es ()

188+cancelWith :: (Exception e, AsyncE :> es) => Async a -> e -> Eff es ()

174cancelWith a = unsafeEff_ . A.cancelWith a

189cancelWith a = unsafeEff_ . A.cancelWith a

175

190

176-- | Lifted 'A.uninterruptibleCancel'.

191-- | Lifted 'A.uninterruptibleCancel'.

177−uninterruptibleCancel :: Concurrent :> es => Async a -> Eff es ()

192+uninterruptibleCancel :: AsyncE :> es => Async a -> Eff es ()

178uninterruptibleCancel = unsafeEff_ . A.uninterruptibleCancel

193uninterruptibleCancel = unsafeEff_ . A.uninterruptibleCancel

179

194

180-- | Lifted 'A.waitCatch'.

195-- | Lifted 'A.waitCatch'.

181waitCatch

196waitCatch

182− :: Concurrent :> es

197+ :: AsyncE :> es

183 => Async a

198 => Async a

184 -> Eff es (Either SomeException a)

199 -> Eff es (Either SomeException a)

185waitCatch = unsafeEff_ . A.waitCatch

200waitCatch = unsafeEff_ . A.waitCatch

186

201

187-- | Lifted 'A.waitAny'.

202-- | Lifted 'A.waitAny'.

188−waitAny :: Concurrent :> es => [Async a] -> Eff es (Async a, a)

203+waitAny :: AsyncE :> es => [Async a] -> Eff es (Async a, a)

189waitAny = unsafeEff_ . A.waitAny

204waitAny = unsafeEff_ . A.waitAny

190

205

191-- | Lifted 'A.waitAnyCatch'.

206-- | Lifted 'A.waitAnyCatch'.

192waitAnyCatch

207waitAnyCatch

193− :: Concurrent :> es

208+ :: AsyncE :> es

194 => [Async a]

209 => [Async a]

195 -> Eff es (Async a, Either SomeException a)

210 -> Eff es (Async a, Either SomeException a)

196waitAnyCatch = unsafeEff_ . A.waitAnyCatch

211waitAnyCatch = unsafeEff_ . A.waitAnyCatch

197

212

198-- | Lifted 'A.waitAnyCancel'.

213-- | Lifted 'A.waitAnyCancel'.

199−waitAnyCancel :: Concurrent :> es => [Async a] -> Eff es (Async a, a)

214+waitAnyCancel :: AsyncE :> es => [Async a] -> Eff es (Async a, a)

200waitAnyCancel = unsafeEff_ . A.waitAnyCancel

215waitAnyCancel = unsafeEff_ . A.waitAnyCancel

201

216

202-- | Lifted 'A.waitAnyCatchCancel'.

217-- | Lifted 'A.waitAnyCatchCancel'.

203waitAnyCatchCancel

218waitAnyCatchCancel

204− :: Concurrent :> es

219+ :: AsyncE :> es

205 => [Async a]

220 => [Async a]

206 -> Eff es (Async a, Either SomeException a)

221 -> Eff es (Async a, Either SomeException a)

207waitAnyCatchCancel = unsafeEff_ . A.waitAnyCatchCancel

222waitAnyCatchCancel = unsafeEff_ . A.waitAnyCatchCancel

208

223

209-- | Lifted 'A.waitEither'.

224-- | Lifted 'A.waitEither'.

210waitEither

225waitEither

211− :: Concurrent :> es

226+ :: AsyncE :> es

212 => Async a

227 => Async a

213 -> Async b

228 -> Async b

214 -> Eff es (Either a b)

229 -> Eff es (Either a b)

@@ -216,7 +231,7 @@ waitEither a b = unsafeEff_ $ A.waitEither a b

216

231

217-- | Lifted 'A.waitEitherCatch'.

232-- | Lifted 'A.waitEitherCatch'.

218waitEitherCatch

233waitEitherCatch

219− :: Concurrent :> es

234+ :: AsyncE :> es

220 => Async a

235 => Async a

221 -> Async b

236 -> Async b

222 -> Eff es (Either (Either SomeException a) (Either SomeException b))

237 -> Eff es (Either (Either SomeException a) (Either SomeException b))

@@ -224,7 +239,7 @@ waitEitherCatch a b = unsafeEff_ $ A.waitEitherCatch a b

224

239

225-- | Lifted 'A.waitEitherCancel'.

240-- | Lifted 'A.waitEitherCancel'.

226waitEitherCancel

241waitEitherCancel

227− :: Concurrent :> es

242+ :: AsyncE :> es

228 => Async a

243 => Async a

229 -> Async b

244 -> Async b

230 -> Eff es (Either a b)

245 -> Eff es (Either a b)

@@ -232,53 +247,53 @@ waitEitherCancel a b = unsafeEff_ $ A.waitEitherCancel a b

232

247

233-- | Lifted 'A.waitEitherCatchCancel'.

248-- | Lifted 'A.waitEitherCatchCancel'.

234waitEitherCatchCancel

249waitEitherCatchCancel

235− :: Concurrent :> es

250+ :: AsyncE :> es

236 => Async a

251 => Async a

237 -> Async b

252 -> Async b

238 -> Eff es (Either (Either SomeException a) (Either SomeException b))

253 -> Eff es (Either (Either SomeException a) (Either SomeException b))

239waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatch a b

254waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatch a b

240

255

241-- | Lifted 'A.waitEither_'.

256-- | Lifted 'A.waitEither_'.

242−waitEither_ :: Concurrent :> es => Async a -> Async b -> Eff es ()

257+waitEither_ :: AsyncE :> es => Async a -> Async b -> Eff es ()

243waitEither_ a b = unsafeEff_ $ A.waitEither_ a b

258waitEither_ a b = unsafeEff_ $ A.waitEither_ a b

244

259

245-- | Lifted 'A.waitBoth'.

260-- | Lifted 'A.waitBoth'.

246−waitBoth :: Concurrent :> es => Async a -> Async b -> Eff es (a, b)

261+waitBoth :: AsyncE :> es => Async a -> Async b -> Eff es (a, b)

247waitBoth a b = unsafeEff_ $ A.waitBoth a b

262waitBoth a b = unsafeEff_ $ A.waitBoth a b

248

263

249-- | Lifted 'A.link'.

264-- | Lifted 'A.link'.

250−link :: Concurrent :> es => Async a -> Eff es ()

265+link :: AsyncE :> es => Async a -> Eff es ()

251link = unsafeEff_ . A.link

266link = unsafeEff_ . A.link

252

267

253-- | Lifted 'A.linkOnly'.

268-- | Lifted 'A.linkOnly'.

254−linkOnly :: Concurrent :> es => (SomeException -> Bool) -> Async a -> Eff es ()

269+linkOnly :: AsyncE :> es => (SomeException -> Bool) -> Async a -> Eff es ()

255linkOnly f = unsafeEff_ . A.linkOnly f

270linkOnly f = unsafeEff_ . A.linkOnly f

256

271

257-- | Lifted 'A.link2'.

272-- | Lifted 'A.link2'.

258−link2 :: Concurrent :> es => Async a -> Async b -> Eff es ()

273+link2 :: AsyncE :> es => Async a -> Async b -> Eff es ()

259link2 a b = unsafeEff_ $ A.link2 a b

274link2 a b = unsafeEff_ $ A.link2 a b

260

275

261-- | Lifted 'A.link2Only'.

276-- | Lifted 'A.link2Only'.

262−link2Only :: Concurrent :> es => (SomeException -> Bool) -> Async a -> Async b -> Eff es ()

277+link2Only :: AsyncE :> es => (SomeException -> Bool) -> Async a -> Async b -> Eff es ()

263link2Only f a b = unsafeEff_ $ A.link2Only f a b

278link2Only f a b = unsafeEff_ $ A.link2Only f a b

264

279

265-- | Lifted 'A.race'.

280-- | Lifted 'A.race'.

266−race :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (Either a b)

281+race :: AsyncE :> es => Eff es a -> Eff es b -> Eff es (Either a b)

267race ma mb = unsafeEff $ \es -> do

282race ma mb = unsafeEff $ \es -> do

268 A.race (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

283 A.race (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

269

284

270-- | Lifted 'A.race_'.

285-- | Lifted 'A.race_'.

271−race_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es ()

286+race_ :: AsyncE :> es => Eff es a -> Eff es b -> Eff es ()

272race_ ma mb = unsafeEff $ \es -> do

287race_ ma mb = unsafeEff $ \es -> do

273 A.race_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

288 A.race_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

274

289

275-- | Lifted 'A.concurrently'.

290-- | Lifted 'A.concurrently'.

276−concurrently :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (a, b)

291+concurrently :: AsyncE :> es => Eff es a -> Eff es b -> Eff es (a, b)

277concurrently ma mb = unsafeEff $ \es -> do

292concurrently ma mb = unsafeEff $ \es -> do

278 A.concurrently (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

293 A.concurrently (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

279

294

280-- | Lifted 'A.concurrently_'.

295-- | Lifted 'A.concurrently_'.

281−concurrently_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es ()

296+concurrently_ :: AsyncE :> es => Eff es a -> Eff es b -> Eff es ()

282concurrently_ ma mb = unsafeEff $ \es -> do

297concurrently_ ma mb = unsafeEff $ \es -> do

283 A.concurrently_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

298 A.concurrently_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es)

284

299

@@ -288,7 +303,7 @@ concurrently_ ma mb = unsafeEff $ \es -> do

288

303

289-- | Lifted 'A.mapConcurrently'.

304-- | Lifted 'A.mapConcurrently'.

290mapConcurrently

305mapConcurrently

291− :: (Traversable f, Concurrent :> es)

306+ :: (Traversable f, AsyncE :> es)

292 => (a -> Eff es b)

307 => (a -> Eff es b)

293 -> f a

308 -> f a

294 -> Eff es (f b)

309 -> Eff es (f b)

@@ -297,7 +312,7 @@ mapConcurrently f t = unsafeEff $ \es -> do

297

312

298-- | Lifted 'A.mapConcurrently_'.

313-- | Lifted 'A.mapConcurrently_'.

299mapConcurrently_

314mapConcurrently_

300− :: (Foldable f, Concurrent :> es)

315+ :: (Foldable f, AsyncE :> es)

301 => (a -> Eff es b)

316 => (a -> Eff es b)

302 -> f a

317 -> f a

303 -> Eff es ()

318 -> Eff es ()

@@ -306,7 +321,7 @@ mapConcurrently_ f t = unsafeEff $ \es -> do

306

321

307-- | Lifted 'A.forConcurrently'.

322-- | Lifted 'A.forConcurrently'.

308forConcurrently

323forConcurrently

309− :: (Traversable f, Concurrent :> es)

324+ :: (Traversable f, AsyncE :> es)

310 => f a

325 => f a

311 -> (a -> Eff es b)

326 -> (a -> Eff es b)

312 -> Eff es (f b)

327 -> Eff es (f b)

@@ -315,7 +330,7 @@ forConcurrently t f = unsafeEff $ \es -> do

315

330

316-- | Lifted 'A.forConcurrently_'.

331-- | Lifted 'A.forConcurrently_'.

317forConcurrently_

332forConcurrently_

318− :: (Foldable f, Concurrent :> es)

333+ :: (Foldable f, AsyncE :> es)

319 => f a

334 => f a

320 -> (a -> Eff es b)

335 -> (a -> Eff es b)

321 -> Eff es ()

336 -> Eff es ()

@@ -323,12 +338,12 @@ forConcurrently_ t f = unsafeEff $ \es -> do

323 U.forConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)

338 U.forConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)

324

339

325-- | Lifted 'A.replicateConcurrently'.

340-- | Lifted 'A.replicateConcurrently'.

326−replicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a]

341+replicateConcurrently :: AsyncE :> es => Int -> Eff es a -> Eff es [a]

327replicateConcurrently n f = unsafeEff $ \es -> do

342replicateConcurrently n f = unsafeEff $ \es -> do

328 U.replicateConcurrently n (unEff f =<< cloneEnv es)

343 U.replicateConcurrently n (unEff f =<< cloneEnv es)

329

344

330-- | Lifted 'A.replicateConcurrently_'.

345-- | Lifted 'A.replicateConcurrently_'.

331−replicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es ()

346+replicateConcurrently_ :: AsyncE :> es => Int -> Eff es a -> Eff es ()

332replicateConcurrently_ n f = unsafeEff $ \es -> do

347replicateConcurrently_ n f = unsafeEff $ \es -> do

333 U.replicateConcurrently_ n (unEff f =<< cloneEnv es)

348 U.replicateConcurrently_ n (unEff f =<< cloneEnv es)

334

349

@@ -337,7 +352,7 @@ replicateConcurrently_ n f = unsafeEff $ \es -> do

337

352

338-- | Lifted 'U.pooledMapConcurrentlyN'.

353-- | Lifted 'U.pooledMapConcurrentlyN'.

339pooledMapConcurrentlyN

354pooledMapConcurrentlyN

340− :: (Concurrent :> es, Traversable t)

355+ :: (AsyncE :> es, Traversable t)

341 => Int

356 => Int

342 -> (a -> Eff es b)

357 -> (a -> Eff es b)

343 -> t a

358 -> t a

@@ -347,7 +362,7 @@ pooledMapConcurrentlyN threads f t = unsafeEff $ \es -> do

347

362

348-- | Lifted 'U.pooledMapConcurrently'.

363-- | Lifted 'U.pooledMapConcurrently'.

349pooledMapConcurrently

364pooledMapConcurrently

350− :: (Concurrent :> es, Traversable t)

365+ :: (AsyncE :> es, Traversable t)

351 => (a -> Eff es b)

366 => (a -> Eff es b)

352 -> t a

367 -> t a

353 -> Eff es (t b)

368 -> Eff es (t b)

@@ -356,7 +371,7 @@ pooledMapConcurrently f t = unsafeEff $ \es -> do

356

371

357-- | Lifted 'U.pooledMapConcurrentlyN'.

372-- | Lifted 'U.pooledMapConcurrentlyN'.

358pooledMapConcurrentlyN_

373pooledMapConcurrentlyN_

359− :: (Concurrent :> es, Foldable f)

374+ :: (AsyncE :> es, Foldable f)

360 => Int

375 => Int

361 -> (a -> Eff es b)

376 -> (a -> Eff es b)

362 -> f a

377 -> f a

@@ -366,7 +381,7 @@ pooledMapConcurrentlyN_ threads f t = unsafeEff $ \es -> do

366

381

367-- | Lifted 'U.pooledMapConcurrently_'.

382-- | Lifted 'U.pooledMapConcurrently_'.

368pooledMapConcurrently_

383pooledMapConcurrently_

369− :: (Concurrent :> es, Foldable f)

384+ :: (AsyncE :> es, Foldable f)

370 => (a -> Eff es b)

385 => (a -> Eff es b)

371 -> f a

386 -> f a

372 -> Eff es ()

387 -> Eff es ()

@@ -375,7 +390,7 @@ pooledMapConcurrently_ f t = unsafeEff $ \es -> do

375

390

376-- | Lifted 'U.pooledForConcurrentlyN'.

391-- | Lifted 'U.pooledForConcurrentlyN'.

377pooledForConcurrentlyN

392pooledForConcurrentlyN

378− :: (Concurrent :> es, Traversable t)

393+ :: (AsyncE :> es, Traversable t)

379 => Int

394 => Int

380 -> t a

395 -> t a

381 -> (a -> Eff es b)

396 -> (a -> Eff es b)

@@ -385,7 +400,7 @@ pooledForConcurrentlyN threads t f = unsafeEff $ \es -> do

385

400

386-- | Lifted 'U.pooledForConcurrently'.

401-- | Lifted 'U.pooledForConcurrently'.

387pooledForConcurrently

402pooledForConcurrently

388− :: (Concurrent :> es, Traversable t)

403+ :: (AsyncE :> es, Traversable t)

389 => t a

404 => t a

390 -> (a -> Eff es b)

405 -> (a -> Eff es b)

391 -> Eff es (t b)

406 -> Eff es (t b)

@@ -394,7 +409,7 @@ pooledForConcurrently t f = unsafeEff $ \es -> do

394

409

395-- | Lifted 'U.pooledForConcurrentlyN'.

410-- | Lifted 'U.pooledForConcurrentlyN'.

396pooledForConcurrentlyN_

411pooledForConcurrentlyN_

397− :: (Concurrent :> es, Foldable f)

412+ :: (AsyncE :> es, Foldable f)

398 => Int

413 => Int

399 -> f a

414 -> f a

400 -> (a -> Eff es b)

415 -> (a -> Eff es b)

@@ -404,7 +419,7 @@ pooledForConcurrentlyN_ threads t f = unsafeEff $ \es -> do

404

419

405-- | Lifted 'U.pooledForConcurrently_'.

420-- | Lifted 'U.pooledForConcurrently_'.

406pooledForConcurrently_

421pooledForConcurrently_

407− :: (Concurrent :> es, Foldable f)

422+ :: (AsyncE :> es, Foldable f)

408 => f a

423 => f a

409 -> (a -> Eff es b)

424 -> (a -> Eff es b)

410 -> Eff es ()

425 -> Eff es ()

@@ -412,22 +427,22 @@ pooledForConcurrently_ t f = unsafeEff $ \es -> do

412 U.pooledForConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)

427 U.pooledForConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es)

413

428

414-- | Lifted 'U.pooledReplicateConcurrentlyN'.

429-- | Lifted 'U.pooledReplicateConcurrentlyN'.

415−pooledReplicateConcurrentlyN :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es [a]

430+pooledReplicateConcurrentlyN :: AsyncE :> es => Int -> Int -> Eff es a -> Eff es [a]

416pooledReplicateConcurrentlyN threads n f = unsafeEff $ \es -> do

431pooledReplicateConcurrentlyN threads n f = unsafeEff $ \es -> do

417 U.pooledReplicateConcurrentlyN threads n (unEff f =<< cloneEnv es)

432 U.pooledReplicateConcurrentlyN threads n (unEff f =<< cloneEnv es)

418

433

419-- | Lifted 'U.pooledReplicateConcurrently'.

434-- | Lifted 'U.pooledReplicateConcurrently'.

420−pooledReplicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a]

435+pooledReplicateConcurrently :: AsyncE :> es => Int -> Eff es a -> Eff es [a]

421pooledReplicateConcurrently n f = unsafeEff $ \es -> do

436pooledReplicateConcurrently n f = unsafeEff $ \es -> do

422 U.pooledReplicateConcurrently n (unEff f =<< cloneEnv es)

437 U.pooledReplicateConcurrently n (unEff f =<< cloneEnv es)

423

438

424-- | Lifted 'U.pooledReplicateConcurrentlyN_'.

439-- | Lifted 'U.pooledReplicateConcurrentlyN_'.

425−pooledReplicateConcurrentlyN_ :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es ()

440+pooledReplicateConcurrentlyN_ :: AsyncE :> es => Int -> Int -> Eff es a -> Eff es ()

426pooledReplicateConcurrentlyN_ threads n f = unsafeEff $ \es -> do

441pooledReplicateConcurrentlyN_ threads n f = unsafeEff $ \es -> do

427 U.pooledReplicateConcurrentlyN_ threads n (unEff f =<< cloneEnv es)

442 U.pooledReplicateConcurrentlyN_ threads n (unEff f =<< cloneEnv es)

428

443

429-- | Lifted 'U.pooledReplicateConcurrently_'.

444-- | Lifted 'U.pooledReplicateConcurrently_'.

430−pooledReplicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es ()

445+pooledReplicateConcurrently_ :: AsyncE :> es => Int -> Eff es a -> Eff es ()

431pooledReplicateConcurrently_ n f = unsafeEff $ \es -> do

446pooledReplicateConcurrently_ n f = unsafeEff $ \es -> do

432 U.pooledReplicateConcurrently_ n (unEff f =<< cloneEnv es)

447 U.pooledReplicateConcurrently_ n (unEff f =<< cloneEnv es)

433

448

@@ -467,7 +482,7 @@ conc :: Eff es a -> Conc es a

467conc = Action

482conc = Action

468

483

469-- | Lifted 'U.runConc'.

484-- | Lifted 'U.runConc'.

470−runConc :: Concurrent :> es => Conc es a -> Eff es a

485+runConc :: AsyncE :> es => Conc es a -> Eff es a

471runConc m = unsafeEff $ \es -> U.runConc (unliftConc es m)

486runConc m = unsafeEff $ \es -> U.runConc (unliftConc es m)

472 where

487 where

473 unliftConc :: Env es -> Conc es a -> U.Conc IO a

488 unliftConc :: Env es -> Conc es a -> U.Conc IO a

@@ -488,20 +503,20 @@ newtype Concurrently es a = Concurrently { runConcurrently :: Eff es a }

488instance Functor (Concurrently es) where

503instance Functor (Concurrently es) where

489 fmap f (Concurrently a) = Concurrently (fmap f a)

504 fmap f (Concurrently a) = Concurrently (fmap f a)

490

505

491−instance Concurrent :> es => Applicative (Concurrently es) where

506+instance AsyncE :> es => Applicative (Concurrently es) where

492 pure = Concurrently . pure

507 pure = Concurrently . pure

493 Concurrently fs <*> Concurrently as =

508 Concurrently fs <*> Concurrently as =

494 Concurrently ((\(f, a) -> f a) <$> concurrently fs as)

509 Concurrently ((\(f, a) -> f a) <$> concurrently fs as)

495

510

496−instance Concurrent :> es => Alternative (Concurrently es) where

511+instance AsyncE :> es => Alternative (Concurrently es) where

497 empty = Concurrently . unsafeEff_ . forever $ threadDelay maxBound

512 empty = Concurrently . unsafeEff_ . forever $ threadDelay maxBound

498 Concurrently as <|> Concurrently bs =

513 Concurrently as <|> Concurrently bs =

499 Concurrently (either id id <$> race as bs)

514 Concurrently (either id id <$> race as bs)

500

515

501−instance (Concurrent :> es, Semigroup a) => Semigroup (Concurrently es a) where

516+instance (AsyncE :> es, Semigroup a) => Semigroup (Concurrently es a) where

502 (<>) = liftA2 (<>)

517 (<>) = liftA2 (<>)

503

518

504−instance (Concurrent :> es, Monoid a) => Monoid (Concurrently es a) where

519+instance (AsyncE :> es, Monoid a) => Monoid (Concurrently es a) where

505 mempty = pure mempty

520 mempty = pure mempty

506

521

507----------------------------------------

522----------------------------------------

@@ -519,9 +534,10 @@ liftAsyncWithUnmask

519 :: (((forall b. IO b -> IO b) -> IO a) -> IO (Async a))

534 :: (((forall b. IO b -> IO b) -> IO a) -> IO (Async a))

520 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)

535 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)

521 -> Eff es (Async a)

536 -> Eff es (Async a)

522−liftAsyncWithUnmask fork action = unsafeEff $ \es -> do

537+liftAsyncWithUnmask fork action = do

538+ unsafeWithLiftMapIO $ \liftMap -> unsafeEff $ \es -> do

523− esA <- cloneEnv es

539+ esA <- cloneEnv es

524− fork $ \unmask -> unEff (action $ unsafeLiftMapIO unmask) esA

540+ fork $ \unmask -> unEff (action $ liftMap unmask) esA

525

541

526liftWithAsync

542liftWithAsync

527 :: (IO a -> (Async a -> IO b) -> IO b)

543 :: (IO a -> (Async a -> IO b) -> IO b)

@@ -538,7 +554,8 @@ liftWithAsyncWithUnmask

538 -> ((forall c. Eff es c -> Eff es c) -> Eff es a)

554 -> ((forall c. Eff es c -> Eff es c) -> Eff es a)

539 -> (Async a -> Eff es b)

555 -> (Async a -> Eff es b)

540 -> Eff es b

556 -> Eff es b

541−liftWithAsyncWithUnmask withA action k = unsafeEff $ \es -> do

557+liftWithAsyncWithUnmask withA action k = do

558+ unsafeWithLiftMapIO $ \liftMap -> unsafeEff $ \es -> do

542− esA <- cloneEnv es

559+ esA <- cloneEnv es

543− withA (\unmask -> unEff (action $ unsafeLiftMapIO unmask) esA)

560+ withA (\unmask -> unEff (action $ liftMap unmask) esA)

544− (\a -> unEff (k a) es)

561+ (\a -> unEff (k a) es)

effectful/src/Effectful/Concurrent.hsdeleted−218

@@ -1,218 +0,0 @@

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/Concurrent/Chan.hsdeleted−45

@@ -1,45 +0,0 @@

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.hsdeleted−79

@@ -1,79 +0,0 @@

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.hsdeleted−108

@@ -1,108 +0,0 @@

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.hsdeleted−30

@@ -1,30 +0,0 @@

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.hsdeleted−30

@@ -1,30 +0,0 @@

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.hsdeleted−146

@@ -1,146 +0,0 @@

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.hsdeleted−71

@@ -1,71 +0,0 @@

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.hsdeleted−347

@@ -1,347 +0,0 @@

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.hsdeleted−15

@@ -1,15 +0,0 @@

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.hsdeleted−143

@@ -1,143 +0,0 @@

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.hsdeleted−182

@@ -1,182 +0,0 @@

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+7−31

@@ -11,21 +11,15 @@ 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

21 ) where

14 ) where

22

15

23import Control.Exception

16import Control.Exception

24import qualified Control.Monad.Trans.Resource as R

17import qualified Control.Monad.Trans.Resource as R

25import qualified Control.Monad.Trans.Resource.Internal as RI

18import qualified Control.Monad.Trans.Resource.Internal as RI

26

19

27−import Effectful.Dispatch.Static

20+import Effectful.Internal.Effect

21+import Effectful.Internal.Env

28−import Effectful.Monad

22+import Effectful.Internal.Monad

29

23

30-- | Data tag for a resource effect.

24-- | Data tag for a resource effect.

31newtype Resource :: Effect where

25newtype Resource :: Effect where

@@ -37,33 +31,15 @@ runResource m = unsafeEff $ \es0 -> do

37 size0 <- sizeEnv es0

31 size0 <- sizeEnv es0

38 istate <- R.createInternalState

32 istate <- R.createInternalState

39 mask $ \restore -> do

33 mask $ \restore -> do

40− es <- unsafeConsEnv (DataA (Resource istate)) noRelinker es0

34+ es <- unsafeConsEnv (IdE (Resource istate)) noRelinker es0

41 a <- restore (unEff m es) `catch` \e -> do

35 a <- restore (unEff m es) `catch` \e -> do

42− unsafeTailEnv size0 es

36+ _ <- unsafeTailEnv size0 es

43 RI.stateCleanupChecked (Just e) istate

37 RI.stateCleanupChecked (Just e) istate

44 throwIO e

38 throwIO e

45− unsafeTailEnv size0 es

39+ _ <- unsafeTailEnv size0 es

46 RI.stateCleanupChecked Nothing istate

40 RI.stateCleanupChecked Nothing istate

47 pure a

41 pure a

48

42

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−

67instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where

43instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where

68 liftResourceT (RI.ResourceT m) = unsafeEff $ \es -> do

44 liftResourceT (RI.ResourceT m) = unsafeEff $ \es -> do

69− getEnv es >>= \(DataA (Resource istate)) -> m istate

45+ getEnv es >>= \(IdE (Resource istate)) -> m istate

effectful/src/Effectful/Temporary.hsdeleted−70

@@ -1,70 +0,0 @@

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.hsdeleted−28

@@ -1,28 +0,0 @@

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+7−6

@@ -2,12 +2,13 @@ module AsyncTests (asyncTests) where

2

3import Control.Concurrent (threadDelay)

4import Control.Monad

5+import Control.Monad.IO.Class

5import Test.Tasty

6import Test.Tasty

6import Test.Tasty.HUnit

7import Test.Tasty.HUnit

7import qualified Data.Set as S

8import qualified Data.Set as S

8

9

9import Effectful

10import Effectful

10−import Effectful.Concurrent.Async

11+import Effectful.Async

11import Effectful.Error

12import Effectful.Error

12import Effectful.State.Dynamic

13import Effectful.State.Dynamic

13

14

@@ -23,7 +24,7 @@ asyncTests = testGroup "Async"

23 ]

24 ]

24

25

25test_localState :: Assertion

26test_localState :: Assertion

26−test_localState = runEff . runConcurrent . evalLocalState x $ do

27+test_localState = runEff . runAsyncE . evalLocalState x $ do

27 replicateConcurrently_ 2 $ do

28 replicateConcurrently_ 2 $ do

28 r <- goDownward 0

29 r <- goDownward 0

29 U.assertEqual "expected result" x r

30 U.assertEqual "expected result" x r

@@ -41,7 +42,7 @@ test_localState = runEff . runConcurrent . evalLocalState x $ do

41 else goDownward $ acc + 1

42 else goDownward $ acc + 1

42

43

43test_sharedState :: Assertion

44test_sharedState :: Assertion

44−test_sharedState = runEff . runConcurrent . evalSharedState (S.empty @Int) $ do

45+test_sharedState = runEff . runAsyncE . evalSharedState (S.empty @Int) $ do

45 concurrently_ (addWhen even x) (addWhen odd x)

46 concurrently_ (addWhen even x) (addWhen odd x)

46 U.assertEqual "expected result" (S.fromList [1..x]) =<< get

47 U.assertEqual "expected result" (S.fromList [1..x]) =<< get

47 where

48 where

@@ -57,7 +58,7 @@ test_sharedState = runEff . runConcurrent . evalSharedState (S.empty @Int) $ do

57 addWhen f $ n - 1

58 addWhen f $ n - 1

58

59

59test_errorHandling :: Assertion

60test_errorHandling :: Assertion

60−test_errorHandling = runEff . runConcurrent . evalSharedState (0::Int) $ do

61+test_errorHandling = runEff . runAsyncE . evalSharedState (0::Int) $ do

61 r <- runError $ concurrently_

62 r <- runError $ concurrently_

62 (liftIO (threadDelay 10000) >> throwError err)

63 (liftIO (threadDelay 10000) >> throwError err)

63 (modify (+x))

64 (modify (+x))

@@ -73,7 +74,7 @@ test_errorHandling = runEff . runConcurrent . evalSharedState (0::Int) $ do

73 err = "thrown from async"

74 err = "thrown from async"

74

75

75test_asyncWithUnmask :: Assertion

76test_asyncWithUnmask :: Assertion

76−test_asyncWithUnmask = runEff . runConcurrent . evalLocalState "initial" $ do

77+test_asyncWithUnmask = runEff . runAsyncE . evalLocalState "initial" $ do

77 x <- asyncWithUnmask $ \unmask -> do

78 x <- asyncWithUnmask $ \unmask -> do

78 liftIO $ threadDelay 10000

79 liftIO $ threadDelay 10000

79 r1 <- get @String -- 2

80 r1 <- get @String -- 2

@@ -88,7 +89,7 @@ test_asyncWithUnmask = runEff . runConcurrent . evalLocalState "initial" $ do

88 (inner1, inner2, outer)

89 (inner1, inner2, outer)

89

90

90test_pooledWorkers :: Assertion

91test_pooledWorkers :: Assertion

91−test_pooledWorkers = runEff . runConcurrent . evalLocalState (0::Int) $ do

92+test_pooledWorkers = runEff . runAsyncE . evalLocalState (0::Int) $ do

92 x <- pooledForConcurrentlyN threads [1..n] $ \k -> do

93 x <- pooledForConcurrentlyN threads [1..n] $ \k -> do

93 r <- get @Int

94 r <- get @Int

94 modify @Int (+1)

95 modify @Int (+1)

effectful/tests/ConcurrencyTests.hs+1

@@ -2,6 +2,7 @@ module ConcurrencyTests (concurrencyTests) where

2

3import Control.Concurrent (threadDelay)

4import Control.Monad

5+import Control.Monad.IO.Class

5import Test.Tasty

6import Test.Tasty

6import Test.Tasty.HUnit

7import Test.Tasty.HUnit

7import UnliftIO

8import UnliftIO

effectful/tests/EnvironmentTests.hsdeleted−48

@@ -1,48 +0,0 @@

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,5 +1,6 @@

1module ErrorTests (errorTests) where

2

3+import Control.Monad.IO.Class

3import Test.Tasty

4import Test.Tasty

4import Test.Tasty.HUnit

5import Test.Tasty.HUnit

5

6

effectful/tests/Main.hs−6

@@ -4,19 +4,13 @@ import Test.Tasty

4

5import AsyncTests

6import ConcurrencyTests

7−import EnvironmentTests

8import ErrorTests

7import ErrorTests

9import StateTests

8import StateTests

10−import TimeoutTests

11−import UnliftTests

12

9

13main :: IO ()

10main :: IO ()

14main = defaultMain $ testGroup "effectful"

11main = defaultMain $ testGroup "effectful"

15 [ asyncTests

12 [ asyncTests

16 , concurrencyTests

13 , concurrencyTests

17− , environmentTests

18 , errorTests

14 , errorTests

19 , stateTests

15 , stateTests

20− , timeoutTests

21− , unliftTests

22 ]

16 ]

effectful/tests/StateTests.hs−1

@@ -97,7 +97,6 @@ test_localEffects = runEff $ do

97 where

98 expected :: Int

99 expected = 4

100−

101----------------------------------------

100----------------------------------------

102-- Helpers

101-- Helpers

103

102

effectful/tests/TimeoutTests.hsdeleted−25

@@ -1,25 +0,0 @@

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.hsdeleted−93

@@ -1,93 +0,0 @@

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+1−17

@@ -2,12 +2,11 @@ module Utils

2 ( assertBool

3 , assertEqual

4 , assertFailure

5− , assertThrows

6 , Ex(..)

5 , Ex(..)

7 ) where

6 ) where

8

7

9import Control.Exception

8import Control.Exception

10−import Control.Monad

9+import Control.Monad.IO.Class

11import GHC.Stack

10import GHC.Stack

12import qualified Test.Tasty.HUnit as T

11import qualified Test.Tasty.HUnit as T

13

12

@@ -27,20 +26,5 @@ assertEqual msg expected given = liftIO $ T.assertEqual msg expected given

27assertFailure :: (HasCallStack, IOE :> es) => String -> Eff es a

26assertFailure :: (HasCallStack, IOE :> es) => String -> Eff es a

28assertFailure msg = liftIO $ T.assertFailure msg

27assertFailure msg = liftIO $ T.assertFailure msg

29

28

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−

45data Ex = Ex deriving (Eq, Show)

29data Ex = Ex deriving (Eq, Show)

46instance Exception Ex

30instance Exception Ex