024a883...master · typeable/ether

git.iko.soy/typeable/ether

on master help sign in

.gitignore+17−2

since splitsnapshots

unifiedsplit

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

1−tags

1+# Cabal

2dist

3dist-newstyle

4−.stack-work

5.cabal-sandbox/

4.cabal-sandbox/

6cabal.sandbox.config

5cabal.sandbox.config

6+cabal.project.local

7+.ghc.environment*

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+25−18

@@ -1,24 +1,31 @@

1−sudo: false

1+language: nix

3−cache:

3+os:

4− directories:

4+ - linux

5− - $HOME/.stack/

5+ - osx

7−before_install:

7+env:

8− - mkdir -p ~/.local/bin

8+ - HC=ghc822

9− - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

9+ - HC=ghc844

10− - export PATH=~/.local/bin:$PATH

10+ - HC=ghc861

11− - stack --version

12− - stack setup

14−install:

12+before_install:

15− - stack install --only-dependencies --no-terminal

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

17script:

16script:

18− - stack test ether:regression --no-terminal --ghc-options -Werror

17+ - ./nix-cabal new-test ether:regression

19− - stack bench ether:bench --no-terminal --ghc-options -Werror

18+ - ./nix-cabal new-bench ether:bench

19+

20+cache:

21+ directories:

22+ - ~/.cabal

23+ - ~/.ghc

21−addons:

25+matrix:

22− apt:

26+ # broken at the moment

23− packages:

27+ exclude:

24− - libgmp-dev

28+ - os: osx

29+ env: HC=ghc822

30+ - os: osx

31+ env: HC=ghc861

CHANGELOG.md+5

@@ -1,3 +1,8 @@

1+0.5.1.0

2+-------

4+* Disable `HasLens` for tuples via cabal flag.

10.5.0.0

60.5.0.0

2-------

7-------

README.md−16

@@ -2,24 +2,8 @@

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)

