a40e519...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+47−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,14 +46,22 @@ 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.4.2,

58+ transformers >=0.5.2.0,

42− transformers-lift >=0.1.0.1,

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,

64+ writer-cps-mtl >= 0.1.1.4,

47 exceptions >=0.8,

65 exceptions >=0.8,

48 template-haskell >=2.11,

66 template-haskell >=2.11,

49 tagged >=0.8.5,

67 tagged >=0.8.5,

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

83 ghc-options:

101 ghc-options:

84 -Wall -O2

102 -Wall -O2

103

104+ if flag(disable-tup-instances)

105+ cpp-options: -DDISABLE_TUP_INSTANCES

106+

86test-suite regression

107test-suite regression

108

88 build-depends:

109 build-depends:

89− base >=4.9 && <4.11,

110+ base >=4.9 && <4.13,

90 transformers >=0.4.2,

111 transformers >=0.4.2,

91 mtl >=2.2.1,

112 mtl >=2.2.1,

92 tasty >=0.10,

113 tasty >=0.10,

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

100 Regression.hs

121 Regression.hs

101

122

102 other-modules:

123 other-modules:

124+ TupleInstances

103 Regression.T1

125 Regression.T1

104 Regression.T2

126 Regression.T2

105 Regression.T3

127 Regression.T3

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

150 ghc-options:

172 ghc-options:

151 -Wall -fno-warn-missing-signatures

173 -Wall -fno-warn-missing-signatures

152

174

175+ if flag(disable-tup-instances)

176+ cpp-options: -DDISABLE_TUP_INSTANCES

177+

153

178

154benchmark bench

179benchmark bench

155

180

156 build-depends:

181 build-depends:

157− base >=4.9 && <4.11,

182+ base >=4.9 && <4.13,

158 mtl >=2.2.1,

183 mtl >=2.2.1,

159 transformers >=0.4.2,

184 transformers >=0.4.2,

160 criterion >=1.1,

185 criterion >=1.1,

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

165 main-is:

190 main-is:

166 Bench.hs

191 Bench.hs

167

192

193+ other-modules:

194+ TupleInstances

195+

168 type:

196 type:

169 exitcode-stdio-1.0

197 exitcode-stdio-1.0

170

198

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

204

232

205 ghc-prof-options:

233 ghc-prof-options:

206 -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+10−115

@@ -6,6 +6,8 @@ module Ether.Internal

6 , LensLike

7 , Lens

8 , Lens'

9+ , ReifiedLens(..)

10+ , ReifiedLens'

9 , view

11 , view

10 , over

12 , over

11 , HList(..)

13 , HList(..)

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

14 , HandleSuper

16 , HandleSuper

15 , HandleConstraint

17 , HandleConstraint

16 , Handle(..)

18 , Handle(..)

19+ , makeTupleInstancesHasLens

17 ) where

20 ) where

19import Control.Applicative

22import Control.Applicative

20−import Control.Monad

21import Data.Coerce

23import Data.Coerce

22import Data.Functor.Identity

24import Data.Functor.Identity

23import Data.Kind

25import Data.Kind

24−import Data.List as List

25import Data.Tagged

26import Data.Tagged

26−import Data.Traversable

27import GHC.Exts (Constraint)

28−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 ()

30data TAGGED e t

34data TAGGED e t

@@ -53,121 +57,12 @@ class

53 where

57 where

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

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

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

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

57−

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

59−

60−type Lens' s a = Lens s s a a

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

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

63− lensOf :: Lens' outer inner

64−

65−instance HasLens a a a where

66− lensOf = id

