5ec6816..master · effectful

git.iko.soy/effectful

on master help sign in

.github/workflows/haskell-ci.yml+41−40

since splitsnapshots

unifiedsplit

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

1# This GitHub workflow config has been generated by a script via

3−# haskell-ci 'github' '--config=cabal.haskell-ci' 'effectful.cabal'

3+# haskell-ci 'github' '--config=cabal.haskell-ci' 'cabal.project'

5# To regenerate the script (for example after adjusting tested-with) run

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

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

10#

11−# version: 0.13.20210621

11+# version: 0.13.20211116

12#

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

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

14#

15name: Haskell-CI

16on:

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

24 linux:

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

26 runs-on: ubuntu-18.04

27+ timeout-minutes:

28+ 60

27 container:

29 container:

28 image: buildpack-deps:bionic

30 image: buildpack-deps:bionic

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

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

30 strategy:

32 strategy:

31 matrix:

33 matrix:

32 include:

34 include:

33− - compiler: ghc-9.2.0.20210422

35+ - compiler: ghc-9.2.1

34 compilerKind: ghc

36 compilerKind: ghc

35− compilerVersion: 9.2.0.20210422

37+ compilerVersion: 9.2.1

36 setup-method: ghcup

38 setup-method: ghcup

37− allow-failure: true

38− - compiler: ghc-9.0.1

39− compilerKind: ghc

40− compilerVersion: 9.0.1

41− setup-method: hvr-ppa

42 allow-failure: false

39 allow-failure: false

43− - compiler: ghc-8.10.4

40+ - compiler: ghc-8.10.7

44 compilerKind: ghc

41 compilerKind: ghc

45− compilerVersion: 8.10.4

42+ compilerVersion: 8.10.7

46− setup-method: hvr-ppa

43+ setup-method: ghcup

47 allow-failure: false

44 allow-failure: false

48 - compiler: ghc-8.8.4

45 - compiler: ghc-8.8.4

49 compilerKind: ghc

46 compilerKind: ghc

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

65 else

62 else

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

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

67 apt-get update

64 apt-get update

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

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

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

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

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

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

69 fi

70 fi

70 env:

71 env:

71 HCKIND: ${{ matrix.compilerKind }}

72 HCKIND: ${{ matrix.compilerKind }}

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

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

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

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

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

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

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

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

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

87 else

88 else

88 HC=$HCDIR/bin/$HCKIND

89 HC=$HCDIR/bin/$HCKIND

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

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

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

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

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

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

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

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

93 fi

94 fi

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

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

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

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

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

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

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

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

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

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

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

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

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

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

102 env:

103 env:

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

125 repository hackage.haskell.org

126 repository hackage.haskell.org

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

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

127 EOF

128 EOF

128− if $HEADHACKAGE; then

129 cat >> $CABAL_CONFIG <<EOF

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

130+ program-default-options

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

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

132− secure: True

133− root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d

134− 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329

135− f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89

136− key-threshold: 3

137 EOF

132 EOF

138− fi

139 cat $CABAL_CONFIG

133 cat $CABAL_CONFIG

140 - name: versions

134 - name: versions

141 run: |

135 run: |

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

148 - name: cache (tools)

142 - name: cache (tools)

149 uses: actions/cache@v2

143 uses: actions/cache@v2

150 with:

144 with:

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

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

152 path: ~/.haskell-ci-tools

146 path: ~/.haskell-ci-tools

153 - name: install cabal-plan

147 - name: install cabal-plan

154 run: |

148 run: |

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

161 cabal-plan --version

155 cabal-plan --version

162 - name: install doctest

156 - name: install doctest

163 run: |

157 run: |

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

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

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

159+ doctest --version

166 - name: checkout

160 - name: checkout

167 uses: actions/checkout@v2

161 uses: actions/checkout@v2

168 with:

162 with:

@@ -170,7 +164,8 @@ jobs:

170 - name: initial cabal.project for sdist

164 - name: initial cabal.project for sdist

171 run: |

165 run: |

172 touch cabal.project

166 touch cabal.project

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

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

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

174 cat cabal.project

169 cat cabal.project

175 - name: sdist

170 - name: sdist

176 run: |

171 run: |

@@ -184,20 +179,22 @@ jobs:

184 run: |

179 run: |

185 PKGDIR_effectful="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-[0-9.]*')"

180 PKGDIR_effectful="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-[0-9.]*')"

186 echo "PKGDIR_effectful=${PKGDIR_effectful}" >> "$GITHUB_ENV"

181 echo "PKGDIR_effectful=${PKGDIR_effectful}" >> "$GITHUB_ENV"

182+ PKGDIR_effectful_core="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effectful-core-[0-9.]*')"

183+ echo "PKGDIR_effectful_core=${PKGDIR_effectful_core}" >> "$GITHUB_ENV"

187 rm -f cabal.project cabal.project.local

184 rm -f cabal.project cabal.project.local

188 touch cabal.project

185 touch cabal.project

189 touch cabal.project.local

186 touch cabal.project.local

190 echo "packages: ${PKGDIR_effectful}" >> cabal.project

187 echo "packages: ${PKGDIR_effectful}" >> cabal.project

188+ echo "packages: ${PKGDIR_effectful_core}" >> cabal.project

191 echo "package effectful" >> cabal.project

189 echo "package effectful" >> cabal.project

192 echo " ghc-options: -Werror=missing-methods" >> cabal.project

190 echo " ghc-options: -Werror=missing-methods" >> cabal.project

191+ echo "package effectful-core" >> cabal.project

192+ echo " ghc-options: -Werror=missing-methods" >> cabal.project

193 cat >> cabal.project <<EOF

194 package effectful

195 flags: +benchmark-foreign-libraries

196 EOF

197− if $HEADHACKAGE; then

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

199− fi

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

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

201 cat cabal.project

198 cat cabal.project

202 cat cabal.project.local

199 cat cabal.project.local

203 - name: dump install plan

200 - name: dump install plan

@@ -225,14 +222,18 @@ jobs:

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

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

226 - name: doctest

223 - name: doctest

227 run: |

224 run: |

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

225+ cd ${PKGDIR_effectful} || false

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

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

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

227+ cd ${PKGDIR_effectful_core} || false

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

229+ cd ${PKGDIR_effectful_core} || false

231− 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 utils ; fi

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

232 - name: cabal check

231 - name: cabal check

233 run: |

232 run: |

234 cd ${PKGDIR_effectful} || false

233 cd ${PKGDIR_effectful} || false

235 ${CABAL} -vnormal check

234 ${CABAL} -vnormal check

235+ cd ${PKGDIR_effectful_core} || false

236+ ${CABAL} -vnormal check

236 - name: haddock

237 - name: haddock

237 run: |

238 run: |

238 $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all

239 $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all

README.md+25−4

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

1# effectful

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−[![Hackage](https://img.shields.io/hackage/v/effectful.svg)](https://hackage.haskell.org/package/effectful)

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)

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)

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

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

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

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

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

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

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

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

21− discarded state).

24+ modifications).

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

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

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

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

@@ -100,11 +103,25 @@ to "boring" transformer stacks, most of which are a dozen of newtype'd `StateT`

100or `ReaderT` transformers, each with a few associated operations (usually tied

103or `ReaderT` transformers, each with a few associated operations (usually tied

101to a type class), not to replace monad transformers altogether.

104to a type class), not to replace monad transformers altogether.

102

105

106+## Usage

107+

108+The effect system and its effects are split among several libraries:

109+

110+- The `effectful-core` library contains the main machinery of the effect system

111+ itself and a few basic effects.

112+ It aims for a small dependency footprint and provides the building blocks for

113+ more advanced effects.

114+

115+- _TBD_ `effectful-resource`, `effectful-process`, ...

116+

117+- Finally, the `effectful` library which comes with 'batteries included'. It is

118+ build on top of the other libraries and re-exports the functionality of those.

119+

103## Example

120## Example

104

121

105A `Filesystem` effect with two handlers, one that runs in `IO` and another that

122A `Filesystem` effect with two handlers, one that runs in `IO` and another that

106uses an in-memory virtual file system can be found

123uses an in-memory virtual file system can be found

