on b40212a help sign in
23 files changed+369−333
since splitsnapshots
unifiedsplit
.gitignore+2−17 .travis.yml+18−25 CHANGELOG.md−5 README.md+16 bench/Bench.hs−1 bench/TupleInstances.hs−9 ether.cabal+14−44 shell.nix−22 src/Ether/Except.hs+15−1 src/Ether/Internal.hs+115−6 src/Ether/Internal/HasLens.hs−24 src/Ether/Internal/TH_TupleInstances.hs−79 src/Ether/Internal/TH_Utils.hs−14 src/Ether/Internal/Tags.hs−18 src/Ether/Internal/TupleInstances.hs−24 src/Ether/Reader.hs+30−2 src/Ether/State.hs+56 src/Ether/TagDispatch.hs+50 src/Ether/TaggedTrans.hs+8−32 src/Ether/Writer.hs+40 stack.yaml+5 test/Regression/T1.hs−1 test/TupleInstances.hs−9
.gitignore+2−17
@@ -1,21 +1,6 @@
1−# Cabal
1+tags
22dist
33dist-newstyle
4+.stack-work
45.cabal-sandbox/
56cabal.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
22
3−os:
4− - linux
5− - osx
6−
7−env:
8− - HC=ghc822
9− - HC=ghc844
10− - HC=ghc861
3+cache:
4+ directories:
5+ - $HOME/.stack/
116
127before_install:
13− - curl https://raw.githubusercontent.com/monadfix/nix-cabal/master/nix-cabal -o nix-cabal && chmod u+x nix-cabal
14− - travis_retry ./nix-cabal new-update
8+ - mkdir -p ~/.local/bin
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
1513
16−script:
17− - ./nix-cabal new-test ether:regression
18− - ./nix-cabal new-bench ether:bench
14+install:
15+ - stack install --only-dependencies --no-terminal
1916
20−cache:
21− directories:
22− - ~/.cabal
23− - ~/.ghc
17+script:
18+ - stack test ether:regression --no-terminal --ghc-options -Werror
19+ - stack bench ether:bench --no-terminal --ghc-options -Werror
2420
25−matrix:
26− # broken at the moment
27− exclude:
28− - os: osx
29− env: HC=ghc822
30− - os: osx
31− env: HC=ghc861
21+addons:
22+ apt:
23+ packages:
24+ - libgmp-dev
CHANGELOG.md−5
@@ -1,8 +1,3 @@
1−0.5.1.0
2−-------
3−
4−* Disable `HasLens` for tuples via cabal flag.
5−
610.5.0.0
72-------
83
README.md+16
@@ -2,8 +2,24 @@
22
33[![Build Status](https://img.shields.io/travis/int-index/ether.svg)](https://travis-ci.org/int-index/ether)
44[![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)
56
67
78Ether is a Haskell library that extends [mtl](https://hackage.haskell.org/package/mtl)
89and [transformers](https://hackage.haskell.org/package/transformers) with tagged
910monad 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
88import qualified Control.Monad.State as M
99import Criterion.Main
1010import Ether
11−import TupleInstances ()
1211
1312id' :: a -> a
1413id' = 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+14−44
@@ -1,17 +1,21 @@
1−cabal-version: 2.2
21name: ether
3−version: 0.5.2.0
2+version: 0.5.0.0
43synopsis: Monad transformers and classes
5−description: Lib
6−license: BSD-3-Clause
7−-- ^ unfortunately have to change this line due to the issue with cabal2nix
8−license-file: LICENSE
4+description:
5+ Ether is a Haskell library that extends @mtl@ and @transformers@ with
6+ tagged monad transformers and classes in a compatible way.
7+
8+ Introduction <https://int-index.github.io/ether/>
9+
910category: Control
11+license: BSD3
12+license-file: LICENSE
1013author: Vladislav Zavialov
1114maintainer: Vladislav Zavialov <vlad.z.4096@gmail.com>
1215homepage: https://int-index.github.io/ether/
1316bug-reports: https://github.com/int-index/ether/issues
1417build-type: Simple
18+cabal-version: >=1.18
1519extra-source-files: CHANGELOG.md
1620
1721source-repository head
@@ -20,20 +24,6 @@ source-repository head
2024 location: git@github.com:int-index/ether.git
2125
2226
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−
3727library
3828
3929 exposed-modules:
@@ -46,18 +36,11 @@ library
4636 Ether.TagDispatch
4737 Ether.Internal
4838
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−
5639 build-depends:
57− base >=4.9 && <4.13,
40+ base >=4.9 && <4.11,
5841 transformers >=0.5.2.0,
5942 transformers-lift >=0.2.0.1,
60− mtl >=2.2.2,
43+ mtl >=2.2.1,
6144 mmorph >=1.0.4,
6245 monad-control >=1.0.0.4,
6346 transformers-base >=0.4.4,
@@ -101,13 +84,10 @@ library
10184 ghc-options:
10285 -Wall -O2
10386
104− if flag(disable-tup-instances)
105− cpp-options: -DDISABLE_TUP_INSTANCES
106−
10787test-suite regression
10888
10989 build-depends:
110− base >=4.9 && <4.13,
90+ base >=4.9 && <4.11,
11191 transformers >=0.4.2,
11292 mtl >=2.2.1,
11393 tasty >=0.10,
@@ -121,7 +101,6 @@ test-suite regression
121101 Regression.hs
122102
123103 other-modules:
124− TupleInstances
125104 Regression.T1
126105 Regression.T2
127106 Regression.T3
@@ -172,14 +151,11 @@ test-suite regression
172151 ghc-options:
173152 -Wall -fno-warn-missing-signatures
174153
175− if flag(disable-tup-instances)
176− cpp-options: -DDISABLE_TUP_INSTANCES
177−
178154
179155benchmark bench
180156
181157 build-depends:
182− base >=4.9 && <4.13,
158+ base >=4.9 && <4.11,
183159 mtl >=2.2.1,
184160 transformers >=0.4.2,
185161 criterion >=1.1,
@@ -190,9 +166,6 @@ benchmark bench
190166 main-is:
191167 Bench.hs
192168
193− other-modules:
194− TupleInstances
195−
196169 type:
197170 exitcode-stdio-1.0
198171
@@ -232,6 +205,3 @@ benchmark bench
232205
233206 ghc-prof-options:
234207 -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 #-}
5050 , Monad (t m)
5151 , MonadExcept tag e m
5252 ) => MonadExcept tag e (t m) where
53+
5354 throw = Lift.lift . throw @tag
55+ {-# INLINE throw #-}
56+
5457 catch = Lift.liftCatch (catch @tag)
58+ {-# INLINE catch #-}
5559
5660-- | Encode type-level information for 'ExceptT'.
5761data EXCEPT
@@ -73,14 +77,17 @@ type ExceptT tag e = TaggedTrans (TAGGED EXCEPT tag) (T.ExceptT e)
7377-- | Runs an 'Except' and returns either an exception or a normal value.
7478runExcept :: forall tag e a . Except tag e a -> Either e a
7579runExcept = coerce (T.runExcept @e @a)
80+{-# INLINE runExcept #-}
7681
7782-- | Runs an 'ExceptT' and returns either an exception or a normal value.
7883runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)
7984runExceptT = coerce (T.runExceptT @e @m @a)
85+{-# INLINE runExceptT #-}
8086
8187-- | Constructor for computations in the exception monad transformer.
8288exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
8389exceptT = coerce (T.ExceptT @e @m @a)
90+{-# INLINE exceptT #-}
8491
8592type instance HandleSuper EXCEPT e trans = ()
8693type instance HandleConstraint EXCEPT e trans m =
@@ -88,40 +95,47 @@ type instance HandleConstraint EXCEPT e trans m =
8895
8996instance Handle EXCEPT e (T.ExceptT e) where
9097 handling r = r
98+ {-# INLINE handling #-}
9199
92100instance
93101 ( Handle EXCEPT e trans
94102 , Monad m, Monad (trans m)
95103 ) => MonadExcept tag e (TaggedTrans (TAGGED EXCEPT tag) trans m)
96104 where
97−
98105 throw =
99106 handling @EXCEPT @e @trans @m $
100107 coerce (T.throwError @e @(trans m) @a) ::
101108 forall eff a . e -> TaggedTrans eff trans m a
109+ {-# INLINE throw #-}
102110
103111 catch =
104112 handling @EXCEPT @e @trans @m $
105113 coerce (T.catchError @e @(trans m) @a) ::
106114 forall eff a . Catch e (TaggedTrans eff trans m) a
115+ {-# INLINE catch #-}
107116
108117type MonadExcept' e = MonadExcept e e
109118
110119throw' :: forall e m a . MonadExcept' e m => e -> m a
111120throw' = throw @e
121+{-# INLINE throw' #-}
112122
113123catch' :: forall e m a . MonadExcept' e m => m a -> (e -> m a) -> m a
114124catch' = catch @e
125+{-# INLINE catch' #-}
115126
116127type Except' e = Except e e
117128
118129runExcept' :: Except' e a -> Either e a
119130runExcept' = runExcept
131+{-# INLINE runExcept' #-}
120132
121133type ExceptT' e = ExceptT e e
122134
123135exceptT' :: m (Either e a) -> ExceptT' e m a
124136exceptT' = exceptT
137+{-# INLINE exceptT' #-}
125138
126139runExceptT' :: ExceptT' e m a -> m (Either e a)
127140runExceptT' = runExceptT
141+{-# INLINE runExceptT' #-}
src/Ether/Internal.hs+115−6
@@ -16,20 +16,17 @@ module Ether.Internal
1616 , HandleSuper
1717 , HandleConstraint
1818 , Handle(..)
19− , makeTupleInstancesHasLens
2019 ) where
2120
2221import Control.Applicative
2322import Data.Coerce
2423import Data.Functor.Identity
2524import Data.Kind
25+import Data.List as List
2626import Data.Tagged
27+import Data.Traversable
2728import GHC.Exts (Constraint)
28−
29−import Ether.Internal.HasLens
30−import Ether.Internal.Tags
31−import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)
32−import Ether.Internal.TupleInstances ()
29+import qualified Language.Haskell.TH as TH
3330
3431data TAGGED e t
3532
@@ -57,12 +54,124 @@ class
5754 where
5855 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r
5956
57+type LensLike f s t a b = (a -> f b) -> s -> f t
58+
59+type Lens s t a b = forall f. Functor f => LensLike f s t a b
60+
61+type Lens' s a = Lens s s a a
62+
6063newtype ReifiedLens s t a b = Lens (Lens s t a b)
6164
6265type ReifiedLens' s a = ReifiedLens s s a a
6366
67+class HasLens tag outer inner | tag outer -> inner where
68+ lensOf :: Lens' outer inner
69+
70+instance HasLens a a a where
71+ lensOf = id
72+ {-# INLINE lensOf #-}
73+
74+instance HasLens t (Tagged t a) a where
75+ lensOf = \f -> fmap coerce . f . coerce
76+
6477view :: LensLike (Const a) s t a b -> s -> a
6578view l = coerce (l Const)
79+{-# INLINE view #-}
6680
6781over :: LensLike Identity s t a b -> (a -> b) -> s -> t
6882over = coerce
83+{-# INLINE over #-}
84+
85+data HList xs where
86+ HNil :: HList '[]
87+ HCons :: x -> HList xs -> HList (x ': xs)
88+
89+type KindOf (a :: k) = k
90+
91+type family TagsK (p :: Type) :: [Type]
92+type family Tags (p :: Type) :: HList (TagsK p)
93+
94+return []
95+
96+type instance TagsK () = '[]
97+type instance TagsK (Tagged t a) = '[KindOf t]
98+
99+do
100+ let
101+ tupCount = 62
102+ varName k = TH.mkName ('a' : show k)
103+ tagName k = TH.mkName ('t' : show k)
104+ for [2..tupCount] $ \n -> do
105+ let
106+ tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $
107+ (\k -> TH.ConT ''Tagged `TH.AppT`
108+ TH.VarT (tagName k) `TH.AppT`
109+ TH.VarT (varName k)) <$> [0..n-1]
110+ tagsList = List.foldr
111+ (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)
112+ TH.PromotedNilT
113+ (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1])
114+ return $
115+ TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)
116+
117+return []
118+
119+type instance Tags () = 'HNil
120+type instance Tags (Tagged t a) = 'HCons t 'HNil
121+
122+do
123+ let
124+ tupCount = 62
125+ varName k = TH.mkName ('a' : show k)
126+ tagName k = TH.mkName ('t' : show k)
127+ for [2..tupCount] $ \n -> do
128+ let
129+ tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $
130+ (\k -> TH.ConT ''Tagged `TH.AppT`
131+ TH.VarT (tagName k) `TH.AppT`
132+ TH.VarT (varName k)) <$> [0..n-1]
133+ tagsList = List.foldr
134+ (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)
135+ (TH.PromotedT 'HNil)
136+ (TH.VarT . tagName <$> [0..n-1])
137+ return $
138+ TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)
139+
140+do
141+ let
142+ tupCount = 62
143+ varName k = TH.mkName ('a' : show k)
144+ fmap List.concat $
145+ for [2..tupCount] $ \n ->
146+ for [0..n-1] $ \k -> do
147+ let
148+ tag = TH.mkName "tag"
149+ prev = varName <$> [0..k-1]
150+ cur = varName k
151+ next = varName <$> [k+1..n-1]
152+ tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
153+ ( map TH.VarT prev ++
154+ [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++
155+ map TH.VarT next )
156+ let
157+ cur' = TH.mkName "x"
158+ f = TH.mkName "f"
159+ return $
160+ TH.InstanceD Nothing []
161+ (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)
162+ [ TH.FunD 'lensOf
163+ [ TH.Clause
164+ [TH.VarP f, TH.TupP
165+ ( map TH.VarP prev ++
166+ [TH.ConP 'Tagged [TH.VarP cur]] ++
167+ map TH.VarP next )]
168+ (TH.NormalB $
169+ TH.VarE 'fmap `TH.AppE`
170+ (TH.LamE [TH.VarP cur']
171+ (TH.TupE
172+ ( map TH.VarE prev ++
173+ [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++
174+ map TH.VarE next ))) `TH.AppE`
175+ (TH.VarE f `TH.AppE` TH.VarE cur) )
176+ [] ],
177+ TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]
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 #-}
7777 , MonadReader tag r m
7878 ) => MonadReader tag r (t m)
7979 where
80+
8081 ask = Lift.lift (ask @tag)
82+ {-# INLINE ask #-}
83+
8184 local = Lift.liftLocal (ask @tag) (local @tag)
85+ {-# INLINE local #-}
86+
8287 reader = Lift.lift . reader @tag
88+ {-# INLINE reader #-}
8389
8490instance {-# OVERLAPPABLE #-}
8591 ( Monad (trans m)
@@ -92,18 +98,21 @@ instance {-# OVERLAPPABLE #-}
9298 TaggedTrans effs trans m r ->
9399 TaggedTrans (eff ': effs) trans m r)
94100 (ask @tag)
101+ {-# INLINE ask #-}
95102
96103 local =
97104 (coerce :: forall a .
98105 Lift.Local r (TaggedTrans effs trans m) a ->
99106 Lift.Local r (TaggedTrans (eff ': effs) trans m) a)
100107 (local @tag)
108+ {-# INLINE local #-}
101109
102110 reader =
103111 (coerce :: forall a .
104112 ((r -> a) -> TaggedTrans effs trans m a) ->
105113 ((r -> a) -> TaggedTrans (eff ': effs) trans m a))
106114 (reader @tag)
115+ {-# INLINE reader #-}
107116
108117-- | Retrieves a function of the current environment.
109118asks
@@ -113,6 +122,7 @@ asks
113122 -- ^ The selector function to apply to the environment.
114123 -> m a
115124asks = reader @tag
125+{-# INLINE asks #-}
116126
117127-- | Encode type-level information for 'ReaderT'.
118128data READER
@@ -135,16 +145,19 @@ type ReaderT tag r = TaggedTrans (TAGGED READER tag) (T.ReaderT r)
135145-- | Constructor for computations in the reader monad transformer.
136146readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
137147readerT = coerce (T.ReaderT @r @m @a)
148+{-# INLINE readerT #-}
138149
139150-- | Runs a 'ReaderT' with the given environment
140151-- and returns the final value.
141152runReaderT :: 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 #-}
143155
144156-- | Runs a 'ReaderT' with the given environment
145157-- and returns the final value.
146158runReader :: forall tag r a . Reader tag r a -> r -> a
147159runReader = coerce (T.runReader @r @a)
160+{-# INLINE runReader #-}
148161
149162type instance HandleSuper READER r trans = ()
150163type instance HandleConstraint READER r trans m =
@@ -152,6 +165,7 @@ type instance HandleConstraint READER r trans m =
152165
153166instance Handle READER r (T.ReaderT r) where
154167 handling r = r
168+ {-# INLINE handling #-}
155169
156170instance
157171 ( Handle READER r trans
@@ -162,16 +176,19 @@ instance
162176 ask =
163177 handling @READER @r @trans @m $
164178 coerce (T.ask @r @(trans m))
179+ {-# INLINE ask #-}
165180
166181 local =
167182 handling @READER @r @trans @m $
168183 coerce (T.local @r @(trans m) @a) ::
169184 forall eff a . Local r (TaggedTrans eff trans m) a
185+ {-# INLINE local #-}
170186
171187 reader =
172188 handling @READER @r @trans @m $
173189 coerce (T.reader @r @(trans m) @a) ::
174190 forall eff a . (r -> a) -> TaggedTrans eff trans m a
191+ {-# INLINE reader #-}
175192
176193instance
177194 ( HasLens tag payload r
@@ -186,6 +203,7 @@ instance
186203 trans m a ->
187204 TaggedTrans eff trans m a)
188205 (T.asks (view (lensOf @tag @payload @r)))
206+ {-# INLINE ask #-}
189207
190208 local f =
191209 handling @READER @payload @trans @m $
@@ -193,6 +211,7 @@ instance
193211 (trans m a -> trans m a) ->
194212 (TaggedTrans eff trans m a -> TaggedTrans eff trans m a))
195213 (T.local (over (lensOf @tag @payload @r) f))
214+ {-# INLINE local #-}
196215
197216type family READERS (ts :: HList xs) :: [Type] where
198217 READERS 'HNil = '[]
@@ -203,34 +222,43 @@ type ReadersT r = TaggedTrans (READERS (Tags r)) (T.ReaderT r)
203222type Readers r = ReadersT r Identity
204223
205224runReadersT :: 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 #-}
207227
208228runReaders :: forall p a . Readers p a -> p -> a
209229runReaders = coerce (T.runReader @p @a)
230+{-# INLINE runReaders #-}
210231
211232type ReaderT' r = ReaderT r r
212233
213234readerT' :: (r -> m a) -> ReaderT' r m a
214235readerT' = readerT
236+{-# INLINE readerT' #-}
215237
216238runReaderT' :: ReaderT' r m a -> r -> m a
217239runReaderT' = runReaderT
240+{-# INLINE runReaderT' #-}
218241
219242type Reader' r = Reader r r
220243
221244runReader' :: Reader' r a -> r -> a
222245runReader' = runReader
246+{-# INLINE runReader' #-}
223247
224248type MonadReader' r = MonadReader r r
225249
226250local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a
227251local' = local @r
252+{-# INLINE local' #-}
228253
229254ask' :: forall r m . MonadReader' r m => m r
230255ask' = ask @r
256+{-# INLINE ask' #-}
231257
232258reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a
233259reader' = reader @r
260+{-# INLINE reader' #-}
234261
235262asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a
236263asks' = asks @r
264+{-# INLINE asks' #-}
src/Ether/State.hs+56
@@ -114,9 +114,15 @@ instance {-# OVERLAPPABLE #-}
114114 , MonadState tag s m
115115 ) => MonadState tag s (t m)
116116 where
117+
117118 get = Lift.lift (get @tag)
119+ {-# INLINE get #-}
120+
118121 put = Lift.lift . put @tag
122+ {-# INLINE put #-}
123+
119124 state = Lift.lift . state @tag
125+ {-# INLINE state #-}
120126
121127instance {-# OVERLAPPABLE #-}
122128 ( Monad (trans m)
@@ -129,26 +135,31 @@ instance {-# OVERLAPPABLE #-}
129135 TaggedTrans effs trans m s ->
130136 TaggedTrans (eff ': effs) trans m s)
131137 (get @tag)
138+ {-# INLINE get #-}
132139
133140 put =
134141 (coerce ::
135142 (s -> TaggedTrans effs trans m ()) ->
136143 (s -> TaggedTrans (eff ': effs) trans m ()))
137144 (put @tag)
145+ {-# INLINE put #-}
138146
139147 state =
140148 (coerce :: forall a .
141149 ((s -> (a, s)) -> TaggedTrans effs trans m a) ->
142150 ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a))
143151 (state @tag)
152+ {-# INLINE state #-}
144153
145154-- | Modifies the state inside a state monad.
146155modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()
147156modify f = state @tag (\s -> ((), f s))
157+{-# INLINABLE modify #-}
148158
149159-- | Gets specific component of the state, using a projection function supplied.
150160gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a
151161gets f = fmap f (get @tag)
162+{-# INLINABLE gets #-}
152163
153164-- | Encode type-level information for 'StateT'.
154165data STATE
@@ -159,9 +170,11 @@ type instance HandleConstraint STATE s trans m =
159170
160171instance Handle STATE s (T.Strict.StateT s) where
161172 handling r = r
173+ {-# INLINE handling #-}
162174
163175instance Handle STATE s (T.Lazy.StateT s) where
164176 handling r = r
177+ {-# INLINE handling #-}
165178
166179instance
167180 ( Handle STATE s trans
@@ -172,15 +185,18 @@ instance
172185 get =
173186 handling @STATE @s @trans @m $
174187 coerce (T.get @s @(trans m))
188+ {-# INLINE get #-}
175189
176190 put =
177191 handling @STATE @s @trans @m $
178192 coerce (T.put @s @(trans m))
193+ {-# INLINE put #-}
179194
180195 state =
181196 handling @STATE @s @trans @m $
182197 coerce (T.state @s @(trans m) @a) ::
183198 forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a
199+ {-# INLINE state #-}
184200
185201instance
186202 ( HasLens tag payload s
@@ -195,6 +211,7 @@ instance
195211 trans m a ->
196212 TaggedTrans eff trans m a)
197213 (T.gets (view (lensOf @tag @payload @s)))
214+ {-# INLINE get #-}
198215
199216 put s =
200217 handling @STATE @payload @trans @m $
@@ -202,6 +219,7 @@ instance
202219 trans m a ->
203220 TaggedTrans eff trans m a)
204221 (T.modify (over (lensOf @tag @payload @s) (const s)))
222+ {-# INLINE put #-}
205223
206224 state f =
207225 handling @STATE @payload @trans @m $
@@ -209,6 +227,7 @@ instance
209227 trans m a ->
210228 TaggedTrans eff trans m a)
211229 (T.state (lensOf @tag @payload @s f))
230+ {-# INLINE state #-}
212231
213232-- | The parametrizable state monad.
214233--
@@ -227,36 +246,43 @@ type StateT tag s = TaggedTrans (TAGGED STATE tag) (T.Strict.StateT s)
227246-- | Constructor for computations in the state monad transformer.
228247stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
229248stateT = coerce (T.Strict.StateT @s @m @a)
249+{-# INLINE stateT #-}
230250
231251-- | Runs a 'StateT' with the given initial state
232252-- and returns both the final value and the final state.
233253runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
234254runStateT = coerce (T.Strict.runStateT @s @m @a)
255+{-# INLINE runStateT #-}
235256
236257-- | Runs a 'StateT' with the given initial state
237258-- and returns the final value, discarding the final state.
238259evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
239260evalStateT = coerce (T.Strict.evalStateT @m @s @a)
261+{-# INLINE evalStateT #-}
240262
241263-- | Runs a 'StateT' with the given initial state
242264-- and returns the final state, discarding the final value.
243265execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
244266execStateT = coerce (T.Strict.execStateT @m @s @a)
267+{-# INLINE execStateT #-}
245268
246269-- | Runs a 'State' with the given initial state
247270-- and returns both the final value and the final state.
248271runState :: forall tag s a . State tag s a -> s -> (a, s)
249272runState = coerce (T.Strict.runState @s @a)
273+{-# INLINE runState #-}
250274
251275-- | Runs a 'State' with the given initial state
252276-- and returns the final value, discarding the final state.
253277evalState :: forall tag s a . State tag s a -> s -> a
254278evalState = coerce (T.Strict.evalState @s @a)
279+{-# INLINE evalState #-}
255280
256281-- | Runs a 'State' with the given initial state
257282-- and returns the final state, discarding the final value.
258283execState :: forall tag s a . State tag s a -> s -> s
259284execState = coerce (T.Strict.execState @s @a)
285+{-# INLINE execState #-}
260286
261287-- | The parametrizable state monad.
262288--
@@ -275,36 +301,43 @@ type LazyStateT tag s = TaggedTrans (TAGGED STATE tag) (T.Lazy.StateT s)
275301-- | Constructor for computations in the state monad transformer.
276302lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a
277303lazyStateT = coerce (T.Lazy.StateT @s @m @a)
304+{-# INLINE lazyStateT #-}
278305
279306-- | Runs a 'StateT' with the given initial state
280307-- and returns both the final value and the final state.
281308runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s)
282309runLazyStateT = coerce (T.Lazy.runStateT @s @m @a)
310+{-# INLINE runLazyStateT #-}
283311
284312-- | Runs a 'StateT' with the given initial state
285313-- and returns the final value, discarding the final state.
286314evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a
287315evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a)
316+{-# INLINE evalLazyStateT #-}
288317
289318-- | Runs a 'StateT' with the given initial state
290319-- and returns the final state, discarding the final value.
291320execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s
292321execLazyStateT = coerce (T.Lazy.execStateT @m @s @a)
322+{-# INLINE execLazyStateT #-}
293323
294324-- | Runs a 'State' with the given initial state
295325-- and returns both the final value and the final state.
296326runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s)
297327runLazyState = coerce (T.Lazy.runState @s @a)
328+{-# INLINE runLazyState #-}
298329
299330-- | Runs a 'State' with the given initial state
300331-- and returns the final value, discarding the final state.
301332evalLazyState :: forall tag s a . LazyState tag s a -> s -> a
302333evalLazyState = coerce (T.Lazy.evalState @s @a)
334+{-# INLINE evalLazyState #-}
303335
304336-- | Runs a 'State' with the given initial state
305337-- and returns the final state, discarding the final value.
306338execLazyState :: forall tag s a . LazyState tag s a -> s -> s
307339execLazyState = coerce (T.Lazy.execState @s @a)
340+{-# INLINE execLazyState #-}
308341
309342type family STATES (ts :: HList xs) :: [Type] where
310343 STATES 'HNil = '[]
@@ -316,76 +349,97 @@ type States s = StatesT s Identity
316349
317350runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p)
318351runStatesT = coerce (T.Strict.runStateT @p @m @a)
352+{-# INLINE runStatesT #-}
319353
320354runStates :: forall p a . States p a -> p -> (a, p)
321355runStates = coerce (T.Strict.runState @p @a)
356+{-# INLINE runStates #-}
322357
323358type StateT' s = StateT s s
324359
325360stateT' :: (s -> m (a, s)) -> StateT' s m a
326361stateT' = stateT
362+{-# INLINE stateT' #-}
327363
328364runStateT' :: StateT' s m a -> s -> m (a, s)
329365runStateT' = runStateT
366+{-# INLINE runStateT' #-}
330367
331368runState' :: State' s a -> s -> (a, s)
332369runState' = runState
370+{-# INLINE runState' #-}
333371
334372evalStateT' :: Monad m => StateT' s m a -> s -> m a
335373evalStateT' = evalStateT
374+{-# INLINE evalStateT' #-}
336375
337376type State' s = State s s
338377
339378evalState' :: State' s a -> s -> a
340379evalState' = evalState
380+{-# INLINE evalState' #-}
341381
342382execStateT' :: Monad m => StateT' s m a -> s -> m s
343383execStateT' = execStateT
384+{-# INLINE execStateT' #-}
344385
345386execState' :: State' s a -> s -> s
346387execState' = execState
388+{-# INLINE execState' #-}
347389
348390type LazyStateT' s = LazyStateT s s
349391
350392lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a
351393lazyStateT' = lazyStateT
394+{-# INLINE lazyStateT' #-}
352395
353396runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s)
354397runLazyStateT' = runLazyStateT
398+{-# INLINE runLazyStateT' #-}
355399
356400runLazyState' :: LazyState' s a -> s -> (a, s)
357401runLazyState' = runLazyState
402+{-# INLINE runLazyState' #-}
358403
359404evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a
360405evalLazyStateT' = evalLazyStateT
406+{-# INLINE evalLazyStateT' #-}
361407
362408type LazyState' s = LazyState s s
363409
364410evalLazyState' :: LazyState' s a -> s -> a
365411evalLazyState' = evalLazyState
412+{-# INLINE evalLazyState' #-}
366413
367414execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s
368415execLazyStateT' = execLazyStateT
416+{-# INLINE execLazyStateT' #-}
369417
370418execLazyState' :: LazyState' s a -> s -> s
371419execLazyState' = execLazyState
420+{-# INLINE execLazyState' #-}
372421
373422type MonadState' s = MonadState s s
374423
375424get' :: forall s m . MonadState' s m => m s
376425get' = get @s
426+{-# INLINE get' #-}
377427
378428gets' :: forall s m a . MonadState' s m => (s -> a) -> m a
379429gets' = gets @s
430+{-# INLINE gets' #-}
380431
381432put' :: forall s m . MonadState' s m => s -> m ()
382433put' = put @s
434+{-# INLINE put' #-}
383435
384436state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a
385437state' = state @s
438+{-# INLINE state' #-}
386439
387440modify' :: forall s m . MonadState' s m => (s -> s) -> m ()
388441modify' = modify @s
442+{-# INLINE modify' #-}
389443
390444-- | Encode type-level information for 'zoom'.
391445data ZOOM t z
@@ -399,6 +453,7 @@ zoom
399453 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a)
400454 -> m a
401455zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))
456+{-# INLINE zoom #-}
402457
403458instance
404459 ( MonadState tag sOuter m
@@ -413,3 +468,4 @@ instance
413468 (state @tag . l)
414469 where
415470 Lens l = reflect (Proxy :: Proxy z)
471+ {-# INLINE state #-}
src/Ether/TagDispatch.hs+50
@@ -63,38 +63,63 @@ type TagAttachT t = TaggedTrans (TAG_ATTACH t) IdentityT
6363-- | Attach a tag to untagged transformers.
6464tagAttach :: forall tag m a . TagAttachT tag m a -> m a
6565tagAttach = coerce (runIdentityT @_ @m @a)
66+{-# INLINE tagAttach #-}
6667
6768instance {-# OVERLAPPING #-}
6869 ( MonadReader tag r m, trans ~ IdentityT
6970 ) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m)
7071 where
72+
7173 ask = ask @tag
74+ {-# INLINE ask #-}
75+
7276 local = local @tag
77+ {-# INLINE local #-}
78+
7379 reader = reader @tag
80+ {-# INLINE reader #-}
7481
7582instance {-# OVERLAPPING #-}
7683 ( MonadState tag s m, trans ~ IdentityT
7784 ) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m)
7885 where
86+
7987 get = get @tag
88+ {-# INLINE get #-}
89+
8090 put = put @tag
91+ {-# INLINE put #-}
92+
8193 state = state @tag
94+ {-# INLINE state #-}
8295
8396instance {-# OVERLAPPING #-}
8497 ( MonadExcept tag e m, trans ~ IdentityT
8598 ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m)
8699 where
100+
87101 throwError = throw @tag
102+ {-# INLINE throwError #-}
103+
88104 catchError = catch @tag
105+ {-# INLINE catchError #-}
89106
90107instance {-# OVERLAPPING #-}
91108 ( MonadWriter tag w m, trans ~ IdentityT
92109 ) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m)
93110 where
111+
94112 writer = writer @tag
113+ {-# INLINE writer #-}
114+
95115 tell = tell @tag
116+ {-# INLINE tell #-}
117+
96118 listen = listen @tag
119+ {-# INLINE listen #-}
120+
97121 pass = pass @tag
122+ {-# INLINE pass #-}
98123
99124-- | Encode type-level information for 'tagReplace'.
100125data TAG_REPLACE tOld tNew
@@ -104,35 +129,60 @@ type TagReplaceT tOld tNew = TaggedTrans (TAG_REPLACE tOld tNew) IdentityT
104129-- | Replace a tag with another tag.
105130tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a
106131tagReplace = coerce (runIdentityT @_ @m @a)
132+{-# INLINE tagReplace #-}
107133
108134instance
109135 ( MonadReader tNew r m, trans ~ IdentityT
110136 ) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
111137 where
138+
112139 ask = ask @tNew
140+ {-# INLINE ask #-}
141+
113142 local = local @tNew
143+ {-# INLINE local #-}
144+
114145 reader = reader @tNew
146+ {-# INLINE reader #-}
115147
116148instance
117149 ( MonadState tNew s m, trans ~ IdentityT
118150 ) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
119151 where
152+
120153 get = get @tNew
154+ {-# INLINE get #-}
155+
121156 put = put @tNew
157+ {-# INLINE put #-}
158+
122159 state = state @tNew
160+ {-# INLINE state #-}
123161
124162instance
125163 ( MonadExcept tNew e m, trans ~ IdentityT
126164 ) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
127165 where
166+
128167 throw = throw @tNew
168+ {-# INLINE throw #-}
169+
129170 catch = catch @tNew
171+ {-# INLINE catch #-}
130172
131173instance
132174 ( MonadWriter tNew w m, trans ~ IdentityT
133175 ) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m)
134176 where
177+
135178 writer = writer @tNew
179+ {-# INLINE writer #-}
180+
136181 tell = tell @tNew
182+ {-# INLINE tell #-}
183+
137184 listen = listen @tNew
185+ {-# INLINE listen #-}
186+
138187 pass = pass @tNew
188+ {-# INLINE pass #-}
src/Ether/TaggedTrans.hs+8−32
@@ -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−
51module Ether.TaggedTrans
62 ( TaggedTrans(..)
73 ) where
@@ -11,7 +7,7 @@ import Control.Monad (MonadPlus)
117import Control.Monad.Fix (MonadFix)
128import Control.Monad.Trans.Class (MonadTrans, lift)
139import Control.Monad.IO.Class (MonadIO)
14−import Control.Monad.Morph (MFunctor(..), MMonad(..))
10+import Control.Monad.Morph (MFunctor, MMonad)
1511import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
1612
1713import qualified Control.Monad.Base as MB
@@ -37,7 +33,7 @@ newtype TaggedTrans tag trans m a = TaggedTrans (trans m a)
3733 deriving
3834 ( Generic
3935 , Functor, Applicative, Alternative, Monad, MonadPlus
40− , MonadFix, MonadTrans, MonadIO
36+ , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
4137 , MonadThrow, MonadCatch, MonadMask )
4238
4339type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a
@@ -53,6 +49,7 @@ instance
5349 (b a -> trans m a) ->
5450 (b a -> TaggedTrans tag trans m a))
5551 MB.liftBase
52+ {-# INLINE liftBase #-}
5653
5754instance
5855 ( MC.MonadTransControl trans
@@ -63,9 +60,11 @@ instance
6360 liftWith = MC.defaultLiftWith
6461 (coerce :: Pack tag trans m a)
6562 (coerce :: Unpack tag trans m a)
63+ {-# INLINE liftWith #-}
6664
6765 restoreT = MC.defaultRestoreT
6866 (coerce :: Pack tag trans m a)
67+ {-# INLINE restoreT #-}
6968
7069type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a
7170
@@ -76,6 +75,7 @@ coerceLiftBaseWith ::
7675 LiftBaseWith b (TaggedTrans tag trans m) a
7776coerceLiftBaseWith lbw =
7877 unLBW (coerce (LBW lbw))
78+{-# INLINE coerceLiftBaseWith #-}
7979
8080instance
8181 ( MC.MonadBaseControl b (trans m)
@@ -84,12 +84,14 @@ instance
8484 type StM (TaggedTrans tag trans m) a = MC.StM (trans m) a
8585
8686 liftBaseWith = coerceLiftBaseWith MC.liftBaseWith
87+ {-# INLINE liftBaseWith #-}
8788
8889 restoreM =
8990 (coerce :: forall a .
9091 (MC.StM (trans m) a -> trans m a) ->
9192 (MC.StM (trans m) a -> TaggedTrans tag trans m a))
9293 MC.restoreM
94+ {-# INLINE restoreM #-}
9395
9496type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a
9597
@@ -178,29 +180,3 @@ instance
178180 where
179181 throwError = lift . Mtl.throwError
180182 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+40
@@ -96,10 +96,18 @@ instance {-# OVERLAPPABLE #-}
9696 , MonadWriter tag w m
9797 , Monoid w
9898 ) => MonadWriter tag w (t m) where
99+
99100 writer = Lift.lift . writer @tag
101+ {-# INLINE writer #-}
102+
100103 tell = Lift.lift . tell @tag
104+ {-# INLINE tell #-}
105+
101106 listen = Lift.liftListen (listen @tag)
107+ {-# INLINE listen #-}
108+
102109 pass = Lift.liftPass (pass @tag)
110+ {-# INLINE pass #-}
103111
104112-- | Execute an action and add the result of applying the given function to
105113-- its accumulator to the value of the computation.
@@ -123,9 +131,11 @@ type instance HandleConstraint WRITER w trans m =
123131
124132instance Monoid w => Handle WRITER w (T.CPS.WriterT w) where
125133 handling r = r
134+ {-# INLINE handling #-}
126135
127136instance Monoid w => Handle WRITER w (T.Lazy.WriterT w) where
128137 handling r = r
138+ {-# INLINE handling #-}
129139
130140instance
131141 ( Handle WRITER w trans
@@ -137,20 +147,24 @@ instance
137147 handling @WRITER @w @trans @m $
138148 coerce (T.writer @w @(trans m) @a) ::
139149 forall eff a . (a, w) -> TaggedTrans eff trans m a
150+ {-# INLINE writer #-}
140151
141152 tell =
142153 handling @WRITER @w @trans @m $
143154 coerce (T.tell @w @(trans m))
155+ {-# INLINE tell #-}
144156
145157 listen =
146158 handling @WRITER @w @trans @m $
147159 coerce (T.listen @w @(trans m) @a) ::
148160 forall eff a . Listen w (TaggedTrans eff trans m) a
161+ {-# INLINE listen #-}
149162
150163 pass =
151164 handling @WRITER @w @trans @m $
152165 coerce (T.pass @w @(trans m) @a) ::
153166 forall eff a . Pass w (TaggedTrans eff trans m) a
167+ {-# INLINE pass #-}
154168
155169-- | The parametrizable writer monad.
156170--
@@ -169,26 +183,31 @@ type WriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.CPS.WriterT w)
169183-- | Constructor for computations in the writer monad transformer.
170184writerT :: forall tag w m a . (Functor m, Monoid w) => m (a, w) -> WriterT tag w m a
171185writerT = coerce (T.CPS.writerT @m @w @a)
186+{-# INLINE writerT #-}
172187
173188-- | Runs a 'WriterT' and returns both the normal value
174189-- and the final accumulator.
175190runWriterT :: forall tag w m a . Monoid w => WriterT tag w m a -> m (a, w)
176191runWriterT = coerce (T.CPS.runWriterT @w @m @a)
192+{-# INLINE runWriterT #-}
177193
178194-- | Runs a 'Writer' and returns both the normal value
179195-- and the final accumulator.
180196runWriter :: forall tag w a . Monoid w => Writer tag w a -> (a, w)
181197runWriter = coerce (T.CPS.runWriter @w @a)
198+{-# INLINE runWriter #-}
182199
183200-- | Runs a 'WriterT' and returns the final accumulator,
184201-- discarding the normal value.
185202execWriterT :: forall tag w m a . (Monad m, Monoid w) => WriterT tag w m a -> m w
186203execWriterT = coerce (T.CPS.execWriterT @m @w @a)
204+{-# INLINE execWriterT #-}
187205
188206-- | Runs a 'Writer' and returns the final accumulator,
189207-- discarding the normal value.
190208execWriter :: forall tag w a . Monoid w => Writer tag w a -> w
191209execWriter = coerce (T.CPS.execWriter @w @a)
210+{-# INLINE execWriter #-}
192211
193212-- | The parametrizable writer monad.
194213--
@@ -207,81 +226,102 @@ type LazyWriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.Lazy.WriterT w)
207226-- | Constructor for computations in the writer monad transformer.
208227lazyWriterT :: forall tag w m a . m (a, w) -> LazyWriterT tag w m a
209228lazyWriterT = coerce (T.Lazy.WriterT @w @m @a)
229+{-# INLINE lazyWriterT #-}
210230
211231-- | Runs a 'WriterT' and returns both the normal value
212232-- and the final accumulator.
213233runLazyWriterT :: forall tag w m a . LazyWriterT tag w m a -> m (a, w)
214234runLazyWriterT = coerce (T.Lazy.runWriterT @w @m @a)
235+{-# INLINE runLazyWriterT #-}
215236
216237-- | Runs a 'Writer' and returns both the normal value
217238-- and the final accumulator.
218239runLazyWriter :: forall tag w a . LazyWriter tag w a -> (a, w)
219240runLazyWriter = coerce (T.Lazy.runWriter @w @a)
241+{-# INLINE runLazyWriter #-}
220242
221243-- | Runs a 'WriterT' and returns the final accumulator,
222244-- discarding the normal value.
223245execLazyWriterT :: forall tag w m a . Monad m => LazyWriterT tag w m a -> m w
224246execLazyWriterT = coerce (T.Lazy.execWriterT @m @w @a)
247+{-# INLINE execLazyWriterT #-}
225248
226249-- | Runs a 'Writer' and returns the final accumulator,
227250-- discarding the normal value.
228251execLazyWriter :: forall tag w a . LazyWriter tag w a -> w
229252execLazyWriter = coerce (T.Lazy.execWriter @w @a)
253+{-# INLINE execLazyWriter #-}
230254
231255type Writer' w = Writer w w
232256
233257runWriter' :: Monoid w => Writer' w a -> (a, w)
234258runWriter' = runWriter
259+{-# INLINE runWriter' #-}
235260
236261execWriter' :: Monoid w => Writer' w a -> w
237262execWriter' = execWriter
263+{-# INLINE execWriter' #-}
238264
239265type WriterT' w = WriterT w w
240266
241267writerT' :: (Functor m, Monoid w) => m (a, w) -> WriterT' w m a
242268writerT' = writerT
269+{-# INLINE writerT' #-}
243270
244271runWriterT' :: Monoid w => WriterT' w m a -> m (a, w)
245272runWriterT' = runWriterT
273+{-# INLINE runWriterT' #-}
246274
247275execWriterT' :: (Monad m, Monoid w) => WriterT' w m a -> m w
248276execWriterT' = execWriterT
277+{-# INLINE execWriterT' #-}
249278
250279type LazyWriter' w = LazyWriter w w
251280
252281runLazyWriter' :: LazyWriter' w a -> (a, w)
253282runLazyWriter' = runLazyWriter
283+{-# INLINE runLazyWriter' #-}
254284
255285execLazyWriter' :: LazyWriter' w a -> w
256286execLazyWriter' = execLazyWriter
287+{-# INLINE execLazyWriter' #-}
257288
258289type LazyWriterT' w = LazyWriterT w w
259290
260291lazyWriterT' :: m (a, w) -> LazyWriterT' w m a
261292lazyWriterT' = lazyWriterT
293+{-# INLINE lazyWriterT' #-}
262294
263295runLazyWriterT' :: LazyWriterT' w m a -> m (a, w)
264296runLazyWriterT' = runLazyWriterT
297+{-# INLINE runLazyWriterT' #-}
265298
266299execLazyWriterT' :: Monad m => LazyWriterT' w m a -> m w
267300execLazyWriterT' = execLazyWriterT
301+{-# INLINE execLazyWriterT' #-}
268302
269303type MonadWriter' w = MonadWriter w w
270304
271305writer' :: forall w m a . MonadWriter' w m => (a, w) -> m a
272306writer' = writer @w
307+{-# INLINE writer' #-}
273308
274309tell' :: forall w m . MonadWriter' w m => w -> m ()
275310tell' = tell @w
311+{-# INLINE tell' #-}
276312
277313listen' :: forall w m a . MonadWriter' w m => m a -> m (a, w)
278314listen' = listen @w
315+{-# INLINE listen' #-}
279316
280317pass' :: forall w m a . MonadWriter' w m => m (a, w -> w) -> m a
281318pass' = pass @w
319+{-# INLINE pass' #-}
282320
283321listens' :: forall w m a b . MonadWriter' w m => (w -> b) -> m a -> m (a, b)
284322listens' = listens @w
323+{-# INLINE listens' #-}
285324
286325censor' :: forall w m a . MonadWriter' w m => (w -> w) -> m a -> m a
287326censor' = censor @w
327+{-# INLINE censor' #-}
stack.yamlnew file+5
@@ -0,0 +1,5 @@
1+resolver: lts-8.13
2+packages: ['.']
3+
4+extra-deps:
5+- transformers-lift-0.2.0.1
test/Regression/T1.hs−1
@@ -1,7 +1,6 @@
11module Regression.T1 (test1) where
22
33import Ether
4−import TupleInstances ()
54import Data.List (group)
65
76import Test.Tasty
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