67− {-# INLINE lensOf #-}

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

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

70view l = coerce (l Const)

65view l = coerce (l Const)

71−{-# INLINE view #-}

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

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

74over = coerce

68over = coerce

75−{-# INLINE over #-}

76−

77−data HList xs where

78− HNil :: HList '[]

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

80−

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

82−

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

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

85−

86−return []

87−

88−type instance TagsK () = '[]

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

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

91−

92−return []

93−

94−type instance Tags () = 'HNil

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

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

97−

98−do

99− let

100− tupCount = 62

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

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

103− fmap List.concat $

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

105− \varNames' -> do

106− let n = List.length varNames'

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

108− tag <- TH.newName "tag"

109− let

110− (cur:rest) = varNames'

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

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

113− map TH.VarT rest )

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

115− (map TH.VarT rest)

116− return $

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

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

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

120− return tagsInstances

121−do

122− let

123− tupCount = 62

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

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

126− fmap List.concat $

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

128− \varNames' -> do

129− let n = List.length varNames'

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

131− tag <- TH.newName "tag"

132− let

133− (cur:rest) = varNames'

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

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

136− map TH.VarT rest )

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

138− (map TH.VarT rest)

139− tagsInst =

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

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

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

143− return tagsInst

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

145− tag <- TH.newName "tag"

146− let

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

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

149− ( map TH.VarT prev ++

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

151− map TH.VarT next )

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

153− f <- TH.newName "f"

154− return $

155− TH.InstanceD Nothing []

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

157− [ TH.FunD 'lensOf

158− [ TH.Clause

159− [TH.VarP f, TH.TupP

160− ( map TH.VarP prev ++

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

162− map TH.VarP next )]

163− (TH.NormalB $

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

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

166− (TH.TupE

167− ( map TH.VarE prev ++

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

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

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

171− [] ],

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

173− return $ tagsInstances ++ hasLensInstances

src/Ether/Internal/HasLens.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−64

@@ -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,107 +316,82 @@ 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

446

392

447type ZoomT t (z :: Type) = TaggedTrans (ZOOM t z) IdentityT

393type ZoomT t (z :: Type) = TaggedTrans (ZOOM t z) IdentityT

448

394

449−newtype ReifiedLens s t a b = Lens (Lens s t a b)

450−

451−type ReifiedLens' s a = ReifiedLens s s a a

452−

453-- | Zoom into a part of a state using a lens.

395-- | Zoom into a part of a state using a lens.

454zoom

396zoom

455 :: forall tag sOuter sInner m a

397 :: forall tag sOuter sInner m a

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

457 -> (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)

458 -> m a

400 -> m a

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

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

460−{-# INLINE zoom #-}

461

402

462instance

403instance

463 ( MonadState tag sOuter m

404 ( MonadState tag sOuter m

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

472 (state @tag . l)

413 (state @tag . l)

473 where

414 where

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

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

475− {-# 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+123−56

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

@@ -42,12 +60,14 @@ module Ether.Writer

42import Control.Monad.Signatures (Listen, Pass)

60import Control.Monad.Signatures (Listen, Pass)

43import qualified Control.Monad.Trans.Lift.Listen as Lift

61import 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

45−import qualified Control.Monad.Writer as T

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

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

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

46import Data.Coerce

66import Data.Coerce

47import Data.Functor.Identity

67import Data.Functor.Identity

49−import Ether.TaggedTrans

50import Ether.Internal

69import Ether.Internal

70+import Ether.TaggedTrans

52class (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

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

76 , MonadWriter tag w m

96 , MonadWriter tag w m

77 , Monoid w

97 , Monoid w

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

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

79−

80 writer = Lift.lift . writer @tag

99 writer = Lift.lift . writer @tag

81− {-# INLINE writer #-}

82−

83 tell = Lift.lift . tell @tag

100 tell = Lift.lift . tell @tag

84− {-# INLINE tell #-}

85−

86 listen = Lift.liftListen (listen @tag)

101 listen = Lift.liftListen (listen @tag)

87− {-# INLINE listen #-}

88−

89 pass = Lift.liftPass (pass @tag)

102 pass = Lift.liftPass (pass @tag)

90− {-# INLINE pass #-}

103

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

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

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

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

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

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

106data WRITER

118data WRITER

107

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+

108-- | The parametrizable writer monad.

155-- | The parametrizable writer monad.

109--

156--

110-- Computations can accumulate a monoid value.

157-- Computations can accumulate a monoid value.

@@ -117,88 +164,108 @@ type Writer tag w = WriterT tag w Identity

117--

164--

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

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

119-- the outputs of the subcomputations using 'mappend'.

166-- the outputs of the subcomputations using 'mappend'.

120−type WriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.WriterT w)

167+type WriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.CPS.WriterT w)

121

168

122-- | Constructor for computations in the writer monad transformer.

169-- | Constructor for computations in the writer monad transformer.

123−writerT :: forall tag w m a . m (a, w) -> WriterT tag w m a

170+writerT :: forall tag w m a . (Functor m, Monoid w) => m (a, w) -> WriterT tag w m a

124−writerT = coerce (T.WriterT @w @m @a)

171+writerT = coerce (T.CPS.writerT @m @w @a)

125

172

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

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

127-- and the final accumulator.

174-- and the final accumulator.

128−runWriterT :: forall tag w m a . WriterT tag w m a -> m (a, w)

175+runWriterT :: forall tag w m a . Monoid w => WriterT tag w m a -> m (a, w)

129−runWriterT = coerce (T.runWriterT @w @m @a)

176+runWriterT = coerce (T.CPS.runWriterT @w @m @a)

130

177

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

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

132-- and the final accumulator.

179-- and the final accumulator.

133−runWriter :: forall tag w a . Writer tag w a -> (a, w)

180+runWriter :: forall tag w a . Monoid w => Writer tag w a -> (a, w)

134−runWriter = coerce (T.runWriter @w @a)

181+runWriter = coerce (T.CPS.runWriter @w @a)

135

182

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

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

137-- discarding the normal value.

184-- discarding the normal value.

138−execWriterT :: forall tag w m a . Monad m => WriterT tag w m a -> m w

185+execWriterT :: forall tag w m a . (Monad m, Monoid w) => WriterT tag w m a -> m w

139−execWriterT = coerce (T.execWriterT @m @w @a)

186+execWriterT = coerce (T.CPS.execWriterT @m @w @a)

140

187

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

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

142-- discarding the normal value.

189-- discarding the normal value.

143−execWriter :: forall tag w a . Writer tag w a -> w

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

144−execWriter = coerce (T.execWriter @w @a)

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

145

192

146−type instance HandleSuper WRITER w trans = Monoid w

193+-- | The parametrizable writer monad.

147−type instance HandleConstraint WRITER w trans m =

194+--

148− 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

149

200

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

201+-- | The writer monad transformer.

151− handling r = r

202+--

152− {-# 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)

153

206

154−instance

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

155− ( Handle WRITER w trans

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

156− , Monad m, Monad (trans m)

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

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

158− where

159

210

160− writer =

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

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

212+-- and the final accumulator.

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

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

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

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

164− {-# INLINE writer #-}

165

215

166− tell =

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

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

217+-- and the final accumulator.

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

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

169− {-# INLINE tell #-}

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

170

220

171− listen =

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

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

222+-- discarding the normal value.

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

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

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

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

175− {-# INLINE listen #-}

176

225

177− pass =

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

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

227+-- discarding the normal value.

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

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

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

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

181− {-# INLINE pass #-}

182

230

183type Writer' w = Writer w w

231type Writer' w = Writer w w

184

232

185−runWriter' :: Writer' w a -> (a, w)

233+runWriter' :: Monoid w => Writer' w a -> (a, w)

186runWriter' = runWriter

234runWriter' = runWriter

187

235

188−execWriter' :: Writer' w a -> w

236+execWriter' :: Monoid w => Writer' w a -> w

189execWriter' = execWriter

237execWriter' = execWriter

190

238

191type WriterT' w = WriterT w w

239type WriterT' w = WriterT w w

192

240

193−writerT' :: m (a, w) -> WriterT' w m a

241+writerT' :: (Functor m, Monoid w) => m (a, w) -> WriterT' w m a

194writerT' = writerT

242writerT' = writerT

195

243

196−runWriterT' :: WriterT' w m a -> m (a, w)

244+runWriterT' :: Monoid w => WriterT' w m a -> m (a, w)

197runWriterT' = runWriterT

245runWriterT' = runWriterT

198

246

199−execWriterT' :: Monad m => WriterT' w m a -> m w

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

200execWriterT' = execWriterT

248execWriterT' = execWriterT

201

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+

202type MonadWriter' w = MonadWriter w w

269type MonadWriter' w = MonadWriter w w

203

270

204writer' :: 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−2

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

1−resolver: lts-8.12

2−packages: ['.']

test/Regression/T1.hs+14−2

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

1module Regression.T1 (test1) where

3import Ether

4+import TupleInstances ()

5+import Data.List (group)

5import Test.Tasty

7import Test.Tasty

6import Test.Tasty.QuickCheck

8import Test.Tasty.QuickCheck

@@ -23,6 +25,10 @@ testEther = do

24runner1 s1 s2 = flip (runReader @Tag1) s1 . flip (runReaderT @Tag2) s2

26runner1 s1 s2 = flip (runReader @Tag1) s1 . flip (runReaderT @Tag2) s2

25runner2 s1 s2 = flip (runReader @Tag2) s2 . flip (runReaderT @Tag1) s1

27runner2 s1 s2 = flip (runReader @Tag2) s2 . flip (runReaderT @Tag1) s1

28+runner3 s1 s2 = flip runReaders (Tagged @Tag1 s1, Tagged @Tag2 s2)

29+

30+same :: Eq a => [a] -> Bool

31+same = (<=1) . length . group

27test1 :: TestTree

33test1 :: TestTree

28test1 = testGroup "T1: Reader local environment"

34test1 = testGroup "T1: Reader local environment"

@@ -32,7 +38,13 @@ test1 = testGroup "T1: Reader local environment"

32 , testProperty "runner₂ works"

38 , testProperty "runner₂ works"

33 $ \s1 s2 -> property

39 $ \s1 s2 -> property

34 $ runner2 s1 s2 testEther == ((s1, s2), (s1, map succ s2))

40 $ runner2 s1 s2 testEther == ((s1, s2), (s1, map succ s2))

41+ , testProperty "runner₃ works"

42+ $ \s1 s2 -> property

43+ $ runner3 s1 s2 testEther == ((s1, s2), (s1, map succ s2))

35− , testProperty "runner₁ == runner₂"

44+ , testProperty "runner₁ == runner₂ == runner₃"

36 $ \s1 s2 -> property

45 $ \s1 s2 -> property

46+ $ same

37− $ runner1 s1 s2 testEther == runner2 s1 s2 testEther

47+ [ runner1 s1 s2 testEther

48+ , runner2 s1 s2 testEther

49+ , runner3 s1 s2 testEther ]

38 ]

50 ]

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