107−[here](https://github.com/arybczak/effectful/blob/master/examples/FileSystem.hs).

124+[here](https://github.com/arybczak/effectful/blob/master/effectful/examples/FileSystem.hs).

108

125

109## Resources

126## Resources

110

127

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

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

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

123

140

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

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

142+

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

144+

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

cabal.haskell-ci+1−3

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

1branches: master

3−doctest: <9.2

3+doctest: <9.3

4tests: True

5benchmarks: True

7−ghcup-jobs: >=9.2

8−

9raw-project

7raw-project

10 package effectful

8 package effectful

11 flags: +benchmark-foreign-libraries

9 flags: +benchmark-foreign-libraries

cabal.projectnew file+3

@@ -0,0 +1,3 @@

1+packages:

2+ effectful/effectful.cabal

3+ effectful-core/effectful-core.cabal

doctest.sh+32−22

@@ -7,25 +7,35 @@

7# - Compile doctest with the same GHC version the project currently uses.

10+set -eu

11+

12+run_doctest() {

13+ pushd "${1}"

10−doctest src \

14+ doctest \

15+ "${2}" \

11− -XBangPatterns \

16+ -XBangPatterns \

12− -XConstraintKinds \

17+ -XConstraintKinds \

13− -XDataKinds \

18+ -XDataKinds \

14− -XDeriveFunctor \

19+ -XDeriveFunctor \

20+ -XDeriveGeneric \

15− -XFlexibleContexts \

21+ -XFlexibleContexts \

16− -XFlexibleInstances \

22+ -XFlexibleInstances \

17− -XGADTs \

23+ -XGADTs \

18− -XGeneralizedNewtypeDeriving \

24+ -XGeneralizedNewtypeDeriving \

19− -XLambdaCase \

25+ -XLambdaCase \

20− -XMultiParamTypeClasses \

26+ -XMultiParamTypeClasses \

21− -XNoStarIsType \

27+ -XNoStarIsType \

22− -XRankNTypes \

28+ -XRankNTypes \

23− -XRecordWildCards \

29+ -XRecordWildCards \

24− -XRoleAnnotations \

30+ -XRoleAnnotations \

25− -XScopedTypeVariables \

31+ -XScopedTypeVariables \

26− -XStandaloneDeriving \

32+ -XStandaloneDeriving \

27− -XStrictData \

28− -XTupleSections \

33+ -XTupleSections \

29− -XTypeApplications \

34+ -XTypeApplications \

30− -XTypeFamilies \

35+ -XTypeFamilies \

31− -XTypeOperators

36+ -XTypeOperators

37+ popd

38+}

39+

40+run_doctest effectful-core src

41+run_doctest effectful src

effectful-core/CHANGELOG.mdnew file+2

@@ -0,0 +1,2 @@

1+# effectful-core-0.0.0.0 (2021-06-13)

2+* Initial alpha release.

effectful-core/LICENSEnew file+30

@@ -0,0 +1,30 @@

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Andrzej Rybczak nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

effectful.cabal → effectful-core/effectful-core.cabalrenamed+22−85

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

1cabal-version: 2.4

2build-type: Simple

3−name: effectful

3+name: effectful-core

4−version: 0.0.0.0

4+version: 0.1

5license: BSD-3-Clause

6license-file: LICENSE

7category: Control

@@ -11,21 +11,20 @@ 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

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

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

15extra-source-files: CHANGELOG.md

19extra-source-files: CHANGELOG.md

16− README.md

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

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

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

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

21source-repository head

24source-repository head

22 type: git

25 type: git

23 location: https://github.com/arybczak/effectful.git

26 location: https://github.com/arybczak/effectful.git

25−flag benchmark-foreign-libraries

26− description: Include other effect libraries in the benchmarks.

27− default: False

28−

29common language

28common language

30 ghc-options: -Wall -Wcompat

29 ghc-options: -Wall -Wcompat

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

35 ConstraintKinds

34 ConstraintKinds

36 DataKinds

35 DataKinds

37 DeriveFunctor

36 DeriveFunctor

37+ DeriveGeneric

38 FlexibleContexts

39 FlexibleInstances

40 GADTs

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

47 RoleAnnotations

48 ScopedTypeVariables

49 StandaloneDeriving

50− StrictData

51 TupleSections

50 TupleSections

52 TypeApplications

51 TypeApplications

53 TypeFamilies

52 TypeFamilies

@@ -68,34 +67,32 @@ library

69 ghc-options: -O2

68 ghc-options: -O2

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

70+ build-depends: effectful-internal-utils

72− , async

71+

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

73− , containers

73+ , containers >= 0.6

74− , effectful-internal-utils

75− , exceptions

74+ , exceptions >= 0.10.4

76− , monad-control

75+ , monad-control >= 1.0.3

77− , primitive

76+ , primitive >= 0.7.3.0

78− , resourcet

79− , stm

80− , transformers-base

77+ , transformers-base >= 0.4.6

81− , unliftio-core

78+ , unliftio-core >= 0.2.0.1

82− , unliftio

84 hs-source-dirs: src

80 hs-source-dirs: src

86 exposed-modules: Effectful

82 exposed-modules: Effectful

87− Effectful.Async

83+ Effectful.Dispatch.Dynamic

84+ Effectful.Dispatch.Static

88 Effectful.Error

85 Effectful.Error

89 Effectful.Error.Dynamic

86 Effectful.Error.Dynamic

90 Effectful.Fail

87 Effectful.Fail

91− Effectful.Handler

92 Effectful.Internal.Effect

88 Effectful.Internal.Effect

93 Effectful.Internal.Env

89 Effectful.Internal.Env

94 Effectful.Internal.Monad

90 Effectful.Internal.Monad

95 Effectful.Internal.Unlift

91 Effectful.Internal.Unlift

96 Effectful.Monad

92 Effectful.Monad

93+ Effectful.Prim

97 Effectful.Reader

94 Effectful.Reader

98− Effectful.Resource

95+ Effectful.Reader.Dynamic

99 Effectful.State.Dynamic

96 Effectful.State.Dynamic

100 Effectful.State.Local

97 Effectful.State.Local

101 Effectful.State.Shared

98 Effectful.State.Shared

@@ -103,64 +100,4 @@ library

103 Effectful.Writer.Local

100 Effectful.Writer.Local

104 Effectful.Writer.Shared

101 Effectful.Writer.Shared

105

102

106− reexported-modules: Effectful.Internal.Utils

103+ reexported-modules: Effectful.Internal.Utils

107−

108−test-suite test

109− import: language

110−

111− ghc-options: -threaded -rtsopts -with-rtsopts=-N4

112−

113− build-depends: base

114− , containers

115− , effectful

116− , exceptions

117− , lifted-base

118− , tasty

119− , tasty-hunit

120− , unliftio

121−

122− hs-source-dirs: tests

123−

124− type: exitcode-stdio-1.0

125− main-is: Main.hs

126−

127− other-modules: AsyncTests

128− ConcurrencyTests

129− ErrorTests

130− StateTests

131− Utils

132−

133−benchmark bench

134− import: language

135−

136− ghc-options: -threaded -rtsopts -with-rtsopts=-T

137−

138− if flag(benchmark-foreign-libraries)

139− build-depends: mtl

140−

141− if impl(ghc < 9)

142− build-depends: freer-simple

143−

144− if impl(ghc < 9.2)

145− build-depends: fused-effects

146−

147− if impl(ghc < 9)

148− build-depends: polysemy

149−

150− build-depends: base

151− , effectful

152− , tasty-bench

153− , unix

154− , unliftio

155− , async

156−

157− hs-source-dirs: bench

158−

159− type: exitcode-stdio-1.0

160− main-is: Main.hs

161−

162− other-modules: Concurrency

163− Countdown

164− FileSizes

165− Unlift

166− Utils

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

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

9 -- * Running the 'Eff' monad

11− -- ** Pure operations

11+ -- ** Pure computations

12 , runPureEff

14− -- ** Operations with side effects

14+ -- ** Computations with side effects

15 , IOE

16 , runEff

@@ -21,6 +21,7 @@ module Effectful

21 , Limit(..)

22 , unliftStrategy

23 , withUnliftStrategy

24+ , withEffToIO

25 -- * 'Effect' handlers

26 -- * 'Effect' handlers

@@ -29,13 +30,9 @@ module Effectful

30 -- ** Basic handlers

31 -- ** Basic handlers

31 , interpret

32 , interpret

32− , interpretM

33−

34− -- ** Derived handlers

35 , reinterpret

33 , reinterpret

36− , reinterpretM

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

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

39 , LocalEnv

36 , LocalEnv

41 -- *** Unlifts

38 -- *** Unlifts

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

51 -- *** Bidirectional lifts

48 -- *** Bidirectional lifts

52 , localLiftUnlift

49 , localLiftUnlift

53 , localLiftUnliftIO

50 , localLiftUnliftIO

51+

52+ -- * Re-exports

53+ , MonadIO(..)

54+ , MonadUnliftIO(..)

54 ) where

55 ) where

56−import Effectful.Handler

57+import Effectful.Dispatch.Dynamic

57import Effectful.Monad

58import Effectful.Monad

effectful-core/src/Effectful/Dispatch/Dynamic.hsnew file+246

@@ -0,0 +1,246 @@

1+module Effectful.Dispatch.Dynamic

2+ ( -- * Sending operations to the handler

3+ send

5+ -- * Handling effects

6+ , EffectHandler

7+ , interpret

8+ , reinterpret

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

11+ , LocalEnv

12+

13+ -- *** Unlifts

14+ , localSeqUnlift

15+ , localSeqUnliftIO

16+ , localUnlift

17+ , localUnliftIO

18+

19+ -- *** Lifts

20+ , withLiftMap

21+ , withLiftMapIO

22+

23+ -- *** Bidirectional lifts

24+ , localLiftUnlift

25+ , localLiftUnliftIO

26+

27+ -- *** Utils

28+ , SuffixOf

29+

30+ -- * Re-exports

31+ , HasCallStack

32+ ) where

33+

34+import Control.Monad.IO.Unlift

35+import Data.Kind

36+import GHC.Stack (HasCallStack)

37+

38+import Effectful.Internal.Effect

39+import Effectful.Internal.Env

40+import Effectful.Internal.Monad

41+

42+----------------------------------------

43+-- Handling effects

44+

45+-- | Interpret an effect.

46+interpret

47+ :: EffectHandler e es

48+ -- ^ The effect handler.

49+ -> Eff (e : es) a

50+ -> Eff es a

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

52+ les <- forkEnv es

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

54+

55+-- | Interpret an effect using other effects.

56+reinterpret

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

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

59+ -> EffectHandler e handlerEs

60+ -- ^ The effect handler.

61+ -> Eff (e : es) a

62+ -> Eff es b

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

64+ les0 <- forkEnv es

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

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

67+

68+----------------------------------------

69+-- Unlifts

70+

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

72+-- general version see 'localUnlift'.

73+localSeqUnlift

74+ :: (HasCallStack, SuffixOf es handlerEs)

75+ => LocalEnv localEs handlerEs

76+ -- ^ Local environment.

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

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

79+ -> Eff es a

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

81+ seqUnliftIO les $ \unlift -> do

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

83+

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

85+-- general version see 'localUnliftIO'.

86+localSeqUnliftIO

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

88+ => LocalEnv localEs handlerEs

89+ -- ^ Local environment.

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

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

92+ -> Eff es a

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

94+

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

96+localUnlift

97+ :: (HasCallStack, SuffixOf es handlerEs)

98+ => LocalEnv localEs handlerEs

99+ -- ^ Local environment.

100+ -> UnliftStrategy

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

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

103+ -> Eff es a

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

105+ SeqUnlift -> unsafeEff $ \es -> do

106+ seqUnliftIO les $ \unlift -> do

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

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

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

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

111+

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

113+localUnliftIO

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

115+ => LocalEnv localEs handlerEs

116+ -- ^ Local environment.

117+ -> UnliftStrategy

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

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

120+ -> Eff es a

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

122+ SeqUnlift -> liftIO $ seqUnliftIO les k

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

124+

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

126+--

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

128+--

129+-- to

130+--

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

132+--

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

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

135+withLiftMap

136+ :: (HasCallStack, SuffixOf es handlerEs)

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)

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

141+ -> Eff es r

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

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

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

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

146+ seqUnliftIO localEs $ \unlift -> do

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

148+

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

150+--

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

152+--

153+-- to

154+--

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

156+--

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

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

159+--

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

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

162+--

163+-- >>> :{

164+-- data Fork :: Effect where

165+-- ForkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> Fork m ThreadId

166+-- :}

167+--

168+-- >>> :{

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

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

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

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

173+-- :}

174+withLiftMapIO

175+ :: (HasCallStack, SuffixOf es handlerEs, 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)

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

180+ -> Eff es r

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

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

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

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

185+

186+----------------------------------------

187+-- Bidirectional lifts

188+

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

190+--

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

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

193+--

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

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

196+localLiftUnlift

197+ :: (HasCallStack, SuffixOf es handlerEs)

198+ => LocalEnv localEs handlerEs

199+ -- ^ Local environment.

200+ -> UnliftStrategy

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

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

203+ -> Eff es a

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

205+ SeqUnlift -> unsafeEff $ \es -> do

206+ seqUnliftIO es $ \unliftEs -> do

207+ seqUnliftIO les $ \unliftLocalEs -> do

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

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

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

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

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

213+

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

215+-- unrestricted lifting function.

216+--

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

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

219+--

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

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

222+localLiftUnliftIO

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

224+ => LocalEnv localEs handlerEs

225+ -- ^ Local environment.

226+ -> UnliftStrategy

