git.iko.soy/typeable/ether
on d24e51a help sign in
7b3583a
swap
0 ahead, 31 behind
.gitignore+2−17
since splitsnapshots
unifiedsplit
@@ -1,21 +1,6 @@
1−# Cabal
1+tags
2dist
2dist
3dist-newstyle
3dist-newstyle
4+.stack-work
4.cabal-sandbox/
5.cabal-sandbox/
5cabal.sandbox.config
6cabal.sandbox.config
6−cabal.project.local
7−.ghc.environment*
8−
9−# Profiling
10−*.prof
11−
12−# Stack
13−.stack-work
14−
15−# Emacs
16−TAGS
17−.dir-locals.el
18−
19−# Vim
20−tags
21−*.swp
.travis.yml+18−25
@@ -1,31 +1,24 @@
1−language: nix
1+sudo: false
2
2
3−os:
3+cache:
4− - linux
4+ directories:
5− - osx
5+ - $HOME/.stack/
6−
7−env:
8− - HC=ghc822
9− - HC=ghc844
10− - HC=ghc861
11
6
12before_install:
7before_install:
13− - curl https://raw.githubusercontent.com/monadfix/nix-cabal/master/nix-cabal -o nix-cabal && chmod u+x nix-cabal
8+ - mkdir -p ~/.local/bin
14− - travis_retry ./nix-cabal new-update
9+ - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
10+ - export PATH=~/.local/bin:$PATH
11+ - stack --version
12+ - stack setup
15
13
16−script:
14+install:
17− - ./nix-cabal new-test ether:regression
15+ - stack install --only-dependencies --no-terminal
18− - ./nix-cabal new-bench ether:bench
19
16
20−cache:
17+script:
21− directories:
18+ - stack test ether:regression --no-terminal --ghc-options -Werror
22− - ~/.cabal
19+ - stack bench ether:bench --no-terminal --ghc-options -Werror
23− - ~/.ghc
24
20
25−matrix:
21+addons:
26− # broken at the moment
22+ apt:
27− exclude:
23+ packages:
28− - os: osx
24+ - libgmp-dev
29− env: HC=ghc822
30− - os: osx
31− env: HC=ghc861
CHANGELOG.md−5
@@ -1,8 +1,3 @@
1−0.5.1.0
2−-------
3−
4−* Disable `HasLens` for tuples via cabal flag.
5−
60.5.0.0
10.5.0.0
7-------
2-------
8
3
README.md+16
@@ -2,8 +2,24 @@
2
2
3[![Build Status](https://img.shields.io/travis/int-index/ether.svg)](https://travis-ci.org/int-index/ether)
3[![Build Status](https://img.shields.io/travis/int-index/ether.svg)](https://travis-ci.org/int-index/ether)
4[![Hackage](https://img.shields.io/hackage/v/ether.svg)](https://hackage.haskell.org/package/ether)
4[![Hackage](https://img.shields.io/hackage/v/ether.svg)](https://hackage.haskell.org/package/ether)
5+[![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/int-index/ether)
5
6
6
7
7Ether is a Haskell library that extends [mtl](https://hackage.haskell.org/package/mtl)
8Ether is a Haskell library that extends [mtl](https://hackage.haskell.org/package/mtl)
8and [transformers](https://hackage.haskell.org/package/transformers) with tagged
9and [transformers](https://hackage.haskell.org/package/transformers) with tagged
9monad transformers and classes in a compatible way.
10monad transformers and classes in a compatible way.
11+
12+## Installation
13+
14+You can install `ether 0.4.0.0`
15+
16+1. using Cabal, from Hackage;
17+2. using Stack, from Stackage;
18+3. using Portage, from Gentoo Haskell Overlay.
19+
20+If unsure, use [Stack](https://github.com/commercialhaskell/stack).
21+
22+## Getting Started
23+
24+To get started, read the introduction on the [homepage](https://int-index.github.io/ether/).
25+If you need help with Ether or if you have any questions about it, ask me in the Gitter chat.
bench/Bench.hs−1
@@ -8,7 +8,6 @@ import qualified Control.Monad.Reader as M
8import qualified Control.Monad.State as M
8import qualified Control.Monad.State as M
9import Criterion.Main
9import Criterion.Main
10import Ether
10import Ether
11−import TupleInstances ()
12
11
13id' :: a -> a
12id' :: a -> a
14id' = id
13id' = id
bench/TupleInstances.hsdeleted−9
@@ -1,9 +0,0 @@
1−{-# OPTIONS -fno-warn-orphans #-}
2−{-# LANGUAGE CPP #-}
3−
4−module TupleInstances () where
5−
6−#ifdef DISABLE_TUP_INSTANCES
7−import Ether.Internal (makeTupleInstancesHasLens)
8−makeTupleInstancesHasLens [4,5,9]
9−#endif
ether.cabal+16−47
@@ -1,17 +1,21 @@
1−cabal-version: 2.2
2name: ether
1name: ether
3−version: 0.5.2.0
2+version: 0.5.0.0
4synopsis: Monad transformers and classes
3synopsis: Monad transformers and classes
5−description: Lib
4+description:
6−license: BSD-3-Clause
5+ Ether is a Haskell library that extends @mtl@ and @transformers@ with
7−-- ^ unfortunately have to change this line due to the issue with cabal2nix
6+ tagged monad transformers and classes in a compatible way.
8−license-file: LICENSE
7+
8+ Introduction <https://int-index.github.io/ether/>
9+
9category: Control
10category: Control
11+license: BSD3
12+license-file: LICENSE
10author: Vladislav Zavialov
13author: Vladislav Zavialov
11maintainer: Vladislav Zavialov <vlad.z.4096@gmail.com>
14maintainer: Vladislav Zavialov <vlad.z.4096@gmail.com>
12homepage: https://int-index.github.io/ether/
15homepage: https://int-index.github.io/ether/
13bug-reports: https://github.com/int-index/ether/issues
16bug-reports: https://github.com/int-index/ether/issues
14build-type: Simple
17build-type: Simple
18+cabal-version: >=1.18
15extra-source-files: CHANGELOG.md
19extra-source-files: CHANGELOG.md
16
20
17source-repository head
21source-repository head
@@ -20,20 +24,6 @@ source-repository head
20 location: git@github.com:int-index/ether.git
24 location: git@github.com:int-index/ether.git
21
25
22
26
23−flag disable-tup-instances
24−
25− description:
26− Disable auto-generated 'HasLens' instances for tuples. The reason one
27− might want to do this is to reduce the size of .hi-files, as well as the
28− time and memory GHC needs to build Ether. To recover flattening with
29− tuples, use 'Ether.Internal.makeTupleInstancesHasLens' at specific tuple
30− sizes you need in your application.
31−
32− This is a build-time performance hack, enable this flag at your own risk.
33−
34− default: False
35− manual: True
36−
37library
27library
38
28
39 exposed-modules:
29 exposed-modules:
@@ -46,22 +36,14 @@ library
46 Ether.TagDispatch
36 Ether.TagDispatch
47 Ether.Internal
37 Ether.Internal
48
38
49− other-modules:
50− Ether.Internal.Tags
51− Ether.Internal.HasLens
52− Ether.Internal.TH_Utils
53− Ether.Internal.TH_TupleInstances
54− Ether.Internal.TupleInstances
55−
56 build-depends:
39 build-depends:
57− base >=4.9 && <4.13,
40+ base >=4.9 && <4.11,
58− transformers >=0.5.2.0,
41+ transformers >=0.4.2,
59− transformers-lift >=0.2.0.1,
42+ transformers-lift >=0.1.0.1,
60− mtl >=2.2.2,
43+ mtl >=2.2.1,
61 mmorph >=1.0.4,
44 mmorph >=1.0.4,
62 monad-control >=1.0.0.4,
45 monad-control >=1.0.0.4,
63 transformers-base >=0.4.4,
46 transformers-base >=0.4.4,
64− writer-cps-mtl >= 0.1.1.4,
65 exceptions >=0.8,
47 exceptions >=0.8,
66 template-haskell >=2.11,
48 template-haskell >=2.11,
67 tagged >=0.8.5,
49 tagged >=0.8.5,
@@ -101,13 +83,10 @@ library
101 ghc-options:
83 ghc-options:
102 -Wall -O2
84 -Wall -O2
103
85
104− if flag(disable-tup-instances)
105− cpp-options: -DDISABLE_TUP_INSTANCES
106−
107test-suite regression
86test-suite regression
108
87
109 build-depends:
88 build-depends:
110− base >=4.9 && <4.13,
89+ base >=4.9 && <4.11,
111 transformers >=0.4.2,
90 transformers >=0.4.2,
112 mtl >=2.2.1,
91 mtl >=2.2.1,
113 tasty >=0.10,
92 tasty >=0.10,
@@ -121,7 +100,6 @@ test-suite regression
121 Regression.hs
100 Regression.hs
122
101
123 other-modules:
102 other-modules:
124− TupleInstances
125 Regression.T1
103 Regression.T1
126 Regression.T2
104 Regression.T2
127 Regression.T3
105 Regression.T3
@@ -172,14 +150,11 @@ test-suite regression
172 ghc-options:
150 ghc-options:
173 -Wall -fno-warn-missing-signatures
151 -Wall -fno-warn-missing-signatures
174
152
175− if flag(disable-tup-instances)
176− cpp-options: -DDISABLE_TUP_INSTANCES
177−
178
153
179benchmark bench
154benchmark bench
180
155
181 build-depends:
156 build-depends:
182− base >=4.9 && <4.13,
157+ base >=4.9 && <4.11,
183 mtl >=2.2.1,
158 mtl >=2.2.1,
184 transformers >=0.4.2,
159 transformers >=0.4.2,
185 criterion >=1.1,
160 criterion >=1.1,
@@ -190,9 +165,6 @@ benchmark bench
190 main-is:
165 main-is:
191 Bench.hs
166 Bench.hs
192
167
193− other-modules:
194− TupleInstances
195−
196 type:
168 type:
197 exitcode-stdio-1.0
169 exitcode-stdio-1.0
198
170
@@ -232,6 +204,3 @@ benchmark bench
232
204
233 ghc-prof-options:
205 ghc-prof-options:
234 -fprof-auto
206 -fprof-auto
235−
236− if flag(disable-tup-instances)
237− cpp-options: -DDISABLE_TUP_INSTANCES
shell.nixdeleted−22
@@ -1,22 +0,0 @@
1−{ pkgs ? import <nixpkgs> {},
2− hc ? "ghc844"
3−}:
4−
5−pkgs.stdenv.mkDerivation rec {
6− name = "ether";
7− buildInputs = [
8− pkgs.haskell.compiler.${hc}
9− pkgs.git
10− pkgs.zlib
11− pkgs.cabal-install
12− pkgs.pkgconfig
13− ];
14− shellHook = ''
15− export LD_LIBRARY_PATH=${pkgs.lib.makeLibraryPath buildInputs}:$LD_LIBRARY_PATH
16− export LANG=en_US.UTF-8
17− '';
18− LOCALE_ARCHIVE =
19− if pkgs.stdenv.isLinux
20− then "${pkgs.glibcLocales}/lib/locale/locale-archive"
21− else "";
22−}
src/Ether/Except.hs+15−1
@@ -50,8 +50,12 @@ instance {-# OVERLAPPABLE #-}
50 , Monad (t m)
50 , Monad (t m)
51 , MonadExcept tag e m
51 , MonadExcept tag e m
52 ) => MonadExcept tag e (t m) where
52 ) => MonadExcept tag e (t m) where
53+
53 throw = Lift.lift . throw @tag
54 throw = Lift.lift . throw @tag
55+ {-# INLINE throw #-}
56+
54 catch = Lift.liftCatch (catch @tag)
57 catch = Lift.liftCatch (catch @tag)
58+ {-# INLINE catch #-}
55
59
56-- | Encode type-level information for 'ExceptT'.
60-- | Encode type-level information for 'ExceptT'.
57data EXCEPT
61data EXCEPT
@@ -73,14 +77,17 @@ type ExceptT tag e = TaggedTrans (TAGGED EXCEPT tag) (T.ExceptT e)
73-- | Runs an 'Except' and returns either an exception or a normal value.
77-- | Runs an 'Except' and returns either an exception or a normal value.
74runExcept :: forall tag e a . Except tag e a -> Either e a
78runExcept :: forall tag e a . Except tag e a -> Either e a
75runExcept = coerce (T.runExcept @e @a)
79runExcept = coerce (T.runExcept @e @a)
80+{-# INLINE runExcept #-}
76
81
77-- | Runs an 'ExceptT' and returns either an exception or a normal value.
82-- | Runs an 'ExceptT' and returns either an exception or a normal value.
78runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)
83runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)
79runExceptT = coerce (T.runExceptT @e @m @a)
84runExceptT = coerce (T.runExceptT @e @m @a)
85+{-# INLINE runExceptT #-}
80
86
81-- | Constructor for computations in the exception monad transformer.
87-- | Constructor for computations in the exception monad transformer.
82exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
88exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
83exceptT = coerce (T.ExceptT @e @m @a)
89exceptT = coerce (T.ExceptT @e @m @a)
90+{-# INLINE exceptT #-}
84
91
85type instance HandleSuper EXCEPT e trans = ()
92type instance HandleSuper EXCEPT e trans = ()
86type instance HandleConstraint EXCEPT e trans m =
93type instance HandleConstraint EXCEPT e trans m =
@@ -88,40 +95,47 @@ type instance HandleConstraint EXCEPT e trans m =
88
95
89instance Handle EXCEPT e (T.ExceptT e) where
96instance Handle EXCEPT e (T.ExceptT e) where
90 handling r = r
97 handling r = r
98+ {-# INLINE handling #-}
91
99
92instance
100instance
93 ( Handle EXCEPT e trans
101 ( Handle EXCEPT e trans
94 , Monad m, Monad (trans m)
102 , Monad m, Monad (trans m)
95 ) => MonadExcept tag e (TaggedTrans (TAGGED EXCEPT tag) trans m)
103 ) => MonadExcept tag e (TaggedTrans (TAGGED EXCEPT tag) trans m)
96 where
104 where
97−
98 throw =
105 throw =
99 handling @EXCEPT @e @trans @m $
106 handling @EXCEPT @e @trans @m $
100 coerce (T.throwError @e @(trans m) @a) ::
107 coerce (T.throwError @e @(trans m) @a) ::
101 forall eff a . e -> TaggedTrans eff trans m a
108 forall eff a . e -> TaggedTrans eff trans m a
109+ {-# INLINE throw #-}
102
110
103 catch =
111 catch =
104 handling @EXCEPT @e @trans @m $
112 handling @EXCEPT @e @trans @m $
105 coerce (T.catchError @e @(trans m) @a) ::
113 coerce (T.catchError @e @(trans m) @a) ::
106 forall eff a . Catch e (TaggedTrans eff trans m) a
114 forall eff a . Catch e (TaggedTrans eff trans m) a
115+ {-# INLINE catch #-}
107
116
108type MonadExcept' e = MonadExcept e e
117type MonadExcept' e = MonadExcept e e
109
118
110throw' :: forall e m a . MonadExcept' e m => e -> m a
119throw' :: forall e m a . MonadExcept' e m => e -> m a
111throw' = throw @e
120throw' = throw @e
121+{-# INLINE throw' #-}
112
122
113catch' :: forall e m a . MonadExcept' e m => m a -> (e -> m a) -> m a
123catch' :: forall e m a . MonadExcept' e m => m a -> (e -> m a) -> m a
114catch' = catch @e
124catch' = catch @e
125+{-# INLINE catch' #-}
115
126
116type Except' e = Except e e
127type Except' e = Except e e
117
128
118runExcept' :: Except' e a -> Either e a
129runExcept' :: Except' e a -> Either e a
119runExcept' = runExcept
130runExcept' = runExcept
131+{-# INLINE runExcept' #-}
120
132
121type ExceptT' e = ExceptT e e
133type ExceptT' e = ExceptT e e
122
134
123exceptT' :: m (Either e a) -> ExceptT' e m a
135exceptT' :: m (Either e a) -> ExceptT' e m a
124exceptT' = exceptT
136exceptT' = exceptT
137+{-# INLINE exceptT' #-}
125
138
126runExceptT' :: ExceptT' e m a -> m (Either e a)
139runExceptT' :: ExceptT' e m a -> m (Either e a)
127runExceptT' = runExceptT
140runExceptT' = runExceptT
141+{-# INLINE runExceptT' #-}
src/Ether/Internal.hs+115−10
@@ -6,8 +6,6 @@ module Ether.Internal
6 , LensLike
6 , LensLike
7 , Lens
7 , Lens
8 , Lens'
8 , Lens'
9− , ReifiedLens(..)
10− , ReifiedLens'
11 , view
9 , view
12 , over
10 , over
13 , HList(..)
11 , HList(..)
@@ -16,20 +14,18 @@ module Ether.Internal
16 , HandleSuper
14 , HandleSuper
17 , HandleConstraint
15 , HandleConstraint
18 , Handle(..)
16 , Handle(..)
19− , makeTupleInstancesHasLens
20 ) where
17 ) where
21
18
22import Control.Applicative
19import Control.Applicative
20+import Control.Monad
23import Data.Coerce
21import Data.Coerce
24import Data.Functor.Identity
22import Data.Functor.Identity
25import Data.Kind
23import Data.Kind
24+import Data.List as List
26import Data.Tagged
25import Data.Tagged
26+import Data.Traversable
27import GHC.Exts (Constraint)
27import GHC.Exts (Constraint)
28−
28+import qualified Language.Haskell.TH as TH
29−import Ether.Internal.HasLens
30−import Ether.Internal.Tags
31−import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)
32−import Ether.Internal.TupleInstances ()
33
29
34data TAGGED e t
30data TAGGED e t
35
31
@@ -57,12 +53,121 @@ class
57 where
53 where
58 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r
54 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r
59
55
60−newtype ReifiedLens s t a b = Lens (Lens s t a b)
56+type LensLike f s t a b = (a -> f b) -> s -> f t
57+
58+type Lens s t a b = forall f. Functor f => LensLike f s t a b
59+
60+type Lens' s a = Lens s s a a
61
61
62−type ReifiedLens' s a = ReifiedLens s s a a
62+class HasLens tag outer inner | tag outer -> inner where
63+ lensOf :: Lens' outer inner
64+
65+instance HasLens a a a where
66+ lensOf = id
67+ {-# INLINE lensOf #-}
63
68
64view :: LensLike (Const a) s t a b -> s -> a
69view :: LensLike (Const a) s t a b -> s -> a
65view l = coerce (l Const)
70view l = coerce (l Const)
71+{-# INLINE view #-}
66
72
67over :: LensLike Identity s t a b -> (a -> b) -> s -> t
73over :: LensLike Identity s t a b -> (a -> b) -> s -> t
68over = coerce
74over = coerce
75+{-# INLINE over #-}
76+
77+data HList xs where
78+ HNil :: HList '[]
79+ HCons :: x -> HList xs -> HList (x ': xs)
80+
81+type KindOf (a :: k) = k
82+
83+type family TagsK (p :: Type) :: [Type]
84+type family Tags (p :: Type) :: HList (TagsK p)
85+
86+return []
87+
88+type instance TagsK () = '[]
89+type instance TagsK (Tagged t a) = '[KindOf t]
90+type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]
91+
92+return []
93+
94+type instance Tags () = 'HNil
95+type instance Tags (Tagged t a) = 'HCons t 'HNil
96+type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)
97+
98+do
99+ let
100+ tupCount = 62
101+ names = [1..] >>= flip replicateM ['a'..'z']
102+ varNames <- traverse TH.newName (take tupCount names)
103+ fmap List.concat $
104+ for (List.drop 2 (List.inits varNames)) $
105+ \varNames' -> do
106+ let n = List.length varNames'
107+ tagsInstances <- for [() | n > 2] $ \() -> do
108+ tag <- TH.newName "tag"
109+ let
110+ (cur:rest) = varNames'
111+ tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
112+ ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :
113+ map TH.VarT rest )
114+ tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))
115+ (map TH.VarT rest)
116+ return $
117+ TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy]
118+ ( TH.PromotedConsT `TH.AppT` (TH.ConT ''KindOf `TH.AppT` TH.VarT tag) `TH.AppT`
119+ (TH.ConT ''TagsK `TH.AppT` tupTy') ))
120+ return tagsInstances
121+do
122+ let
123+ tupCount = 62
124+ names = [1..] >>= flip replicateM ['a'..'z']
125+ varNames <- traverse TH.newName (take tupCount names)
126+ fmap List.concat $
127+ for (List.drop 2 (List.inits varNames)) $
128+ \varNames' -> do
129+ let n = List.length varNames'
130+ tagsInstances <- for [() | n > 2] $ \() -> do
131+ tag <- TH.newName "tag"
132+ let
133+ (cur:rest) = varNames'
134+ tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
135+ ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :
136+ map TH.VarT rest )
137+ tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))
138+ (map TH.VarT rest)
139+ tagsInst =
140+ TH.TySynInstD ''Tags (TH.TySynEqn [tupTy]
141+ ( TH.PromotedT 'HCons `TH.AppT` TH.VarT tag `TH.AppT`
142+ (TH.ConT ''Tags `TH.AppT` tupTy') ))
143+ return tagsInst
144+ hasLensInstances <- for [0..n-1] $ \k -> do
145+ tag <- TH.newName "tag"
146+ let
147+ (prev, cur:next) = List.splitAt k varNames'
148+ tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
149+ ( map TH.VarT prev ++
150+ [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++
151+ map TH.VarT next )
152+ cur' <- TH.newName "x"
153+ f <- TH.newName "f"
154+ return $
155+ TH.InstanceD Nothing []
156+ (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)
157+ [ TH.FunD 'lensOf
158+ [ TH.Clause
159+ [TH.VarP f, TH.TupP
160+ ( map TH.VarP prev ++
161+ [TH.ConP 'Tagged [TH.VarP cur]] ++
162+ map TH.VarP next )]
163+ (TH.NormalB $
164+ TH.VarE 'fmap `TH.AppE`
165+ (TH.LamE [TH.VarP cur']
166+ (TH.TupE
167+ ( map TH.VarE prev ++
168+ [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++
169+ map TH.VarE next ))) `TH.AppE`
170+ (TH.VarE f `TH.AppE` TH.VarE cur) )
171+ [] ],
172+ TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]
173+ return $ tagsInstances ++ hasLensInstances
src/Ether/Internal/HasLens.hsdeleted−24
@@ -1,24 +0,0 @@
1−module Ether.Internal.HasLens
2− ( LensLike
3− , Lens
4− , Lens'
5− , HasLens(..)
6− ) where
7−
8−import Data.Tagged
9−import Data.Coerce
10−
11−type LensLike f s t a b = (a -> f b) -> s -> f t
12−
13−type Lens s t a b = forall f. Functor f => LensLike f s t a b
14−
15−type Lens' s a = Lens s s a a
16−
17−class HasLens tag outer inner | tag outer -> inner where
18− lensOf :: Lens' outer inner
19−
20−instance HasLens a a a where
21− lensOf = id
22−
23−instance HasLens t (Tagged t a) a where
24− lensOf = \f -> fmap coerce . f . coerce
src/Ether/Internal/TH_TupleInstances.hsdeleted−79
@@ -1,79 +0,0 @@
1−module Ether.Internal.TH_TupleInstances
2− ( makeTupleInstancesTagsK
3− , makeTupleInstancesTags
4− , makeTupleInstancesHasLens
5− ) where
6−
7−import Data.Tagged
8−import Data.Traversable
9−import Data.List as List
10−import qualified Language.Haskell.TH as TH
11−
12−import Ether.Internal.HasLens
13−import Ether.Internal.Tags
14−import Ether.Internal.TH_Utils
15−
16−makeTupleInstancesTagsK :: TH.DecsQ
17−makeTupleInstancesTagsK = do
18− for [2..tupCount] $ \n -> do
19− let
20− tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $
21− (\k -> TH.ConT ''Tagged `TH.AppT`
22− TH.VarT (tagName k) `TH.AppT`
23− TH.VarT (varName k)) <$> [0..n-1]
24− tagsList = List.foldr
25− (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)
26− TH.PromotedNilT
27− (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1])
28− return $
29− TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)
30−
31−makeTupleInstancesTags :: TH.DecsQ
32−makeTupleInstancesTags = do
33− for [2..tupCount] $ \n -> do
34− let
35− tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $
36− (\k -> TH.ConT ''Tagged `TH.AppT`
37− TH.VarT (tagName k) `TH.AppT`
38− TH.VarT (varName k)) <$> [0..n-1]
39− tagsList = List.foldr
40− (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)
41− (TH.PromotedT 'HNil)
42− (TH.VarT . tagName <$> [0..n-1])
43− return $
44− TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)
45−
46−makeTupleInstancesHasLens :: [Int] -> TH.DecsQ
47−makeTupleInstancesHasLens range = List.concat <$> do
48− for range $ \n ->
49− for [0..n-1] $ \k -> do
50− let
51− tag = TH.mkName "tag"
52− prev = varName <$> [0..k-1]
53− cur = varName k
54− next = varName <$> [k+1..n-1]
55− tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
56− ( map TH.VarT prev ++
57− [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++
58− map TH.VarT next )
59− let
60− cur' = TH.mkName "x"
61− f = TH.mkName "f"
62− return $
63− TH.InstanceD Nothing []
64− (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)
65− [ TH.FunD 'lensOf
66− [ TH.Clause
67− [TH.VarP f, TH.TupP
68− ( map TH.VarP prev ++
69− [TH.ConP 'Tagged [TH.VarP cur]] ++
70− map TH.VarP next )]
71− (TH.NormalB $
72− TH.VarE 'fmap `TH.AppE`
73− (TH.LamE [TH.VarP cur']
74− (TH.TupE
75− ( map TH.VarE prev ++
76− [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++
77− map TH.VarE next ))) `TH.AppE`
78− (TH.VarE f `TH.AppE` TH.VarE cur) )
79− [] ] ]
src/Ether/Internal/TH_Utils.hsdeleted−14
@@ -1,14 +0,0 @@
1−module Ether.Internal.TH_Utils
2− ( tupCount
3− , varName
4− , tagName
5− ) where
6−
7−import qualified Language.Haskell.TH as TH
8−
9−tupCount :: Int
10−tupCount = 62
11−
12−varName, tagName :: Int -> TH.Name
13−varName k = TH.mkName ('a' : show k)
14−tagName k = TH.mkName ('t' : show k)
src/Ether/Internal/Tags.hsdeleted−18
@@ -1,18 +0,0 @@
1−module Ether.Internal.Tags
2− ( Tags
3− , TagsK
4− , HList(..)
5− , KindOf
6− ) where
7−
8−import Data.Kind
9−
10−data HList xs where
11− HNil :: HList '[]
12− HCons :: x -> HList xs -> HList (x ': xs)
13−
14−type KindOf (a :: k) = k
15−
16−type family TagsK (p :: Type) :: [Type]
17−type family Tags (p :: Type) :: HList (TagsK p)
18−
src/Ether/Internal/TupleInstances.hsdeleted−24
@@ -1,24 +0,0 @@
1−{-# OPTIONS -fno-warn-orphans #-}
2−{-# LANGUAGE CPP #-}
3−
4−module Ether.Internal.TupleInstances () where
5−
6−import Data.Tagged
7−import Ether.Internal.Tags
8−import Ether.Internal.TH_TupleInstances
9−
10−type instance TagsK () = '[]
11−type instance TagsK (Tagged t a) = '[KindOf t]
12−type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]
13−
14−makeTupleInstancesTagsK
15−
16−type instance Tags () = 'HNil
17−type instance Tags (Tagged t a) = 'HCons t 'HNil
18−type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)
19−
20−makeTupleInstancesTags
21−
22−#ifndef DISABLE_TUP_INSTANCES
23−makeTupleInstancesHasLens [2..62]
24−#endif
src/Ether/Reader.hs+30−2
@@ -77,9 +77,15 @@ instance {-# OVERLAPPABLE #-}
77 , MonadReader tag r m
77 , MonadReader tag r m
78 ) => MonadReader tag r (t m)
78 ) => MonadReader tag r (t m)
79 where
79 where
80+
80 ask = Lift.lift (ask @tag)
81 ask = Lift.lift (ask @tag)
82+ {-# INLINE ask #-}
83+
81 local = Lift.liftLocal (ask @tag) (local @tag)
84 local = Lift.liftLocal (ask @tag) (local @tag)
85+ {-# INLINE local #-}
86+
82 reader = Lift.lift . reader @tag
87 reader = Lift.lift . reader @tag
88+ {-# INLINE reader #-}
83
89
84instance {-# OVERLAPPABLE #-}
90instance {-# OVERLAPPABLE #-}
85 ( Monad (trans m)
91 ( Monad (trans m)
@@ -92,18 +98,21 @@ instance {-# OVERLAPPABLE #-}
92 TaggedTrans effs trans m r ->
98 TaggedTrans effs trans m r ->
93 TaggedTrans (eff ': effs) trans m r)
99 TaggedTrans (eff ': effs) trans m r)
94 (ask @tag)
100 (ask @tag)
101+ {-# INLINE ask #-}
95
102
96 local =
103 local =
97 (coerce :: forall a .
104 (coerce :: forall a .
98 Lift.Local r (TaggedTrans effs trans m) a ->
105 Lift.Local r (TaggedTrans effs trans m) a ->
99 Lift.Local r (TaggedTrans (eff ': effs) trans m) a)
106 Lift.Local r (TaggedTrans (eff ': effs) trans m) a)
100 (local @tag)
107 (local @tag)
108+ {-# INLINE local #-}
101
109
102 reader =
110 reader =
103 (coerce :: forall a .
111 (coerce :: forall a .
104 ((r -> a) -> TaggedTrans effs trans m a) ->
112 ((r -> a) -> TaggedTrans effs trans m a) ->
105 ((r -> a) -> TaggedTrans (eff ': effs) trans m a))
113 ((r -> a) -> TaggedTrans (eff ': effs) trans m a))
106 (reader @tag)
114 (reader @tag)
115+ {-# INLINE reader #-}
107
116
108-- | Retrieves a function of the current environment.
117-- | Retrieves a function of the current environment.
109asks
118asks
@@ -113,6 +122,7 @@ asks
113 -- ^ The selector function to apply to the environment.
122 -- ^ The selector function to apply to the environment.
114 -> m a
123 -> m a
115asks = reader @tag
124asks = reader @tag
125+{-# INLINE asks #-}
116
126
117-- | Encode type-level information for 'ReaderT'.
127-- | Encode type-level information for 'ReaderT'.
118data READER
128data READER
@@ -135,16 +145,19 @@ type ReaderT tag r = TaggedTrans (TAGGED READER tag) (T.ReaderT r)
135-- | Constructor for computations in the reader monad transformer.
145-- | Constructor for computations in the reader monad transformer.
136readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
146readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
137readerT = coerce (T.ReaderT @r @m @a)
147readerT = coerce (T.ReaderT @r @m @a)
148+{-# INLINE readerT #-}
138
149
139-- | Runs a 'ReaderT' with the given environment
150-- | Runs a 'ReaderT' with the given environment
140-- and returns the final value.
151-- and returns the final value.
141runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a
152runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a
142−runReaderT = coerce (T.runReaderT @r @m @a)
153+runReaderT = coerce (T.runReaderT @r @_ @m @a)
154+{-# INLINE runReaderT #-}
143
155
144-- | Runs a 'ReaderT' with the given environment
156-- | Runs a 'ReaderT' with the given environment
145-- and returns the final value.
157-- and returns the final value.
146runReader :: forall tag r a . Reader tag r a -> r -> a
158runReader :: forall tag r a . Reader tag r a -> r -> a
147runReader = coerce (T.runReader @r @a)
159runReader = coerce (T.runReader @r @a)
160+{-# INLINE runReader #-}
148
161
149type instance HandleSuper READER r trans = ()
162type instance HandleSuper READER r trans = ()
150type instance HandleConstraint READER r trans m =
163type instance HandleConstraint READER r trans m =
@@ -152,6 +165,7 @@ type instance HandleConstraint READER r trans m =
152
165
153instance Handle READER r (T.ReaderT r) where
166instance Handle READER r (T.ReaderT r) where
154 handling r = r
167 handling r = r
168+ {-# INLINE handling #-}
155
169
156instance
170instance
157 ( Handle READER r trans
171 ( Handle READER r trans
@@ -162,16 +176,19 @@ instance
162 ask =
176 ask =
163 handling @READER @r @trans @m $
177 handling @READER @r @trans @m $
164 coerce (T.ask @r @(trans m))
178 coerce (T.ask @r @(trans m))
179+ {-# INLINE ask #-}
165
180
166 local =
181 local =
167 handling @READER @r @trans @m $
182 handling @READER @r @trans @m $
168 coerce (T.local @r @(trans m) @a) ::
183 coerce (T.local @r @(trans m) @a) ::
169 forall eff a . Local r (TaggedTrans eff trans m) a
184 forall eff a . Local r (TaggedTrans eff trans m) a
185+ {-# INLINE local #-}
170
186
171 reader =
187 reader =
172 handling @READER @r @trans @m $
188 handling @READER @r @trans @m $
173 coerce (T.reader @r @(trans m) @a) ::
189 coerce (T.reader @r @(trans m) @a) ::
174 forall eff a . (r -> a) -> TaggedTrans eff trans m a
190 forall eff a . (r -> a) -> TaggedTrans eff trans m a
191+ {-# INLINE reader #-}
175
192
176instance
193instance
177 ( HasLens tag payload r
194 ( HasLens tag payload r
@@ -186,6 +203,7 @@ instance
186 trans m a ->
203 trans m a ->
187 TaggedTrans eff trans m a)
204 TaggedTrans eff trans m a)
188 (T.asks (view (lensOf @tag @payload @r)))
205 (T.asks (view (lensOf @tag @payload @r)))
206+ {-# INLINE ask #-}
189
207
190 local f =
208 local f =
191 handling @READER @payload @trans @m $
209 handling @READER @payload @trans @m $
@@ -193,6 +211,7 @@ instance
193 (trans m a -> trans m a) ->
211 (trans m a -> trans m a) ->
194 (TaggedTrans eff trans m a -> TaggedTrans eff trans m a))
212 (TaggedTrans eff trans m a -> TaggedTrans eff trans m a))
195 (T.local (over (lensOf @tag @payload @r) f))
213 (T.local (over (lensOf @tag @payload @r) f))
214+ {-# INLINE local #-}
196
215
197type family READERS (ts :: HList xs) :: [Type] where
216type family READERS (ts :: HList xs) :: [Type] where
198 READERS 'HNil = '[]
217 READERS 'HNil = '[]
@@ -203,34 +222,43 @@ type ReadersT r = TaggedTrans (READERS (Tags r)) (T.ReaderT r)
203type Readers r = ReadersT r Identity
222type Readers r = ReadersT r Identity
204
223
205runReadersT :: forall p m a . ReadersT p m a -> p -> m a
224runReadersT :: forall p m a . ReadersT p m a -> p -> m a
206−runReadersT = coerce (T.runReaderT @p @m @a)
225+runReadersT = coerce (T.runReaderT @p @_ @m @a)
226+{-# INLINE runReadersT #-}
207
227
208runReaders :: forall p a . Readers p a -> p -> a
228runReaders :: forall p a . Readers p a -> p -> a
209runReaders = coerce (T.runReader @p @a)
229runReaders = coerce (T.runReader @p @a)
230+{-# INLINE runReaders #-}
210
231
211type ReaderT' r = ReaderT r r
232type ReaderT' r = ReaderT r r
212
233
213readerT' :: (r -> m a) -> ReaderT' r m a
234readerT' :: (r -> m a) -> ReaderT' r m a
214readerT' = readerT
235readerT' = readerT
236+{-# INLINE readerT' #-}
215
237
216runReaderT' :: ReaderT' r m a -> r -> m a
238runReaderT' :: ReaderT' r m a -> r -> m a
217runReaderT' = runReaderT
239runReaderT' = runReaderT
240+{-# INLINE runReaderT' #-}
218
241
219type Reader' r = Reader r r
242type Reader' r = Reader r r
220
243
221runReader' :: Reader' r a -> r -> a
244runReader' :: Reader' r a -> r -> a
222runReader' = runReader
245runReader' = runReader
246+{-# INLINE runReader' #-}
223
247
224type MonadReader' r = MonadReader r r
248type MonadReader' r = MonadReader r r
225
249
226local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a
250local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a
227local' = local @r
251local' = local @r
252+{-# INLINE local' #-}
228
253
229ask' :: forall r m . MonadReader' r m => m r
254ask' :: forall r m . MonadReader' r m => m r
230ask' = ask @r
255ask' = ask @r
256+{-# INLINE ask' #-}
231
257
232reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a
258reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a
233reader' = reader @r
259reader' = reader @r
260+{-# INLINE reader' #-}
234
261
235asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a
262asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a
236asks' = asks @r
263asks' = asks @r
264+{-# INLINE asks' #-}
src/Ether/State.hs+64−4
@@ -85,8 +85,8 @@ import Data.Kind
85import Data.Proxy
85import Data.Proxy
86import Data.Reflection
86import Data.Reflection
87
87
88−import Ether.Internal
89import Ether.TaggedTrans
88import Ether.TaggedTrans
89+import Ether.Internal
90
90
91class Monad m => MonadState tag s m | m tag -> s where
91class Monad m => MonadState tag s m | m tag -> s where
92
92
@@ -114,9 +114,15 @@ instance {-# OVERLAPPABLE #-}
114 , MonadState tag s m
114 , MonadState tag s m
115 ) => MonadState tag s (t m)
115 ) => MonadState tag s (t m)
116 where
116 where
117+
117 get = Lift.lift (get @tag)
118 get = Lift.lift (get @tag)
119+ {-# INLINE get #-}
120+
118 put = Lift.lift . put @tag
121 put = Lift.lift . put @tag
122+ {-# INLINE put #-}
123+
119 state = Lift.lift . state @tag
124 state = Lift.lift . state @tag
125+ {-# INLINE state #-}
120
126
121instance {-# OVERLAPPABLE #-}
127instance {-# OVERLAPPABLE #-}
122 ( Monad (trans m)
128 ( Monad (trans m)
@@ -129,29 +135,34 @@ instance {-# OVERLAPPABLE #-}
129 TaggedTrans effs trans m s ->
135 TaggedTrans effs trans m s ->
130 TaggedTrans (eff ': effs) trans m s)
136 TaggedTrans (eff ': effs) trans m s)
131 (get @tag)
137 (get @tag)
138+ {-# INLINE get #-}
132
139
133 put =
140 put =
134 (coerce ::
141 (coerce ::
135 (s -> TaggedTrans effs trans m ()) ->
142 (s -> TaggedTrans effs trans m ()) ->
136 (s -> TaggedTrans (eff ': effs) trans m ()))
143 (s -> TaggedTrans (eff ': effs) trans m ()))
137 (put @tag)
144 (put @tag)
145+ {-# INLINE put #-}
138
146
139 state =
147 state =
140 (coerce :: forall a .
148 (coerce :: forall a .
141 ((s -> (a, s)) -> TaggedTrans effs trans m a) ->
149 ((s -> (a, s)) -> TaggedTrans effs trans m a) ->
142 ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a))
150 ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a))
143 (state @tag)
151 (state @tag)
152+ {-# INLINE state #-}
153+
154+-- | Encode type-level information for 'StateT'.
155+data STATE
144
156
145-- | Modifies the state inside a state monad.
157-- | Modifies the state inside a state monad.
146modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()
158modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()
147modify f = state @tag (\s -> ((), f s))
159modify f = state @tag (\s -> ((), f s))
160+{-# INLINABLE modify #-}
148
161
149-- | Gets specific component of the state, using a projection function supplied.
162-- | Gets specific component of the state, using a projection function supplied.
150gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
163gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
151gets f = fmap f (get @tag)
164gets f = fmap f (get @tag)
152−
165+{-# INLINABLE gets #-}
153−-- | Encode type-level information for 'StateT'.
154−data STATE
155
166
156type instance HandleSuper STATE s trans = ()
167type instance HandleSuper STATE s trans = ()
157type instance HandleConstraint STATE s trans m =
168type instance HandleConstraint STATE s trans m =
@@ -159,9 +170,11 @@ type instance HandleConstraint STATE s trans m =
159
170
160instance Handle STATE s (T.Strict.StateT s) where
171instance Handle STATE s (T.Strict.StateT s) where
161 handling r = r
172 handling r = r
173+ {-# INLINE handling #-}
162
174
163instance Handle STATE s (T.Lazy.StateT s) where
175instance Handle STATE s (T.Lazy.StateT s) where
164 handling r = r
176 handling r = r
177+ {-# INLINE handling #-}
165
178
166instance
179instance
167 ( Handle STATE s trans
180 ( Handle STATE s trans
@@ -172,15 +185,18 @@ instance
172 get =
185 get =
173 handling @STATE @s @trans @m $
186 handling @STATE @s @trans @m $
174 coerce (T.get @s @(trans m))
187 coerce (T.get @s @(trans m))
188+ {-# INLINE get #-}
175
189
176 put =
190 put =
177 handling @STATE @s @trans @m $
191 handling @STATE @s @trans @m $
178 coerce (T.put @s @(trans m))
192 coerce (T.put @s @(trans m))
193+ {-# INLINE put #-}
179
194
180 state =
195 state =
181 handling @STATE @s @trans @m $
196 handling @STATE @s @trans @m $
182 coerce (T.state @s @(trans m) @a) ::
197 coerce (T.state @s @(trans m) @a) ::
183 forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a
198 forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a
199+ {-# INLINE state #-}
184
200
185instance
201instance
186 ( HasLens tag payload s
202 ( HasLens tag payload s
@@ -195,6 +211,7 @@ instance
195 trans m a ->
211 trans m a ->
196 TaggedTrans eff trans m a)
212 TaggedTrans eff trans m a)
197 (T.gets (view (lensOf @tag @payload @s)))
213 (T.gets (view (lensOf @tag @payload @s)))
214+ {-# INLINE get #-}
198
215
199 put s =
216 put s =
200 handling @STATE @payload @trans @m $
217 handling @STATE @payload @trans @m $
@@ -202,6 +219,7 @@ instance
202 trans m a ->
219 trans m a ->
203 TaggedTrans eff trans m a)
220 TaggedTrans eff trans m a)
204 (T.modify (over (lensOf @tag @payload @s) (const s)))
221 (T.modify (over (lensOf @tag @payload @s) (const s)))
222+ {-# INLINE put #-}
205
223
206 state f =
224 state f =
207 handling @STATE @payload @trans @m $
225 handling @STATE @payload @trans @m $
@@ -209,6 +227,7 @@ instance
209 trans m a ->
227 trans m a ->
210 TaggedTrans eff trans m a)
228 TaggedTrans eff trans m a)
211 (T.state (lensOf @tag @payload @s f))
229 (T.state (lensOf @tag @payload @s f))
230+ {-# INLINE state #-}
212
231
213-- | The parametrizable state monad.
232-- | The parametrizable state monad.
214--
233--
@@ -227,36 +246,43 @@ type StateT tag s = TaggedTrans (TAGGED STATE tag) (T.Strict.StateT s)
227-- | Constructor for computations in the state monad transformer.
246-- | Constructor for computations in the state monad transformer.
228stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
247stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
229stateT = coerce (T.Strict.StateT @s @m @a)
248stateT = coerce (T.Strict.StateT @s @m @a)
249+{-# INLINE stateT #-}
230
250
231-- | Runs a 'StateT' with the given initial state
251-- | Runs a 'StateT' with the given initial state
232-- and returns both the final value and the final state.
252-- and returns both the final value and the final state.
233runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
253runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
234runStateT = coerce (T.Strict.runStateT @s @m @a)
254runStateT = coerce (T.Strict.runStateT @s @m @a)
255+{-# INLINE runStateT #-}
235
256
236-- | Runs a 'StateT' with the given initial state
257-- | Runs a 'StateT' with the given initial state
237-- and returns the final value, discarding the final state.
258-- and returns the final value, discarding the final state.
238evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
259evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
239evalStateT = coerce (T.Strict.evalStateT @m @s @a)
260evalStateT = coerce (T.Strict.evalStateT @m @s @a)
261+{-# INLINE evalStateT #-}
240
262
241-- | Runs a 'StateT' with the given initial state
263-- | Runs a 'StateT' with the given initial state
242-- and returns the final state, discarding the final value.
264-- and returns the final state, discarding the final value.
243execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
265execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
244execStateT = coerce (T.Strict.execStateT @m @s @a)
266execStateT = coerce (T.Strict.execStateT @m @s @a)
267+{-# INLINE execStateT #-}
245
268
246-- | Runs a 'State' with the given initial state
269-- | Runs a 'State' with the given initial state
247-- and returns both the final value and the final state.
270-- and returns both the final value and the final state.
248runState :: forall tag s a . State tag s a -> s -> (a, s)
271runState :: forall tag s a . State tag s a -> s -> (a, s)
249runState = coerce (T.Strict.runState @s @a)
272runState = coerce (T.Strict.runState @s @a)
273+{-# INLINE runState #-}
250
274
251-- | Runs a 'State' with the given initial state
275-- | Runs a 'State' with the given initial state
252-- and returns the final value, discarding the final state.
276-- and returns the final value, discarding the final state.
253evalState :: forall tag s a . State tag s a -> s -> a
277evalState :: forall tag s a . State tag s a -> s -> a
254evalState = coerce (T.Strict.evalState @s @a)
278evalState = coerce (T.Strict.evalState @s @a)
279+{-# INLINE evalState #-}
255
280
256-- | Runs a 'State' with the given initial state
281-- | Runs a 'State' with the given initial state
257-- and returns the final state, discarding the final value.
282-- and returns the final state, discarding the final value.
258execState :: forall tag s a . State tag s a -> s -> s
283execState :: forall tag s a . State tag s a -> s -> s
259execState = coerce (T.Strict.execState @s @a)
284execState = coerce (T.Strict.execState @s @a)
285+{-# INLINE execState #-}
260
286
261-- | The parametrizable state monad.
287-- | The parametrizable state monad.
262--
288--
@@ -275,36 +301,43 @@ type LazyStateT tag s = TaggedTrans (TAGGED STATE tag) (T.Lazy.StateT s)
275-- | Constructor for computations in the state monad transformer.
301-- | Constructor for computations in the state monad transformer.
276lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a
302lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a
277lazyStateT = coerce (T.Lazy.StateT @s @m @a)
303lazyStateT = coerce (T.Lazy.StateT @s @m @a)
304+{-# INLINE lazyStateT #-}
278
305
279-- | Runs a 'StateT' with the given initial state
306-- | Runs a 'StateT' with the given initial state
280-- and returns both the final value and the final state.
307-- and returns both the final value and the final state.
281runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s)
308runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s)
282runLazyStateT = coerce (T.Lazy.runStateT @s @m @a)
309runLazyStateT = coerce (T.Lazy.runStateT @s @m @a)
310+{-# INLINE runLazyStateT #-}
283
311
284-- | Runs a 'StateT' with the given initial state
312-- | Runs a 'StateT' with the given initial state
285-- and returns the final value, discarding the final state.
313-- and returns the final value, discarding the final state.
286evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a
314evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a
287evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a)
315evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a)
316+{-# INLINE evalLazyStateT #-}
288
317
289-- | Runs a 'StateT' with the given initial state
318-- | Runs a 'StateT' with the given initial state
290-- and returns the final state, discarding the final value.
319-- and returns the final state, discarding the final value.
291execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s
320execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s
292execLazyStateT = coerce (T.Lazy.execStateT @m @s @a)
321execLazyStateT = coerce (T.Lazy.execStateT @m @s @a)
322+{-# INLINE execLazyStateT #-}
293
323
294-- | Runs a 'State' with the given initial state
324-- | Runs a 'State' with the given initial state
295-- and returns both the final value and the final state.
325-- and returns both the final value and the final state.
296runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s)
326runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s)
297runLazyState = coerce (T.Lazy.runState @s @a)
327runLazyState = coerce (T.Lazy.runState @s @a)
328+{-# INLINE runLazyState #-}
298
329
299-- | Runs a 'State' with the given initial state
330-- | Runs a 'State' with the given initial state
300-- and returns the final value, discarding the final state.
331-- and returns the final value, discarding the final state.
301evalLazyState :: forall tag s a . LazyState tag s a -> s -> a
332evalLazyState :: forall tag s a . LazyState tag s a -> s -> a
302evalLazyState = coerce (T.Lazy.evalState @s @a)
333evalLazyState = coerce (T.Lazy.evalState @s @a)
334+{-# INLINE evalLazyState #-}
303
335
304-- | Runs a 'State' with the given initial state
336-- | Runs a 'State' with the given initial state
305-- and returns the final state, discarding the final value.
337-- and returns the final state, discarding the final value.
306execLazyState :: forall tag s a . LazyState tag s a -> s -> s
338execLazyState :: forall tag s a . LazyState tag s a -> s -> s
307execLazyState = coerce (T.Lazy.execState @s @a)
339execLazyState = coerce (T.Lazy.execState @s @a)
340+{-# INLINE execLazyState #-}
308
341
309type family STATES (ts :: HList xs) :: [Type] where
342type family STATES (ts :: HList xs) :: [Type] where
310 STATES 'HNil = '[]
343 STATES 'HNil = '[]
@@ -316,82 +349,107 @@ type States s = StatesT s Identity
316
349
317runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p)
350runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p)
318runStatesT = coerce (T.Strict.runStateT @p @m @a)
351runStatesT = coerce (T.Strict.runStateT @p @m @a)
352+{-# INLINE runStatesT #-}
319
353
320runStates :: forall p a . States p a -> p -> (a, p)
354runStates :: forall p a . States p a -> p -> (a, p)
321runStates = coerce (T.Strict.runState @p @a)
355runStates = coerce (T.Strict.runState @p @a)
356+{-# INLINE runStates #-}
322
357
323type StateT' s = StateT s s
358type StateT' s = StateT s s
324
359
325stateT' :: (s -> m (a, s)) -> StateT' s m a
360stateT' :: (s -> m (a, s)) -> StateT' s m a
326stateT' = stateT
361stateT' = stateT
362+{-# INLINE stateT' #-}
327
363
328runStateT' :: StateT' s m a -> s -> m (a, s)
364runStateT' :: StateT' s m a -> s -> m (a, s)
329runStateT' = runStateT
365runStateT' = runStateT
366+{-# INLINE runStateT' #-}
330
367
331runState' :: State' s a -> s -> (a, s)
368runState' :: State' s a -> s -> (a, s)
332runState' = runState
369runState' = runState
370+{-# INLINE runState' #-}
333
371
334evalStateT' :: Monad m => StateT' s m a -> s -> m a
372evalStateT' :: Monad m => StateT' s m a -> s -> m a
335evalStateT' = evalStateT
373evalStateT' = evalStateT
374+{-# INLINE evalStateT' #-}
336
375
337type State' s = State s s
376type State' s = State s s
338
377
339evalState' :: State' s a -> s -> a
378evalState' :: State' s a -> s -> a
340evalState' = evalState
379evalState' = evalState
380+{-# INLINE evalState' #-}
341
381
342execStateT' :: Monad m => StateT' s m a -> s -> m s
382execStateT' :: Monad m => StateT' s m a -> s -> m s
343execStateT' = execStateT
383execStateT' = execStateT
384+{-# INLINE execStateT' #-}
344
385
345execState' :: State' s a -> s -> s
386execState' :: State' s a -> s -> s
346execState' = execState
387execState' = execState
388+{-# INLINE execState' #-}
347
389
348type LazyStateT' s = LazyStateT s s
390type LazyStateT' s = LazyStateT s s
349
391
350lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a
392lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a
351lazyStateT' = lazyStateT
393lazyStateT' = lazyStateT
394+{-# INLINE lazyStateT' #-}
352
395
353runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s)
396runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s)
354runLazyStateT' = runLazyStateT
397runLazyStateT' = runLazyStateT
398+{-# INLINE runLazyStateT' #-}
355
399
356runLazyState' :: LazyState' s a -> s -> (a, s)
400runLazyState' :: LazyState' s a -> s -> (a, s)
357runLazyState' = runLazyState
401runLazyState' = runLazyState
402+{-# INLINE runLazyState' #-}
358
403
359evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a
404evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a
360evalLazyStateT' = evalLazyStateT
405evalLazyStateT' = evalLazyStateT
406+{-# INLINE evalLazyStateT' #-}
361
407
362type LazyState' s = LazyState s s
408type LazyState' s = LazyState s s
363
409
364evalLazyState' :: LazyState' s a -> s -> a
410evalLazyState' :: LazyState' s a -> s -> a
365evalLazyState' = evalLazyState
411evalLazyState' = evalLazyState
412+{-# INLINE evalLazyState' #-}
366
413
367execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s
414execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s
368execLazyStateT' = execLazyStateT
415execLazyStateT' = execLazyStateT
416+{-# INLINE execLazyStateT' #-}
369
417
370execLazyState' :: LazyState' s a -> s -> s
418execLazyState' :: LazyState' s a -> s -> s
371execLazyState' = execLazyState
419execLazyState' = execLazyState
420+{-# INLINE execLazyState' #-}
372
421
373type MonadState' s = MonadState s s
422type MonadState' s = MonadState s s
374
423
375get' :: forall s m . MonadState' s m => m s
424get' :: forall s m . MonadState' s m => m s
376get' = get @s
425get' = get @s
426+{-# INLINE get' #-}
377
427
378gets' :: forall s m a . MonadState' s m => (s -> a) -> m a
428gets' :: forall s m a . MonadState' s m => (s -> a) -> m a
379gets' = gets @s
429gets' = gets @s
430+{-# INLINE gets' #-}
380
431
381put' :: forall s m . MonadState' s m => s -> m ()
432put' :: forall s m . MonadState' s m => s -> m ()
382put' = put @s
433put' = put @s
434+{-# INLINE put' #-}
383
435
384state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a
436state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a
385state' = state @s
437state' = state @s
438+{-# INLINE state' #-}
386
439
387modify' :: forall s m . MonadState' s m => (s -> s) -> m ()
440modify' :: forall s m . MonadState' s m => (s -> s) -> m ()
388modify' = modify @s
441modify' = modify @s
442+{-# INLINE modify' #-}
389
443
390-- | Encode type-level information for 'zoom'.
444-- | Encode type-level information for 'zoom'.
391data ZOOM t z
445data ZOOM t z
392
446
393type ZoomT t (z :: Type) = TaggedTrans (ZOOM t z) IdentityT
447type ZoomT t (z :: Type) = TaggedTrans (ZOOM t z) IdentityT
394
448
449+newtype ReifiedLens s t a b = Lens (Lens s t a b)
450+
451+type ReifiedLens' s a = ReifiedLens s s a a
452+
395-- | Zoom into a part of a state using a lens.
453-- | Zoom into a part of a state using a lens.
396zoom
454zoom
397 :: forall tag sOuter sInner m a
455 :: forall tag sOuter sInner m a
@@ -399,6 +457,7 @@ zoom
399 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a)
457 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a)
400 -> m a
458 -> m a
401zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))
459zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))
460+{-# INLINE zoom #-}
402
461
403instance
462instance
404 ( MonadState tag sOuter m
463 ( MonadState tag sOuter m
@@ -413,3 +472,4 @@ instance
413 (state @tag . l)
472 (state @tag . l)
414 where
473 where
415 Lens l = reflect (Proxy :: Proxy z)
474 Lens l = reflect (Proxy :: Proxy z)
475+ {-# INLINE state #-}
src/Ether/TagDispatch.hs+54−4
@@ -63,38 +63,63 @@ type TagAttachT t = TaggedTrans (TAG_ATTACH t) IdentityT
63-- | Attach a tag to untagged transformers.
63-- | Attach a tag to untagged transformers.
64tagAttach :: forall tag m a . TagAttachT tag m a -> m a
64tagAttach :: forall tag m a . TagAttachT tag m a -> m a
65tagAttach = coerce (runIdentityT @_ @m @a)
65tagAttach = coerce (runIdentityT @_ @m @a)
66+{-# INLINE tagAttach #-}
66
67
67−instance {-# OVERLAPPING #-}
68+instance
68 ( MonadReader tag r m, trans ~ IdentityT
69 ( MonadReader tag r m, trans ~ IdentityT
69 ) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m)
70 ) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m)
70 where
71 where
72+
71 ask = ask @tag
73 ask = ask @tag
74+ {-# INLINE ask #-}
75+
72 local = local @tag
76 local = local @tag
77+ {-# INLINE local #-}
78+
73 reader = reader @tag
79 reader = reader @tag
80+ {-# INLINE reader #-}
74
81
75−instance {-# OVERLAPPING #-}
82+instance
76 ( MonadState tag s m, trans ~ IdentityT
83 ( MonadState tag s m, trans ~ IdentityT
77 ) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m)
84 ) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m)
78 where
85 where
86+
79 get = get @tag
87 get = get @tag
88+ {-# INLINE get #-}
89+
80 put = put @tag
90 put = put @tag
91+ {-# INLINE put #-}
92+
81 state = state @tag
93 state = state @tag
94+ {-# INLINE state #-}
82
95
83−instance {-# OVERLAPPING #-}
96+instance
84 ( MonadExcept tag e m, trans ~ IdentityT
97 ( MonadExcept tag e m, trans ~ IdentityT
85 ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m)
98 ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m)
86 where
99 where
100+
87 throwError = throw @tag
101 throwError = throw @tag
102+ {-# INLINE throwError #-}
103+
88 catchError = catch @tag
104 catchError = catch @tag
105+ {-# INLINE catchError #-}
89
106
90−instance {-# OVERLAPPING #-}
107+instance
91 ( MonadWriter tag w m, trans ~ IdentityT
108 ( MonadWriter tag w m, trans ~ IdentityT
92 ) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m)
109 ) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m)
93 where
110 where
111+
94 writer = writer @tag
112 writer = writer @tag
113+ {-# INLINE writer #-}
114+
95 tell = tell @tag
115 tell = tell @tag
116+ {-# INLINE tell #-}
117+
96 listen = listen @tag
118 listen = listen @tag
119+ {-# INLINE listen #-}
120+
97 pass = pass @tag
121 pass = pass @tag
122+ {-# INLINE pass #-}
98
123
99-- | Encode type-level information for 'tagReplace'.
124-- | Encode type-level information for 'tagReplace'.
100data TAG_REPLACE tOld tNew
125data TAG_REPLACE tOld tNew
@@ -104,35 +129,60 @@ type TagReplaceT tOld tNew = TaggedTrans (TAG_REPLACE tOld tNew) IdentityT
104-- | Replace a tag with another tag.
129-- | Replace a tag with another tag.
105tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a
130tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a
106tagReplace = coerce (runIdentityT @_ @m @a)
131tagReplace = coerce (runIdentityT @_ @m @a)
132+{-# INLINE tagReplace #-}
107
133
108instance
134instance
109 ( MonadReader tNew r m, trans ~ IdentityT
135 ( MonadReader tNew r m, trans ~ IdentityT
110 ) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
136 ) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
111 where
137 where
138+
112 ask = ask @tNew
139 ask = ask @tNew
140+ {-# INLINE ask #-}
141+
113 local = local @tNew
142 local = local @tNew
143+ {-# INLINE local #-}
144+
114 reader = reader @tNew
145 reader = reader @tNew
146+ {-# INLINE reader #-}
115
147
116instance
148instance
117 ( MonadState tNew s m, trans ~ IdentityT
149 ( MonadState tNew s m, trans ~ IdentityT
118 ) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
150 ) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
119 where
151 where
152+
120 get = get @tNew
153 get = get @tNew
154+ {-# INLINE get #-}
155+
121 put = put @tNew
156 put = put @tNew
157+ {-# INLINE put #-}
158+
122 state = state @tNew
159 state = state @tNew
160+ {-# INLINE state #-}
123
161
124instance
162instance
125 ( MonadExcept tNew e m, trans ~ IdentityT
163 ( MonadExcept tNew e m, trans ~ IdentityT
126 ) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
164 ) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
127 where
165 where
166+
128 throw = throw @tNew
167 throw = throw @tNew
168+ {-# INLINE throw #-}
169+
129 catch = catch @tNew
170 catch = catch @tNew
171+ {-# INLINE catch #-}
130
172
131instance
173instance
132 ( MonadWriter tNew w m, trans ~ IdentityT
174 ( MonadWriter tNew w m, trans ~ IdentityT
133 ) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
175 ) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
134 where
176 where
177+
135 writer = writer @tNew
178 writer = writer @tNew
179+ {-# INLINE writer #-}
180+
136 tell = tell @tNew
181 tell = tell @tNew
182+ {-# INLINE tell #-}
183+
137 listen = listen @tNew
184 listen = listen @tNew
185+ {-# INLINE listen #-}
186+
138 pass = pass @tNew
187 pass = pass @tNew
188+ {-# INLINE pass #-}
src/Ether/TaggedTrans.hs+13−37
@@ -1,7 +1,3 @@
1−-- The use of ImpredicativeTypes here is safe, see discussion under GitHub issue
2−-- #35. It's only needed to allow the visible type application of a polytype.
3−{-# LANGUAGE ImpredicativeTypes #-}
4−
5module Ether.TaggedTrans
1module Ether.TaggedTrans
6 ( TaggedTrans(..)
2 ( TaggedTrans(..)
7 ) where
3 ) where
@@ -11,7 +7,7 @@ import Control.Monad (MonadPlus)
11import Control.Monad.Fix (MonadFix)
7import Control.Monad.Fix (MonadFix)
12import Control.Monad.Trans.Class (MonadTrans, lift)
8import Control.Monad.Trans.Class (MonadTrans, lift)
13import Control.Monad.IO.Class (MonadIO)
9import Control.Monad.IO.Class (MonadIO)
14−import Control.Monad.Morph (MFunctor(..), MMonad(..))
10+import Control.Monad.Morph (MFunctor, MMonad)
15import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
11import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
16
12
17import qualified Control.Monad.Base as MB
13import qualified Control.Monad.Base as MB
@@ -37,7 +33,7 @@ newtype TaggedTrans tag trans m a = TaggedTrans (trans m a)
37 deriving
33 deriving
38 ( Generic
34 ( Generic
39 , Functor, Applicative, Alternative, Monad, MonadPlus
35 , Functor, Applicative, Alternative, Monad, MonadPlus
40− , MonadFix, MonadTrans, MonadIO
36+ , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
41 , MonadThrow, MonadCatch, MonadMask )
37 , MonadThrow, MonadCatch, MonadMask )
42
38
43type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a
39type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a
@@ -53,6 +49,7 @@ instance
53 (b a -> trans m a) ->
49 (b a -> trans m a) ->
54 (b a -> TaggedTrans tag trans m a))
50 (b a -> TaggedTrans tag trans m a))
55 MB.liftBase
51 MB.liftBase
52+ {-# INLINE liftBase #-}
56
53
57instance
54instance
58 ( MC.MonadTransControl trans
55 ( MC.MonadTransControl trans
@@ -63,9 +60,11 @@ instance
63 liftWith = MC.defaultLiftWith
60 liftWith = MC.defaultLiftWith
64 (coerce :: Pack tag trans m a)
61 (coerce :: Pack tag trans m a)
65 (coerce :: Unpack tag trans m a)
62 (coerce :: Unpack tag trans m a)
63+ {-# INLINE liftWith #-}
66
64
67 restoreT = MC.defaultRestoreT
65 restoreT = MC.defaultRestoreT
68 (coerce :: Pack tag trans m a)
66 (coerce :: Pack tag trans m a)
67+ {-# INLINE restoreT #-}
69
68
70type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a
69type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a
71
70
@@ -76,6 +75,7 @@ coerceLiftBaseWith ::
76 LiftBaseWith b (TaggedTrans tag trans m) a
75 LiftBaseWith b (TaggedTrans tag trans m) a
77coerceLiftBaseWith lbw =
76coerceLiftBaseWith lbw =
78 unLBW (coerce (LBW lbw))
77 unLBW (coerce (LBW lbw))
78+{-# INLINE coerceLiftBaseWith #-}
79
79
80instance
80instance
81 ( MC.MonadBaseControl b (trans m)
81 ( MC.MonadBaseControl b (trans m)
@@ -84,12 +84,14 @@ instance
84 type StM (TaggedTrans tag trans m) a = MC.StM (trans m) a
84 type StM (TaggedTrans tag trans m) a = MC.StM (trans m) a
85
85
86 liftBaseWith = coerceLiftBaseWith MC.liftBaseWith
86 liftBaseWith = coerceLiftBaseWith MC.liftBaseWith
87+ {-# INLINE liftBaseWith #-}
87
88
88 restoreM =
89 restoreM =
89 (coerce :: forall a .
90 (coerce :: forall a .
90 (MC.StM (trans m) a -> trans m a) ->
91 (MC.StM (trans m) a -> trans m a) ->
91 (MC.StM (trans m) a -> TaggedTrans tag trans m a))
92 (MC.StM (trans m) a -> TaggedTrans tag trans m a))
92 MC.restoreM
93 MC.restoreM
94+ {-# INLINE restoreM #-}
93
95
94type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a
96type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a
95
97
@@ -130,7 +132,7 @@ instance Lift.LiftCallCC trans => Lift.LiftCallCC (TaggedTrans tag trans) where
130
132
131-- Instances for mtl classes
133-- Instances for mtl classes
132
134
133−instance
135+instance {-# OVERLAPPABLE #-}
134 ( Mtl.MonadCont m
136 ( Mtl.MonadCont m
135 , Lift.LiftCallCC trans
137 , Lift.LiftCallCC trans
136 , Monad (trans m)
138 , Monad (trans m)
@@ -138,7 +140,7 @@ instance
138 where
140 where
139 callCC = Lift.liftCallCC' Mtl.callCC
141 callCC = Lift.liftCallCC' Mtl.callCC
140
142
141−instance
143+instance {-# OVERLAPPABLE #-}
142 ( Mtl.MonadReader r m
144 ( Mtl.MonadReader r m
143 , Lift.LiftLocal trans
145 , Lift.LiftLocal trans
144 , Monad (trans m)
146 , Monad (trans m)
@@ -148,7 +150,7 @@ instance
148 local = Lift.liftLocal Mtl.ask Mtl.local
150 local = Lift.liftLocal Mtl.ask Mtl.local
149 reader = lift . Mtl.reader
151 reader = lift . Mtl.reader
150
152
151−instance
153+instance {-# OVERLAPPABLE #-}
152 ( Mtl.MonadState s m
154 ( Mtl.MonadState s m
153 , MonadTrans trans
155 , MonadTrans trans
154 , Monad (trans m)
156 , Monad (trans m)
@@ -158,7 +160,7 @@ instance
158 put = lift . Mtl.put
160 put = lift . Mtl.put
159 state = lift . Mtl.state
161 state = lift . Mtl.state
160
162
161−instance
163+instance {-# OVERLAPPABLE #-}
162 ( Mtl.MonadWriter w m
164 ( Mtl.MonadWriter w m
163 , Lift.LiftListen trans
165 , Lift.LiftListen trans
164 , Lift.LiftPass trans
166 , Lift.LiftPass trans
@@ -170,7 +172,7 @@ instance
170 listen = Lift.liftListen Mtl.listen
172 listen = Lift.liftListen Mtl.listen
171 pass = Lift.liftPass Mtl.pass
173 pass = Lift.liftPass Mtl.pass
172
174
173−instance
175+instance {-# OVERLAPPABLE #-}
174 ( Mtl.MonadError e m
176 ( Mtl.MonadError e m
175 , Lift.LiftCatch trans
177 , Lift.LiftCatch trans
176 , Monad (trans m)
178 , Monad (trans m)
@@ -178,29 +180,3 @@ instance
178 where
180 where
179 throwError = lift . Mtl.throwError
181 throwError = lift . Mtl.throwError
180 catchError = Lift.liftCatch Mtl.catchError
182 catchError = Lift.liftCatch Mtl.catchError
181−
182−type Hoist trans =
183− forall m n b . Monad m =>
184− (forall a . m a -> n a) -> trans m b -> trans n b
185−
186−-- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will
187−-- trigger GHC Trac #11837 on GHC 8.0.1 and older.
188−instance MFunctor trans => MFunctor (TaggedTrans tag trans) where
189− hoist =
190− coerce
191− @(Hoist trans)
192− @(Hoist (TaggedTrans tag trans))
193− hoist
194−
195−type Embed trans =
196− forall n m b . Monad n =>
197− (forall a . m a -> trans n a) -> trans m b -> trans n b
198−
199−-- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will
200−-- trigger GHC Trac #11837 on GHC 8.0.1 and older.
201−instance MMonad trans => MMonad (TaggedTrans tag trans) where
202− embed =
203− coerce
204− @(Embed trans)
205− @(Embed (TaggedTrans tag trans))
206− embed
src/Ether/Writer.hs+56−123
@@ -17,15 +17,6 @@ module Ether.Writer
17 , writerT
17 , writerT
18 , runWriterT
18 , runWriterT
19 , execWriterT
19 , execWriterT
20− -- * The Writer monad (lazy)
21− , LazyWriter
22− , runLazyWriter
23− , execLazyWriter
24− -- * The WriterT monad transformer (lazy)
25− , LazyWriterT
26− , lazyWriterT
27− , runLazyWriterT
28− , execLazyWriterT
29 -- * MonadWriter class (implicit)
20 -- * MonadWriter class (implicit)
30 , MonadWriter'
21 , MonadWriter'
31 , writer'
22 , writer'
@@ -43,15 +34,6 @@ module Ether.Writer
43 , writerT'
34 , writerT'
44 , runWriterT'
35 , runWriterT'
45 , execWriterT'
36 , execWriterT'
46− -- * The Writer monad (lazy, implicit)
47− , LazyWriter'
48− , runLazyWriter'
49− , execLazyWriter'
50− -- * The WriterT monad transformer (lazy, implicit)
51− , LazyWriterT'
52− , lazyWriterT'
53− , runLazyWriterT'
54− , execLazyWriterT'
55 -- * Internal labels
37 -- * Internal labels
56 , TAGGED
38 , TAGGED
57 , WRITER
39 , WRITER
@@ -60,14 +42,12 @@ module Ether.Writer
60import Control.Monad.Signatures (Listen, Pass)
42import Control.Monad.Signatures (Listen, Pass)
61import qualified Control.Monad.Trans.Lift.Listen as Lift
43import qualified Control.Monad.Trans.Lift.Listen as Lift
62import qualified Control.Monad.Trans.Lift.Pass as Lift
44import qualified Control.Monad.Trans.Lift.Pass as Lift
63−import qualified Control.Monad.Writer.Class as T
45+import qualified Control.Monad.Writer as T
64−import qualified Control.Monad.Writer.CPS as T.CPS
65−import qualified Control.Monad.Writer.Lazy as T.Lazy
66import Data.Coerce
46import Data.Coerce
67import Data.Functor.Identity
47import Data.Functor.Identity
68
48
69−import Ether.Internal
70import Ether.TaggedTrans
49import Ether.TaggedTrans
50+import Ether.Internal
71
51
72class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where
52class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where
73
53
@@ -96,10 +76,18 @@ instance {-# OVERLAPPABLE #-}
96 , MonadWriter tag w m
76 , MonadWriter tag w m
97 , Monoid w
77 , Monoid w
98 ) => MonadWriter tag w (t m) where
78 ) => MonadWriter tag w (t m) where
79+
99 writer = Lift.lift . writer @tag
80 writer = Lift.lift . writer @tag
81+ {-# INLINE writer #-}
82+
100 tell = Lift.lift . tell @tag
83 tell = Lift.lift . tell @tag
84+ {-# INLINE tell #-}
85+
101 listen = Lift.liftListen (listen @tag)
86 listen = Lift.liftListen (listen @tag)
87+ {-# INLINE listen #-}
88+
102 pass = Lift.liftPass (pass @tag)
89 pass = Lift.liftPass (pass @tag)
90+ {-# INLINE pass #-}
103
91
104-- | Execute an action and add the result of applying the given function to
92-- | Execute an action and add the result of applying the given function to
105-- its accumulator to the value of the computation.
93-- its accumulator to the value of the computation.
@@ -117,41 +105,6 @@ censor f m = pass @tag $ do
117-- | Encode type-level information for 'WriterT'.
105-- | Encode type-level information for 'WriterT'.
118data WRITER
106data WRITER
119
107
120−type instance HandleSuper WRITER w trans = Monoid w
121−type instance HandleConstraint WRITER w trans m =
122− T.MonadWriter w (trans m)
123−
124−instance Monoid w => Handle WRITER w (T.CPS.WriterT w) where
125− handling r = r
126−
127−instance Monoid w => Handle WRITER w (T.Lazy.WriterT w) where
128− handling r = r
129−
130−instance
131− ( Handle WRITER w trans
132− , Monad m, Monad (trans m)
133− ) => MonadWriter tag w (TaggedTrans (TAGGED WRITER tag) trans m)
134− where
135−
136− writer =
137− handling @WRITER @w @trans @m $
138− coerce (T.writer @w @(trans m) @a) ::
139− forall eff a . (a, w) -> TaggedTrans eff trans m a
140−
141− tell =
142− handling @WRITER @w @trans @m $
143− coerce (T.tell @w @(trans m))
144−
145− listen =
146− handling @WRITER @w @trans @m $
147− coerce (T.listen @w @(trans m) @a) ::
148− forall eff a . Listen w (TaggedTrans eff trans m) a
149−
150− pass =
151− handling @WRITER @w @trans @m $
152− coerce (T.pass @w @(trans m) @a) ::
153− forall eff a . Pass w (TaggedTrans eff trans m) a
154−
155-- | The parametrizable writer monad.
108-- | The parametrizable writer monad.
156--
109--
157-- Computations can accumulate a monoid value.
110-- Computations can accumulate a monoid value.
@@ -164,108 +117,88 @@ type Writer tag w = WriterT tag w Identity
164--
117--
165-- The 'return' function produces the output 'mempty', while '>>=' combines
118-- The 'return' function produces the output 'mempty', while '>>=' combines
166-- the outputs of the subcomputations using 'mappend'.
119-- the outputs of the subcomputations using 'mappend'.
167−type WriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.CPS.WriterT w)
120+type WriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.WriterT w)
168
121
169-- | Constructor for computations in the writer monad transformer.
122-- | Constructor for computations in the writer monad transformer.
170−writerT :: forall tag w m a . (Functor m, Monoid w) => m (a, w) -> WriterT tag w m a
123+writerT :: forall tag w m a . m (a, w) -> WriterT tag w m a
171−writerT = coerce (T.CPS.writerT @m @w @a)
124+writerT = coerce (T.WriterT @w @m @a)
172
125
173-- | Runs a 'WriterT' and returns both the normal value
126-- | Runs a 'WriterT' and returns both the normal value
174-- and the final accumulator.
127-- and the final accumulator.
175−runWriterT :: forall tag w m a . Monoid w => WriterT tag w m a -> m (a, w)
128+runWriterT :: forall tag w m a . WriterT tag w m a -> m (a, w)
176−runWriterT = coerce (T.CPS.runWriterT @w @m @a)
129+runWriterT = coerce (T.runWriterT @w @m @a)
177
130
178-- | Runs a 'Writer' and returns both the normal value
131-- | Runs a 'Writer' and returns both the normal value
179-- and the final accumulator.
132-- and the final accumulator.
180−runWriter :: forall tag w a . Monoid w => Writer tag w a -> (a, w)
133+runWriter :: forall tag w a . Writer tag w a -> (a, w)
181−runWriter = coerce (T.CPS.runWriter @w @a)
134+runWriter = coerce (T.runWriter @w @a)
182
135
183-- | Runs a 'WriterT' and returns the final accumulator,
136-- | Runs a 'WriterT' and returns the final accumulator,
184-- discarding the normal value.
137-- discarding the normal value.
185−execWriterT :: forall tag w m a . (Monad m, Monoid w) => WriterT tag w m a -> m w
138+execWriterT :: forall tag w m a . Monad m => WriterT tag w m a -> m w
186−execWriterT = coerce (T.CPS.execWriterT @m @w @a)
139+execWriterT = coerce (T.execWriterT @m @w @a)
187
140
188-- | Runs a 'Writer' and returns the final accumulator,
141-- | Runs a 'Writer' and returns the final accumulator,
189-- discarding the normal value.
142-- discarding the normal value.
190−execWriter :: forall tag w a . Monoid w => Writer tag w a -> w
143+execWriter :: forall tag w a . Writer tag w a -> w
191−execWriter = coerce (T.CPS.execWriter @w @a)
144+execWriter = coerce (T.execWriter @w @a)
192
145
193−-- | The parametrizable writer monad.
146+type instance HandleSuper WRITER w trans = Monoid w
194−--
147+type instance HandleConstraint WRITER w trans m =
195−-- Computations can accumulate a monoid value.
148+ T.MonadWriter w (trans m)
196−--
197−-- The 'return' function produces the output 'mempty', while '>>=' combines
198−-- the outputs of the subcomputations using 'mappend'.
199−type LazyWriter tag w = LazyWriterT tag w Identity
200
149
201−-- | The writer monad transformer.
150+instance Monoid w => Handle WRITER w (T.WriterT w) where
202−--
151+ handling r = r
203−-- The 'return' function produces the output 'mempty', while '>>=' combines
152+ {-# INLINE handling #-}
204−-- the outputs of the subcomputations using 'mappend'.
205−type LazyWriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.Lazy.WriterT w)
206
153
207−-- | Constructor for computations in the writer monad transformer.
154+instance
208−lazyWriterT :: forall tag w m a . m (a, w) -> LazyWriterT tag w m a
155+ ( Handle WRITER w trans
209−lazyWriterT = coerce (T.Lazy.WriterT @w @m @a)
156+ , Monad m, Monad (trans m)
157+ ) => MonadWriter tag w (TaggedTrans (TAGGED WRITER tag) trans m)
158+ where
210
159
211−-- | Runs a 'WriterT' and returns both the normal value
160+ writer =
212−-- and the final accumulator.
161+ handling @WRITER @w @trans @m $
213−runLazyWriterT :: forall tag w m a . LazyWriterT tag w m a -> m (a, w)
162+ coerce (T.writer @w @(trans m) @a) ::
214−runLazyWriterT = coerce (T.Lazy.runWriterT @w @m @a)
163+ forall eff a . (a, w) -> TaggedTrans eff trans m a
164+ {-# INLINE writer #-}
215
165
216−-- | Runs a 'Writer' and returns both the normal value
166+ tell =
217−-- and the final accumulator.
167+ handling @WRITER @w @trans @m $
218−runLazyWriter :: forall tag w a . LazyWriter tag w a -> (a, w)
168+ coerce (T.tell @w @(trans m))
219−runLazyWriter = coerce (T.Lazy.runWriter @w @a)
169+ {-# INLINE tell #-}
220
170
221−-- | Runs a 'WriterT' and returns the final accumulator,
171+ listen =
222−-- discarding the normal value.
172+ handling @WRITER @w @trans @m $
223−execLazyWriterT :: forall tag w m a . Monad m => LazyWriterT tag w m a -> m w
173+ coerce (T.listen @w @(trans m) @a) ::
224−execLazyWriterT = coerce (T.Lazy.execWriterT @m @w @a)
174+ forall eff a . Listen w (TaggedTrans eff trans m) a
175+ {-# INLINE listen #-}
225
176
226−-- | Runs a 'Writer' and returns the final accumulator,
177+ pass =
227−-- discarding the normal value.
178+ handling @WRITER @w @trans @m $
228−execLazyWriter :: forall tag w a . LazyWriter tag w a -> w
179+ coerce (T.pass @w @(trans m) @a) ::
229−execLazyWriter = coerce (T.Lazy.execWriter @w @a)
180+ forall eff a . Pass w (TaggedTrans eff trans m) a
181+ {-# INLINE pass #-}
230
182
231type Writer' w = Writer w w
183type Writer' w = Writer w w
232
184
233−runWriter' :: Monoid w => Writer' w a -> (a, w)
185+runWriter' :: Writer' w a -> (a, w)
234runWriter' = runWriter
186runWriter' = runWriter
235
187
236−execWriter' :: Monoid w => Writer' w a -> w
188+execWriter' :: Writer' w a -> w
237execWriter' = execWriter
189execWriter' = execWriter
238
190
239type WriterT' w = WriterT w w
191type WriterT' w = WriterT w w
240
192
241−writerT' :: (Functor m, Monoid w) => m (a, w) -> WriterT' w m a
193+writerT' :: m (a, w) -> WriterT' w m a
242writerT' = writerT
194writerT' = writerT
243
195
244−runWriterT' :: Monoid w => WriterT' w m a -> m (a, w)
196+runWriterT' :: WriterT' w m a -> m (a, w)
245runWriterT' = runWriterT
197runWriterT' = runWriterT
246
198
247−execWriterT' :: (Monad m, Monoid w) => WriterT' w m a -> m w
199+execWriterT' :: Monad m => WriterT' w m a -> m w
248execWriterT' = execWriterT
200execWriterT' = execWriterT
249
201
250−type LazyWriter' w = LazyWriter w w
251−
252−runLazyWriter' :: LazyWriter' w a -> (a, w)
253−runLazyWriter' = runLazyWriter
254−
255−execLazyWriter' :: LazyWriter' w a -> w
256−execLazyWriter' = execLazyWriter
257−
258−type LazyWriterT' w = LazyWriterT w w
259−
260−lazyWriterT' :: m (a, w) -> LazyWriterT' w m a
261−lazyWriterT' = lazyWriterT
262−
263−runLazyWriterT' :: LazyWriterT' w m a -> m (a, w)
264−runLazyWriterT' = runLazyWriterT
265−
266−execLazyWriterT' :: Monad m => LazyWriterT' w m a -> m w
267−execLazyWriterT' = execLazyWriterT
268−
269type MonadWriter' w = MonadWriter w w
202type MonadWriter' w = MonadWriter w w
270
203
271writer' :: forall w m a . MonadWriter' w m => (a, w) -> m a
204writer' :: forall w m a . MonadWriter' w m => (a, w) -> m a
stack.yamlnew file+2
@@ -0,0 +1,2 @@
1+resolver: lts-8.12
2+packages: ['.']
test/Regression/T1.hs+2−14
@@ -1,8 +1,6 @@
1module Regression.T1 (test1) where
1module Regression.T1 (test1) where
2
2
3import Ether
3import Ether
4−import TupleInstances ()
5−import Data.List (group)
6
4
7import Test.Tasty
5import Test.Tasty
8import Test.Tasty.QuickCheck
6import Test.Tasty.QuickCheck
@@ -25,10 +23,6 @@ testEther = do
25
23
26runner1 s1 s2 = flip (runReader @Tag1) s1 . flip (runReaderT @Tag2) s2
24runner1 s1 s2 = flip (runReader @Tag1) s1 . flip (runReaderT @Tag2) s2
27runner2 s1 s2 = flip (runReader @Tag2) s2 . flip (runReaderT @Tag1) s1
25runner2 s1 s2 = flip (runReader @Tag2) s2 . flip (runReaderT @Tag1) s1
28−runner3 s1 s2 = flip runReaders (Tagged @Tag1 s1, Tagged @Tag2 s2)
29−
30−same :: Eq a => [a] -> Bool
31−same = (<=1) . length . group
32
26
33test1 :: TestTree
27test1 :: TestTree
34test1 = testGroup "T1: Reader local environment"
28test1 = testGroup "T1: Reader local environment"
@@ -38,13 +32,7 @@ test1 = testGroup "T1: Reader local environment"
38 , testProperty "runner₂ works"
32 , testProperty "runner₂ works"
39 $ \s1 s2 -> property
33 $ \s1 s2 -> property
40 $ runner2 s1 s2 testEther == ((s1, s2), (s1, map succ s2))
34 $ runner2 s1 s2 testEther == ((s1, s2), (s1, map succ s2))
41− , testProperty "runner₃ works"
42− $ \s1 s2 -> property
43− $ runner3 s1 s2 testEther == ((s1, s2), (s1, map succ s2))
44− , testProperty "runner₁ == runner₂ == runner₃"
35+ , testProperty "runner₁ == runner₂"
45 $ \s1 s2 -> property
36 $ \s1 s2 -> property
46− $ same
47− [ runner1 s1 s2 testEther
37+ $ runner1 s1 s2 testEther == runner2 s1 s2 testEther
48− , runner2 s1 s2 testEther
49− , runner3 s1 s2 testEther ]
50 ]
38 ]
test/TupleInstances.hsdeleted−9
@@ -1,9 +0,0 @@
1−{-# OPTIONS -fno-warn-orphans #-}
2−{-# LANGUAGE CPP #-}
3−
4−module TupleInstances () where
5−
6−#ifdef DISABLE_TUP_INSTANCES
7−import Ether.Internal (makeTupleInstancesHasLens)
8−makeTupleInstancesHasLens [2]
9−#endif