on master help sign in
Initial commit
commitc7a3cf7a63f84da436f415a522f5218921b319a5 authorAndrzej Rybczak <andrzej@rybczak.net> dateSat 29 May 2021, 06:22 (5 years ago)
24 files changed+1771
.github/workflows/haskell-ci.yml+255 .gitignore+6 CHANGELOG.md+2 LICENSE+30 bench/Countdown.hs+232 bench/Main.hs+50 cabal.haskell-ci+7 effective.cabal+110 src/Effective.hs+34 src/Effective/Class/Reader.hs+42 src/Effective/Class/State.hs+43 src/Effective/Class/Writer.hs+46 src/Effective/Coroutine.hs+89 src/Effective/Error.hs+62 src/Effective/Internal/Env.hs+191 src/Effective/Internal/Has.hs+35 src/Effective/Internal/Monad.hs+177 src/Effective/Internal/Utils.hs+16 src/Effective/Reader.hs+30 src/Effective/Resource.hs+44 src/Effective/State.hs+50 src/Effective/State/Dynamic.hs+114 src/Effective/State/MVar.hs+59 src/Effective/Writer.hs+47
.github/workflows/haskell-ci.ymlnew file+255
@@ -0,0 +1,255 @@
1+# This GitHub workflow config has been generated by a script via
2+#
3+# haskell-ci 'github' '--config=cabal.haskell-ci' 'effective.cabal'
4+#
5+# To regenerate the script (for example after adjusting tested-with) run
6+#
7+# haskell-ci regenerate
8+#
9+# For more information, see https://github.com/haskell-CI/haskell-ci
10+#
11+# version: 0.13.20210606
12+#
13+# REGENDATA ("0.13.20210606",["github","--config=cabal.haskell-ci","effective.cabal"])
14+#
15+name: Haskell-CI
16+on:
17+ push:
18+ branches:
19+ - master
20+ pull_request:
21+ branches:
22+ - master
23+jobs:
24+ linux:
25+ name: Haskell-CI - Linux - ${{ matrix.compiler }}
26+ runs-on: ubuntu-18.04
27+ container:
28+ image: buildpack-deps:bionic
29+ continue-on-error: ${{ matrix.allow-failure }}
30+ strategy:
31+ matrix:
32+ include:
33+ - compiler: ghc-9.2.0.20210422
34+ compilerKind: ghc
35+ compilerVersion: 9.2.0.20210422
36+ setup-method: ghcup
37+ allow-failure: true
38+ - compiler: ghc-9.0.1
39+ compilerKind: ghc
40+ compilerVersion: 9.0.1
41+ setup-method: hvr-ppa
42+ allow-failure: false
43+ - compiler: ghc-8.10.4
44+ compilerKind: ghc
45+ compilerVersion: 8.10.4
46+ setup-method: hvr-ppa
47+ allow-failure: false
48+ - compiler: ghc-8.8.4
49+ compilerKind: ghc
50+ compilerVersion: 8.8.4
51+ setup-method: hvr-ppa
52+ allow-failure: false
53+ - compiler: ghc-8.6.5
54+ compilerKind: ghc
55+ compilerVersion: 8.6.5
56+ setup-method: hvr-ppa
57+ allow-failure: false
58+ - compiler: ghc-8.4.4
59+ compilerKind: ghc
60+ compilerVersion: 8.4.4
61+ setup-method: hvr-ppa
62+ allow-failure: false
63+ - compiler: ghc-8.2.2
64+ compilerKind: ghc
65+ compilerVersion: 8.2.2
66+ setup-method: hvr-ppa
67+ allow-failure: false
68+ - compiler: ghc-8.0.2
69+ compilerKind: ghc
70+ compilerVersion: 8.0.2
71+ setup-method: hvr-ppa
72+ allow-failure: false
73+ fail-fast: false
74+ steps:
75+ - name: apt
76+ run: |
77+ apt-get update
78+ apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
79+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
80+ mkdir -p "$HOME/.ghcup/bin"
81+ curl -sL https://downloads.haskell.org/ghcup/0.1.14.1/x86_64-linux-ghcup-0.1.14.1 > "$HOME/.ghcup/bin/ghcup"
82+ chmod a+x "$HOME/.ghcup/bin/ghcup"
83+ "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
84+ "$HOME/.ghcup/bin/ghcup" install cabal 3.4.0.0
85+ else
86+ apt-add-repository -y 'ppa:hvr/ghc'
87+ apt-get update
88+ apt-get install -y "$HCNAME" cabal-install-3.4
89+ fi
90+ env:
91+ HCKIND: ${{ matrix.compilerKind }}
92+ HCNAME: ${{ matrix.compiler }}
93+ HCVER: ${{ matrix.compilerVersion }}
94+ - name: Set PATH and environment variables
95+ run: |
96+ echo "$HOME/.cabal/bin" >> $GITHUB_PATH
97+ echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
98+ echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
99+ echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
100+ HCDIR=/opt/$HCKIND/$HCVER
101+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
102+ HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
103+ echo "HC=$HC" >> "$GITHUB_ENV"
104+ echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
105+ echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
106+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.4.0.0 -vnormal+nowrap" >> "$GITHUB_ENV"
107+ else
108+ HC=$HCDIR/bin/$HCKIND
109+ echo "HC=$HC" >> "$GITHUB_ENV"
110+ echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
111+ echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
112+ echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> "$GITHUB_ENV"
113+ fi
114+
115+ HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
116+ echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
117+ echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
118+ echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
119+ if [ $((HCNUMVER >= 90200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
120+ echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
121+ echo "GHCJSARITH=0" >> "$GITHUB_ENV"
122+ env:
123+ HCKIND: ${{ matrix.compilerKind }}
124+ HCNAME: ${{ matrix.compiler }}
125+ HCVER: ${{ matrix.compilerVersion }}
126+ - name: env
127+ run: |
128+ env
129+ - name: write cabal config
130+ run: |
131+ mkdir -p $CABAL_DIR
132+ cat >> $CABAL_CONFIG <<EOF
133+ remote-build-reporting: anonymous
134+ write-ghc-environment-files: never
135+ remote-repo-cache: $CABAL_DIR/packages
136+ logs-dir: $CABAL_DIR/logs
137+ world-file: $CABAL_DIR/world
138+ extra-prog-path: $CABAL_DIR/bin
139+ symlink-bindir: $CABAL_DIR/bin
140+ installdir: $CABAL_DIR/bin
141+ build-summary: $CABAL_DIR/logs/build.log
142+ store-dir: $CABAL_DIR/store
143+ install-dirs user
144+ prefix: $CABAL_DIR
145+ repository hackage.haskell.org
146+ url: http://hackage.haskell.org/
147+ EOF
148+ if $HEADHACKAGE; then
149+ cat >> $CABAL_CONFIG <<EOF
150+ repository head.hackage.ghc.haskell.org
151+ url: https://ghc.gitlab.haskell.org/head.hackage/
152+ secure: True
153+ root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
154+ 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
155+ f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
156+ key-threshold: 3
157+ EOF
158+ fi
159+ cat $CABAL_CONFIG
160+ - name: versions
161+ run: |
162+ $HC --version || true
163+ $HC --print-project-git-commit-id || true
164+ $CABAL --version || true
165+ - name: update cabal index
166+ run: |
167+ $CABAL v2-update -v
168+ - name: cache (tools)
169+ uses: actions/cache@v2
170+ with:
171+ key: ${{ runner.os }}-${{ matrix.compiler }}-tools-60139de7
172+ path: ~/.haskell-ci-tools
173+ - name: install cabal-plan
174+ run: |
175+ mkdir -p $HOME/.cabal/bin
176+ curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
177+ echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c -
178+ xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
179+ rm -f cabal-plan.xz
180+ chmod a+x $HOME/.cabal/bin/cabal-plan
181+ cabal-plan --version
182+ - name: install doctest
183+ run: |
184+ if [ $((HCNUMVER < 90000)) -ne 0 ] ; then $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.17' ; fi
185+ if [ $((HCNUMVER < 90000)) -ne 0 ] ; then doctest --version ; fi
186+ - name: checkout
187+ uses: actions/checkout@v2
188+ with:
189+ path: source
190+ - name: initial cabal.project for sdist
191+ run: |
192+ touch cabal.project
193+ echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
194+ cat cabal.project
195+ - name: sdist
196+ run: |
197+ mkdir -p sdist
198+ $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
199+ - name: unpack
200+ run: |
201+ mkdir -p unpacked
202+ find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
203+ - name: generate cabal.project
204+ run: |
205+ PKGDIR_effective="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/effective-[0-9.]*')"
206+ echo "PKGDIR_effective=${PKGDIR_effective}" >> "$GITHUB_ENV"
207+ rm -f cabal.project cabal.project.local
208+ touch cabal.project
209+ touch cabal.project.local
210+ echo "packages: ${PKGDIR_effective}" >> cabal.project
211+ if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package effective" >> cabal.project ; fi
212+ if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi
213+ cat >> cabal.project <<EOF
214+ EOF
215+ if $HEADHACKAGE; then
216+ echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project
217+ fi
218+ $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(effective)$/; }' >> cabal.project.local
219+ cat cabal.project
220+ cat cabal.project.local
221+ - name: dump install plan
222+ run: |
223+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
224+ cabal-plan
225+ - name: cache
226+ uses: actions/cache@v2
227+ with:
228+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
229+ path: ~/.cabal/store
230+ restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
231+ - name: install dependencies
232+ run: |
233+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
234+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
235+ - name: build w/o tests
236+ run: |
237+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
238+ - name: build
239+ run: |
240+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
241+ - name: doctest
242+ run: |
243+ if [ $((HCNUMVER < 90000)) -ne 0 ] ; then cd ${PKGDIR_effective} || false ; fi
244+ if [ $((HCNUMVER < 90000)) -ne 0 ] ; then doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDefaultSignatures -XDeriveFunctor -XFlexibleContexts -XFlexibleInstances -XFunctionalDependencies -XGADTs -XGeneralizedNewtypeDeriving -XInstanceSigs -XLambdaCase -XNamedFieldPuns -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XStrictData -XTupleSections -XTypeApplications -XTypeInType -XTypeFamilies -XTypeOperators src ; fi
245+ - name: cabal check
246+ run: |
247+ cd ${PKGDIR_effective} || false
248+ ${CABAL} -vnormal check
249+ - name: haddock
250+ run: |
251+ $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
252+ - name: unconstrained build
253+ run: |
254+ rm -f cabal.project.local
255+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
.gitignorenew file+6
@@ -0,0 +1,6 @@
1+*~
2+*.swp
3+dist-*
4+dist
5+.ghc.environment.*
6+cabal.project.local
CHANGELOG.mdnew file+2
@@ -0,0 +1,2 @@
1+# effective-0.1.0.0 (2021-mm-dd)
2+* Initial release.
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2021, Andrzej Rybczak
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
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.
bench/Countdown.hsnew file+232
@@ -0,0 +1,232 @@
1+{-# LANGUAGE CPP #-}
2+module Countdown where
3+
4+import Data.Functor.Identity
5+
6+import qualified Control.Monad.Reader as M
7+import qualified Control.Monad.State as M
8+
9+import qualified Effective as E
10+import qualified Effective.Reader as E
11+import qualified Effective.State as E
12+import qualified Effective.State.Dynamic as DE
13+
14+#ifdef VERSION_freer_simple
15+import qualified Control.Monad.Freer as FS
16+import qualified Control.Monad.Freer.Reader as FS
17+import qualified Control.Monad.Freer.State as FS
18+#endif
19+
20+#ifdef VERSION_eff
21+import qualified Control.Effect as L
22+#endif
23+
24+#ifdef VERSION_fused_effects
25+import qualified Control.Algebra as FE
26+import qualified Control.Carrier.Reader as FE
27+import qualified Control.Carrier.State.Strict as FE
28+#endif
29+
30+#ifdef VERSION_polysemy
31+import qualified Polysemy as P
32+import qualified Polysemy.Reader as P
33+import qualified Polysemy.State as P
34+#endif
35+
36+----------------------------------------
37+-- reference
38+
39+countdownRef :: Integer -> (Integer, Integer)
40+countdownRef n = if n <= 0 then (n, n) else countdownRef $ n - 1
41+{-# NOINLINE countdownRef #-}
42+
43+----------------------------------------
44+-- mtl
45+
46+programMtl :: M.MonadState Integer m => m Integer
47+programMtl = do
48+ n <- M.get @Integer
49+ if n <= 0
50+ then pure n
51+ else do
52+ M.put (n - 1)
53+ programMtl
54+{-# NOINLINE programMtl #-}
55+
56+countdownMtl :: Integer -> (Integer, Integer)
57+countdownMtl n = flip M.runState n $ programMtl
58+
59+countdownMtlDeep :: Integer -> (Integer, Integer)
60+countdownMtlDeep n = runIdentity
61+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
62+ . flip M.runStateT n
63+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
64+ $ programMtl
65+ where
66+ runR = flip M.runReaderT ()
67+
68+----------------------------------------
69+-- effective (static)
70+
71+programEffectiveStatic :: E.State Integer E.:> es => E.Eff es Integer
72+programEffectiveStatic = do
73+ n <- E.get @Integer
74+ if n <= 0
75+ then pure n
76+ else do
77+ E.put (n - 1)
78+ programEffectiveStatic
79+{-# NOINLINE programEffectiveStatic #-}
80+
81+countdownEffectiveStatic :: Integer -> IO (Integer, Integer)
82+countdownEffectiveStatic n = E.runEff . E.runState n $ programEffectiveStatic
83+
84+countdownEffectiveStaticDeep :: Integer -> IO (Integer, Integer)
85+countdownEffectiveStaticDeep n = E.runEff
86+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
87+ . E.runState n
88+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
89+ $ programEffectiveStatic
90+ where
91+ runR = E.runReader ()
92+
93+----------------------------------------
94+-- effective (dynamic)
95+
96+programEffectiveDynamic :: DE.State Integer E.:> es => E.Eff es Integer
97+programEffectiveDynamic = do
98+ n <- DE.get @Integer
99+ if n <= 0
100+ then pure n
101+ else do
102+ DE.put (n - 1)
103+ programEffectiveDynamic
104+{-# NOINLINE programEffectiveDynamic #-}
105+
106+countdownEffectiveDynamic :: Integer -> IO (Integer, Integer)
107+countdownEffectiveDynamic n = E.runEff . DE.runState n $ programEffectiveDynamic
108+
109+countdownEffectiveDynamicDeep :: Integer -> IO (Integer, Integer)
110+countdownEffectiveDynamicDeep n = E.runEff
111+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
112+ . DE.runState n
113+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
114+ $ programEffectiveDynamic
115+ where
116+ runR = E.runReader ()
117+
118+----------------------------------------
119+-- fused-effects
120+
121+#ifdef VERSION_fused_effects
122+
123+programFusedEffects :: FE.Has (FE.State Integer) sig m => m Integer
124+programFusedEffects = do
125+ n <- FE.get @Integer
126+ if n <= 0
127+ then pure n
128+ else do
129+ FE.put (n - 1)
130+ programFusedEffects
131+{-# NOINLINE programFusedEffects #-}
132+
133+countdownFusedEffects :: Integer -> (Integer, Integer)
134+countdownFusedEffects n = FE.run . FE.runState n $ programFusedEffects
135+
136+countdownFusedEffectsDeep :: Integer -> (Integer, Integer)
137+countdownFusedEffectsDeep n = FE.run
138+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
139+ . FE.runState n
140+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
141+ $ programFusedEffects
142+ where
143+ runR = FE.runReader ()
144+
145+#endif
146+
147+----------------------------------------
148+-- polysemy
149+
150+#ifdef VERSION_polysemy
151+
152+programPolysemy :: P.Member (P.State Integer) r => P.Sem r Integer
153+programPolysemy = do
154+ n <- P.get @Integer
155+ if n <= 0
156+ then pure n
157+ else do
158+ P.put (n - 1)
159+ programPolysemy
160+{-# NOINLINE programPolysemy #-}
161+
162+countdownPolysemy :: Integer -> (Integer, Integer)
163+countdownPolysemy n = P.run . P.runState n $ programPolysemy
164+
165+countdownPolysemyDeep :: Integer -> (Integer, Integer)
166+countdownPolysemyDeep n = P.run
167+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
168+ . P.runState n
169+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
170+ $ programPolysemy
171+ where
172+ runR = P.runReader ()
173+
174+#endif
175+
176+----------------------------------------
177+-- eff
178+
179+#ifdef VERSION_eff
180+
181+programEff :: L.State Integer L.:< es => L.Eff es Integer
182+programEff = do
183+ n <- L.get @Integer
184+ if n <= 0
185+ then pure n
186+ else do
187+ L.put (n - 1)
188+ programEff
189+{-# NOINLINE programEff #-}
190+
191+countdownEff :: Integer -> (Integer, Integer)
192+countdownEff n = L.run . L.runState n $ programEff
193+
194+countdownEffDeep :: Integer -> (Integer, Integer)
195+countdownEffDeep n = L.run
196+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
197+ . L.runState n
198+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
199+ $ programEff
200+ where
201+ runR = L.runReader ()
202+
203+#endif
204+
205+----------------------------------------
206+-- freer-simple
207+
208+#ifdef VERSION_freer_simple
209+
210+programFreerSimple :: FS.Member (FS.State Integer) es => FS.Eff es Integer
211+programFreerSimple = do
212+ n <- FS.get @Integer
213+ if n <= 0
214+ then pure n
215+ else do
216+ FS.put (n - 1)
217+ programFreerSimple
218+{-# NOINLINE programFreerSimple #-}
219+
220+countdownFreerSimple :: Integer -> (Integer, Integer)
221+countdownFreerSimple n = FS.run . FS.runState n $ programFreerSimple
222+
223+countdownFreerSimpleDeep :: Integer -> (Integer, Integer)
224+countdownFreerSimpleDeep n = FS.run
225+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
226+ . FS.runState n
227+ . runR . runR . runR . runR . runR . runR . runR . runR . runR . runR
228+ $ programFreerSimple
229+ where
230+ runR = FS.runReader ()
231+
232+#endif
bench/Main.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# LANGUAGE CPP #-}
2+module Main where
3+
4+import Test.Tasty.Bench
5+
6+import Countdown
7+
8+main :: IO ()
9+main = defaultMain
10+ [ bgroup "countdown"
11+ [ bgroup "reference" $ mkCountdown nf countdownRef
12+ , bgroup "shallow"
13+ [ bgroup "effective (S)" $ mkCountdown nfAppIO countdownEffectiveStatic
14+ , bgroup "effective (D)" $ mkCountdown nfAppIO countdownEffectiveDynamic
15+#ifdef VERSION_freer_simple
16+ , bgroup "freer-simple" $ mkCountdown nf countdownFreerSimple
17+#endif
18+#ifdef VERSION_eff
19+ , bgroup "eff" $ mkCountdown nf countdownEff
20+#endif
21+ , bgroup "mtl" $ mkCountdown nf countdownMtl
22+#ifdef VERSION_fused_effects
23+ , bgroup "fused-effects" $ mkCountdown nf countdownFusedEffects
24+#endif
25+#ifdef VERSION_polysemy
26+ , bgroup "polysemy" $ mkCountdown nf countdownPolysemy
27+#endif
28+ ]
29+ , bgroup "deep"
30+ [ bgroup "effective (S)" $ mkCountdown nfAppIO countdownEffectiveStaticDeep
31+ , bgroup "effective (D)" $ mkCountdown nfAppIO countdownEffectiveDynamicDeep
32+#ifdef VERSION_eff
33+ , bgroup "eff" $ mkCountdown nf countdownEffDeep
34+#endif
35+#ifdef VERSION_freer_simple
36+ , bgroup "freer-simple" $ mkCountdown nf countdownFreerSimpleDeep
37+#endif
38+#ifdef VERSION_polysemy
39+ , bgroup "polysemy" $ mkCountdown nf countdownPolysemyDeep
40+#endif
41+ , bgroup "mtl" $ mkCountdown nf countdownMtlDeep
42+#ifdef VERSION_fused_effects
43+ , bgroup "fused-effects" $ mkCountdown nf countdownFusedEffectsDeep
44+#endif
45+ ]
46+ ]
47+ ]
48+
49+mkCountdown :: (nf -> Integer -> Benchmarkable) -> nf -> [Benchmark]
50+mkCountdown f g = map (\n -> bench (show n) $ f g n) [100, 1000, 10000]
cabal.haskell-cinew file+7
@@ -0,0 +1,7 @@
1+branches: master
2+
3+doctest: <9
4+tests: True
5+benchmarks: True
6+
7+ghcup-jobs: >=9.2
effective.cabalnew file+110
@@ -0,0 +1,110 @@
1+cabal-version: 2.4
2+build-type: Simple
3+name: effective
4+version: 0.1.0.0
5+license: BSD-3-Clause
6+license-file: LICENSE
7+category: Control
8+maintainer: andrzej@rybczak.net
9+author: Andrzej Rybczak
10+synopsis: An effect system based on the ReaderT design pattern.
11+
12+description: An effect system based on the ReaderT design pattern, combining
13+ advantages of both.
14+
15+extra-source-files: CHANGELOG.md
16+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4
17+ || ==9.0.1 || ==9.2.0.20210422
18+
19+bug-reports: https://github.com/arybczak/effective/issues
20+source-repository head
21+ type: git
22+ location: https://github.com/arybczak/effective.git
23+
24+common language
25+ ghc-options: -Wall
26+
27+ default-language: Haskell2010
28+
29+ default-extensions: BangPatterns
30+ ConstraintKinds
31+ DataKinds
32+ DefaultSignatures
33+ DeriveFunctor
34+ FlexibleContexts
35+ FlexibleInstances
36+ FunctionalDependencies
37+ GADTs
38+ GeneralizedNewtypeDeriving
39+ InstanceSigs
40+ LambdaCase
41+ NamedFieldPuns
42+ RankNTypes
43+ RecordWildCards
44+ RoleAnnotations
45+ ScopedTypeVariables
46+ StandaloneDeriving
47+ StrictData
48+ TupleSections
49+ TypeApplications
50+ TypeInType
51+ TypeFamilies
52+ TypeOperators
53+
54+library
55+ import: language
56+
57+ build-depends: base <5
58+ , exceptions
59+ , ghc-prim
60+ , monad-control
61+ , primitive
62+ , resourcet
63+ , transformers
64+ , transformers-base
65+ , unliftio-core
66+
67+ hs-source-dirs: src
68+
69+ exposed-modules: Effective
70+ Effective.Class.Reader
71+ Effective.Class.State
72+ Effective.Class.Writer
73+ Effective.Coroutine
74+ Effective.Error
75+ Effective.Internal.Env
76+ Effective.Internal.Has
77+ Effective.Internal.Monad
78+ Effective.Internal.Utils
79+ Effective.Reader
80+ Effective.Resource
81+ Effective.State
82+ Effective.State.Dynamic
83+ Effective.State.MVar
84+ Effective.Writer
85+
86+benchmark bench
87+ import: language
88+
89+ ghc-options: -threaded -rtsopts -with-rtsopts=-T
90+
91+ if impl(ghc >= 8.2 && < 9.2)
92+ build-depends: fused-effects
93+
94+ if impl(ghc >= 8.4 && < 9)
95+ build-depends: polysemy
96+
97+ if impl(ghc < 9)
98+ build-depends: freer-simple
99+
100+ build-depends: base <5
101+ , effective
102+ , mtl
103+ , tasty-bench
104+
105+ hs-source-dirs: bench
106+
107+ type: exitcode-stdio-1.0
108+ main-is: Main.hs
109+
110+ other-modules: Countdown
src/Effective.hsnew file+34
@@ -0,0 +1,34 @@
1+module Effective
2+ ( -- * The 'Eff' monad
3+ Eff
4+ , runEff
5+ , Effect
6+ , (:>)
7+
8+ -- * The IO effect
9+ , IOE
10+ , runIOE
11+
12+ -- * Execution of IO in effect handlers
13+ , impureEff
14+ , impureEff_
15+
16+ -- * Helpers for defining new effects
17+
18+ -- ** Running
19+ , runEffect
20+ , evalEffect
21+ , execEffect
22+
23+ -- ** Retrieval and modification
24+ , getEffect
25+ , putEffect
26+ , stateEffect
27+ , localEffect
28+ , listenEffect
29+ , readerEffectM
30+ , stateEffectM
31+ ) where
32+
33+import Effective.Internal.Has
34+import Effective.Internal.Monad
src/Effective/Class/Reader.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+module Effective.Class.Reader
3+ ( MonadReader(..)
4+ , asks
5+ ) where
6+
7+import Control.Monad.Trans.Class
8+import Control.Monad.Trans.Control
9+
10+import Effective.Internal.Has
11+import Effective.Internal.Monad
12+import qualified Effective.Reader as R
13+
14+-- | Compatiblity layer for a transition period from MTL-style effect handling
15+-- to 'Effective.Eff'.
16+class Monad m => MonadReader r m where
17+ {-# MINIMAL (ask | reader), local #-}
18+ ask :: m r
19+ ask = reader id
20+
21+ local :: (r -> r) -> m a -> m a
22+
23+ reader :: (r -> a) -> m a
24+ reader f = ask >>= pure . f
25+
26+-- | Generic, overlappable instance.
27+instance {-# OVERLAPPABLE #-}
28+ ( MonadReader r m
29+ , MonadTransControl t
30+ , Monad (t m)
31+ ) => MonadReader r (t m) where
32+ ask = lift ask
33+ local f m = liftWith (\run -> local f (run m)) >>= restoreT . pure
34+ reader = lift . reader
35+
36+instance R.Reader r :> es => MonadReader r (Eff es) where
37+ ask = R.ask
38+ local = R.local
39+ reader = R.reader
40+
41+asks :: MonadReader r m => (r -> a) -> m a
42+asks = reader
src/Effective/Class/State.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+module Effective.Class.State where
3+
4+import Control.Monad.Trans.Class
5+
6+import Effective.Internal.Has
7+import Effective.Internal.Monad
8+import qualified Effective.State.Dynamic as S
9+
10+-- | Compatiblity layer for a transition period from MTL-style effect handling
11+-- to 'Effective.Eff'.
12+class Monad m => MonadState s m where
13+ {-# MINIMAL state | get, put #-}
14+
15+ get :: m s
16+ get = state (\s -> (s, s))
17+
18+ put :: s -> m ()
19+ put s = state (\_ -> ((), s))
20+
21+ state :: (s -> (a, s)) -> m a
22+ state f = do
23+ (a, s) <- f <$> get
24+ s `seq` put s
25+ pure a
26+
27+-- | Generic, overlappable instance.
28+instance {-# OVERLAPPABLE #-}
29+ ( MonadState s m
30+ , MonadTrans t
31+ , Monad (t m)
32+ ) => MonadState s (t m) where
33+ get = lift get
34+ put = lift . put
35+ state = lift . state
36+
37+instance S.State s :> es => MonadState s (Eff es) where
38+ get = S.get
39+ put = S.put
40+ state = S.state
41+
42+modify :: MonadState s m => (s -> s) -> m ()
43+modify f = state (\s -> ((), f s))
src/Effective/Class/Writer.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+module Effective.Class.Writer where
3+
4+import Control.Monad.Trans.Class
5+import Control.Monad.Trans.Control
6+
7+import Effective.Internal.Has
8+import Effective.Internal.Monad
9+import qualified Effective.Writer as W
10+
11+-- | Compatiblity layer for a transition period from MTL-style effect handling
12+-- to 'Effective.Eff'.
13+class Monad m => MonadWriter w m where
14+ {-# MINIMAL (writer | tell), listen #-}
15+
16+ writer :: (a, w) -> m a
17+ writer (a, w) = do
18+ tell w
19+ pure a
20+
21+ tell :: w -> m ()
22+ tell w = writer ((), w)
23+
24+ listen :: m a -> m (a, w)
25+
26+-- | Generic, overlappable instance.
27+instance {-# OVERLAPPABLE #-}
28+ ( MonadWriter w m
29+ , MonadTransControl t
30+ , Monad (t m)
31+ ) => MonadWriter w (t m) where
32+ writer = lift . writer
33+ tell = lift . tell
34+ listen m = do
35+ (stT, w) <- liftWith $ \run -> listen (run m)
36+ (, w) <$> restoreT (pure stT)
37+
38+instance (W.Writer w :> es, Monoid w) => MonadWriter w (Eff es) where
39+ writer = W.writer
40+ tell = W.tell
41+ listen = W.listen
42+
43+listens :: MonadWriter w m => (w -> b) -> m a -> m (a, b)
44+listens f m = do
45+ (a, w) <- listen m
46+ pure (a, f w)
src/Effective/Coroutine.hsnew file+89
@@ -0,0 +1,89 @@
1+-- | Experimental support for coroutines.
2+module Effective.Coroutine
3+ ( Coroutine
4+ , Status(..)
5+ , runCoroutine
6+ , yield
7+ ) where
8+
9+import Control.Concurrent.MVar
10+import Control.Exception
11+import Data.Function
12+import qualified Control.Concurrent as C
13+
14+import Effective.Internal.Env
15+import Effective.Internal.Has
16+import Effective.Internal.Monad
17+
18+data Coroutine o i = forall es r. Coroutine
19+ { crInput :: MVar (i, Env es)
20+ , crState :: MVar (State o r)
21+ , crCallerEnvSize :: Int
22+ }
23+
24+data Status es o i r
25+ = Done r
26+ | Yielded o (i -> Eff es (Status es o i r))
27+
28+runCoroutine :: Eff (Coroutine o i : es) r -> Eff es (Status es o i r)
29+runCoroutine (Eff m) = impureEff $ \es -> do
30+ size <- sizeEnv es
31+ mvInput <- newEmptyMVar
32+ mvState <- newEmptyMVar
33+ mask $ \restore -> do
34+ -- Create a worker thread and continue execution there.
35+ tid <- C.forkIO $ do
36+ let cr = Coroutine mvInput mvState size
37+ er <- try $ restore . m =<< unsafeConsEnv cr es
38+ tryPutMVar mvState (either Failure Success er) >>= \case
39+ False -> error "unexpected"
40+ True -> pure ()
41+ waitForStatus restore es size tid mvInput mvState
42+
43+yield :: Coroutine o i :> es => o -> Eff es i
44+yield o = impureEff $ \es -> mask $ \restore -> do
45+ Coroutine{..} <- getEnv es
46+ size <- sizeEnv es
47+ -- Save local part of the environment as the caller will discard it.
48+ localEs <- takeLastEnv (size - crCallerEnvSize) es
49+ -- Pass control to the caller.
50+ tryPutMVar crState (Yield o) >>= \case
51+ False -> error "unexpected"
52+ True -> do
53+ (i, callerEs) <- restore $ takeMVar crInput
54+ -- The caller resumed, reconstruct the local environment. The environment
55+ -- needs to be replaced since the one we just got might be completely
56+ -- different to what we had before suspending the computation, e.g. if the
57+ -- computation was resumed in a different thread.
58+ unsafeReplaceEnv es =<< unsafeAppendEnv callerEs localEs
59+ pure i
60+
61+----------------------------------------
62+-- Internal
63+
64+data State o r where
65+ Failure :: SomeException -> State o r
66+ Success :: r -> State o r
67+ Yield :: o -> State o r
68+
69+waitForStatus
70+ :: (forall a. IO a -> IO a)
71+ -> Env es
72+ -> Int
73+ -> C.ThreadId
74+ -> MVar (i, Env es)
75+ -> MVar (State o r)
76+ -> IO (Status es o i r)
77+waitForStatus restore0 es0 size0 tid mvInput mvState = fix $ \loop -> do
78+ try @SomeException (restore0 $ takeMVar mvState) >>= \case
79+ Left e -> throwTo tid e >> loop
80+ Right (Failure e) -> throwIO e
81+ Right (Success r) -> Done r <$ unsafeTrimEnv size0 es0
82+ Right (Yield o) -> Yielded o k <$ unsafeTrimEnv size0 es0
83+ where
84+ k i = impureEff $ \es -> mask $ \restore -> do
85+ size <- sizeEnv es
86+ -- Resume suspended computation with the current environment.
87+ tryPutMVar mvInput (i, es) >>= \case
88+ False -> error "unexpected"
89+ True -> waitForStatus restore es size tid mvInput mvState
src/Effective/Error.hsnew file+62
@@ -0,0 +1,62 @@
1+-- | Support for checked exceptions.
2+module Effective.Error
3+ ( Error
4+ , runError
5+ , throwError
6+ , catchError
7+ , tryError
8+ ) where
9+
10+import Control.Exception
11+import Data.Typeable
12+import GHC.Stack
13+
14+import Effective.Internal.Env
15+import Effective.Internal.Has
16+import Effective.Internal.Monad
17+import Effective.Internal.Utils
18+
19+type role Error nominal
20+data Error e = Error
21+
22+runError
23+ :: forall e es a. Exception e
24+ => Eff (Error e : es) a
25+ -> Eff es (Either ([String], e) a)
26+runError (Eff m) = impureEff $ \es0 -> mask $ \release -> do
27+ size <- sizeEnv es0
28+ es <- unsafeConsEnv (Error @e) es0
29+ try (release $ m es) >>= \case
30+ Right a -> Right a <$ unsafeTrimEnv size es
31+ Left (WrapE cs e) -> Left (cs, e) <$ unsafeTrimEnv size es
32+
33+throwError
34+ :: (HasCallStack, Exception e, Error e :> es)
35+ => e
36+ -> Eff es a
37+throwError e = impureEff_ $ do
38+ throwIO $ WrapE (ppCallStack <$> getCallStack callStack) e
39+
40+catchError
41+ :: (Exception e, Error e :> es)
42+ => Eff es a
43+ -> ([String] -> e -> Eff es a)
44+ -> Eff es a
45+catchError (Eff m) handler = impureEff $ \es -> do
46+ size <- sizeEnv es
47+ m es `catch` \(WrapE e cs) -> do
48+ checkSizeEnv size es
49+ unEff (handler e cs) es
50+
51+tryError
52+ :: (Exception e, Error e :> es)
53+ => Eff es a
54+ -> Eff es (Either ([String], e) a)
55+tryError m = (Right <$> m) `catchError` \es e -> pure (Left (es, e))
56+
57+----------------------------------------
58+-- WrapE
59+
60+data WrapE e = WrapE [String] e
61+ deriving Show
62+instance (Show e, Typeable e) => Exception (WrapE e)
src/Effective/Internal/Env.hsnew file+191
@@ -0,0 +1,191 @@
1+{-# OPTIONS_HADDOCK not-home #-}
2+-- | The enviroment for 'Effective.Internal.Monad.Eff'.
3+--
4+-- This module is intended for internal use only, and may change without warning
5+-- in subsequent releases.
6+module Effective.Internal.Env
7+ ( Env
8+
9+ -- * Safe operations
10+ , emptyEnv
11+ , cloneEnv
12+ , sizeEnv
13+ , takeLastEnv
14+ , getEnv
15+ , checkSizeEnv
16+
17+ -- * Extending and shrinking
18+ , unsafeReplaceEnv
19+ , unsafeConsEnv
20+ , unsafeAppendEnv
21+ , unsafeTrimEnv
22+
23+ -- * Data retrieval and update
24+ , unsafePutEnv
25+ , unsafeModifyEnv
26+ , unsafeStateEnv
27+ ) where
28+
29+import Control.Monad
30+import Control.Monad.Primitive
31+import Data.IORef
32+import Data.Primitive.SmallArray
33+import GHC.Exts (Any)
34+import GHC.Stack
35+import Unsafe.Coerce
36+
37+import Effective.Internal.Has
38+
39+type role Env nominal
40+
41+-- | A mutable, extensible record indexed by effect data types.
42+newtype Env (es :: [Effect]) = Env (IORef EnvRef)
43+
44+data EnvRef = EnvRef Int (SmallMutableArray RealWorld Any)
45+
46+-- | Create an empty environment.
47+emptyEnv :: IO (Env '[])
48+emptyEnv = fmap Env . newIORef . EnvRef 0
49+ =<< newSmallArray 0 (error "undefined field")
50+
51+-- | Clone the environment.
52+cloneEnv :: Env es -> IO (Env es)
53+cloneEnv (Env ref) = do
54+ EnvRef n es <- readIORef ref
55+ fmap Env . newIORef . EnvRef n
56+ =<< cloneSmallMutableArray es 0 (sizeofSmallMutableArray es)
57+
58+-- | Get the current size of the environment.
59+sizeEnv :: Env es -> IO Int
60+sizeEnv (Env ref) = do
61+ EnvRef n _ <- readIORef ref
62+ pure n
63+
64+-- | Take last @k@ values from the top of the environment.
65+takeLastEnv :: HasCallStack => Int -> Env es0 -> IO (Env es)
66+takeLastEnv k (Env ref) = do
67+ EnvRef n es <- readIORef ref
68+ if k > n
69+ then error $ "k (" ++ show k ++ ") > n (" ++ show n ++ ")"
70+ else fmap Env . newIORef . EnvRef k =<< cloneSmallMutableArray es (n - k) k
71+
72+-- | Extract a specific data type from the environment.
73+getEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO e
74+getEnv (Env ref) = do
75+ EnvRef n es <- readIORef ref
76+ fromAny <$> readSmallArray es (ixEnv @e @es n)
77+
78+-- | Check that the size of the environment is the same as the expected value.
79+checkSizeEnv :: HasCallStack => Int -> Env es -> IO ()
80+checkSizeEnv k (Env ref) = do
81+ EnvRef n _ <- readIORef ref
82+ when (k /= n) . error $ "k (" ++ show k ++ ") /= n (" ++ show n ++ ")"
83+
84+----------------------------------------
85+-- Extending and shrinking
86+
87+-- | Replace the first argument with the second one in place.
88+unsafeReplaceEnv :: HasCallStack => Env es -> Env es -> IO ()
89+unsafeReplaceEnv (Env ref0) (Env ref1) = writeIORef ref0 =<< readIORef ref1
90+
91+-- | Extend the environment with a new data type in place.
92+unsafeConsEnv :: HasCallStack => e -> Env es -> IO (Env (e : es))
93+unsafeConsEnv e (Env ref) = do
94+ EnvRef n es0 <- readIORef ref
95+ let len = sizeofSmallMutableArray es0
96+ case n `compare` len of
97+ GT -> error $ "n (" ++ show n ++ ") > len (" ++ show len ++ ")"
98+ LT -> do
99+ e `seq` writeSmallArray es0 n (toAny e)
100+ writeIORef ref $! EnvRef (n + 1) es0
101+ EQ -> do
102+ let newLen = max 1 len * 2
103+ es <- newSmallArray newLen (error "undefined field")
104+ copySmallMutableArray es 0 es0 0 len
105+ e `seq` writeSmallArray es n (toAny e)
106+ writeIORef ref $! EnvRef (n + 1) es
107+ pure $ Env ref
108+{-# NOINLINE unsafeConsEnv #-}
109+
110+-- | Extend the first environment with the second one in place.
111+unsafeAppendEnv :: HasCallStack => Env es0 -> Env es1 -> IO (Env es)
112+unsafeAppendEnv (Env ref0) (Env ref1) = do
113+ EnvRef n0 es0 <- readIORef ref0
114+ EnvRef n1 es1 <- readIORef ref1
115+ let n = n0 + n1
116+ if n <= sizeofSmallMutableArray es0
117+ then do
118+ copySmallMutableArray es0 n0 es1 0 n1
119+ writeIORef ref0 $! EnvRef n es0
120+ pure $ Env ref0
121+ else do
122+ es <- newSmallArray n (error "undefined field")
123+ copySmallMutableArray es 0 es0 0 n0
124+ copySmallMutableArray es n0 es1 0 n1
125+ writeIORef ref0 $! EnvRef n es
126+ pure $ Env ref0
127+{-# NOINLINE unsafeAppendEnv #-}
128+
129+-- | Trim the environment to the given size in place.
130+unsafeTrimEnv :: HasCallStack => Int -> Env es -> IO (Env es0)
131+unsafeTrimEnv k (Env ref) = do
132+ EnvRef n es <- readIORef ref
133+ if k > n
134+ then error $ "k (" ++ show k ++ ") > n (" ++ show n ++ ")"
135+ else do
136+ overwrite es k (n - k)
137+ writeIORef ref $! EnvRef k es
138+ pure $ Env ref
139+ where
140+ overwrite es base = \case
141+ 0 -> pure ()
142+ i -> do
143+ writeSmallArray es (base + i - 1) (error "undefined field")
144+ overwrite es base (i - 1)
145+{-# NOINLINE unsafeTrimEnv #-}
146+
147+----------------------------------------
148+-- Data retrieval and update
149+
150+-- | Replace the data type in the environment with a new value in place.
151+unsafePutEnv
152+ :: forall e es. (HasCallStack, e :> es)
153+ => e
154+ -> Env es
155+ -> IO ()
156+unsafePutEnv e (Env ref) = do
157+ EnvRef n es <- readIORef ref
158+ e `seq` writeSmallArray es (ixEnv @e @es n) (toAny e)
159+
160+-- | Modify the data type in the environment in place.
161+unsafeModifyEnv
162+ :: forall e es. (HasCallStack, e :> es)
163+ => (e -> e)
164+ -> Env es
165+ -> IO ()
166+unsafeModifyEnv f (Env ref) = do
167+ EnvRef n es <- readIORef ref
168+ let i = ixEnv @e @es n
169+ e <- f . fromAny <$> readSmallArray es i
170+ e `seq` writeSmallArray es i (toAny e)
171+
172+-- | Modify the data type in the enviroment in place and return a value.
173+unsafeStateEnv
174+ :: forall e es a. (HasCallStack, e :> es)
175+ => (e -> (a, e))
176+ -> Env es -> IO a
177+unsafeStateEnv f (Env ref) = do
178+ EnvRef n es <- readIORef ref
179+ let i = ixEnv @e @es n
180+ (a, e) <- f . fromAny <$> readSmallArray es i
181+ e `seq` writeSmallArray es i (toAny e)
182+ pure a
183+
184+----------------------------------------
185+-- Internal helpers
186+
187+toAny :: a -> Any
188+toAny = unsafeCoerce
189+
190+fromAny :: Any -> a
191+fromAny = unsafeCoerce
src/Effective/Internal/Has.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE UndecidableInstances #-}
3+{-# OPTIONS_HADDOCK not-home #-}
4+-- | Type-safe indexing for 'Effective.Internal.Monad.Env'.
5+--
6+-- This module is intended for internal use only, and may change without warning
7+-- in subsequent releases.
8+module Effective.Internal.Has
9+ ( Effect
10+ , (:>)
11+ , ixEnv
12+ ) where
13+
14+import Data.Kind
15+
16+type Effect = Type
17+
18+class (e :: Effect) :> (es :: [Effect]) where
19+ -- | Get position of @e@ in @es@.
20+ --
21+ -- /Note:/ GHC is kind enough to cache these values as they're top level CAFs,
22+ -- so the lookup is amortized @O(1)@ without any language level tricks.
23+ ixOf :: Int
24+ ixOf = -- Don't show "minimal complete definition" in haddock.
25+ error "unimplemented"
26+
27+instance {-# OVERLAPPING #-} e :> (e : es) where
28+ ixOf = 0
29+
30+instance e :> es => e :> (x : es) where
31+ ixOf = 1 + ixOf @e @es
32+
33+-- | Get position of @e@ in the 'Effective.Internal.Env.Env'.
34+ixEnv :: forall e es. e :> es => Int -> Int
35+ixEnv n = n - ixOf @e @es - 1
src/Effective/Internal/Monad.hsnew file+177
@@ -0,0 +1,177 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# OPTIONS_HADDOCK not-home #-}
3+-- | The 'Eff' monad.
4+--
5+-- This module is intended for internal use only, and may change without warning
6+-- in subsequent releases.
7+module Effective.Internal.Monad
8+ ( -- * Monad
9+ Eff(..)
10+ , runEff
11+ , impureEff
12+ , impureEff_
13+
14+ -- * IO
15+ , IOE
16+ , runIOE
17+
18+ -- * Helpers
19+ , runEffect
20+ , evalEffect
21+ , execEffect
22+ , getEffect
23+ , putEffect
24+ , stateEffect
25+ , localEffect
26+ , listenEffect
27+ , readerEffectM
28+ , stateEffectM
29+ ) where
30+
31+import Control.Monad.Base
32+import Control.Monad.Catch
33+import Control.Monad.IO.Class
34+import Control.Monad.IO.Unlift
35+import Control.Monad.Trans.Control
36+import GHC.Magic (oneShot)
37+
38+import Effective.Internal.Env
39+import Effective.Internal.Has
40+
41+type role Eff nominal representational
42+
43+newtype Eff (es :: [Effect]) a = Eff { unEff :: Env es -> IO a }
44+
45+runEff :: Eff '[] a -> IO a
46+runEff (Eff m) = m =<< emptyEnv
47+
48+impureEff :: (Env es -> IO a) -> Eff es a
49+impureEff m = Eff (oneShot m)
50+
51+impureEff_ :: IO a -> Eff es a
52+impureEff_ m = impureEff $ \_ -> m
53+
54+----------------------------------------
55+-- Base
56+
57+instance Functor (Eff es) where
58+ fmap f (Eff m) = impureEff $ \es -> f <$> m es
59+
60+instance Applicative (Eff es) where
61+ pure = impureEff_ . pure
62+ Eff mf <*> Eff mx = impureEff $ \es -> mf es <*> mx es
63+
64+instance Monad (Eff es) where
65+ Eff m >>= k = impureEff $ \es -> do
66+ a <- m es
67+ unEff (k a) es
68+
69+----------------------------------------
70+-- Exception
71+
72+instance MonadThrow (Eff es) where
73+ throwM e = impureEff_ $ throwM e
74+
75+instance MonadCatch (Eff es) where
76+ catch (Eff m) handler = impureEff $ \es -> do
77+ size <- sizeEnv es
78+ m es `catch` \e -> do
79+ checkSizeEnv size es
80+ unEff (handler e) es
81+
82+instance MonadMask (Eff es) where
83+ mask k = impureEff $ \es -> mask $ \restore ->
84+ unEff (k $ (\f (Eff m) -> impureEff $ f . m) restore) es
85+
86+ uninterruptibleMask k = impureEff $ \es -> uninterruptibleMask $ \restore ->
87+ unEff (k $ (\f (Eff m) -> impureEff $ f . m) restore) es
88+
89+ generalBracket acquire release use = impureEff $ \es -> mask $ \restore -> do
90+ size <- sizeEnv es
91+ resource <- unEff acquire es
92+ b <- restore (unEff (use resource) es) `catch` \e -> do
93+ checkSizeEnv size es
94+ _ <- unEff (release resource $ ExitCaseException e) es
95+ throwM e
96+ checkSizeEnv size es
97+ c <- unEff (release resource $ ExitCaseSuccess b) es
98+ pure (b, c)
99+
100+----------------------------------------
101+-- IO
102+
103+data IOE = IOE
104+
105+runIOE :: Eff '[IOE] a -> Eff '[] a
106+runIOE = evalEffect IOE
107+
108+instance IOE :> es => MonadIO (Eff es) where
109+ liftIO = impureEff_
110+
111+instance IOE :> es => MonadBase IO (Eff es) where
112+ liftBase = impureEff_
113+
114+instance IOE :> es => MonadBaseControl IO (Eff es) where
115+ type StM (Eff es) a = a
116+ liftBaseWith f = impureEff $ \es -> f $ \(Eff m) -> m es
117+ restoreM = pure
118+
119+instance IOE :> es => MonadUnliftIO (Eff es) where
120+ withRunInIO k = impureEff $ \es ->
121+ withRunInIO $ \run -> k (\(Eff m) -> run $ m es)
122+
123+----------------------------------------
124+-- Helpers
125+
126+runEffect :: e -> Eff (e : es) a -> Eff es (a, e)
127+runEffect e0 (Eff m) = impureEff $ \es0 -> do
128+ size <- sizeEnv es0
129+ bracket (unsafeConsEnv e0 es0)
130+ (unsafeTrimEnv size)
131+ (\es -> (,) <$> m es <*> getEnv es)
132+
133+evalEffect :: e -> Eff (e : es) a -> Eff es a
134+evalEffect e (Eff m) = impureEff $ \es0 -> do
135+ size <- sizeEnv es0
136+ bracket (unsafeConsEnv e es0)
137+ (unsafeTrimEnv size)
138+ (\es -> m es)
139+
140+execEffect :: e -> Eff (e : es) a -> Eff es e
141+execEffect e0 (Eff m) = impureEff $ \es0 -> do
142+ size <- sizeEnv es0
143+ bracket (unsafeConsEnv e0 es0)
144+ (unsafeTrimEnv size)
145+ (\es -> m es *> getEnv es)
146+
147+getEffect :: e :> es => Eff es e
148+getEffect = impureEff $ \es -> getEnv es
149+
150+putEffect :: e :> es => e -> Eff es ()
151+putEffect e = impureEff $ \es -> unsafePutEnv e es
152+
153+stateEffect :: e :> es => (e -> (a, e)) -> Eff es a
154+stateEffect f = impureEff $ \es -> unsafeStateEnv f es
155+
156+localEffect :: e :> es => (e -> e) -> Eff es a -> Eff es a
157+localEffect f (Eff m) = impureEff $ \es -> do
158+ bracket (unsafeStateEnv (\e -> (e, f e)) es)
159+ (\e -> unsafePutEnv e es)
160+ (\_ -> m es)
161+
162+listenEffect :: (e :> es, Monoid e) => Eff es a -> Eff es (a, e)
163+listenEffect (Eff m) = impureEff $ \es -> mask $ \restore -> do
164+ e0 <- unsafeStateEnv (\e -> (e, mempty)) es
165+ -- If an exception is thrown, restore e0 and keep parts of e1.
166+ a <- restore (m es) `onException` unsafeModifyEnv (\e -> e0 `mappend` e) es
167+ e1 <- unsafeStateEnv (\e -> (e, e0 `mappend` e)) es
168+ pure (a, e1)
169+
170+readerEffectM :: e :> es => (e -> Eff es a) -> Eff es a
171+readerEffectM f = impureEff $ \es -> getEnv es >>= \e -> unEff (f e) es
172+
173+stateEffectM :: e :> es => (e -> Eff es (a, e)) -> Eff es a
174+stateEffectM f = impureEff $ \es -> do
175+ (a, e) <- (\e -> unEff (f e) es) =<< getEnv es
176+ unsafePutEnv e es
177+ pure a
src/Effective/Internal/Utils.hsnew file+16
@@ -0,0 +1,16 @@
1+{-# OPTIONS_HADDOCK not-home #-}
2+-- | Miscellaneous functions.
3+--
4+-- This module is intended for internal use only, and may change without warning
5+-- in subsequent releases.
6+module Effective.Internal.Utils
7+ ( ppCallStack
8+ ) where
9+
10+import GHC.Stack.Types
11+
12+-- | Pretty print a position from a 'CallStack'.
13+ppCallStack :: (String, SrcLoc) -> String
14+ppCallStack (fun, SrcLoc {..}) = fun ++ " at " ++ srcLocFile
15+ ++ ":" ++ show srcLocStartLine ++ ":" ++ show srcLocStartCol
16+ ++ " in " ++ srcLocPackage ++ ":" ++ srcLocModule
src/Effective/Reader.hsnew file+30
@@ -0,0 +1,30 @@
1+-- | The 'Reader' as an effect.
2+module Effective.Reader
3+ ( Reader
4+ , runReader
5+ , ask
6+ , local
7+ , reader
8+ , asks
9+ ) where
10+
11+import Effective.Internal.Has
12+import Effective.Internal.Monad
13+
14+-- | Provide access to a read only value of type @r@.
15+newtype Reader r = Reader { unReader :: r }
16+
17+runReader :: r -> Eff (Reader r : es) a -> Eff es a
18+runReader r = evalEffect (Reader r)
19+
20+ask :: Reader r :> es => Eff es r
21+ask = unReader <$> getEffect
22+
23+local :: Reader r :> es => (r -> r) -> Eff es a -> Eff es a
24+local f = localEffect (Reader . f . unReader)
25+
26+reader :: Reader r :> es => (r -> a) -> Eff es a
27+reader f = f . unReader <$> getEffect
28+
29+asks :: Reader r :> es => (r -> a) -> Eff es a
30+asks = reader
src/Effective/Resource.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE UndecidableInstances #-}
2+{-# OPTIONS_GHC -Wno-orphans #-}
3+-- | Resource management via 'R.MonadResource'.
4+module Effective.Resource
5+ ( Resource
6+ , runResource
7+
8+ -- * Registering and releasing resources
9+ , R.allocate
10+ , R.allocate_
11+ , R.register
12+ , R.release
13+ , R.unprotect
14+ ) where
15+
16+import Control.Exception
17+import qualified Control.Monad.Trans.Resource as R
18+import qualified Control.Monad.Trans.Resource.Internal as RI
19+
20+import Effective.Internal.Env
21+import Effective.Internal.Has
22+import Effective.Internal.Monad
23+
24+-- | Data tag for a resource effect.
25+newtype Resource = Resource R.InternalState
26+
27+-- | Run the resource effect.
28+runResource :: Eff (Resource : es) a -> Eff es a
29+runResource (Eff m) = impureEff $ \es0 -> do
30+ size0 <- sizeEnv es0
31+ istate <- R.createInternalState
32+ mask $ \restore -> do
33+ es <- unsafeConsEnv (Resource istate) es0
34+ a <- restore (m es) `catch` \e -> do
35+ _ <- unsafeTrimEnv size0 es
36+ RI.stateCleanupChecked (Just e) istate
37+ throwIO e
38+ _ <- unsafeTrimEnv size0 es
39+ RI.stateCleanupChecked Nothing istate
40+ pure a
41+
42+instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where
43+ liftResourceT (RI.ResourceT m) = impureEff $ \es -> do
44+ getEnv es >>= \(Resource istate) -> m istate
src/Effective/State.hsnew file+50
@@ -0,0 +1,50 @@
1+-- | The 'State' as an effect.
2+--
3+-- Represented as a pure value underneath, therefore:
4+--
5+-- - very fast
6+--
7+-- - not suitable for sharing between multiple threads.
8+--
9+-- If you plan to do the latter, have a look at "Effective.State.MVar" or
10+-- "Effective.State.Dynamic".
11+--
12+module Effective.State
13+ ( State
14+ , runState
15+ , evalState
16+ , execState
17+ , get
18+ , put
19+ , state
20+ , modify
21+ ) where
22+
23+import Data.Coerce
24+
25+import Effective.Internal.Has
26+import Effective.Internal.Monad
27+
28+-- | Provide access to a pure, mutable state of type @s@.
29+newtype State s = State { unState :: s }
30+
31+runState :: s -> Eff (State s : es) a -> Eff es (a, s)
32+runState s = coerce . runEffect (State s)
33+
34+evalState :: s -> Eff (State s : es) a -> Eff es a
35+evalState s = evalEffect (State s)
36+
37+execState :: s -> Eff (State s : es) a -> Eff es s
38+execState s = coerce . execEffect (State s)
39+
40+get :: State s :> es => Eff es s
41+get = unState <$> getEffect
42+
43+put :: State s :> es => s -> Eff es ()
44+put = putEffect . State
45+
46+state :: State s :> es => (s -> (a, s)) -> Eff es a
47+state f = stateEffect $ \(State s0) -> let (a, s) = f s0 in (a, State s)
48+
49+modify :: State s :> es => (s -> s) -> Eff es ()
50+modify f = state (\s -> ((), f s))
src/Effective/State/Dynamic.hsnew file+114
@@ -0,0 +1,114 @@
1+-- | The 'State' as an effect with dynamic dispatch.
2+--
3+-- It's not clear in which situation it's beneficial to use this instead of
4+-- "Effective.State" or "Effective.State.MVar" as you either:
5+--
6+-- - Share state between threads and need the synchonized version.
7+--
8+-- - Don't share state between threads and are free to use the faster, pure
9+-- version.
10+--
11+-- However, let's include this for now.
12+--
13+module Effective.State.Dynamic
14+ ( State
15+
16+ -- * Pure
17+ , runState
18+ , evalState
19+ , execState
20+
21+ -- * MVar
22+ , runStateMVar
23+ , evalStateMVar
24+ , execStateMVar
25+
26+ -- * Operations
27+ , get
28+ , put
29+ , state
30+ , modify
31+ ) where
32+
33+import Control.Concurrent.MVar
34+
35+import Effective.Internal.Has
36+import Effective.Internal.Monad
37+
38+-- | Provide access to a mutable state of type @s@.
39+--
40+-- Whether the state is represented as a pure value or an 'MVar' depends on the
41+-- interpretation.
42+data State s = forall ref. State
43+ { _ref :: ref
44+ , _get :: forall es. ref -> Eff es s
45+ , _put :: forall es. ref -> s -> Eff es ref
46+ , _state :: forall es a. ref -> (s -> (a, s)) -> Eff es (a, ref)
47+ }
48+
49+----------------------------------------
50+-- Pure
51+
52+runState :: s -> Eff (State s : es) a -> Eff es (a, s)
53+runState s m = evalEffect (statePure s) $ (,) <$> m <*> get
54+
55+evalState :: s -> Eff (State s : es) a -> Eff es a
56+evalState s = evalEffect (statePure s)
57+
58+execState :: s -> Eff (State s : es) a -> Eff es s
59+execState s m = evalEffect (statePure s) $ m *> get
60+
61+statePure :: s -> State s
62+statePure s0 = State
63+ { _ref = s0
64+ , _get = pure
65+ , _put = \_ -> pure
66+ , _state = \s f -> pure $ f s
67+ }
68+
69+----------------------------------------
70+-- MVar
71+
72+runStateMVar :: s -> Eff (State s : es) a -> Eff es (a, s)
73+runStateMVar s m = do
74+ v <- impureEff_ $ newMVar s
75+ evalEffect (stateMVar v) $ (,) <$> m <*> get
76+
77+evalStateMVar :: s -> Eff (State s : es) a -> Eff es a
78+evalStateMVar s m = do
79+ v <- impureEff_ $ newMVar s
80+ evalEffect (stateMVar v) m
81+
82+execStateMVar :: s -> Eff (State s : es) a -> Eff es s
83+execStateMVar s m = do
84+ v <- impureEff_ $ newMVar s
85+ evalEffect (stateMVar v) $ m *> get
86+
87+stateMVar :: MVar s -> State s
88+stateMVar v0 = State
89+ { _ref = v0
90+ , _get = impureEff_ . readMVar
91+ , _put = \v s -> impureEff_ . modifyMVar v $ \_ ->
92+ s `seq` pure (s, v)
93+ , _state = \v f -> impureEff_ . modifyMVar v $ \s0 ->
94+ let (a, s) = f s0 in s `seq` pure (s, (a, v))
95+ }
96+
97+----------------------------------------
98+-- Operations
99+
100+get :: State s :> es => Eff es s
101+get = readerEffectM $ \State{..} -> _get _ref
102+
103+put :: State s :> es => s -> Eff es ()
104+put s = stateEffectM $ \State{..} -> do
105+ ref <- _put _ref s
106+ pure ((), State { _ref = ref, .. })
107+
108+state :: State s :> es => (s -> (a, s)) -> Eff es a
109+state f = stateEffectM $ \State{..} -> do
110+ (a, ref) <- _state _ref f
111+ pure (a, State { _ref = ref, .. })
112+
113+modify :: State s :> es => (s -> s) -> Eff es ()
114+modify f = state (\s -> ((), f s))
src/Effective/State/MVar.hsnew file+59
@@ -0,0 +1,59 @@
1+-- | The 'State' as an effect.
2+--
3+-- Represented as an MVar underneath, therefore:
4+--
5+-- - slower than "Effective.State"
6+--
7+-- - suitable for sharing between multiple threads.
8+--
9+module Effective.State.MVar
10+ ( State
11+ , runState
12+ , evalState
13+ , execState
14+ , get
15+ , put
16+ , state
17+ , modify
18+ ) where
19+
20+import Control.Concurrent.MVar
21+
22+import Effective.Internal.Has
23+import Effective.Internal.Monad
24+
25+-- | Provide access to a synchronized, mutable state of type @s@.
26+newtype State s = State (MVar s)
27+
28+runState :: s -> Eff (State s : es) a -> Eff es (a, s)
29+runState s m = do
30+ v <- impureEff_ $ newMVar s
31+ evalEffect (State v) $ (,) <$> m <*> get
32+
33+evalState :: s -> Eff (State s : es) a -> Eff es a
34+evalState s m = do
35+ v <- impureEff_ $ newMVar s
36+ evalEffect (State v) m
37+
38+execState :: s -> Eff (State s : es) a -> Eff es s
39+execState s m = do
40+ v <- impureEff_ $ newMVar s
41+ evalEffect (State v) $ m *> get
42+
43+get :: State s :> es => Eff es s
44+get = do
45+ State v <- getEffect
46+ impureEff_ $ readMVar v
47+
48+put :: State s :> es => s -> Eff es ()
49+put s = do
50+ State v <- getEffect
51+ impureEff_ . modifyMVar_ v $ \_ -> s `seq` pure s
52+
53+state :: State s :> es => (s -> (a, s)) -> Eff es a
54+state f = do
55+ State v <- getEffect
56+ impureEff_ . modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)
57+
58+modify :: State s :> es => (s -> s) -> Eff es ()
59+modify f = state (\s -> ((), f s))
src/Effective/Writer.hsnew file+47
@@ -0,0 +1,47 @@
1+-- | The 'Writer' as an effect.
2+module Effective.Writer
3+ ( Writer
4+ , runWriter
5+ , execWriter
6+ , writer
7+ , tell
8+ , listen
9+ , listens
10+ ) where
11+
12+import Data.Coerce
13+import qualified Data.Semigroup as S
14+
15+import Effective.Internal.Has
16+import Effective.Internal.Monad
17+
18+-- | Provide access to a write only value of type @w@.
19+newtype Writer w = Writer w
20+ deriving (S.Semigroup, Monoid)
21+
22+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
23+runWriter = fmap coerce . runEffect mempty
24+
25+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
26+execWriter = fmap coerce . execEffect mempty
27+
28+writer :: (Writer w :> es, Monoid w) => (a, w) -> Eff es a
29+writer (a, w) = stateEffect $ \w0 -> (a, w0 `mappend` Writer w)
30+
31+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
32+tell w = stateEffect $ \w0 -> ((), w0 `mappend` Writer w)
33+
34+listen
35+ :: (Writer w :> es, Monoid w)
36+ => Eff es a
37+ -> Eff es (a, w)
38+listen = fmap (\(a, Writer w) -> (a, w)) . listenEffect
39+
40+listens
41+ :: (Writer w :> es, Monoid w)
42+ => (w -> b)
43+ -> Eff es a
44+ -> Eff es (a, b)
45+listens f m = do
46+ (a, w) <- listen m
47+ pure (a, f w)