227+ -> ((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.

229+ -> Eff es a

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

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

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

233+

234+----------------------------------------

235+-- Utils

236+

237+-- | Require that the second list of effects is a suffix of the first one.

238+--

239+-- In other words, 'SuffixOf' @es@ @baseEs@ means "a suffix of @es@ is

240+-- @baseEs@".

241+type family SuffixOf (es :: [Effect]) (baseEs :: [Effect]) :: Constraint where

242+ SuffixOf baseEs baseEs = ()

243+ SuffixOf (e : es) baseEs = SuffixOf es baseEs

244+

245+-- $setup

246+-- >>> import Control.Concurrent

effectful-core/src/Effectful/Dispatch/Static.hsnew file+82

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

1+module Effectful.Dispatch.Static

2+ ( -- * Low level API

3+ DataA(..)

5+ -- ** Extending the environment

6+ , runData

7+ , evalData

8+ , execData

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.hsnew file+198

@@ -0,0 +1,198 @@

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

2+--

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

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

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

6+--

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

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

9+--

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

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

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

13+-- *** Exception: BOOM!

14+-- ...

15+--

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

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

18+--

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

20+-- "caught"

21+--

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

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

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

25+--

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

27+-- >>> :{

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

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

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

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

32+-- :}

33+-- Beginning.

34+-- Computing.

35+-- Cleaning up.

36+-- Left "oops"

37+--

38+-- /Note:/ unlike the 'Control.Monad.Trans.Except.ExceptT' monad transformer

39+-- from the @transformers@ library, the order in which you handle the 'Error'

40+-- effect with regard to other stateful effects does not matter. Consider the

41+-- following:

42+--

43+-- >>> import qualified Control.Monad.State.Strict as T

44+-- >>> import qualified Control.Monad.Except as T

45+--

46+-- >>> let m1 = (T.modify (++ " there!") >> T.throwError "oops") `T.catchError` \_ -> pure ()

47+--

48+-- >>> (`T.runStateT` "Hi") . T.runExceptT $ m1

49+-- (Right (),"Hi there!")

50+--

51+-- >>> T.runExceptT . (`T.runStateT` "Hi") $ m1

52+-- Right ((),"Hi")

53+--

54+-- Here, whether state modifications within the @catchError@ block are lost or

55+-- not depends on the shape of the monad transformer stack, which is surprising

56+-- and can be a source of subtle bugs. On the other hand:

57+--

58+-- >>> import Effectful.State.Local

59+--

60+-- >>> let m2 = (modify (++ " there!") >> throwError "oops") `catchError` \_ (_::String) -> pure ()

61+--

62+-- >>> runEff . runState "Hi" . runError @String $ m2

63+-- (Right (),"Hi there!")

64+--

65+-- >>> runEff . runError @String . runState "Hi" $ m2

66+-- Right ((),"Hi there!")

67+--

68+-- Here, no matter the order of effects, state modifications within the

69+-- @catchError@ block always persist, giving predictable behavior.

70+module Effectful.Error

71+ ( Error

72+ , runError

73+ , throwError

74+ , catchError

75+ , handleError

76+ , tryError

77+

78+ -- * Re-exports

79+ , HasCallStack

80+ , CallStack

81+ , getCallStack

82+ , prettyCallStack

83+ ) where

84+

85+import Control.Exception

86+import Data.Typeable

87+import Data.Unique

88+import GHC.Stack

89+

90+import Effectful.Dispatch.Static

91+import Effectful.Monad

92+

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

94+newtype Error e :: Effect where

95+ Error :: ErrorId -> Error e m r

96+

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

98+runError

99+ :: forall e es a. Typeable e

100+ => Eff (Error e : es) a

101+ -> Eff es (Either (CallStack, e) a)

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

103+ eid <- newErrorId

104+ size0 <- sizeEnv es0

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

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

107+ unsafeTailEnv size0 es

108+ pure r

109+ where

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

111+ Right a -> pure $ Right a

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

113+ $ throwIO ex

114+

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

116+throwError

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

118+ => e

119+ -- ^ The error.

120+ -> Eff es a

121+throwError e = unsafeEff $ \es -> do

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

123+ throwIO $ ErrorEx eid callStack e

124+

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

126+catchError

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

128+ => Eff es a

129+ -- ^ The inner computation.

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

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

132+ -> Eff es a

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

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

135+ size <- sizeEnv es

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

137+ checkSizeEnv size es

138+ unEff (handler cs e) es

139+

140+-- | The same as @'flip' 'catchError'@, which is useful in situations where the

141+-- code for the handler is shorter.

142+handleError

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

144+ => (CallStack -> e -> Eff es a)

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

146+ -> Eff es a

147+ -- ^ The inner computation.

148+ -> Eff es a

149+handleError = flip catchError

150+

151+-- | Similar to 'catchError', but returns an 'Either' result which is a 'Right'

152+-- if no error was thrown and a 'Left' otherwise.

153+tryError

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

155+ => Eff es a

156+ -- ^ The inner computation.

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

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

159+

160+----------------------------------------

161+-- Helpers

162+

163+newtype ErrorId = ErrorId Unique

164+ deriving Eq

165+

166+-- | A unique is picked so that distinct 'Error' handlers for the same type

167+-- don't catch each other's exceptions.

168+newErrorId :: IO ErrorId

169+newErrorId = ErrorId <$> newUnique

170+

171+tryHandler

172+ :: Typeable e

173+ => SomeException

174+ -> ErrorId

175+ -> (CallStack -> e -> r)

176+ -> IO r

177+ -> IO r

178+tryHandler ex eid0 handler next = case fromException ex of

179+ Just (ErrorEx eid cs e)

180+ | eid0 == eid -> pure $ handler cs e

181+ | otherwise -> next

182+ Nothing -> next

183+

184+data ErrorEx e = ErrorEx !ErrorId CallStack e

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

186+ showsPrec p (ErrorEx _ cs e)

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

188+ . showsPrec p (typeOf e)

189+ . (") " ++)

190+ . showsPrec p cs

191+instance Typeable e => Exception (ErrorEx e)

192+

193+catchErrorIO :: Typeable e => ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a

194+catchErrorIO eid m handler = do

195+ m `catch` \err@(ErrorEx etag e cs) -> do

196+ if eid == etag

197+ then handler e cs

198+ else throwIO err

src/Effectful/Error/Dynamic.hs → effectful-core/src/Effectful/Error/Dynamic.hsrenamed+8−9

@@ -7,21 +7,20 @@ module Effectful.Error.Dynamic

7 ) where

9import Data.Typeable

10−import GHC.Stack

12−import Effectful.Handler

11+import Effectful.Dispatch.Dynamic

13import Effectful.Monad

12import Effectful.Monad

14import qualified Effectful.Error as E

13import qualified Effectful.Error as E

16data Error e :: Effect where

15data Error e :: Effect where

17 ThrowError :: e -> Error e m a

16 ThrowError :: e -> Error e m a

18− CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a

17+ CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a

20runError

19runError

21 :: Typeable e

20 :: Typeable e

22 => Eff (Error e : es) a

21 => Eff (Error e : es) a

23− -> Eff es (Either (CallStack, e) a)

22+ -> Eff es (Either (E.CallStack, e) a)

24−runError = reinterpretM E.runError $ \env -> \case

23+runError = reinterpret E.runError $ \env -> \case

25 ThrowError e -> E.throwError e

24 ThrowError e -> E.throwError e

26 CatchError m h -> localSeqUnlift env $ \unlift -> do

25 CatchError m h -> localSeqUnlift env $ \unlift -> do

27 E.catchError (unlift m) (\cs -> unlift . h cs)

26 E.catchError (unlift m) (\cs -> unlift . h cs)

@@ -33,14 +32,14 @@ throwError

33throwError = send . ThrowError

32throwError = send . ThrowError

35catchError

34catchError

36− :: Error e :> es

35+ :: (HasCallStack, Error e :> es)

37 => Eff es a

36 => Eff es a

38− -> (CallStack -> e -> Eff es a)

37+ -> (E.CallStack -> e -> Eff es a)

39 -> Eff es a

38 -> Eff es a

40catchError m = send . CatchError m

39catchError m = send . CatchError m

42tryError

41tryError

43− :: Error e :> es

42+ :: (HasCallStack, Error e :> es)

44 => Eff es a

43 => Eff es a

45− -> Eff es (Either (CallStack, e) a)

44+ -> Eff es (Either (E.CallStack, e) a)

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

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

effectful-core/src/Effectful/Fail.hsnew file+16

@@ -0,0 +1,16 @@

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

2+module Effectful.Fail

3+ ( Fail(..)

4+ , runFail

5+ ) where

7+import Effectful.Dispatch.Dynamic

8+import Effectful.Error

9+import 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

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

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

8module Effectful.Internal.Effect

9 ( Effect

10 , (:>)(..)

11− , IdE(..)

11+

12+ -- * Re-exports

13+ , Type

12 ) where

14 ) where

14import Data.Kind

16import Data.Kind

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

17-- | The kind of effects.

19-- | The kind of effects.

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

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

20−-- | Adapter for statically dispatched effects.

21−newtype IdE (e :: Effect) where

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

23−

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

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

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

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

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

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

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

25+-- in the list.

28--

26--

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

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

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

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

31--

29--

32-- @

30-- @

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

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

34-- @

32-- @

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

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

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

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

src/Effectful/Internal/Env.hs → effectful-core/src/Effectful/Internal/Env.hsrenamed+141−109

@@ -1,37 +1,50 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE MagicHash #-}

2{-# OPTIONS_HADDOCK not-home #-}

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

4--

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

6-- in subsequent releases.

7module Effectful.Internal.Env

8+ ( -- * The environment

8− ( Env

9+ Env(..)

10+ , Forks(..)

11+ , EnvRef(..)

12+

13+ -- ** ForkId

14+ , ForkId(..)

15+ , ForkIdGen(..)

16+ , newForkIdGen

17+ , cloneForkIdGen

18+ , newForkId

19+

20+ -- ** Relinker

9 , Relinker(..)

21 , Relinker(..)

10 , noRelinker

22 , noRelinker

12− -- * Safe operations

24+ -- * Operations

13 , emptyEnv

25 , emptyEnv

14 , cloneEnv

26 , cloneEnv

15 , forkEnv

27 , forkEnv

16 , sizeEnv

28 , sizeEnv

17− , getEnv

18 , checkSizeEnv

29 , checkSizeEnv

20− -- * Extending and shrinking

31+ -- ** Extending and shrinking

21 , unsafeConsEnv

32 , unsafeConsEnv

22 , unsafeTailEnv

33 , unsafeTailEnv

24− -- * Data retrieval and update

35+ -- ** Data retrieval and update

25− , unsafePutEnv

36+ , getEnv

26− , unsafeModifyEnv

37+ , putEnv

27− , unsafeStateEnv

38+ , stateEnv

39+ , modifyEnv

28 ) where

40 ) where

30import Control.Monad

42import Control.Monad

31import Control.Monad.Primitive

43import Control.Monad.Primitive

32import Data.IORef

44import Data.IORef

33import Data.Primitive.SmallArray

45import Data.Primitive.SmallArray

34−import GHC.Exts (Any)

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

47+import GHC.Stack (HasCallStack)

35import Unsafe.Coerce

48import Unsafe.Coerce

36import qualified Data.IntMap.Strict as IM

49import qualified Data.IntMap.Strict as IM

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

68-- @

81-- @

69--

82--

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

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

71−-- currently:

84+-- currently (brackets represent forks):

72--

85--

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

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

74--

87--

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

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

76--

89--

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

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

78--

91--

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

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

80--

93--

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

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

82-- e09]@.

95-- e09]@.