5−[![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/int-index/ether)

8Ether is a Haskell library that extends [mtl](https://hackage.haskell.org/package/mtl)

7Ether is a Haskell library that extends [mtl](https://hackage.haskell.org/package/mtl)

9and [transformers](https://hackage.haskell.org/package/transformers) with tagged

8and [transformers](https://hackage.haskell.org/package/transformers) with tagged

10monad transformers and classes in a compatible way.

9monad 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,6 +8,7 @@ import qualified Control.Monad.Reader as M

8import qualified Control.Monad.State as M

9import Criterion.Main

10import Ether

11+import TupleInstances ()

12id' :: a -> a

13id' :: a -> a

13id' = id

14id' = id

bench/TupleInstances.hsnew file+9

@@ -0,0 +1,9 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+{-# LANGUAGE CPP #-}

4+module TupleInstances () where

6+#ifdef DISABLE_TUP_INSTANCES

7+import Ether.Internal (makeTupleInstancesHasLens)

8+makeTupleInstancesHasLens [4,5,9]

9+#endif

ether.cabal+46−16

@@ -1,21 +1,17 @@

1+cabal-version: 2.2

1name: ether

2name: ether

2−version: 0.5.0.0

3+version: 0.5.2.0

3synopsis: Monad transformers and classes

4synopsis: Monad transformers and classes

4−description:

5+description: Lib

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−

10−category: Control

11−license: BSD3

6+license: BSD-3-Clause

7+-- ^ unfortunately have to change this line due to the issue with cabal2nix

12license-file: LICENSE

8license-file: LICENSE

9+category: Control

13author: Vladislav Zavialov

10author: Vladislav Zavialov

14maintainer: Vladislav Zavialov <vlad.z.4096@gmail.com>

11maintainer: Vladislav Zavialov <vlad.z.4096@gmail.com>

15homepage: https://int-index.github.io/ether/

12homepage: https://int-index.github.io/ether/

16bug-reports: https://github.com/int-index/ether/issues

13bug-reports: https://github.com/int-index/ether/issues

17build-type: Simple

14build-type: Simple

18−cabal-version: >=1.18

19extra-source-files: CHANGELOG.md

15extra-source-files: CHANGELOG.md

21source-repository head

17source-repository head

@@ -24,6 +20,20 @@ source-repository head

24 location: git@github.com:int-index/ether.git

20 location: git@github.com:int-index/ether.git

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+

27library

37library

29 exposed-modules:

39 exposed-modules:

@@ -36,11 +46,18 @@ library

36 Ether.TagDispatch

46 Ether.TagDispatch

37 Ether.Internal

47 Ether.Internal

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+

39 build-depends:

56 build-depends:

40− base >=4.9 && <4.11,

57+ base >=4.9 && <4.13,

41− transformers >=0.5.4.0,

58+ transformers >=0.5.2.0,

42− transformers-lift >=0.2.0.0,

59+ transformers-lift >=0.2.0.1,

43− mtl >=2.2.1,

60+ mtl >=2.2.2,

44 mmorph >=1.0.4,

61 mmorph >=1.0.4,

45 monad-control >=1.0.0.4,

62 monad-control >=1.0.0.4,

46 transformers-base >=0.4.4,

63 transformers-base >=0.4.4,

@@ -84,10 +101,13 @@ library

84 ghc-options:

101 ghc-options:

85 -Wall -O2

102 -Wall -O2

103

104+ if flag(disable-tup-instances)

105+ cpp-options: -DDISABLE_TUP_INSTANCES

106+

87test-suite regression

107test-suite regression

108

89 build-depends:

109 build-depends:

90− base >=4.9 && <4.11,

110+ base >=4.9 && <4.13,

91 transformers >=0.4.2,

111 transformers >=0.4.2,

92 mtl >=2.2.1,

112 mtl >=2.2.1,

93 tasty >=0.10,

113 tasty >=0.10,

@@ -101,6 +121,7 @@ test-suite regression

101 Regression.hs

121 Regression.hs

102

122

103 other-modules:

123 other-modules:

124+ TupleInstances

104 Regression.T1

125 Regression.T1

105 Regression.T2

126 Regression.T2

106 Regression.T3

127 Regression.T3

@@ -151,11 +172,14 @@ test-suite regression

151 ghc-options:

172 ghc-options:

152 -Wall -fno-warn-missing-signatures

173 -Wall -fno-warn-missing-signatures

153

174

175+ if flag(disable-tup-instances)

176+ cpp-options: -DDISABLE_TUP_INSTANCES

177+

154

178

155benchmark bench

179benchmark bench

156

180

157 build-depends:

181 build-depends:

158− base >=4.9 && <4.11,

182+ base >=4.9 && <4.13,

159 mtl >=2.2.1,

183 mtl >=2.2.1,

160 transformers >=0.4.2,

184 transformers >=0.4.2,

161 criterion >=1.1,

185 criterion >=1.1,

@@ -166,6 +190,9 @@ benchmark bench

166 main-is:

190 main-is:

167 Bench.hs

191 Bench.hs

168

192

193+ other-modules:

194+ TupleInstances

195+

169 type:

196 type:

170 exitcode-stdio-1.0

197 exitcode-stdio-1.0

171

198

@@ -205,3 +232,6 @@ benchmark bench

205

232

206 ghc-prof-options:

233 ghc-prof-options:

207 -fprof-auto

234 -fprof-auto

235+

236+ if flag(disable-tup-instances)

237+ cpp-options: -DDISABLE_TUP_INSTANCES

shell.nixnew file+22

@@ -0,0 +1,22 @@

1+{ pkgs ? import <nixpkgs> {},

2+ hc ? "ghc844"

3+}:

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+1−15

@@ -50,12 +50,8 @@ instance {-# OVERLAPPABLE #-}

50 , Monad (t m)

51 , MonadExcept tag e m

52 ) => MonadExcept tag e (t m) where

53−

54 throw = Lift.lift . throw @tag

53 throw = Lift.lift . throw @tag

55− {-# INLINE throw #-}

56−

57 catch = Lift.liftCatch (catch @tag)

54 catch = Lift.liftCatch (catch @tag)

58− {-# INLINE catch #-}

60-- | Encode type-level information for 'ExceptT'.

56-- | Encode type-level information for 'ExceptT'.

61data EXCEPT

57data EXCEPT

@@ -77,17 +73,14 @@ type ExceptT tag e = TaggedTrans (TAGGED EXCEPT tag) (T.ExceptT e)

77-- | Runs an 'Except' and returns either an exception or a normal value.

73-- | Runs an 'Except' and returns either an exception or a normal value.

78runExcept :: forall tag e a . Except tag e a -> Either e a

74runExcept :: forall tag e a . Except tag e a -> Either e a

79runExcept = coerce (T.runExcept @e @a)

75runExcept = coerce (T.runExcept @e @a)

80−{-# INLINE runExcept #-}

82-- | Runs an 'ExceptT' and returns either an exception or a normal value.

77-- | Runs an 'ExceptT' and returns either an exception or a normal value.

83runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)

78runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)

84runExceptT = coerce (T.runExceptT @e @m @a)

79runExceptT = coerce (T.runExceptT @e @m @a)

85−{-# INLINE runExceptT #-}

87-- | Constructor for computations in the exception monad transformer.

81-- | Constructor for computations in the exception monad transformer.

88exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a

82exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a

89exceptT = coerce (T.ExceptT @e @m @a)

83exceptT = coerce (T.ExceptT @e @m @a)

90−{-# INLINE exceptT #-}

92type instance HandleSuper EXCEPT e trans = ()

85type instance HandleSuper EXCEPT e trans = ()

93type instance HandleConstraint EXCEPT e trans m =

86type instance HandleConstraint EXCEPT e trans m =

@@ -95,47 +88,40 @@ type instance HandleConstraint EXCEPT e trans m =

96instance Handle EXCEPT e (T.ExceptT e) where

89instance Handle EXCEPT e (T.ExceptT e) where

97 handling r = r

90 handling r = r

98− {-# INLINE handling #-}

100instance

92instance

101 ( Handle EXCEPT e trans

93 ( Handle EXCEPT e trans

102 , Monad m, Monad (trans m)

94 , Monad m, Monad (trans m)

103 ) => MonadExcept tag e (TaggedTrans (TAGGED EXCEPT tag) trans m)

95 ) => MonadExcept tag e (TaggedTrans (TAGGED EXCEPT tag) trans m)

104 where

96 where

97+

105 throw =

98 throw =

106 handling @EXCEPT @e @trans @m $

99 handling @EXCEPT @e @trans @m $

107 coerce (T.throwError @e @(trans m) @a) ::

100 coerce (T.throwError @e @(trans m) @a) ::

108 forall eff a . e -> TaggedTrans eff trans m a

101 forall eff a . e -> TaggedTrans eff trans m a

109− {-# INLINE throw #-}

110

102

111 catch =

103 catch =

112 handling @EXCEPT @e @trans @m $

104 handling @EXCEPT @e @trans @m $

113 coerce (T.catchError @e @(trans m) @a) ::

105 coerce (T.catchError @e @(trans m) @a) ::

114 forall eff a . Catch e (TaggedTrans eff trans m) a

106 forall eff a . Catch e (TaggedTrans eff trans m) a

115− {-# INLINE catch #-}

116

107

117type MonadExcept' e = MonadExcept e e

108type MonadExcept' e = MonadExcept e e

118

109

119throw' :: forall e m a . MonadExcept' e m => e -> m a

110throw' :: forall e m a . MonadExcept' e m => e -> m a

120throw' = throw @e

111throw' = throw @e

121−{-# INLINE throw' #-}

122

112

123catch' :: forall e m a . MonadExcept' e m => m a -> (e -> m a) -> m a

113catch' :: forall e m a . MonadExcept' e m => m a -> (e -> m a) -> m a

124catch' = catch @e

114catch' = catch @e

125−{-# INLINE catch' #-}

126

115

127type Except' e = Except e e

116type Except' e = Except e e

128

117

129runExcept' :: Except' e a -> Either e a

118runExcept' :: Except' e a -> Either e a

130runExcept' = runExcept

119runExcept' = runExcept

131−{-# INLINE runExcept' #-}

132

120

133type ExceptT' e = ExceptT e e

121type ExceptT' e = ExceptT e e

134

122

135exceptT' :: m (Either e a) -> ExceptT' e m a

123exceptT' :: m (Either e a) -> ExceptT' e m a

136exceptT' = exceptT

124exceptT' = exceptT

137−{-# INLINE exceptT' #-}

138

125

139runExceptT' :: ExceptT' e m a -> m (Either e a)

126runExceptT' :: ExceptT' e m a -> m (Either e a)

140runExceptT' = runExceptT

127runExceptT' = runExceptT

141−{-# INLINE runExceptT' #-}

src/Ether/Internal.hs+6−117

@@ -16,18 +16,20 @@ module Ether.Internal

16 , HandleSuper

17 , HandleConstraint

18 , Handle(..)

19+ , makeTupleInstancesHasLens

19 ) where

20 ) where

21import Control.Applicative

22import Control.Applicative

22−import Control.Monad

23import Data.Coerce

24import Data.Functor.Identity

25import Data.Kind

26−import Data.List as List

27import Data.Tagged

26import Data.Tagged

28−import Data.Traversable

29import GHC.Exts (Constraint)

27import GHC.Exts (Constraint)

30−import qualified Language.Haskell.TH as TH

28+

29+import Ether.Internal.HasLens

30+import Ether.Internal.Tags

31+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

32+import Ether.Internal.TupleInstances ()

32data TAGGED e t

34data TAGGED e t

@@ -55,125 +57,12 @@ class

55 where

57 where

56 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r

58 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r

58−type LensLike f s t a b = (a -> f b) -> s -> f t

59−

60−type Lens s t a b = forall f. Functor f => LensLike f s t a b

61−

62−type Lens' s a = Lens s s a a

63−

64newtype ReifiedLens s t a b = Lens (Lens s t a b)

60newtype ReifiedLens s t a b = Lens (Lens s t a b)

66type ReifiedLens' s a = ReifiedLens s s a a

62type ReifiedLens' s a = ReifiedLens s s a a

68−class HasLens tag outer inner | tag outer -> inner where

69− lensOf :: Lens' outer inner

70−

71−instance HasLens a a a where

72− lensOf = id

73− {-# INLINE lensOf #-}

74−

75view :: LensLike (Const a) s t a b -> s -> a

64view :: LensLike (Const a) s t a b -> s -> a

76view l = coerce (l Const)

65view l = coerce (l Const)

77−{-# INLINE view #-}

79over :: LensLike Identity s t a b -> (a -> b) -> s -> t

67over :: LensLike Identity s t a b -> (a -> b) -> s -> t

80over = coerce

68over = coerce

81−{-# INLINE over #-}

82−

83−data HList xs where

84− HNil :: HList '[]

85− HCons :: x -> HList xs -> HList (x ': xs)

86−

87−type KindOf (a :: k) = k

88−

89−type family TagsK (p :: Type) :: [Type]

90−type family Tags (p :: Type) :: HList (TagsK p)

91−

92−return []

93−

94−type instance TagsK () = '[]

95−type instance TagsK (Tagged t a) = '[KindOf t]

96−type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]

97−

98−return []

99−

100−type instance Tags () = 'HNil

101−type instance Tags (Tagged t a) = 'HCons t 'HNil

102−type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)

103−

104−do

105− let

106− tupCount = 62

107− names = [1..] >>= flip replicateM ['a'..'z']

108− varNames <- traverse TH.newName (take tupCount names)

109− fmap List.concat $

110− for (List.drop 2 (List.inits varNames)) $

111− \varNames' -> do

112− let n = List.length varNames'

113− tagsInstances <- for [() | n > 2] $ \() -> do

114− tag <- TH.newName "tag"

115− let

116− (cur:rest) = varNames'

117− tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))

118− ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :

119− map TH.VarT rest )

120− tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))

121− (map TH.VarT rest)

122− return $

123− TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy]

124− ( TH.PromotedConsT `TH.AppT` (TH.ConT ''KindOf `TH.AppT` TH.VarT tag) `TH.AppT`

125− (TH.ConT ''TagsK `TH.AppT` tupTy') ))

126− return tagsInstances

127−do

128− let

129− tupCount = 62

130− names = [1..] >>= flip replicateM ['a'..'z']

131− varNames <- traverse TH.newName (take tupCount names)

132− fmap List.concat $

133− for (List.drop 2 (List.inits varNames)) $

134− \varNames' -> do

135− let n = List.length varNames'

136− tagsInstances <- for [() | n > 2] $ \() -> do

137− tag <- TH.newName "tag"

138− let

139− (cur:rest) = varNames'

140− tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))

141− ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :

142− map TH.VarT rest )

143− tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))

144− (map TH.VarT rest)

145− tagsInst =

146− TH.TySynInstD ''Tags (TH.TySynEqn [tupTy]

147− ( TH.PromotedT 'HCons `TH.AppT` TH.VarT tag `TH.AppT`

148− (TH.ConT ''Tags `TH.AppT` tupTy') ))

149− return tagsInst

150− hasLensInstances <- for [0..n-1] $ \k -> do

151− tag <- TH.newName "tag"

152− let

153− (prev, cur:next) = List.splitAt k varNames'

154− tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))

155− ( map TH.VarT prev ++

156− [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++

157− map TH.VarT next )

158− cur' <- TH.newName "x"

159− f <- TH.newName "f"

160− return $

161− TH.InstanceD Nothing []

162− (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)

163− [ TH.FunD 'lensOf

164− [ TH.Clause

165− [TH.VarP f, TH.TupP

166− ( map TH.VarP prev ++

167− [TH.ConP 'Tagged [TH.VarP cur]] ++

168− map TH.VarP next )]

169− (TH.NormalB $

170− TH.VarE 'fmap `TH.AppE`

171− (TH.LamE [TH.VarP cur']

172− (TH.TupE

173− ( map TH.VarE prev ++

174− [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++

175− map TH.VarE next ))) `TH.AppE`

176− (TH.VarE f `TH.AppE` TH.VarE cur) )

177− [] ],

178− TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]

179− return $ tagsInstances ++ hasLensInstances

src/Ether/Internal/HasLens.hsnew file+24

@@ -0,0 +1,24 @@

1+module Ether.Internal.HasLens

2+ ( LensLike

3+ , Lens

4+ , Lens'

5+ , HasLens(..)

6+ ) where

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

@@ -0,0 +1,79 @@

1+module Ether.Internal.TH_TupleInstances

2+ ( makeTupleInstancesTagsK

3+ , makeTupleInstancesTags

4+ , makeTupleInstancesHasLens

5+ ) where

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

@@ -0,0 +1,14 @@

1+module Ether.Internal.TH_Utils

2+ ( tupCount

3+ , varName

4+ , tagName

5+ ) where

7+import qualified Language.Haskell.TH as TH

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

@@ -0,0 +1,18 @@

1+module Ether.Internal.Tags

2+ ( Tags

3+ , TagsK

4+ , HList(..)

5+ , KindOf

6+ ) where

8+import Data.Kind

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

@@ -0,0 +1,24 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+{-# LANGUAGE CPP #-}

4+module Ether.Internal.TupleInstances () where

6+import Data.Tagged

7+import Ether.Internal.Tags

8+import Ether.Internal.TH_TupleInstances

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

@@ -77,15 +77,9 @@ instance {-# OVERLAPPABLE #-}

77 , MonadReader tag r m

78 ) => MonadReader tag r (t m)

79 where

80−

81 ask = Lift.lift (ask @tag)

80 ask = Lift.lift (ask @tag)

82− {-# INLINE ask #-}

83−

84 local = Lift.liftLocal (ask @tag) (local @tag)

81 local = Lift.liftLocal (ask @tag) (local @tag)

85− {-# INLINE local #-}

86−

87 reader = Lift.lift . reader @tag

82 reader = Lift.lift . reader @tag

88− {-# INLINE reader #-}

90instance {-# OVERLAPPABLE #-}

84instance {-# OVERLAPPABLE #-}

91 ( Monad (trans m)

85 ( Monad (trans m)

@@ -98,21 +92,18 @@ instance {-# OVERLAPPABLE #-}

98 TaggedTrans effs trans m r ->

92 TaggedTrans effs trans m r ->

99 TaggedTrans (eff ': effs) trans m r)

93 TaggedTrans (eff ': effs) trans m r)

100 (ask @tag)

94 (ask @tag)

101− {-# INLINE ask #-}

102

103 local =

96 local =

104 (coerce :: forall a .

97 (coerce :: forall a .

105 Lift.Local r (TaggedTrans effs trans m) a ->

98 Lift.Local r (TaggedTrans effs trans m) a ->

106 Lift.Local r (TaggedTrans (eff ': effs) trans m) a)

99 Lift.Local r (TaggedTrans (eff ': effs) trans m) a)

107 (local @tag)

100 (local @tag)

108− {-# INLINE local #-}

109

101

110 reader =

102 reader =

111 (coerce :: forall a .

103 (coerce :: forall a .

112 ((r -> a) -> TaggedTrans effs trans m a) ->

104 ((r -> a) -> TaggedTrans effs trans m a) ->

113 ((r -> a) -> TaggedTrans (eff ': effs) trans m a))

105 ((r -> a) -> TaggedTrans (eff ': effs) trans m a))

114 (reader @tag)

106 (reader @tag)

115− {-# INLINE reader #-}

116

107

117-- | Retrieves a function of the current environment.

108-- | Retrieves a function of the current environment.

118asks

109asks

@@ -122,7 +113,6 @@ asks

122 -- ^ The selector function to apply to the environment.

113 -- ^ The selector function to apply to the environment.

123 -> m a

114 -> m a

124asks = reader @tag

115asks = reader @tag

125−{-# INLINE asks #-}

126

116

127-- | Encode type-level information for 'ReaderT'.

117-- | Encode type-level information for 'ReaderT'.

128data READER

118data READER

@@ -145,19 +135,16 @@ type ReaderT tag r = TaggedTrans (TAGGED READER tag) (T.ReaderT r)

145-- | Constructor for computations in the reader monad transformer.

135-- | Constructor for computations in the reader monad transformer.

146readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a

136readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a

147readerT = coerce (T.ReaderT @r @m @a)

137readerT = coerce (T.ReaderT @r @m @a)

148−{-# INLINE readerT #-}

149

138

150-- | Runs a 'ReaderT' with the given environment

139-- | Runs a 'ReaderT' with the given environment

151-- and returns the final value.

140-- and returns the final value.

152runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a

141runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a

153−runReaderT = coerce (T.runReaderT @r @_ @m @a)

142+runReaderT = coerce (T.runReaderT @r @m @a)

154−{-# INLINE runReaderT #-}

155

143

156-- | Runs a 'ReaderT' with the given environment

144-- | Runs a 'ReaderT' with the given environment

157-- and returns the final value.

145-- and returns the final value.

158runReader :: forall tag r a . Reader tag r a -> r -> a

146runReader :: forall tag r a . Reader tag r a -> r -> a

159runReader = coerce (T.runReader @r @a)

147runReader = coerce (T.runReader @r @a)

160−{-# INLINE runReader #-}

161

148

162type instance HandleSuper READER r trans = ()

149type instance HandleSuper READER r trans = ()

163type instance HandleConstraint READER r trans m =

150type instance HandleConstraint READER r trans m =

@@ -165,7 +152,6 @@ type instance HandleConstraint READER r trans m =

165

152

166instance Handle READER r (T.ReaderT r) where

153instance Handle READER r (T.ReaderT r) where

167 handling r = r

154 handling r = r

168− {-# INLINE handling #-}

169

155

170instance

156instance

171 ( Handle READER r trans

157 ( Handle READER r trans

@@ -176,19 +162,16 @@ instance

176 ask =

162 ask =

177 handling @READER @r @trans @m $

163 handling @READER @r @trans @m $

178 coerce (T.ask @r @(trans m))

164 coerce (T.ask @r @(trans m))

179− {-# INLINE ask #-}

180

165

181 local =

166 local =

182 handling @READER @r @trans @m $

167 handling @READER @r @trans @m $

183 coerce (T.local @r @(trans m) @a) ::

168 coerce (T.local @r @(trans m) @a) ::

184 forall eff a . Local r (TaggedTrans eff trans m) a

169 forall eff a . Local r (TaggedTrans eff trans m) a

185− {-# INLINE local #-}

186

170

187 reader =

171 reader =

188 handling @READER @r @trans @m $

172 handling @READER @r @trans @m $

189 coerce (T.reader @r @(trans m) @a) ::

173 coerce (T.reader @r @(trans m) @a) ::

190 forall eff a . (r -> a) -> TaggedTrans eff trans m a

174 forall eff a . (r -> a) -> TaggedTrans eff trans m a

191− {-# INLINE reader #-}

192

175

193instance

176instance

194 ( HasLens tag payload r

177 ( HasLens tag payload r

@@ -203,7 +186,6 @@ instance

203 trans m a ->

186 trans m a ->

204 TaggedTrans eff trans m a)

187 TaggedTrans eff trans m a)

205 (T.asks (view (lensOf @tag @payload @r)))

188 (T.asks (view (lensOf @tag @payload @r)))

206− {-# INLINE ask #-}

207

189

208 local f =

190 local f =

209 handling @READER @payload @trans @m $

191 handling @READER @payload @trans @m $

@@ -211,7 +193,6 @@ instance

211 (trans m a -> trans m a) ->

193 (trans m a -> trans m a) ->

212 (TaggedTrans eff trans m a -> TaggedTrans eff trans m a))

194 (TaggedTrans eff trans m a -> TaggedTrans eff trans m a))

213 (T.local (over (lensOf @tag @payload @r) f))

195 (T.local (over (lensOf @tag @payload @r) f))

214− {-# INLINE local #-}

215

196

216type family READERS (ts :: HList xs) :: [Type] where

197type family READERS (ts :: HList xs) :: [Type] where

217 READERS 'HNil = '[]

198 READERS 'HNil = '[]

@@ -222,43 +203,34 @@ type ReadersT r = TaggedTrans (READERS (Tags r)) (T.ReaderT r)

222type Readers r = ReadersT r Identity

203type Readers r = ReadersT r Identity

223

204

224runReadersT :: forall p m a . ReadersT p m a -> p -> m a

205runReadersT :: forall p m a . ReadersT p m a -> p -> m a

225−runReadersT = coerce (T.runReaderT @p @_ @m @a)

206+runReadersT = coerce (T.runReaderT @p @m @a)

226−{-# INLINE runReadersT #-}

227

207

228runReaders :: forall p a . Readers p a -> p -> a

208runReaders :: forall p a . Readers p a -> p -> a

229runReaders = coerce (T.runReader @p @a)

209runReaders = coerce (T.runReader @p @a)

230−{-# INLINE runReaders #-}

231

210

232type ReaderT' r = ReaderT r r

211type ReaderT' r = ReaderT r r

233

212

234readerT' :: (r -> m a) -> ReaderT' r m a

213readerT' :: (r -> m a) -> ReaderT' r m a

235readerT' = readerT

214readerT' = readerT

236−{-# INLINE readerT' #-}

237

215

238runReaderT' :: ReaderT' r m a -> r -> m a

216runReaderT' :: ReaderT' r m a -> r -> m a

239runReaderT' = runReaderT

217runReaderT' = runReaderT

240−{-# INLINE runReaderT' #-}

241

218

242type Reader' r = Reader r r

219type Reader' r = Reader r r

243

220

244runReader' :: Reader' r a -> r -> a

221runReader' :: Reader' r a -> r -> a

245runReader' = runReader

222runReader' = runReader

246−{-# INLINE runReader' #-}

247

223

248type MonadReader' r = MonadReader r r

224type MonadReader' r = MonadReader r r

249

225

250local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a

226local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a

251local' = local @r

227local' = local @r

252−{-# INLINE local' #-}

253

228

254ask' :: forall r m . MonadReader' r m => m r

229ask' :: forall r m . MonadReader' r m => m r

255ask' = ask @r

230ask' = ask @r

256−{-# INLINE ask' #-}

257

231

258reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a

232reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a

259reader' = reader @r

233reader' = reader @r

260−{-# INLINE reader' #-}

261

234

262asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a

235asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a

263asks' = asks @r

236asks' = asks @r

264−{-# INLINE asks' #-}

src/Ether/State.hs+4−60

@@ -85,8 +85,8 @@ import Data.Kind

85import Data.Proxy

86import Data.Reflection

88−import Ether.TaggedTrans

89import Ether.Internal

88import Ether.Internal

89+import Ether.TaggedTrans

91class Monad m => MonadState tag s m | m tag -> s where

@@ -114,15 +114,9 @@ instance {-# OVERLAPPABLE #-}

114 , MonadState tag s m

115 ) => MonadState tag s (t m)

116 where

117−

118 get = Lift.lift (get @tag)

117 get = Lift.lift (get @tag)

119− {-# INLINE get #-}

120−

121 put = Lift.lift . put @tag

118 put = Lift.lift . put @tag

122− {-# INLINE put #-}

123−

124 state = Lift.lift . state @tag

119 state = Lift.lift . state @tag

125− {-# INLINE state #-}

126

120

127instance {-# OVERLAPPABLE #-}

121instance {-# OVERLAPPABLE #-}

128 ( Monad (trans m)

122 ( Monad (trans m)

@@ -135,34 +129,29 @@ instance {-# OVERLAPPABLE #-}

135 TaggedTrans effs trans m s ->

129 TaggedTrans effs trans m s ->

136 TaggedTrans (eff ': effs) trans m s)

130 TaggedTrans (eff ': effs) trans m s)

137 (get @tag)

131 (get @tag)

138− {-# INLINE get #-}

139

132

140 put =

133 put =

141 (coerce ::

134 (coerce ::

142 (s -> TaggedTrans effs trans m ()) ->

135 (s -> TaggedTrans effs trans m ()) ->

143 (s -> TaggedTrans (eff ': effs) trans m ()))

136 (s -> TaggedTrans (eff ': effs) trans m ()))

144 (put @tag)

137 (put @tag)

145− {-# INLINE put #-}

146

138

147 state =

139 state =

148 (coerce :: forall a .

140 (coerce :: forall a .

149 ((s -> (a, s)) -> TaggedTrans effs trans m a) ->

141 ((s -> (a, s)) -> TaggedTrans effs trans m a) ->

150 ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a))

142 ((s -> (a, s)) -> TaggedTrans (eff ': effs) trans m a))

151 (state @tag)

143 (state @tag)

152− {-# INLINE state #-}

153−

154−-- | Encode type-level information for 'StateT'.

155−data STATE

156

144

157-- | Modifies the state inside a state monad.

145-- | Modifies the state inside a state monad.

158modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()

146modify :: forall tag s m . MonadState tag s m => (s -> s) -> m ()

159modify f = state @tag (\s -> ((), f s))

147modify f = state @tag (\s -> ((), f s))

160−{-# INLINABLE modify #-}

161

148

162-- | Gets specific component of the state, using a projection function supplied.

149-- | Gets specific component of the state, using a projection function supplied.

163gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a

150gets :: forall tag s m a . MonadState tag s m => (s -> a) -> m a

164gets f = fmap f (get @tag)

151gets f = fmap f (get @tag)

165−{-# INLINABLE gets #-}

152+

153+-- | Encode type-level information for 'StateT'.

154+data STATE

166

155

167type instance HandleSuper STATE s trans = ()

156type instance HandleSuper STATE s trans = ()

168type instance HandleConstraint STATE s trans m =

157type instance HandleConstraint STATE s trans m =

@@ -170,11 +159,9 @@ type instance HandleConstraint STATE s trans m =

170

159

171instance Handle STATE s (T.Strict.StateT s) where

160instance Handle STATE s (T.Strict.StateT s) where

172 handling r = r

161 handling r = r

173− {-# INLINE handling #-}

174

162

175instance Handle STATE s (T.Lazy.StateT s) where

163instance Handle STATE s (T.Lazy.StateT s) where

176 handling r = r

164 handling r = r

177− {-# INLINE handling #-}

178

165

179instance

166instance

180 ( Handle STATE s trans

167 ( Handle STATE s trans

@@ -185,18 +172,15 @@ instance

185 get =

172 get =

186 handling @STATE @s @trans @m $

173 handling @STATE @s @trans @m $

187 coerce (T.get @s @(trans m))

174 coerce (T.get @s @(trans m))

188− {-# INLINE get #-}

189

175

190 put =

176 put =

191 handling @STATE @s @trans @m $

177 handling @STATE @s @trans @m $

192 coerce (T.put @s @(trans m))

178 coerce (T.put @s @(trans m))

193− {-# INLINE put #-}

194

179

195 state =

180 state =

196 handling @STATE @s @trans @m $

181 handling @STATE @s @trans @m $

197 coerce (T.state @s @(trans m) @a) ::

182 coerce (T.state @s @(trans m) @a) ::

198 forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a

183 forall eff a . (s -> (a, s)) -> TaggedTrans eff trans m a

199− {-# INLINE state #-}

200

184

201instance

185instance

202 ( HasLens tag payload s

186 ( HasLens tag payload s

@@ -211,7 +195,6 @@ instance

211 trans m a ->

195 trans m a ->

212 TaggedTrans eff trans m a)

196 TaggedTrans eff trans m a)

213 (T.gets (view (lensOf @tag @payload @s)))

197 (T.gets (view (lensOf @tag @payload @s)))

214− {-# INLINE get #-}

215

198

216 put s =

199 put s =

217 handling @STATE @payload @trans @m $

200 handling @STATE @payload @trans @m $

@@ -219,7 +202,6 @@ instance

219 trans m a ->

202 trans m a ->

220 TaggedTrans eff trans m a)

203 TaggedTrans eff trans m a)

221 (T.modify (over (lensOf @tag @payload @s) (const s)))

204 (T.modify (over (lensOf @tag @payload @s) (const s)))

222− {-# INLINE put #-}

223

205

224 state f =

206 state f =

225 handling @STATE @payload @trans @m $

207 handling @STATE @payload @trans @m $

@@ -227,7 +209,6 @@ instance

227 trans m a ->

209 trans m a ->

228 TaggedTrans eff trans m a)

210 TaggedTrans eff trans m a)

229 (T.state (lensOf @tag @payload @s f))

211 (T.state (lensOf @tag @payload @s f))

230− {-# INLINE state #-}

231

212

232-- | The parametrizable state monad.

213-- | The parametrizable state monad.

233--

214--

@@ -246,43 +227,36 @@ type StateT tag s = TaggedTrans (TAGGED STATE tag) (T.Strict.StateT s)

246-- | Constructor for computations in the state monad transformer.

227-- | Constructor for computations in the state monad transformer.

247stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a

228stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a

248stateT = coerce (T.Strict.StateT @s @m @a)

229stateT = coerce (T.Strict.StateT @s @m @a)

249−{-# INLINE stateT #-}

250

230

251-- | Runs a 'StateT' with the given initial state

231-- | Runs a 'StateT' with the given initial state

252-- and returns both the final value and the final state.

232-- and returns both the final value and the final state.

253runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)

233runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)

254runStateT = coerce (T.Strict.runStateT @s @m @a)

234runStateT = coerce (T.Strict.runStateT @s @m @a)

255−{-# INLINE runStateT #-}

256

235

257-- | Runs a 'StateT' with the given initial state

236-- | Runs a 'StateT' with the given initial state

258-- and returns the final value, discarding the final state.

237-- and returns the final value, discarding the final state.

259evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a

238evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a

260evalStateT = coerce (T.Strict.evalStateT @m @s @a)

239evalStateT = coerce (T.Strict.evalStateT @m @s @a)

261−{-# INLINE evalStateT #-}

262

240

263-- | Runs a 'StateT' with the given initial state

241-- | Runs a 'StateT' with the given initial state

264-- and returns the final state, discarding the final value.

242-- and returns the final state, discarding the final value.

265execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s

243execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s

266execStateT = coerce (T.Strict.execStateT @m @s @a)

244execStateT = coerce (T.Strict.execStateT @m @s @a)

267−{-# INLINE execStateT #-}

268

245

269-- | Runs a 'State' with the given initial state

246-- | Runs a 'State' with the given initial state

270-- and returns both the final value and the final state.

247-- and returns both the final value and the final state.

271runState :: forall tag s a . State tag s a -> s -> (a, s)

248runState :: forall tag s a . State tag s a -> s -> (a, s)

272runState = coerce (T.Strict.runState @s @a)

249runState = coerce (T.Strict.runState @s @a)

273−{-# INLINE runState #-}

274

250

275-- | Runs a 'State' with the given initial state

251-- | Runs a 'State' with the given initial state

276-- and returns the final value, discarding the final state.

252-- and returns the final value, discarding the final state.

277evalState :: forall tag s a . State tag s a -> s -> a

253evalState :: forall tag s a . State tag s a -> s -> a

278evalState = coerce (T.Strict.evalState @s @a)

254evalState = coerce (T.Strict.evalState @s @a)

279−{-# INLINE evalState #-}

280

255

281-- | Runs a 'State' with the given initial state

256-- | Runs a 'State' with the given initial state

282-- and returns the final state, discarding the final value.

257-- and returns the final state, discarding the final value.

283execState :: forall tag s a . State tag s a -> s -> s

258execState :: forall tag s a . State tag s a -> s -> s

284execState = coerce (T.Strict.execState @s @a)

259execState = coerce (T.Strict.execState @s @a)

285−{-# INLINE execState #-}

286

260

287-- | The parametrizable state monad.

261-- | The parametrizable state monad.

288--

262--

@@ -301,43 +275,36 @@ type LazyStateT tag s = TaggedTrans (TAGGED STATE tag) (T.Lazy.StateT s)

301-- | Constructor for computations in the state monad transformer.

275-- | Constructor for computations in the state monad transformer.

302lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a

276lazyStateT :: forall tag s m a . (s -> m (a, s)) -> LazyStateT tag s m a

303lazyStateT = coerce (T.Lazy.StateT @s @m @a)

277lazyStateT = coerce (T.Lazy.StateT @s @m @a)

304−{-# INLINE lazyStateT #-}

305

278

306-- | Runs a 'StateT' with the given initial state

279-- | Runs a 'StateT' with the given initial state

307-- and returns both the final value and the final state.

280-- and returns both the final value and the final state.

308runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s)

281runLazyStateT :: forall tag s m a . LazyStateT tag s m a -> s -> m (a, s)

309runLazyStateT = coerce (T.Lazy.runStateT @s @m @a)

282runLazyStateT = coerce (T.Lazy.runStateT @s @m @a)

310−{-# INLINE runLazyStateT #-}

311

283

312-- | Runs a 'StateT' with the given initial state

284-- | Runs a 'StateT' with the given initial state

313-- and returns the final value, discarding the final state.

285-- and returns the final value, discarding the final state.

314evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a

286evalLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m a

315evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a)

287evalLazyStateT = coerce (T.Lazy.evalStateT @m @s @a)

316−{-# INLINE evalLazyStateT #-}

317

288

318-- | Runs a 'StateT' with the given initial state

289-- | Runs a 'StateT' with the given initial state

319-- and returns the final state, discarding the final value.

290-- and returns the final state, discarding the final value.

320execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s

291execLazyStateT :: forall tag s m a . Monad m => LazyStateT tag s m a -> s -> m s

321execLazyStateT = coerce (T.Lazy.execStateT @m @s @a)

292execLazyStateT = coerce (T.Lazy.execStateT @m @s @a)

322−{-# INLINE execLazyStateT #-}

323

293

324-- | Runs a 'State' with the given initial state

294-- | Runs a 'State' with the given initial state

325-- and returns both the final value and the final state.

295-- and returns both the final value and the final state.

326runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s)

296runLazyState :: forall tag s a . LazyState tag s a -> s -> (a, s)

327runLazyState = coerce (T.Lazy.runState @s @a)

297runLazyState = coerce (T.Lazy.runState @s @a)

328−{-# INLINE runLazyState #-}

329

298

330-- | Runs a 'State' with the given initial state

299-- | Runs a 'State' with the given initial state

331-- and returns the final value, discarding the final state.

300-- and returns the final value, discarding the final state.

332evalLazyState :: forall tag s a . LazyState tag s a -> s -> a

301evalLazyState :: forall tag s a . LazyState tag s a -> s -> a

333evalLazyState = coerce (T.Lazy.evalState @s @a)

302evalLazyState = coerce (T.Lazy.evalState @s @a)

334−{-# INLINE evalLazyState #-}

335

303

336-- | Runs a 'State' with the given initial state

304-- | Runs a 'State' with the given initial state

337-- and returns the final state, discarding the final value.

305-- and returns the final state, discarding the final value.

338execLazyState :: forall tag s a . LazyState tag s a -> s -> s

306execLazyState :: forall tag s a . LazyState tag s a -> s -> s

339execLazyState = coerce (T.Lazy.execState @s @a)

307execLazyState = coerce (T.Lazy.execState @s @a)

340−{-# INLINE execLazyState #-}

341

308

342type family STATES (ts :: HList xs) :: [Type] where

309type family STATES (ts :: HList xs) :: [Type] where

343 STATES 'HNil = '[]

310 STATES 'HNil = '[]

@@ -349,97 +316,76 @@ type States s = StatesT s Identity

349

316

350runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p)

317runStatesT :: forall p m a . StatesT p m a -> p -> m (a, p)

351runStatesT = coerce (T.Strict.runStateT @p @m @a)

318runStatesT = coerce (T.Strict.runStateT @p @m @a)

352−{-# INLINE runStatesT #-}

353

319

354runStates :: forall p a . States p a -> p -> (a, p)

320runStates :: forall p a . States p a -> p -> (a, p)

355runStates = coerce (T.Strict.runState @p @a)

321runStates = coerce (T.Strict.runState @p @a)

356−{-# INLINE runStates #-}

357

322

358type StateT' s = StateT s s

323type StateT' s = StateT s s

359

324

360stateT' :: (s -> m (a, s)) -> StateT' s m a

325stateT' :: (s -> m (a, s)) -> StateT' s m a

361stateT' = stateT

326stateT' = stateT

362−{-# INLINE stateT' #-}

363

327

364runStateT' :: StateT' s m a -> s -> m (a, s)

328runStateT' :: StateT' s m a -> s -> m (a, s)

365runStateT' = runStateT

329runStateT' = runStateT

366−{-# INLINE runStateT' #-}

367

330

368runState' :: State' s a -> s -> (a, s)

331runState' :: State' s a -> s -> (a, s)

369runState' = runState

332runState' = runState

370−{-# INLINE runState' #-}

371

333

372evalStateT' :: Monad m => StateT' s m a -> s -> m a

334evalStateT' :: Monad m => StateT' s m a -> s -> m a

373evalStateT' = evalStateT

335evalStateT' = evalStateT

374−{-# INLINE evalStateT' #-}

375

336

376type State' s = State s s

337type State' s = State s s

377

338

378evalState' :: State' s a -> s -> a

339evalState' :: State' s a -> s -> a

379evalState' = evalState

340evalState' = evalState

380−{-# INLINE evalState' #-}

381

341

382execStateT' :: Monad m => StateT' s m a -> s -> m s

342execStateT' :: Monad m => StateT' s m a -> s -> m s

383execStateT' = execStateT

343execStateT' = execStateT

384−{-# INLINE execStateT' #-}

385

344

386execState' :: State' s a -> s -> s

345execState' :: State' s a -> s -> s

387execState' = execState

346execState' = execState

388−{-# INLINE execState' #-}

389

347

390type LazyStateT' s = LazyStateT s s

348type LazyStateT' s = LazyStateT s s

391

349

392lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a

350lazyStateT' :: (s -> m (a, s)) -> LazyStateT' s m a

393lazyStateT' = lazyStateT

351lazyStateT' = lazyStateT

394−{-# INLINE lazyStateT' #-}

395

352

396runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s)

353runLazyStateT' :: LazyStateT' s m a -> s -> m (a, s)

397runLazyStateT' = runLazyStateT

354runLazyStateT' = runLazyStateT

398−{-# INLINE runLazyStateT' #-}

399

355

400runLazyState' :: LazyState' s a -> s -> (a, s)

356runLazyState' :: LazyState' s a -> s -> (a, s)

401runLazyState' = runLazyState

357runLazyState' = runLazyState

402−{-# INLINE runLazyState' #-}

403

358

404evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a

359evalLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m a

405evalLazyStateT' = evalLazyStateT

360evalLazyStateT' = evalLazyStateT

406−{-# INLINE evalLazyStateT' #-}

407

361

408type LazyState' s = LazyState s s

362type LazyState' s = LazyState s s

409

363

410evalLazyState' :: LazyState' s a -> s -> a

364evalLazyState' :: LazyState' s a -> s -> a

411evalLazyState' = evalLazyState

365evalLazyState' = evalLazyState

412−{-# INLINE evalLazyState' #-}

413

366

414execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s

367execLazyStateT' :: Monad m => LazyStateT' s m a -> s -> m s

415execLazyStateT' = execLazyStateT

368execLazyStateT' = execLazyStateT

416−{-# INLINE execLazyStateT' #-}

417

369

418execLazyState' :: LazyState' s a -> s -> s

370execLazyState' :: LazyState' s a -> s -> s

419execLazyState' = execLazyState

371execLazyState' = execLazyState

420−{-# INLINE execLazyState' #-}

421

372

422type MonadState' s = MonadState s s

373type MonadState' s = MonadState s s

423

374

424get' :: forall s m . MonadState' s m => m s

375get' :: forall s m . MonadState' s m => m s

425get' = get @s

376get' = get @s

426−{-# INLINE get' #-}

427

377

428gets' :: forall s m a . MonadState' s m => (s -> a) -> m a

378gets' :: forall s m a . MonadState' s m => (s -> a) -> m a

429gets' = gets @s

379gets' = gets @s

430−{-# INLINE gets' #-}

431

380

432put' :: forall s m . MonadState' s m => s -> m ()

381put' :: forall s m . MonadState' s m => s -> m ()

433put' = put @s

382put' = put @s

434−{-# INLINE put' #-}

435

383

436state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a

384state' :: forall s m a . MonadState' s m => (s -> (a, s)) -> m a

437state' = state @s

385state' = state @s

438−{-# INLINE state' #-}

439

386

440modify' :: forall s m . MonadState' s m => (s -> s) -> m ()

387modify' :: forall s m . MonadState' s m => (s -> s) -> m ()

441modify' = modify @s

388modify' = modify @s

442−{-# INLINE modify' #-}

443

389

444-- | Encode type-level information for 'zoom'.

390-- | Encode type-level information for 'zoom'.

445data ZOOM t z

391data ZOOM t z

@@ -453,7 +399,6 @@ zoom

453 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a)

399 -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => ZoomT tag z m a)

454 -> m a

400 -> m a

455zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))

401zoom l m = reify (Lens l) (\(_ :: Proxy z) -> coerce (m @z))

456−{-# INLINE zoom #-}

457

402

458instance

403instance

459 ( MonadState tag sOuter m

404 ( MonadState tag sOuter m

@@ -468,4 +413,3 @@ instance

468 (state @tag . l)

413 (state @tag . l)

469 where

414 where

470 Lens l = reflect (Proxy :: Proxy z)

415 Lens l = reflect (Proxy :: Proxy z)

471− {-# INLINE state #-}

src/Ether/TagDispatch.hs−50

@@ -63,63 +63,38 @@ type TagAttachT t = TaggedTrans (TAG_ATTACH t) IdentityT

63-- | Attach a tag to untagged transformers.

64tagAttach :: forall tag m a . TagAttachT tag m a -> m a

65tagAttach = coerce (runIdentityT @_ @m @a)

66−{-# INLINE tagAttach #-}

68instance {-# OVERLAPPING #-}

67instance {-# OVERLAPPING #-}

69 ( MonadReader tag r m, trans ~ IdentityT

68 ( MonadReader tag r m, trans ~ IdentityT

70 ) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m)

69 ) => Mtl.MonadReader r (TaggedTrans (TAG_ATTACH tag) trans m)

71 where

70 where

72−

73 ask = ask @tag

71 ask = ask @tag

74− {-# INLINE ask #-}

75−

76 local = local @tag

72 local = local @tag

77− {-# INLINE local #-}

78−

79 reader = reader @tag

73 reader = reader @tag

80− {-# INLINE reader #-}

82instance {-# OVERLAPPING #-}

75instance {-# OVERLAPPING #-}

83 ( MonadState tag s m, trans ~ IdentityT

76 ( MonadState tag s m, trans ~ IdentityT

84 ) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m)

77 ) => Mtl.MonadState s (TaggedTrans (TAG_ATTACH tag) trans m)

85 where

78 where

86−

87 get = get @tag

79 get = get @tag

88− {-# INLINE get #-}

89−

90 put = put @tag

80 put = put @tag

91− {-# INLINE put #-}

92−

93 state = state @tag

81 state = state @tag

94− {-# INLINE state #-}

96instance {-# OVERLAPPING #-}

83instance {-# OVERLAPPING #-}

97 ( MonadExcept tag e m, trans ~ IdentityT

84 ( MonadExcept tag e m, trans ~ IdentityT

98 ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m)

85 ) => Mtl.MonadError e (TaggedTrans (TAG_ATTACH tag) trans m)

99 where

86 where

100−

101 throwError = throw @tag

87 throwError = throw @tag

102− {-# INLINE throwError #-}

103−

104 catchError = catch @tag

88 catchError = catch @tag

105− {-# INLINE catchError #-}

106

107instance {-# OVERLAPPING #-}

90instance {-# OVERLAPPING #-}

108 ( MonadWriter tag w m, trans ~ IdentityT

91 ( MonadWriter tag w m, trans ~ IdentityT

109 ) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m)

92 ) => Mtl.MonadWriter w (TaggedTrans (TAG_ATTACH tag) trans m)

110 where

93 where

111−

112 writer = writer @tag

94 writer = writer @tag

113− {-# INLINE writer #-}

114−

115 tell = tell @tag

95 tell = tell @tag

116− {-# INLINE tell #-}

117−

118 listen = listen @tag

96 listen = listen @tag

119− {-# INLINE listen #-}

120−

121 pass = pass @tag

97 pass = pass @tag

122− {-# INLINE pass #-}

123

124-- | Encode type-level information for 'tagReplace'.

99-- | Encode type-level information for 'tagReplace'.

125data TAG_REPLACE tOld tNew

100data TAG_REPLACE tOld tNew

@@ -129,60 +104,35 @@ type TagReplaceT tOld tNew = TaggedTrans (TAG_REPLACE tOld tNew) IdentityT

129-- | Replace a tag with another tag.

104-- | Replace a tag with another tag.

130tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a

105tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a

131tagReplace = coerce (runIdentityT @_ @m @a)

106tagReplace = coerce (runIdentityT @_ @m @a)

132−{-# INLINE tagReplace #-}

133

107

134instance

108instance

135 ( MonadReader tNew r m, trans ~ IdentityT

109 ( MonadReader tNew r m, trans ~ IdentityT

136 ) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m)

110 ) => MonadReader tOld r (TaggedTrans (TAG_REPLACE tOld tNew) trans m)

137 where

111 where

138−

139 ask = ask @tNew

112 ask = ask @tNew

140− {-# INLINE ask #-}

141−

142 local = local @tNew

113 local = local @tNew

143− {-# INLINE local #-}

144−

145 reader = reader @tNew

114 reader = reader @tNew

146− {-# INLINE reader #-}

147

115

148instance

116instance

149 ( MonadState tNew s m, trans ~ IdentityT

117 ( MonadState tNew s m, trans ~ IdentityT

150 ) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m)

118 ) => MonadState tOld s (TaggedTrans (TAG_REPLACE tOld tNew) trans m)

151 where

119 where

152−

153 get = get @tNew

120 get = get @tNew

154− {-# INLINE get #-}

155−

156 put = put @tNew

121 put = put @tNew

157− {-# INLINE put #-}

158−

159 state = state @tNew

122 state = state @tNew

160− {-# INLINE state #-}

161

123

162instance

124instance

163 ( MonadExcept tNew e m, trans ~ IdentityT

125 ( MonadExcept tNew e m, trans ~ IdentityT

164 ) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m)

126 ) => MonadExcept tOld e (TaggedTrans (TAG_REPLACE tOld tNew) trans m)

165 where

127 where

166−

167 throw = throw @tNew

128 throw = throw @tNew

168− {-# INLINE throw #-}

169−

170 catch = catch @tNew

129 catch = catch @tNew

171− {-# INLINE catch #-}

172

130

173instance

131instance

174 ( MonadWriter tNew w m, trans ~ IdentityT

132 ( MonadWriter tNew w m, trans ~ IdentityT

175 ) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m)

133 ) => MonadWriter tOld w (TaggedTrans (TAG_REPLACE tOld tNew) trans m)

176 where

134 where

177−

178 writer = writer @tNew

135 writer = writer @tNew

179− {-# INLINE writer #-}

180−

181 tell = tell @tNew

136 tell = tell @tNew

182− {-# INLINE tell #-}

183−

184 listen = listen @tNew

137 listen = listen @tNew

185− {-# INLINE listen #-}

186−

187 pass = pass @tNew

138 pass = pass @tNew

188− {-# INLINE pass #-}

src/Ether/TaggedTrans.hs+32−8

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

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 #-}

1module Ether.TaggedTrans

5module Ether.TaggedTrans

2 ( TaggedTrans(..)

6 ( TaggedTrans(..)

3 ) where

7 ) where

@@ -7,7 +11,7 @@ import Control.Monad (MonadPlus)

7import Control.Monad.Fix (MonadFix)

11import Control.Monad.Fix (MonadFix)

8import Control.Monad.Trans.Class (MonadTrans, lift)

12import Control.Monad.Trans.Class (MonadTrans, lift)

9import Control.Monad.IO.Class (MonadIO)

13import Control.Monad.IO.Class (MonadIO)

10−import Control.Monad.Morph (MFunctor, MMonad)

14+import Control.Monad.Morph (MFunctor(..), MMonad(..))

11import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)

15import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)

13import qualified Control.Monad.Base as MB

17import qualified Control.Monad.Base as MB

@@ -33,7 +37,7 @@ newtype TaggedTrans tag trans m a = TaggedTrans (trans m a)

33 deriving

37 deriving

34 ( Generic

38 ( Generic

35 , Functor, Applicative, Alternative, Monad, MonadPlus

39 , Functor, Applicative, Alternative, Monad, MonadPlus

36− , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad

40+ , MonadFix, MonadTrans, MonadIO

37 , MonadThrow, MonadCatch, MonadMask )

41 , MonadThrow, MonadCatch, MonadMask )

39type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a

43type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a

@@ -49,7 +53,6 @@ instance

49 (b a -> trans m a) ->

53 (b a -> trans m a) ->

50 (b a -> TaggedTrans tag trans m a))

54 (b a -> TaggedTrans tag trans m a))

51 MB.liftBase

55 MB.liftBase

52− {-# INLINE liftBase #-}

54instance

57instance

55 ( MC.MonadTransControl trans

58 ( MC.MonadTransControl trans

@@ -60,11 +63,9 @@ instance

60 liftWith = MC.defaultLiftWith

63 liftWith = MC.defaultLiftWith

61 (coerce :: Pack tag trans m a)

64 (coerce :: Pack tag trans m a)

62 (coerce :: Unpack tag trans m a)

65 (coerce :: Unpack tag trans m a)

63− {-# INLINE liftWith #-}

65 restoreT = MC.defaultRestoreT

67 restoreT = MC.defaultRestoreT

66 (coerce :: Pack tag trans m a)

68 (coerce :: Pack tag trans m a)

67− {-# INLINE restoreT #-}

69type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a

70type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a

@@ -75,7 +76,6 @@ coerceLiftBaseWith ::

75 LiftBaseWith b (TaggedTrans tag trans m) a

76 LiftBaseWith b (TaggedTrans tag trans m) a

76coerceLiftBaseWith lbw =

77coerceLiftBaseWith lbw =

77 unLBW (coerce (LBW lbw))

78 unLBW (coerce (LBW lbw))

78−{-# INLINE coerceLiftBaseWith #-}

80instance

81 ( MC.MonadBaseControl b (trans m)

@@ -84,14 +84,12 @@ instance

84 type StM (TaggedTrans tag trans m) a = MC.StM (trans m) a

86 liftBaseWith = coerceLiftBaseWith MC.liftBaseWith

87− {-# INLINE liftBaseWith #-}

89 restoreM =

88 restoreM =

90 (coerce :: forall a .

89 (coerce :: forall a .

91 (MC.StM (trans m) a -> trans m a) ->

90 (MC.StM (trans m) a -> trans m a) ->

92 (MC.StM (trans m) a -> TaggedTrans tag trans m a))

91 (MC.StM (trans m) a -> TaggedTrans tag trans m a))

93 MC.restoreM

92 MC.restoreM

94− {-# INLINE restoreM #-}

96type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a

94type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a

@@ -180,3 +178,29 @@ instance

180 where

178 where

181 throwError = lift . Mtl.throwError

179 throwError = lift . Mtl.throwError

182 catchError = Lift.liftCatch Mtl.catchError

180 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+105−39

@@ -17,6 +17,15 @@ module Ether.Writer

17 , writerT

18 , runWriterT

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

20 -- * MonadWriter class (implicit)

29 -- * MonadWriter class (implicit)

21 , MonadWriter'

30 , MonadWriter'

22 , writer'

31 , writer'

@@ -34,6 +43,15 @@ module Ether.Writer

34 , writerT'

43 , writerT'

35 , runWriterT'

44 , runWriterT'

36 , execWriterT'

45 , 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'

37 -- * Internal labels

55 -- * Internal labels

38 , TAGGED

56 , TAGGED

39 , WRITER

57 , WRITER

@@ -44,11 +62,12 @@ import qualified Control.Monad.Trans.Lift.Listen as Lift

44import qualified Control.Monad.Trans.Lift.Pass as Lift

62import qualified Control.Monad.Trans.Lift.Pass as Lift

45import qualified Control.Monad.Writer.Class as T

63import qualified Control.Monad.Writer.Class as T

46import qualified Control.Monad.Writer.CPS as T.CPS

64import qualified Control.Monad.Writer.CPS as T.CPS

65+import qualified Control.Monad.Writer.Lazy as T.Lazy

47import Data.Coerce

66import Data.Coerce

48import Data.Functor.Identity

67import Data.Functor.Identity

50−import Ether.TaggedTrans

51import Ether.Internal

69import Ether.Internal

70+import Ether.TaggedTrans

53class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where

72class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where

@@ -77,18 +96,10 @@ instance {-# OVERLAPPABLE #-}

77 , MonadWriter tag w m

96 , MonadWriter tag w m

78 , Monoid w

97 , Monoid w

79 ) => MonadWriter tag w (t m) where

98 ) => MonadWriter tag w (t m) where

80−

81 writer = Lift.lift . writer @tag

99 writer = Lift.lift . writer @tag

82− {-# INLINE writer #-}

83−

84 tell = Lift.lift . tell @tag

100 tell = Lift.lift . tell @tag

85− {-# INLINE tell #-}

86−

87 listen = Lift.liftListen (listen @tag)

101 listen = Lift.liftListen (listen @tag)

88− {-# INLINE listen #-}

89−

90 pass = Lift.liftPass (pass @tag)

102 pass = Lift.liftPass (pass @tag)

91− {-# INLINE pass #-}

103

93-- | Execute an action and add the result of applying the given function to

104-- | Execute an action and add the result of applying the given function to

94-- its accumulator to the value of the computation.

105-- its accumulator to the value of the computation.

@@ -106,6 +117,41 @@ censor f m = pass @tag $ do

106-- | Encode type-level information for 'WriterT'.

117-- | Encode type-level information for 'WriterT'.

107data WRITER

118data WRITER

108

119

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+

109-- | The parametrizable writer monad.

155-- | The parametrizable writer monad.

110--

156--

111-- Computations can accumulate a monoid value.

157-- Computations can accumulate a monoid value.

@@ -144,42 +190,43 @@ execWriterT = coerce (T.CPS.execWriterT @m @w @a)

144execWriter :: forall tag w a . Monoid w => Writer tag w a -> w

190execWriter :: forall tag w a . Monoid w => Writer tag w a -> w

145execWriter = coerce (T.CPS.execWriter @w @a)

191execWriter = coerce (T.CPS.execWriter @w @a)

146

192

147−type instance HandleSuper WRITER w trans = Monoid w

193+-- | The parametrizable writer monad.

148−type instance HandleConstraint WRITER w trans m =

194+--

149− T.MonadWriter w (trans m)

195+-- Computations can accumulate a monoid value.

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

150

200

151−instance Monoid w => Handle WRITER w (T.CPS.WriterT w) where

201+-- | The writer monad transformer.

152− handling r = r

202+--

153− {-# INLINE handling #-}

203+-- The 'return' function produces the output 'mempty', while '>>=' combines

204+-- the outputs of the subcomputations using 'mappend'.

205+type LazyWriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.Lazy.WriterT w)

154

206

155−instance

207+-- | Constructor for computations in the writer monad transformer.

156− ( Handle WRITER w trans

208+lazyWriterT :: forall tag w m a . m (a, w) -> LazyWriterT tag w m a

157− , Monad m, Monad (trans m)

209+lazyWriterT = coerce (T.Lazy.WriterT @w @m @a)

158− ) => MonadWriter tag w (TaggedTrans (TAGGED WRITER tag) trans m)

159− where

160

210

161− writer =

211+-- | Runs a 'WriterT' and returns both the normal value

162− handling @WRITER @w @trans @m $

212+-- and the final accumulator.

163− coerce (T.writer @w @(trans m) @a) ::

213+runLazyWriterT :: forall tag w m a . LazyWriterT tag w m a -> m (a, w)

164− forall eff a . (a, w) -> TaggedTrans eff trans m a

214+runLazyWriterT = coerce (T.Lazy.runWriterT @w @m @a)

165− {-# INLINE writer #-}

166

215

167− tell =

216+-- | Runs a 'Writer' and returns both the normal value

168− handling @WRITER @w @trans @m $

217+-- and the final accumulator.

169− coerce (T.tell @w @(trans m))

218+runLazyWriter :: forall tag w a . LazyWriter tag w a -> (a, w)

170− {-# INLINE tell #-}

219+runLazyWriter = coerce (T.Lazy.runWriter @w @a)

171

220

172− listen =

221+-- | Runs a 'WriterT' and returns the final accumulator,

173− handling @WRITER @w @trans @m $

222+-- discarding the normal value.

174− coerce (T.listen @w @(trans m) @a) ::

223+execLazyWriterT :: forall tag w m a . Monad m => LazyWriterT tag w m a -> m w

175− forall eff a . Listen w (TaggedTrans eff trans m) a

224+execLazyWriterT = coerce (T.Lazy.execWriterT @m @w @a)

176− {-# INLINE listen #-}

177

225

178− pass =

226+-- | Runs a 'Writer' and returns the final accumulator,

179− handling @WRITER @w @trans @m $

227+-- discarding the normal value.

180− coerce (T.pass @w @(trans m) @a) ::

228+execLazyWriter :: forall tag w a . LazyWriter tag w a -> w

181− forall eff a . Pass w (TaggedTrans eff trans m) a

229+execLazyWriter = coerce (T.Lazy.execWriter @w @a)

182− {-# INLINE pass #-}

183

230

184type Writer' w = Writer w w

231type Writer' w = Writer w w

185

232

@@ -200,6 +247,25 @@ runWriterT' = runWriterT

200execWriterT' :: (Monad m, Monoid w) => WriterT' w m a -> m w

247execWriterT' :: (Monad m, Monoid w) => WriterT' w m a -> m w

201execWriterT' = execWriterT

248execWriterT' = execWriterT

202

249

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+

203type MonadWriter' w = MonadWriter w w

269type MonadWriter' w = MonadWriter w w

204

270

205writer' :: forall w m a . MonadWriter' w m => (a, w) -> m a

271writer' :: forall w m a . MonadWriter' w m => (a, w) -> m a

stack.yamldeleted−8

@@ -1,8 +0,0 @@

1−resolver: lts-8.12

2−packages: ['.']

3−

4−extra-deps:

5−- transformers-0.5.4.0

6−- transformers-lift-0.2.0.0

7−- writer-cps-transformers-0.1.1.3

8−- writer-cps-mtl-0.1.1.4

test/Regression/T1.hs+1

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

1module Regression.T1 (test1) where

3import Ether

4+import TupleInstances ()

4import Data.List (group)

5import Data.List (group)

6import Test.Tasty

7import Test.Tasty

test/TupleInstances.hsnew file+9

@@ -0,0 +1,9 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+{-# LANGUAGE CPP #-}

4+module TupleInstances () where

6+#ifdef DISABLE_TUP_INSTANCES

7+import Ether.Internal (makeTupleInstancesHasLens)

8+makeTupleInstancesHasLens [2]

9+#endif