83--

96--

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

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

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

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

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

102-- it. Moreover, currently:

115-- it. Moreover, currently:

103--

116--

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

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

105--

118--

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

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

107--

120--

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

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

109--

122--

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

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

111− { _forks :: Forks

124+ { _forks :: !Forks

112− , _globalRef :: IORef EnvRef

125+ , _globalRef :: !(IORef EnvRef)

113− , _forkIdGen :: ForkIdGen

126+ , _forkIdGen :: !ForkIdGen

114 }

127 }

115

128

116-- | Local forks of the environment.

129-- | Local forks of the environment.

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

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

118

131

132+-- | Data held in the environment.

119data EnvRef = EnvRef

133data EnvRef = EnvRef

120− { _size :: Int

134+ { _size :: !Int

121− , _data :: SmallMutableArray RealWorld Any

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

122− , _relinkers :: SmallMutableArray RealWorld Any

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

123 }

137 }

124

138

125----------------------------------------

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

126-- ForkId

140-- ForkId

127

141

142+-- | Internal id of the fork.

128newtype ForkId = ForkId { unForkId :: Int }

143newtype ForkId = ForkId { unForkId :: Int }

129

144

130-- | 'ForkId' generation.

145-- | 'ForkId' generation.

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

148----------------------------------------

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

149-- Relinker

164-- Relinker

150

165

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

167+-- the environment.

151−newtype Relinker i (e :: Effect) where

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

152 Relinker

169 Relinker

153− :: ((forall es. Env es -> IO (Env es)) -> handler e -> IO (handler e))

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

154− -> Relinker handler e

171+ -> Relinker adapter e

155

172

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

156−noRelinker :: Relinker handler e

174+noRelinker :: Relinker adapter e

157noRelinker = Relinker $ \_ -> pure

175noRelinker = Relinker $ \_ -> pure

158

176

159----------------------------------------

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

@@ -171,22 +189,22 @@ cloneEnv (Env NoFork gref0 gen0) = do

171 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

189 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

172 gen <- cloneForkIdGen gen0

190 gen <- cloneForkIdGen gen0

173 gref <- newIORef $ EnvRef n es fs

191 gref <- newIORef $ EnvRef n es fs

174− cache <- newIORef IM.empty

192+ store <- newIORef IM.empty

175− relinkData gref gen cache es fs n

193+ relinkData gref gen store es fs n

176 pure $ Env NoFork gref gen

194 pure $ Env NoFork gref gen

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

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

178 EnvRef _ es0 fs0 <- readIORef gref0

196 EnvRef _ es0 fs0 <- readIORef gref0

179 EnvRef n _ _ <- readIORef lref0

197 EnvRef n _ _ <- readIORef lref0

180 let len = baseIx + n

198 let len = baseIx + n

181− es <- newSmallArray len (error "undefined field")

199+ es <- newSmallArray len undefinedData

182− fs <- newSmallArray len (error "undefined field")

200+ fs <- newSmallArray len undefinedData

183 baseN <- copyForks es fs len forks

201 baseN <- copyForks es fs len forks

184 copySmallMutableArray es 0 es0 0 baseN

202 copySmallMutableArray es 0 es0 0 baseN

185 copySmallMutableArray fs 0 fs0 0 baseN

203 copySmallMutableArray fs 0 fs0 0 baseN

186 gen <- cloneForkIdGen gen0

204 gen <- cloneForkIdGen gen0

187 gref <- newIORef $ EnvRef len es fs

205 gref <- newIORef $ EnvRef len es fs

188− cache <- newIORef IM.empty

206+ store <- newIORef IM.empty

189− relinkData gref gen cache es fs n

207+ relinkData gref gen store es fs n

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

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

191 pure $ Env NoFork gref gen

209 pure $ Env NoFork gref gen

192{-# NOINLINE cloneEnv #-}

210{-# NOINLINE cloneEnv #-}

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

236 copySmallMutableArray fs baseIx fs0 0 n

254 copySmallMutableArray fs baseIx fs0 0 n

237 copyForks es fs baseIx forks

255 copyForks es fs baseIx forks

238

256

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

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

240

258

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

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

242relinkData

260relinkData

243 :: IORef EnvRef

261 :: IORef EnvRef

244 -> ForkIdGen

262 -> ForkIdGen

245− -> EnvRefCache

263+ -> EnvRefStore

246 -> SmallMutableArray RealWorld Any

264 -> SmallMutableArray RealWorld Any

247 -> SmallMutableArray RealWorld Any

265 -> SmallMutableArray RealWorld Any

248 -> Int

266 -> Int

249 -> IO ()

267 -> IO ()

250−relinkData gref gen cache es fs = \case

268+relinkData gref gen store es fs = \case

251 0 -> pure ()

269 0 -> pure ()

252 n -> do

270 n -> do

253 let i = n - 1

271 let i = n - 1

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

255 readSmallArray es i

273 readSmallArray es i

256 >>= f relinkEnv . fromAny

274 >>= f relinkEnv . fromAny

257 >>= writeSmallArray es i . toAny

275 >>= writeSmallArray es i . toAny

258− relinkData gref gen cache es fs i

276+ relinkData gref gen store es fs i

259 where

277 where

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

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

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

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

262 <*> pure gref

280 <*> pure gref

263 <*> pure gen

281 <*> pure gen

264

282

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

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

266−relinkForks gref gen cache = \case

284+relinkForks gref gen store = \case

267 NoFork -> pure NoFork

285 NoFork -> pure NoFork

268 Forks fid baseIx lref0 forks -> do

286 Forks fid baseIx lref0 forks -> do

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

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

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

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

271 -- containing its clone.

289 -- containing its clone.

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

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

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

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

274− <*> relinkForks gref gen cache forks

292+ <*> relinkForks gref gen store forks

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

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

276− <*> relinkForks gref gen cache forks

294+ <*> relinkForks gref gen store forks

277

295

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

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

279cloneEnvRef

297cloneEnvRef

280 :: IORef EnvRef

298 :: IORef EnvRef

281 -> ForkIdGen

299 -> ForkIdGen

282− -> EnvRefCache

300+ -> EnvRefStore

283 -> ForkId

301 -> ForkId

284 -> IORef EnvRef

302 -> IORef EnvRef

285 -> IO (IORef EnvRef)

303 -> IO (IORef EnvRef)

286−cloneEnvRef gref gen cache fid lref0 = do

304+cloneEnvRef gref gen store fid lref0 = do

287 EnvRef n es0 fs0 <- readIORef lref0

305 EnvRef n es0 fs0 <- readIORef lref0

288 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)

306 es <- cloneSmallMutableArray es0 0 (sizeofSmallMutableArray es0)

289 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

307 fs <- cloneSmallMutableArray fs0 0 (sizeofSmallMutableArray fs0)

290 ref <- newIORef $ EnvRef n es fs

308 ref <- newIORef $ EnvRef n es fs

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

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

292− relinkData gref gen cache es fs n

310+ relinkData gref gen store es fs n

293 pure ref

311 pure ref

294

312

295----------------------------------------

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

@@ -320,12 +338,6 @@ sizeEnv (Env (Forks _ baseIx lref _) _ _) = do

320 pure $ baseIx + n

338 pure $ baseIx + n

321{-# NOINLINE sizeEnv #-}

339{-# NOINLINE sizeEnv #-}

322

340

323−-- | Extract a specific data type from the environment.

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

325−getEnv env = do

326− (i, es) <- getLocation @e env

327− fromAny <$> readSmallArray es i

328−

329-- | Check that the size of the environment is the same as the expected value.

341-- | Check that the size of the environment is the same as the expected value.

330checkSizeEnv :: Int -> Env es -> IO ()

342checkSizeEnv :: Int -> Env es -> IO ()

331checkSizeEnv k (Env NoFork ref _) = do

343checkSizeEnv k (Env NoFork ref _) = do

@@ -343,7 +355,11 @@ checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do

343-- Extending and shrinking

355-- Extending and shrinking

344

356

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

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

358+--

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

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

361+-- checked anywhere.

346−unsafeConsEnv :: handler e -> Relinker handler e -> Env es -> IO (Env (e : es))

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

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

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

348 NoFork -> do

364 NoFork -> do

349 extendEnvRef gref

365 extendEnvRef gref

@@ -364,10 +380,10 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of

364 writeIORef ref $! EnvRef (n + 1) es0 fs0

380 writeIORef ref $! EnvRef (n + 1) es0 fs0

365 EQ -> do

381 EQ -> do

366 let len = doubleCapacity len0

382 let len = doubleCapacity len0

367− es <- newSmallArray len (error "undefined field")

383+ es <- newSmallArray len undefinedData

368 copySmallMutableArray es 0 es0 0 len0

384 copySmallMutableArray es 0 es0 0 len0

369 e `seq` writeSmallArray es n (toAny e)

385 e `seq` writeSmallArray es n (toAny e)

370− fs <- newSmallArray len (error "undefined field")

386+ fs <- newSmallArray len undefinedData

371 copySmallMutableArray fs 0 fs0 0 len0

387 copySmallMutableArray fs 0 fs0 0 len0

372 f `seq` writeSmallArray fs n (toAny f)

388 f `seq` writeSmallArray fs n (toAny f)

373 writeIORef ref $! EnvRef (n + 1) es fs

389 writeIORef ref $! EnvRef (n + 1) es fs

@@ -378,14 +394,13 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of

378

394

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

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

380-- the environment is as expected.

396-- the environment is as expected.

397+--

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

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

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

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

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

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

383− NoFork -> do

384− shrinkEnvRef len gref

402+ NoFork -> shrinkEnvRef len gref

385− pure $ Env NoFork gref gen

386− Forks _ baseIx lref _ -> do

387− shrinkEnvRef (len - baseIx) lref

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

388− pure $ Env fork gref gen

389 where

404 where

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

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

391 shrinkEnvRef k ref = do

406 shrinkEnvRef k ref = do

@@ -393,62 +408,79 @@ unsafeTailEnv len (Env fork gref gen) = case fork of

393 if k /= n - 1

408 if k /= n - 1

394 then error $ "k (" ++ show k ++ ") /= n - 1 (" ++ show (n - 1) ++ ")"

409 then error $ "k (" ++ show k ++ ") /= n - 1 (" ++ show (n - 1) ++ ")"

395 else do

410 else do

396− writeSmallArray es k (error "undefined field")

411+ writeSmallArray es k undefinedData

397− writeSmallArray fs k (error "undefined field")

412+ writeSmallArray fs k undefinedData

398 writeIORef ref $! EnvRef k es fs

413 writeIORef ref $! EnvRef k es fs

399{-# NOINLINE unsafeTailEnv #-}

414{-# NOINLINE unsafeTailEnv #-}

400

415

401----------------------------------------

416----------------------------------------

402-- Data retrieval and update

417-- Data retrieval and update

403

418

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

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

405−unsafePutEnv

420+getEnv

406− :: forall e es handler. e :> es

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

407− => handler e

408− -> Env es -> IO ()

422+ => Env es

409−unsafePutEnv e env = do

423+ -> IO (adapter e)

424+getEnv env = do

410− (i, es) <- getLocation @e env

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

411− e `seq` writeSmallArray es i (toAny e)

426+ fromAny <$> readSmallArray es i

412

427

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

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

414−unsafeModifyEnv

429+putEnv

415− :: forall e es handler. e :> es

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

416− => (handler e -> handler e)

417− -> Env es

431+ => Env es

432+ -> adapter e

418 -> IO ()

433 -> IO ()

419−unsafeModifyEnv f env = do

434+putEnv env e = do

420− (i, es) <- getLocation @e env

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

421− e <- f . fromAny <$> readSmallArray es i

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

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

423

437

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

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

425−unsafeStateEnv

439+stateEnv

426− :: forall e es handler a. e :> es

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

427− => (handler e -> (a, handler e))

441+ => Env es

428− -> Env es

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

429 -> IO a

443 -> IO a

430−unsafeStateEnv f env = do

444+stateEnv env f = do

431− (i, es) <- getLocation @e env

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

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

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

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

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

434 pure a

448 pure a

435

449

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

451+modifyEnv

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

453+ => Env es

454+ -> (adapter e -> adapter e)

455+ -> IO ()

456+modifyEnv env f = do

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

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

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

460+

436----------------------------------------

461----------------------------------------

437-- Internal helpers

462-- Internal helpers

438

463

464+undefinedData :: HasCallStack => a

465+undefinedData = error "undefined data"

466+

439emptyEnvRef :: IO (IORef EnvRef)

467emptyEnvRef :: IO (IORef EnvRef)

440emptyEnvRef = do

468emptyEnvRef = do

441− es <- newSmallArray 0 (error "undefined field")

469+ es <- newSmallArray 0 undefinedData

442− fs <- newSmallArray 0 (error "undefined field")

470+ fs <- newSmallArray 0 undefinedData

443 newIORef $ EnvRef 0 es fs

471 newIORef $ EnvRef 0 es fs

444

472

473+-- | Location with unboxed fields to make GHC generate Core without unnecessary

474+-- reboxing around the local 'go' function from 'getLocation'.

475+data Location = Location !Int !(SmallMutableArray RealWorld Any)

476+

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

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

446getLocation

478getLocation

447− :: forall e es. e :> es

479+ :: Int

448− => Env es

480+ -> Env es

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

481+ -> IO Location

450−getLocation (Env fork ref _) = do

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

451− EnvRef n es _ <- readIORef ref

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

452 -- Optimized for the common access pattern:

484 -- Optimized for the common access pattern:

453 --

485 --

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

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

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

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

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

458 -- specific effects for reinterpretation.

490 -- specific effects for reinterpretation.

459 case fork of

491 case fork of

460− NoFork -> pure (ix n, es)

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

461 Forks _ baseIx lref forks -> do

493 Forks _ baseIx lref forks -> do

462 EnvRef ln les _ <- readIORef lref

494 EnvRef ln les _ <- readIORef lref

463 let i = ix (baseIx + ln)

495 let i = ix (baseIx + ln)

464 if i >= baseIx

496 if i >= baseIx

465− then pure (i - baseIx, les)

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

466− else go es i forks

498+ else go es# i forks

467 where

499 where

468− go :: SmallMutableArray RealWorld Any

500+ go :: SmallMutableArray# RealWorld Any

469 -> Int

501 -> Int

470 -> Forks

502 -> Forks

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

503+ -> IO Location

472− go es i = \case

504+ go es# i = \case

473− NoFork -> pure (i, es)

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

474 Forks _ baseIx lref forks -> do

506 Forks _ baseIx lref forks -> do

475 EnvRef _ les _ <- readIORef lref

507 EnvRef _ les _ <- readIORef lref

476 if i >= baseIx

508 if i >= baseIx

477− then pure (i - baseIx, les)

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

478− else go es i forks

510+ else go es# i forks

479

511

480 ix :: Int -> Int

512 ix :: Int -> Int

481− ix n = n - reifyIndex @e @es - 1

513+ ix n = n - ixE - 1

482

514

483toAny :: a -> Any

515toAny :: a -> Any

484toAny = unsafeCoerce

516toAny = unsafeCoerce

effectful-core/src/Effectful/Internal/Monad.hsnew file+415

@@ -0,0 +1,415 @@

1+{-# LANGUAGE UndecidableInstances #-}

2+{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}

3+{-# OPTIONS_HADDOCK not-home #-}

4+-- | The 'Eff' monad.

5+--

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

7+-- in subsequent releases.

8+module Effectful.Internal.Monad

9+ ( -- * The 'Eff' monad

10+ Eff

11+ , runPureEff

12+

13+ -- ** Access to the internal representation

14+ , unEff

15+ , unsafeEff

16+ , unsafeEff_

17+

18+ -- * Fail

19+ , Fail(..)

20+

21+ -- * IO

22+ , IOE

23+ , runEff

24+

25+ -- * Prim

26+ , Prim

27+ , runPrim

28+

29+ -- * Unlift strategies

30+ , UnliftStrategy(..)

31+ , Persistence(..)

32+ , Limit(..)

33+ , unliftStrategy

34+ , withUnliftStrategy

35+ , withEffToIO

36+

37+ -- ** Low-level unlifts

38+ , seqUnliftIO

39+ , concUnliftIO

40+

41+ -- * Effects

42+

43+ -- ** Dynamic dispatch

44+ , EffectHandler

45+ , LocalEnv(..)

46+ , HandlerA(..)

47+ , runHandler

48+ , send

49+

50+ -- ** Static dispatch

51+ , DataA(..)

52+ , runData

53+ , evalData

54+ , execData

55+ , getData

56+ , putData

57+ , stateData

58+ , stateDataM

59+ , localData

60+ ) where

61+

62+import Control.Applicative (liftA2)

63+import Control.Monad.Base

64+import Control.Monad.Fix

65+import Control.Monad.IO.Class

66+import Control.Monad.IO.Unlift

67+import Control.Monad.Primitive

68+import Control.Monad.Trans.Control

69+import GHC.Exts (oneShot)

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

71+import GHC.Stack (HasCallStack)

72+import System.IO.Unsafe (unsafeDupablePerformIO)

73+import qualified Control.Exception as E

74+import qualified Control.Monad.Catch as C

75+

76+import Effectful.Internal.Effect

77+import Effectful.Internal.Env

78+import Effectful.Internal.Unlift

79+

80+type role Eff nominal representational

81+

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

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

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

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

87+-- would have the following type:

88+--

89+-- @

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

91+-- @

92+--

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

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

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

97+--

98+-- @

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

100+-- @

101+--

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

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

104+-- order.

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

106+ deriving (Monoid, Semigroup)

107+

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

109+--

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

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

112+runPureEff (Eff m) =

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

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

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

116+ --

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

118+ -- cleanup actions to run.

119+ unsafeDupablePerformIO $ m =<< emptyEnv

120+

121+----------------------------------------

122+-- Access to the internal representation

123+

124+-- | Peel off the constructor of 'Eff'.

125+unEff :: Eff es a -> Env es -> IO a

126+unEff (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.

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

133+unsafeEff m = Eff (oneShot m)

134+

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

136+--

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

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

139+unsafeEff_ :: IO a -> Eff es a

140+unsafeEff_ m = unsafeEff $ \_ -> m

141+

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

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

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

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

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

160+--

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

162+withEffToIO

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

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

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

166+ -> Eff es a

167+withEffToIO f = unliftStrategy >>= \case

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

169+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do

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

171+

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

173+seqUnliftIO

174+ :: HasCallStack

175+ => Env es

176+ -- ^ The environment.

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

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

179+ -> IO a

180+seqUnliftIO es k = seqUnlift k es unEff

181+

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

183+concUnliftIO

184+ :: HasCallStack

185+ => Env es

186+ -- ^ The environment.

187+ -> Persistence

188+ -> Limit

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

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

191+ -> IO a

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

193+

194+----------------------------------------

195+-- Base

196+

197+instance Functor (Eff es) where

198+ fmap f (Eff m) = unsafeEff $ \es -> f <$> m es

199+ a <$ Eff fb = unsafeEff $ \es -> a <$ fb es

200+

201+instance Applicative (Eff es) where

202+ pure = unsafeEff_ . pure

203+ Eff mf <*> Eff mx = unsafeEff $ \es -> mf es <*> mx es

204+ Eff ma *> Eff mb = unsafeEff $ \es -> ma es *> mb es

205+ Eff ma <* Eff mb = unsafeEff $ \es -> ma es <* mb es

206+ liftA2 f (Eff ma) (Eff mb) = unsafeEff $ \es -> liftA2 f (ma es) (mb es)

207+

208+instance Monad (Eff es) where

209+ return = unsafeEff_ . pure

210+ Eff m >>= k = unsafeEff $ \es -> m es >>= \a -> unEff (k a) es

211+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/20008

212+ Eff ma >> Eff mb = unsafeEff $ \es -> ma es >> mb es

213+

214+instance MonadFix (Eff es) where

215+ mfix f = unsafeEff $ \es -> mfix $ \a -> unEff (f a) es

216+

217+----------------------------------------

218+-- Exception

219+

220+instance C.MonadThrow (Eff es) where

221+ throwM = unsafeEff_ . E.throwIO

222+

223+instance C.MonadCatch (Eff es) where

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

225+ size <- sizeEnv es

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

227+ checkSizeEnv size es

228+ unEff (handler e) es

229+

230+instance C.MonadMask (Eff es) where

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

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

233+

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

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

236+

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

238+ size <- sizeEnv es

239+ resource <- unEff acquire es

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

241+ checkSizeEnv size es

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

243+ E.throwIO e

244+ checkSizeEnv size es

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

246+ pure (b, c)

247+

248+----------------------------------------

249+-- Fail

250+

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

252+data Fail :: Effect where

253+ Fail :: String -> Fail m a

254+

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

256+ fail = send . Fail

257+

258+----------------------------------------

259+-- IO

260+

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

262+newtype IOE :: Effect where

263+ IOE :: UnliftStrategy -> IOE m r

264+

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

266+--

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

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

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

270+

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

272+ liftIO = unsafeEff_

273+

274+-- | Use 'withEffToIO' if you want accurate stack traces on errors.

275+instance IOE :> es => MonadUnliftIO (Eff es) where

276+ withRunInIO = withEffToIO

277+

278+-- | Instance included for compatibility with existing code, usage of 'liftIO'

279+-- is preferrable.

280+instance IOE :> es => MonadBase IO (Eff es) where

281+ liftBase = unsafeEff_

282+

283+-- | Instance included for compatibility with existing code, usage of

284+-- 'withRunInIO' is preferrable.

285+instance IOE :> es => MonadBaseControl IO (Eff es) where

286+ type StM (Eff es) a = a

287+ liftBaseWith = withEffToIO

288+ restoreM = pure

289+

290+----------------------------------------

291+-- Primitive

292+

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

294+data Prim :: Effect where

295+ Prim :: Prim m r

296+

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

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

299+runPrim = evalData (DataA Prim)

300+

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

302+ type PrimState (Eff es) = RealWorld

303+ primitive = unsafeEff_ . IO

304+

305+----------------------------------------

306+-- Dynamic dispatch

307+

308+type role LocalEnv nominal nominal

309+

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

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

312+-- handler.

313+--

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

315+-- technical reasons to guarantee soundness.

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

317+

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

319+type EffectHandler e es

320+ = forall a localEs. HasCallStack

321+ => LocalEnv localEs es

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

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

324+ -> e (Eff localEs) a

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

326+ -> Eff es a

327+

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

329+--

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

331+data HandlerA :: Effect -> Type where

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

333+

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

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

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

337+ size0 <- sizeEnv es0

338+ E.bracket (unsafeConsEnv e relinker es0)

339+ (unsafeTailEnv size0)

340+ (\es -> unEff m es)

341+ where

342+ relinker :: Relinker HandlerA e

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

344+ newHandlerEs <- relink handlerEs

345+ pure $ HandlerA newHandlerEs handle

346+

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

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

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

350+ HandlerA handlerEs handle <- getEnv es

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

352+

353+----------------------------------------

354+-- Static dispatch

355+

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

357+--

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

359+-- parameters.

360+newtype DataA :: Effect -> Type where

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

362+

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

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

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

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

367+ size0 <- sizeEnv es0

368+ E.bracket (unsafeConsEnv e0 noRelinker es0)

369+ (unsafeTailEnv size0)

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

371+

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

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

376+ size0 <- sizeEnv es0

377+ E.bracket (unsafeConsEnv e noRelinker es0)

378+ (unsafeTailEnv size0)

379+ (\es -> unEff m es)

380+

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)

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

385+ size0 <- sizeEnv es0

386+ E.bracket (unsafeConsEnv e0 noRelinker es0)

387+ (unsafeTailEnv size0)

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

389+

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

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

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

393+

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

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

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

397+

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

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

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

401+

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

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

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

407+ putEnv es e

408+ pure a

409+

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

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

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

414+ (\e -> putEnv es e)

415+ (\_ -> unEff m es)

src/Effectful/Internal/Unlift.hs → effectful-core/src/Effectful/Internal/Unlift.hsrenamed+128−20

@@ -1,20 +1,30 @@

1{-# LANGUAGE MagicHash #-}

2{-# LANGUAGE UnboxedTuples #-}

3{-# OPTIONS_HADDOCK not-home #-}

4−-- | Implementation of concurrent unlifts.

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

5--

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

7-- in subsequent releases.

8module Effectful.Internal.Unlift

9− ( unsafeEphemeralConcUnliftIO

9+ ( -- * Unlifting strategies

10− , unsafePersistentConcUnliftIO

10+ UnliftStrategy(..)

11+ , Persistence(..)

12+ , Limit(..)

13+

14+ -- * Unlifting functions

15+ , seqUnlift

16+ , concUnlift

17+ , ephemeralConcUnlift

18+ , persistentConcUnlift

11 ) where

19 ) where

13import Control.Concurrent

21import Control.Concurrent

14import Control.Monad

22import Control.Monad

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

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

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

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

25+import GHC.Generics (Generic)

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

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

27+import GHC.Stack (HasCallStack)

18import GHC.Weak (Weak(..))

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

19import System.Mem.Weak (deRefWeak)

29import System.Mem.Weak (deRefWeak)

20import qualified Data.IntMap.Strict as IM

30import qualified Data.IntMap.Strict as IM

@@ -22,17 +32,113 @@ import qualified Data.IntMap.Strict as IM

22import Effectful.Internal.Env

32import Effectful.Internal.Env

23import Effectful.Internal.Utils

33import Effectful.Internal.Utils

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+

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

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

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

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

27−unsafeEphemeralConcUnliftIO

131+ephemeralConcUnlift

132+ :: HasCallStack

28− :: Int

133+ => Int

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

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

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

30 -> Env es

136 -> Env es

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

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

32 -> IO a

138 -> IO a

33−unsafeEphemeralConcUnliftIO uses k es0 unEff = do

139+ephemeralConcUnlift uses k es0 unEff = do

34− when (uses < 0) $ do

140+ unless (uses > 0) $ do

35− error $ "ephemeralConcUnliftIO: invalid number of uses: " ++ show uses

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

36 tid0 <- myThreadId

142 tid0 <- myThreadId

37 -- Create a copy of the environment as a template for the other threads to

143 -- Create a copy of the environment as a template for the other threads to

38 -- use. This can't be done from inside the callback as the environment might

144 -- use. This can't be done from inside the callback as the environment might

@@ -56,16 +162,18 @@ unsafeEphemeralConcUnliftIO uses k es0 unEff = do

162

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

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

58-- unlifting function within a particular thread.

164-- unlifting function within a particular thread.

59−unsafePersistentConcUnliftIO

165+persistentConcUnlift

166+ :: HasCallStack

60− :: Bool

167+ => Bool

61 -> Int

168 -> Int

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

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

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

63 -> Env es

171 -> Env es

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

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

65 -> IO a

173 -> IO a

66−unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do

174+persistentConcUnlift cleanUp threads k es0 unEff = do

67− when (threads < 0) $ do

175+ unless (threads > 0) $ do

68− error $ "persistentConcUnliftIO: invalid number of threads: " ++ show threads

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

69 tid0 <- myThreadId

177 tid0 <- myThreadId

70 -- Create a copy of the environment as a template for the other threads to

178 -- Create a copy of the environment as a template for the other threads to

71 -- use. This can't be done from inside the callback as the environment might

179 -- use. This can't be done from inside the callback as the environment might

@@ -84,9 +192,9 @@ unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do

84 Just es -> pure (te, es)

192 Just es -> pure (te, es)

85 Nothing -> case teCapacity te of

193 Nothing -> case teCapacity te of

86 0 -> error

194 0 -> error

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

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

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

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

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

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

90 1 -> do

198 1 -> do

91 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp

199 wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp

92 let newEntries = ThreadEntries

200 let newEntries = ThreadEntries

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

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

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

118

226

119data ThreadEntries es = ThreadEntries

227data ThreadEntries es = ThreadEntries

120− { teCapacity :: Int

228+ { teCapacity :: !Int

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

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

122 }

230 }

123

231

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

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

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

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

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

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

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

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

128

236

129data ThreadData es

237data ThreadData es

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

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

131 | NoThreadData

239 | NoThreadData

132

240

133----------------------------------------

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

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

@@ -11,17 +11,21 @@ module Effectful.Monad

11 , IOE

12 , runEff

14− -- * Primitive actions

15− , Prim

16− , runPrim

17−

18 -- ** Unlift strategies

14 -- ** Unlift strategies

19 , UnliftStrategy(..)

15 , UnliftStrategy(..)

20 , Persistence(..)

16 , Persistence(..)

21 , Limit(..)

17 , Limit(..)

22 , unliftStrategy

18 , unliftStrategy

23 , withUnliftStrategy

19 , withUnliftStrategy

20+ , withEffToIO

21+

22+ -- * Re-exports

23+ , MonadIO(..)

24+ , MonadUnliftIO(..)

24 ) where

25 ) where

27+import Control.Monad.IO.Class

28+import Control.Monad.IO.Unlift

29+

26import Effectful.Internal.Effect

30import Effectful.Internal.Effect

27import Effectful.Internal.Monad

31import Effectful.Internal.Monad

effectful-core/src/Effectful/Prim.hsnew file+7

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

1+-- | Provider of the 'MonadPrim' instance for 'Eff'.

2+module Effectful.Prim

3+ ( Prim

4+ , runPrim

5+ ) where

7+import Effectful.Internal.Monad

effectful-core/src/Effectful/Reader.hsnew file+49

@@ -0,0 +1,49 @@

1+-- | Support for access to a read only value of a particular type.

2+module Effectful.Reader

3+ ( Reader

4+ , runReader

5+ , ask

6+ , asks

7+ , local

8+ ) where

10+import Effectful.Dispatch.Static

11+import Effectful.Monad

12+

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

14+-- @r@.

15+newtype 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

22+ -> Eff es a

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

24+

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

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

27+ask = do

28+ DataA (Reader r) <- getData

29+ pure r

30+

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

32+--

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

34+asks

35+ :: Reader r :> es

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

37+ -> Eff es a

38+asks f = f <$> ask

39+

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

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

effectful-core/src/Effectful/Reader/Dynamic.hsnew file+32

@@ -0,0 +1,32 @@

1+module Effectful.Reader.Dynamic

2+ ( Reader(..)

3+ , runReader

4+ , ask

5+ , asks

6+ , local

7+ ) where

9+import Effectful.Dispatch.Dynamic

10+import Effectful.Monad

11+import qualified Effectful.Reader as R

12+

13+data Reader r :: Effect where

14+ Ask :: Reader r m r

15+ Local :: (r -> r) -> m a -> Reader r m a

16+

17+runReader :: r -> Eff (Reader r : es) a -> Eff es a

18+runReader r = reinterpret (R.runReader r) $ \env -> \case

19+ Ask -> R.ask

20+ Local f m -> localSeqUnlift env $ \unlift -> R.local f (unlift m)

21+

22+----------------------------------------

23+-- Operations

24+

25+ask :: (HasCallStack, Reader r :> es) => Eff es r

26+ask = send Ask

27+

28+asks :: (HasCallStack, Reader r :> es) => (r -> a) -> Eff es a

29+asks f = f <$> ask

30+

31+local :: (HasCallStack, Reader r :> es ) => (r -> r) -> Eff es a -> Eff es a

32+local f = send . Local f

src/Effectful/State/Dynamic.hs → effectful-core/src/Effectful/State/Dynamic.hsrenamed+38−29

@@ -1,13 +1,4 @@

1-- | The 'State' effect with dynamic dispatch.

2−--

3−-- It's not clear in which situation it's beneficial to use this instead of

4−-- "Effectful.State.Local" or "Effectful.State.Shared" as you either:

5−--

6−-- - Share state between threads and need the shared version.

7−--

8−-- - Don't share state between threads (or want it to be thread local) and are

9−-- free to use the faster, local version.

10−--

11module Effectful.State.Dynamic

2module Effectful.State.Dynamic

12 ( State(..)

3 ( State(..)

@@ -31,17 +22,15 @@ module Effectful.State.Dynamic

31 , modifyM

22 , modifyM

32 ) where

23 ) where

34−import Effectful.Handler

25+import Effectful.Dispatch.Dynamic

35import Effectful.Monad

26import Effectful.Monad

36import qualified Effectful.State.Local as L

27import qualified Effectful.State.Local as L

37import qualified Effectful.State.Shared as S

28import qualified Effectful.State.Shared as S

39−-- | Provide access to a mutable state of type @s@.

30+-- | Provide access to a mutable value of type @s@.

40−--

41−-- Whether the state is local and shareable depends on the interpretation.

42data State s :: Effect where

31data State s :: Effect where

43 Get :: State s m s

32 Get :: State s m s

44− Put :: ~s -> State s m ()

33+ Put :: s -> State s m ()

45 State :: (s -> (a, s)) -> State s m a

34 State :: (s -> (a, s)) -> State s m a

46 StateM :: (s -> m (a, s)) -> State s m a

35 StateM :: (s -> m (a, s)) -> State s m a

@@ -49,17 +38,17 @@ data State s :: Effect where

49-- Local

38-- Local

51runLocalState :: s -> Eff (State s : es) a -> Eff es (a, s)

40runLocalState :: s -> Eff (State s : es) a -> Eff es (a, s)

52−runLocalState s0 = reinterpretM (L.runState s0) localState

41+runLocalState s0 = reinterpret (L.runState s0) localState

54evalLocalState :: s -> Eff (State s : es) a -> Eff es a

43evalLocalState :: s -> Eff (State s : es) a -> Eff es a

55−evalLocalState s0 = reinterpretM (L.evalState s0) localState

44+evalLocalState s0 = reinterpret (L.evalState s0) localState

57execLocalState :: s -> Eff (State s : es) a -> Eff es s

46execLocalState :: s -> Eff (State s : es) a -> Eff es s

58−execLocalState s0 = reinterpretM (L.execState s0) localState

47+execLocalState s0 = reinterpret (L.execState s0) localState

60localState

49localState

61 :: L.State s :> es

50 :: L.State s :> es

62− => LocalEnv localEs

51+ => LocalEnv localEs es

63 -> State s (Eff localEs) a

52 -> State s (Eff localEs) a

64 -> Eff es a

53 -> Eff es a

65localState env = \case

54localState env = \case

@@ -72,17 +61,17 @@ localState env = \case

72-- Shared

61-- Shared

74runSharedState :: s -> Eff (State s : es) a -> Eff es (a, s)

63runSharedState :: s -> Eff (State s : es) a -> Eff es (a, s)

75−runSharedState s0 = reinterpretM (S.runState s0) sharedState

64+runSharedState s0 = reinterpret (S.runState s0) sharedState

77evalSharedState :: s -> Eff (State s : es) a -> Eff es a

66evalSharedState :: s -> Eff (State s : es) a -> Eff es a

78−evalSharedState s0 = reinterpretM (S.evalState s0) sharedState

67+evalSharedState s0 = reinterpret (S.evalState s0) sharedState

80execSharedState :: s -> Eff (State s : es) a -> Eff es s

69execSharedState :: s -> Eff (State s : es) a -> Eff es s

81−execSharedState s0 = reinterpretM (S.execState s0) sharedState

70+execSharedState s0 = reinterpret (S.execState s0) sharedState

83sharedState

72sharedState

84 :: S.State s :> es

73 :: S.State s :> es

85− => LocalEnv localEs

74+ => LocalEnv localEs es

86 -> State s (Eff localEs) a

75 -> State s (Eff localEs) a

87 -> Eff es a

76 -> Eff es a

88sharedState env = \case

77sharedState env = \case

@@ -94,23 +83,43 @@ sharedState env = \case

94----------------------------------------

83----------------------------------------

95-- Operations

84-- Operations

86+get

87+ :: (HasCallStack, State s :> es)

97−get :: State s :> es => Eff es s

88+ => Eff es s

98get = send Get

89get = send Get

91+gets

92+ :: (HasCallStack, State s :> es)

93+ => (s -> a)

100−gets :: State s :> es => (s -> a) -> Eff es a

94+ -> Eff es a

101gets f = f <$> get

95gets f = f <$> get

102

97+put

98+ :: (HasCallStack, State s :> es)

99+ => s

103−put :: State s :> es => s -> Eff es ()

100+ -> Eff es ()

104put = send . Put

101put = send . Put

105

102

103+state

104+ :: (HasCallStack, State s :> es)

105+ => (s -> (a, s))

106−state :: (State s :> es) => (s -> (a, s)) -> Eff es a

106+ -> Eff es a

107state = send . State

108

109−modify :: State s :> es => (s -> s) -> Eff es ()

109+modify

110+ :: (HasCallStack, State s :> es)

111+ => (s -> s)

112+ -> Eff es ()

110modify f = state (\s -> ((), f s))

113modify f = state (\s -> ((), f s))

111

114

115+stateM

116+ :: (HasCallStack, State s :> es)

112−stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a

117+ => (s -> Eff es (a, s))

118+ -> Eff es a

113stateM = send . StateM

119stateM = send . StateM

114

120

115−modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()

121+modifyM

122+ :: (HasCallStack, State s :> es)

123+ => (s -> Eff es s)

124+ -> Eff es ()

116modifyM f = stateM (\s -> ((), ) <$> f s)

125modifyM f = stateM (\s -> ((), ) <$> f s)

effectful-core/src/Effectful/State/Local.hsnew file+131

@@ -0,0 +1,131 @@

1+-- | Support for access to a mutable 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.State.Shared"),

5+--

6+-- - very fast.

7+--

8+-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from

9+-- the @transformers@ library, the 'State' effect doesn't lose state

10+-- modifications when an exception is received:

11+--

12+-- >>> import qualified Control.Monad.Trans.State.Strict as S

13+--

14+-- >>> :{

15+-- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do

16+-- S.modify (++ " there!")

17+-- error "oops"

18+-- :}

19+-- "Hi"

20+--

21+-- >>> :{

22+-- runEff . execState "Hi" . handle (\(_::ErrorCall) -> pure ()) $ do

23+-- modify (++ " there!")

24+-- error "oops"

25+-- :}

26+-- "Hi there!"

27+module Effectful.State.Local

28+ ( State

29+ , runState

30+ , evalState

31+ , execState

32+ , get

33+ , gets

34+ , put

35+ , state

36+ , modify

37+ , stateM

38+ , modifyM

39+ ) where

40+

41+import Effectful.Dispatch.Static

42+import Effectful.Monad

43+

44+-- | Provide access to a strict (WHNF), thread local, mutable value of type @s@.

45+newtype State s :: Effect where

46+ State :: s -> State s m r

47+

48+-- | Run a 'State' effect with the given initial state and return the final

49+-- value along with the final state.

50+runState

51+ :: s -- ^ An initial state.

52+ -> Eff (State s : es) a

53+ -> Eff es (a, s)

54+runState s0 m = do

55+ (a, DataA (State s)) <- runData (DataA (State s0)) m

56+ pure (a, s)

57+

58+-- | Run a 'State' effect with the given initial state and return the final

59+-- value, discarding the final state.

60+evalState

61+ :: s -- ^ An initial state.

62+ -> Eff (State s : es) a

63+ -> Eff es a -- ^ A return value.

64+evalState s = evalData (DataA (State s))

65+

66+-- | Run a 'State' effect with the given initial state and return the final

67+-- state, discarding the final value.

68+execState

69+ :: s -- ^ An initial state.

70+ -> Eff (State s : es) a

71+ -> Eff es s

72+execState s0 m = do

73+ DataA (State s) <- execData (DataA (State s0)) m

74+ pure s

75+

76+-- | Fetch the current value of the state.

77+get :: State s :> es => Eff es s

78+get = do

79+ DataA (State s) <- getData

80+ pure s

81+

82+-- | Get a function of the current state.

83+--

84+-- @'gets' f ≡ f '<$>' 'get'@

85+gets

86+ :: State s :> es

87+ => (s -> a) -- ^ The function to apply to the state.

88+ -> Eff es a

89+gets f = f <$> get

90+

91+-- | Set the current state to the given value.

92+put :: State s :> es => s -> Eff es ()

93+put s = putData (DataA (State s))

94+

95+-- | Apply the function to the current state and return a value.

96+state

97+ :: State s :> es

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

101+

102+-- | Apply the function to the current state.

103+--

104+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@

105+modify

106+ :: State s :> es

107+ => (s -> s) -- ^ The function to modify the state.

108+ -> Eff es ()

109+modify f = state $ \s -> ((), f s)

110+

111+-- | Apply the monadic function to the current state and return a value.

112+stateM

113+ :: State s :> es

114+ => (s -> Eff es (a, s)) -- ^ The function to modify the state.

115+ -> Eff es a

116+stateM f = stateDataM $ \(DataA (State s0)) -> do

117+ (a, s) <- f s0

118+ pure (a, DataA (State s))

119+

120+-- | Apply the monadic function to the current state.

121+--

122+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@

123+modifyM

124+ :: State s :> es

125+ => (s -> Eff es s) -- ^ The monadic function to modify the state.

126+ -> Eff es ()

127+modifyM f = stateM (\s -> ((), ) <$> f s)

128+

129+-- $setup

130+-- >>> import Control.Exception (ErrorCall)

131+-- >>> import Control.Monad.Catch

effectful-core/src/Effectful/State/Shared.hsnew file+127

@@ -0,0 +1,127 @@

1+-- | Support for access to a mutable 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.State.Local").

5+--

6+-- - slightly slower than "Effectful.State.Local".

7+--

8+-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from

9+-- the @transformers@ library, the 'State' effect doesn't lose state

10+-- modifications when an exception is received:

11+--

12+-- >>> import qualified Control.Monad.Trans.State.Strict as S

13+--

14+-- >>> :{

15+-- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do

16+-- S.modify (++ " there!")

17+-- error "oops"

18+-- :}

19+-- "Hi"

20+--

21+-- >>> :{

22+-- runEff . execState "Hi" . handle (\(_::ErrorCall) -> pure ()) $ do

23+-- modify (++ " there!")

24+-- error "oops"

25+-- :}

26+-- "Hi there!"

27+module Effectful.State.Shared

28+ ( State

29+ , runState

30+ , evalState

31+ , execState

32+ , get

33+ , gets

34+ , put

35+ , state

36+ , modify

37+ , stateM

38+ , modifyM

39+ ) where

40+

41+import Control.Concurrent.MVar

42+

43+import Effectful.Dispatch.Static

44+import Effectful.Monad

45+

46+-- | Provide access to a strict (WHNF), shared, mutable value of type @s@.

47+newtype State s :: Effect where

48+ State :: MVar s -> State s m r

49+

50+-- | Run a 'State' effect with the given initial state and return the final

51+-- value along with the final state.

52+runState :: s -> Eff (State s : es) a -> Eff es (a, s)

53+runState s m = do

54+ v <- unsafeEff_ $ newMVar s

55+ a <- evalData (DataA (State v)) m

56+ (a, ) <$> unsafeEff_ (readMVar v)

57+

58+-- | Run a 'State' effect with the given initial state and return the final

59+-- value, discarding the final state.

60+evalState :: s -> Eff (State s : es) a -> Eff es a

61+evalState s m = do

62+ v <- unsafeEff_ $ newMVar s

63+ evalData (DataA (State v)) m

64+

65+-- | Run a 'State' effect with the given initial state and return the final

66+-- state, discarding the final value.

67+execState :: s -> Eff (State s : es) a -> Eff es s

68+execState s m = do

69+ v <- unsafeEff_ $ newMVar s

70+ _ <- evalData (DataA (State v)) m

71+ unsafeEff_ $ readMVar v

72+

73+-- | Fetch the current value of the state.

74+get :: State s :> es => Eff es s

75+get = unsafeEff $ \es -> do

76+ DataA (State v) <- getEnv es

77+ readMVar v

78+

79+-- | Get a function of the current state.

80+--

81+-- @'gets' f ≡ f '<$>' 'get'@

82+gets :: State s :> es => (s -> a) -> Eff es a

83+gets f = f <$> get

84+

85+-- | Set the current state to the given value.

86+put :: State s :> es => s -> Eff es ()

87+put s = unsafeEff $ \es -> do

88+ DataA (State v) <- getEnv es

89+ modifyMVar_ v $ \_ -> s `seq` pure s

90+

91+-- | Apply the function to the current state and return a value.

92+--

93+-- /Note:/ this function gets an exclusive access to the state for its duration.

94+state :: State s :> es => (s -> (a, s)) -> Eff es a

95+state f = unsafeEff $ \es -> do

96+ DataA (State v) <- getEnv es

97+ modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)

98+

99+-- | Apply the function to the current state.

100+--

101+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@

102+--

103+-- /Note:/ this function gets an exclusive access to the state for its duration.

104+modify :: State s :> es => (s -> s) -> Eff es ()

105+modify f = state (\s -> ((), f s))

106+

107+-- | Apply the monadic function to the current state and return a value.

108+--

109+-- /Note:/ this function gets an exclusive access to the state for its duration.

110+stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a

111+stateM f = unsafeEff $ \es -> do

112+ DataA (State v) <- getEnv es

113+ modifyMVar v $ \s0 -> do

114+ (a, s) <- unEff (f s0) es

115+ s `seq` pure (s, a)

116+

117+-- | Apply the monadic function to the current state.

118+--

119+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@

120+--

121+-- /Note:/ this function gets an exclusive access to the state for its duration.

122+modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()

123+modifyM f = stateM (\s -> ((), ) <$> f s)

124+

125+-- $setup

126+-- >>> import Control.Exception (ErrorCall)

127+-- >>> import Control.Monad.Catch

src/Effectful/Writer/Dynamic.hs → effectful-core/src/Effectful/Writer/Dynamic.hsrenamed+21−11

@@ -15,27 +15,27 @@ module Effectful.Writer.Dynamic

15 , listens

16 ) where

18−import Effectful.Handler

18+import Effectful.Dispatch.Dynamic

19import Effectful.Monad

20import qualified Effectful.Writer.Local as L

21import qualified Effectful.Writer.Shared as S

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)

27----------------------------------------

28-- Local

30runLocalWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

31−runLocalWriter = reinterpretM L.runWriter localWriter

31+runLocalWriter = reinterpret L.runWriter localWriter

33execLocalWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

34−execLocalWriter = reinterpretM L.execWriter localWriter

34+execLocalWriter = reinterpret L.execWriter localWriter

36localWriter

37 :: (L.Writer w :> es, Monoid w)

38− => LocalEnv localEs

38+ => LocalEnv localEs es

39 -> Writer w (Eff localEs) a

40 -> Eff es a

41localWriter env = \case

@@ -46,14 +46,14 @@ localWriter env = \case

46-- Shared

48runSharedWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

49−runSharedWriter = reinterpretM S.runWriter sharedWriter

49+runSharedWriter = reinterpret S.runWriter sharedWriter

51execSharedWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

52−execSharedWriter = reinterpretM S.execWriter sharedWriter

52+execSharedWriter = reinterpret S.execWriter sharedWriter

54sharedWriter

55 :: (S.Writer w :> es, Monoid w)

56− => LocalEnv localEs

56+ => LocalEnv localEs es

57 -> Writer w (Eff localEs) a

58 -> Eff es a

59sharedWriter env = \case

@@ -63,13 +63,23 @@ sharedWriter env = \case

63----------------------------------------

64-- Operations

66−tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

66+tell

67+ :: (HasCallStack, Writer w :> es)

68+ => w

69+ -> Eff es ()

67tell = send . Tell

70tell = send . Tell

69−listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

72+listen

73+ :: (HasCallStack, Writer w :> es)

74+ => Eff es a

75+ -> Eff es (a, w)

70listen = send . Listen

76listen = send . Listen

72−listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

78+listens

79+ :: (HasCallStack, Writer w :> es)

80+ => (w -> b)

81+ -> Eff es a

82+ -> Eff es (a, b)

73listens f m = do

83listens f m = do

74 (a, w) <- listen m

84 (a, w) <- listen m

75 pure (a, f w)

85 pure (a, f w)

effectful-core/src/Effectful/Writer/Local.hsnew file+94

@@ -0,0 +1,94 @@

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.

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.

18+module Effectful.Writer.Local

19+ ( Writer

20+ , runWriter

21+ , execWriter

22+ , tell

23+ , listen

24+ , listens

25+ ) where

26+

27+import Control.Exception (onException, mask)

28+

29+import Effectful.Dispatch.Static

30+import Effectful.Monad

31+

32+-- | Provide access to a strict (WHNF), thread local, write only value of type

33+-- @w@.

34+newtype Writer w :: Effect where

35+ Writer :: w -> Writer w m r

36+

37+-- | Run a 'Writer' effect and return the final value along with the final

38+-- output.

39+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

40+runWriter m = do

41+ (a, DataA (Writer w)) <- runData (DataA (Writer mempty)) m

42+ pure (a, w)

43+

44+-- | Run a 'Writer' effect and return the final output, discarding the final

45+-- value.

46+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

47+execWriter m = do

48+ DataA (Writer w) <- execData (DataA (Writer mempty)) m

49+ pure w

50+

51+-- | Append the given output to the overall output of the 'Writer'.

52+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

53+tell w = stateData $ \(DataA (Writer w0)) -> ((), DataA (Writer (w0 <> w)))

54+

55+-- | Execute an action and append its output to the overall output of the

56+-- 'Writer'.

57+--

58+-- /Note:/ if an exception is received while the action is executed, the partial

59+-- output of the action will still be appended to the overall output of the

60+-- 'Writer':

61+--

62+-- >>> :{

63+-- runEff . execWriter @String $ do

64+-- tell "Hi"

65+-- handle (\(_::ErrorCall) -> pure ((), "")) $ do

66+-- tell " there"

67+-- listen $ do

68+-- tell "!"

69+-- error "oops"

70+-- :}

71+-- "Hi there!"

72+listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

73+listen m = unsafeEff $ \es -> mask $ \restore -> do

74+ w0 <- stateEnv es $ \(DataA (Writer w)) -> (w, DataA (Writer mempty))

75+ a <- restore (unEff m es) `onException` merge es w0

76+ (a, ) <$> merge es w0

77+ where

78+ merge es w0 =

79+ -- If an exception is thrown, restore w0 and keep parts of w1.

80+ stateEnv es $ \(DataA (Writer w1)) -> (w1, DataA (Writer (w0 <> w1)))

81+

82+-- | Execute an action and append its output to the overall output of the

83+-- 'Writer', then return the final value along with a function of the recorded

84+-- output.

85+--

86+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@

87+listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

88+listens f m = do

89+ (a, w) <- listen m

90+ pure (a, f w)

91+

92+-- $setup

93+-- >>> import Control.Exception (ErrorCall)

94+-- >>> import Control.Monad.Catch

effectful-core/src/Effectful/Writer/Shared.hsnew file+108

@@ -0,0 +1,108 @@

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.

18+module Effectful.Writer.Shared

19+ ( Writer

20+ , runWriter

21+ , execWriter

22+ , tell

23+ , listen

24+ , listens

25+ ) where

26+

27+import Control.Concurrent.MVar

28+import Control.Exception (onException, uninterruptibleMask)

29+

30+import Effectful.Dispatch.Static

31+import Effectful.Monad

32+

33+-- | Provide access to a strict (WHNF), shared, write only value of type @w@.

34+newtype Writer w :: Effect where

35+ Writer :: MVar w -> Writer w m r

36+

37+-- | Run a 'Writer' effect and return the final value along with the final

38+-- output.

39+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)

40+runWriter m = do

41+ v <- unsafeEff_ $ newMVar mempty

42+ a <- evalData (DataA (Writer v)) m

43+ (a, ) <$> unsafeEff_ (readMVar v)

44+

45+-- | Run a 'Writer' effect and return the final output, discarding the final

46+-- value.

47+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w

48+execWriter m = do

49+ v <- unsafeEff_ $ newMVar mempty

50+ _ <- evalData (DataA (Writer v)) m

51+ unsafeEff_ $ readMVar v

52+

53+-- | Append the given output to the overall output of the 'Writer'.

54+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()

55+tell w1 = unsafeEff $ \es -> do

56+ DataA (Writer v) <- getEnv es

57+ modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w

58+

59+-- | Execute an action and append its output to the overall output of the

60+-- 'Writer'.

61+--

62+-- /Note:/ if an exception is received while the action is executed, the partial

63+-- output of the action will still be appended to the overall output of the

64+-- 'Writer':

65+--

66+-- >>> :{

67+-- runEff . execWriter @String $ do

68+-- tell "Hi"

69+-- handle (\(_::ErrorCall) -> pure ((), "")) $ do

70+-- tell " there"

71+-- listen $ do

72+-- tell "!"

73+-- error "oops"

74+-- :}

75+-- "Hi there!"

76+listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)

77+listen m = unsafeEff $ \es -> do

78+ -- The mask is uninterruptible because modifyMVar_ v0 in the merge function

79+ -- might block and if an async exception is received while waiting, w1 will be

80+ -- lost.

81+ uninterruptibleMask $ \restore -> do

82+ v1 <- newMVar mempty

83+ -- Replace thread local MVar with a fresh one for isolated listening.

84+ v0 <- stateEnv es $ \(DataA (Writer v)) -> (v, DataA (Writer v1))

85+ a <- restore (unEff m es) `onException` merge es v0 v1

86+ (a, ) <$> merge es v0 v1

87+ where

88+ -- Merge results accumulated in the local MVar with the mainline. If an

89+ -- exception was received while listening, merge results recorded so far.

90+ merge es v0 v1 = do

91+ putEnv es $ DataA (Writer v0)

92+ w1 <- readMVar v1

93+ modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w

94+ pure w1

95+

96+-- | Execute an action and append its output to the overall output of the

97+-- 'Writer', then return the final value along with a function of the recorded

98+-- output.

99+--

100+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@

101+listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)

102+listens f m = do

103+ (a, w) <- listen m

104+ pure (a, f w)

105+

106+-- $setup

107+-- >>> import Control.Exception (ErrorCall)

108+-- >>> import Control.Monad.Catch

utils/Effectful/Internal/Utils.hs → effectful-core/utils/Effectful/Internal/Utils.hsrenamed

The content is the same.

utils/utils.c → effectful-core/utils/utils.crenamed

The content is the same.

effectful/CHANGELOG.mdnew file+2

@@ -0,0 +1,2 @@

1+# effectful-0.0.0.0 (2021-06-13)

2+* Initial alpha release.

effectful/LICENSEnew file+30