master..b40212a · typeable/ether

git.iko.soy/typeable/ether

on b40212a help sign in

.gitignore+2−17

since splitsnapshots

unifiedsplit

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

1−# Cabal

1+tags

2dist

3dist-newstyle

4+.stack-work

4.cabal-sandbox/

5.cabal-sandbox/

5cabal.sandbox.config

6cabal.sandbox.config

6−cabal.project.local

7−.ghc.environment*

8−

9−# Profiling

10−*.prof

11−

12−# Stack

13−.stack-work

14−

15−# Emacs

16−TAGS

17−.dir-locals.el

18−

19−# Vim

20−tags

21−*.swp

.travis.yml+18−25

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

1−language: nix

1+sudo: false

3−os:

3+cache:

4− - linux

4+ directories:

5− - osx

5+ - $HOME/.stack/

6−

7−env:

8− - HC=ghc822

9− - HC=ghc844

10− - HC=ghc861

12before_install:

7before_install:

13− - curl https://raw.githubusercontent.com/monadfix/nix-cabal/master/nix-cabal -o nix-cabal && chmod u+x nix-cabal

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

14− - travis_retry ./nix-cabal new-update

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

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

11+ - stack --version

12+ - stack setup

16−script:

14+install:

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

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

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

20−cache:

17+script:

21− directories:

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

22− - ~/.cabal

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

23− - ~/.ghc

25−matrix:

21+addons:

26− # broken at the moment

22+ apt:

27− exclude:

23+ packages:

28− - os: osx

24+ - libgmp-dev

29− env: HC=ghc822

30− - os: osx

31− env: HC=ghc861

CHANGELOG.md−5

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

1−0.5.1.0

2−-------

3−

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

5−

60.5.0.0

10.5.0.0

7-------

2-------

README.md+16

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

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)

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

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

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

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

9monad transformers and classes in a compatible way.

10monad transformers and classes in a compatible way.

11+

12+## Installation

13+

14+You can install `ether 0.4.0.0`

15+

16+1. using Cabal, from Hackage;

17+2. using Stack, from Stackage;

18+3. using Portage, from Gentoo Haskell Overlay.

19+

20+If unsure, use [Stack](https://github.com/commercialhaskell/stack).

21+

22+## Getting Started

23+

24+To get started, read the introduction on the [homepage](https://int-index.github.io/ether/).

25+If you need help with Ether or if you have any questions about it, ask me in the Gitter chat.

bench/Bench.hs−1

@@ -8,7 +8,6 @@ import qualified Control.Monad.Reader as M

8import qualified Control.Monad.State as M

9import Criterion.Main

10import Ether

11−import TupleInstances ()

13id' :: a -> a

12id' :: a -> a

14id' = id

13id' = id

bench/TupleInstances.hsdeleted−9

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

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

2−{-# LANGUAGE CPP #-}

3−

4−module TupleInstances () where

5−

6−#ifdef DISABLE_TUP_INSTANCES

7−import Ether.Internal (makeTupleInstancesHasLens)

8−makeTupleInstancesHasLens [4,5,9]

9−#endif

ether.cabal+14−44

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

1−cabal-version: 2.2

2name: ether

1name: ether

3−version: 0.5.2.0

2+version: 0.5.0.0

4synopsis: Monad transformers and classes

3synopsis: Monad transformers and classes

5−description: Lib

4+description:

6−license: BSD-3-Clause

5+ Ether is a Haskell library that extends @mtl@ and @transformers@ with

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

6+ tagged monad transformers and classes in a compatible way.

8−license-file: LICENSE

8+ Introduction <https://int-index.github.io/ether/>

9category: Control

10category: Control

11+license: BSD3

12+license-file: LICENSE

10author: Vladislav Zavialov

13author: Vladislav Zavialov

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

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

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

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

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

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

14build-type: Simple

17build-type: Simple

18+cabal-version: >=1.18

15extra-source-files: CHANGELOG.md

19extra-source-files: CHANGELOG.md

17source-repository head

21source-repository head

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

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

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

23−flag disable-tup-instances

24−

25− description:

26− Disable auto-generated 'HasLens' instances for tuples. The reason one

27− might want to do this is to reduce the size of .hi-files, as well as the

28− time and memory GHC needs to build Ether. To recover flattening with

29− tuples, use 'Ether.Internal.makeTupleInstancesHasLens' at specific tuple

30− sizes you need in your application.

31−

32− This is a build-time performance hack, enable this flag at your own risk.

33−

34− default: False

35− manual: True

36−

37library

27library

39 exposed-modules:

29 exposed-modules:

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

46 Ether.TagDispatch

36 Ether.TagDispatch

47 Ether.Internal

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

56 build-depends:

39 build-depends:

57− base >=4.9 && <4.13,

40+ base >=4.9 && <4.11,

58 transformers >=0.5.2.0,

41 transformers >=0.5.2.0,

59 transformers-lift >=0.2.0.1,

42 transformers-lift >=0.2.0.1,

60− mtl >=2.2.2,

43+ mtl >=2.2.1,

61 mmorph >=1.0.4,

44 mmorph >=1.0.4,

62 monad-control >=1.0.0.4,

45 monad-control >=1.0.0.4,

63 transformers-base >=0.4.4,

46 transformers-base >=0.4.4,

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

101 ghc-options:

84 ghc-options:

102 -Wall -O2

85 -Wall -O2

103

104− if flag(disable-tup-instances)

105− cpp-options: -DDISABLE_TUP_INSTANCES

106−

107test-suite regression

87test-suite regression

108

109 build-depends:

89 build-depends:

110− base >=4.9 && <4.13,

90+ base >=4.9 && <4.11,

111 transformers >=0.4.2,

91 transformers >=0.4.2,

112 mtl >=2.2.1,

92 mtl >=2.2.1,

113 tasty >=0.10,

93 tasty >=0.10,

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

121 Regression.hs

101 Regression.hs

122

102

123 other-modules:

103 other-modules:

124− TupleInstances

125 Regression.T1

104 Regression.T1

126 Regression.T2

105 Regression.T2

127 Regression.T3

106 Regression.T3

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

172 ghc-options:

151 ghc-options:

173 -Wall -fno-warn-missing-signatures

152 -Wall -fno-warn-missing-signatures

174

153

175− if flag(disable-tup-instances)

176− cpp-options: -DDISABLE_TUP_INSTANCES

177−

178

154

179benchmark bench

155benchmark bench

180

156

181 build-depends:

157 build-depends:

182− base >=4.9 && <4.13,

158+ base >=4.9 && <4.11,

183 mtl >=2.2.1,

159 mtl >=2.2.1,

184 transformers >=0.4.2,

160 transformers >=0.4.2,

185 criterion >=1.1,

161 criterion >=1.1,

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

190 main-is:

166 main-is:

191 Bench.hs

167 Bench.hs

192

168

193− other-modules:

194− TupleInstances

195−

196 type:

169 type:

197 exitcode-stdio-1.0

170 exitcode-stdio-1.0

198

171

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

232

205

233 ghc-prof-options:

206 ghc-prof-options:

234 -fprof-auto

207 -fprof-auto

235−

236− if flag(disable-tup-instances)

237− cpp-options: -DDISABLE_TUP_INSTANCES

shell.nixdeleted−22

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

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

2− hc ? "ghc844"

3−}:

4−

5−pkgs.stdenv.mkDerivation rec {

6− name = "ether";

7− buildInputs = [

8− pkgs.haskell.compiler.${hc}

9− pkgs.git

10− pkgs.zlib

11− pkgs.cabal-install

12− pkgs.pkgconfig

13− ];

14− shellHook = ''

15− export LD_LIBRARY_PATH=${pkgs.lib.makeLibraryPath buildInputs}:$LD_LIBRARY_PATH

16− export LANG=en_US.UTF-8

17− '';

18− LOCALE_ARCHIVE =

19− if pkgs.stdenv.isLinux

20− then "${pkgs.glibcLocales}/lib/locale/locale-archive"

21− else "";

22−}

src/Ether/Except.hs+15−1

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

50 , Monad (t m)

51 , MonadExcept tag e m

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

53+

53 throw = Lift.lift . throw @tag

54 throw = Lift.lift . throw @tag

55+ {-# INLINE throw #-}

56+

54 catch = Lift.liftCatch (catch @tag)

57 catch = Lift.liftCatch (catch @tag)

58+ {-# INLINE catch #-}

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

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

57data EXCEPT

61data EXCEPT

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

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

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

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

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

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

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

80+{-# INLINE runExcept #-}

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

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

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

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

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

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

85+{-# INLINE runExceptT #-}

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

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

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

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

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

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

90+{-# INLINE exceptT #-}

85type instance HandleSuper EXCEPT e trans = ()

92type instance HandleSuper EXCEPT e trans = ()

86type instance HandleConstraint EXCEPT e trans m =

93type instance HandleConstraint EXCEPT e trans m =

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

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

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

90 handling r = r

97 handling r = r

98+ {-# INLINE handling #-}

92instance

100instance

93 ( Handle EXCEPT e trans

101 ( Handle EXCEPT e trans

94 , Monad m, Monad (trans m)

102 , Monad m, Monad (trans m)

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

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

96 where

104 where

97−

98 throw =

105 throw =

99 handling @EXCEPT @e @trans @m $

106 handling @EXCEPT @e @trans @m $

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

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

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

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

109+ {-# INLINE throw #-}

102

110

103 catch =

111 catch =

104 handling @EXCEPT @e @trans @m $

112 handling @EXCEPT @e @trans @m $

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

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

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

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

115+ {-# INLINE catch #-}

107

116

108type MonadExcept' e = MonadExcept e e

117type MonadExcept' e = MonadExcept e e

109

118

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

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

111throw' = throw @e

120throw' = throw @e

121+{-# INLINE throw' #-}

112

122

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

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

114catch' = catch @e

124catch' = catch @e

125+{-# INLINE catch' #-}

115

126

116type Except' e = Except e e

127type Except' e = Except e e

117

128

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

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

119runExcept' = runExcept

130runExcept' = runExcept

131+{-# INLINE runExcept' #-}

120

132

121type ExceptT' e = ExceptT e e

133type ExceptT' e = ExceptT e e

122

134

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

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

124exceptT' = exceptT

136exceptT' = exceptT

137+{-# INLINE exceptT' #-}

125

138

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

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

127runExceptT' = runExceptT

140runExceptT' = runExceptT

141+{-# INLINE runExceptT' #-}

src/Ether/Internal.hs+115−6

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

16 , HandleSuper

17 , HandleConstraint

18 , Handle(..)

19− , makeTupleInstancesHasLens

20 ) where

19 ) where

22import Control.Applicative

21import Control.Applicative

23import Data.Coerce

22import Data.Coerce

24import Data.Functor.Identity

23import Data.Functor.Identity

25import Data.Kind

24import Data.Kind

25+import Data.List as List

26import Data.Tagged

27+import Data.Traversable

27import GHC.Exts (Constraint)

28import GHC.Exts (Constraint)

28−

29+import qualified Language.Haskell.TH as TH

29−import Ether.Internal.HasLens

30−import Ether.Internal.Tags

31−import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

32−import Ether.Internal.TupleInstances ()

34data TAGGED e t

31data TAGGED e t

@@ -57,12 +54,124 @@ class

57 where

54 where

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

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

57+type LensLike f s t a b = (a -> f b) -> s -> f t

58+

59+type Lens s t a b = forall f. Functor f => LensLike f s t a b

60+

61+type Lens' s a = Lens s s a a

62+

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

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

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

65type ReifiedLens' s a = ReifiedLens s s a a

67+class HasLens tag outer inner | tag outer -> inner where

68+ lensOf :: Lens' outer inner

69+

70+instance HasLens a a a where

71+ lensOf = id

72+ {-# INLINE lensOf #-}

73+

74+instance HasLens t (Tagged t a) a where

75+ lensOf = \f -> fmap coerce . f . coerce

76+

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

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

65view l = coerce (l Const)

78view l = coerce (l Const)

79+{-# INLINE view #-}

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

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

68over = coerce

82over = coerce

83+{-# INLINE over #-}

84+

85+data HList xs where

86+ HNil :: HList '[]

87+ HCons :: x -> HList xs -> HList (x ': xs)

88+

89+type KindOf (a :: k) = k

90+

91+type family TagsK (p :: Type) :: [Type]

92+type family Tags (p :: Type) :: HList (TagsK p)

93+

94+return []

95+

96+type instance TagsK () = '[]

97+type instance TagsK (Tagged t a) = '[KindOf t]

98+

99+do

100+ let

101+ tupCount = 62

102+ varName k = TH.mkName ('a' : show k)

103+ tagName k = TH.mkName ('t' : show k)

104+ for [2..tupCount] $ \n -> do

105+ let

106+ tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $

107+ (\k -> TH.ConT ''Tagged `TH.AppT`

108+ TH.VarT (tagName k) `TH.AppT`

109+ TH.VarT (varName k)) <$> [0..n-1]

110+ tagsList = List.foldr

111+ (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)

112+ TH.PromotedNilT

113+ (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1])

114+ return $

115+ TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)

116+

117+return []

118+

119+type instance Tags () = 'HNil

120+type instance Tags (Tagged t a) = 'HCons t 'HNil

121+

122+do

123+ let

124+ tupCount = 62

125+ varName k = TH.mkName ('a' : show k)

126+ tagName k = TH.mkName ('t' : show k)

127+ for [2..tupCount] $ \n -> do

128+ let

129+ tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $

130+ (\k -> TH.ConT ''Tagged `TH.AppT`

131+ TH.VarT (tagName k) `TH.AppT`

132+ TH.VarT (varName k)) <$> [0..n-1]

133+ tagsList = List.foldr

134+ (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)

135+ (TH.PromotedT 'HNil)

136+ (TH.VarT . tagName <$> [0..n-1])

137+ return $

138+ TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)

139+

140+do

141+ let

142+ tupCount = 62

143+ varName k = TH.mkName ('a' : show k)

144+ fmap List.concat $

145+ for [2..tupCount] $ \n ->

146+ for [0..n-1] $ \k -> do

147+ let

148+ tag = TH.mkName "tag"

149+ prev = varName <$> [0..k-1]

150+ cur = varName k

151+ next = varName <$> [k+1..n-1]

152+ tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))

153+ ( map TH.VarT prev ++

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

155+ map TH.VarT next )

156+ let

157+ cur' = TH.mkName "x"

158+ f = TH.mkName "f"

159+ return $

160+ TH.InstanceD Nothing []

161+ (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)

162+ [ TH.FunD 'lensOf

163+ [ TH.Clause

164+ [TH.VarP f, TH.TupP

165+ ( map TH.VarP prev ++

166+ [TH.ConP 'Tagged [TH.VarP cur]] ++

167+ map TH.VarP next )]

168+ (TH.NormalB $

169+ TH.VarE 'fmap `TH.AppE`

170+ (TH.LamE [TH.VarP cur']

171+ (TH.TupE

172+ ( map TH.VarE prev ++

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

174+ map TH.VarE next ))) `TH.AppE`

175+ (TH.VarE f `TH.AppE` TH.VarE cur) )

176+ [] ],

177+ TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]

src/Ether/Internal/HasLens.hsdeleted−24

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

1−module Ether.Internal.HasLens

2− ( LensLike

3− , Lens

4− , Lens'

5− , HasLens(..)

6− ) where

7−

8−import Data.Tagged

9−import Data.Coerce

10−

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

12−

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

14−

15−type Lens' s a = Lens s s a a

16−

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

18− lensOf :: Lens' outer inner

19−

20−instance HasLens a a a where

21− lensOf = id

22−

23−instance HasLens t (Tagged t a) a where

24− lensOf = \f -> fmap coerce . f . coerce

src/Ether/Internal/TH_TupleInstances.hsdeleted−79

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

1−module Ether.Internal.TH_TupleInstances

2− ( makeTupleInstancesTagsK

3− , makeTupleInstancesTags

4− , makeTupleInstancesHasLens

5− ) where

6−

7−import Data.Tagged

8−import Data.Traversable

9−import Data.List as List

10−import qualified Language.Haskell.TH as TH

11−

12−import Ether.Internal.HasLens

13−import Ether.Internal.Tags

14−import Ether.Internal.TH_Utils

15−

16−makeTupleInstancesTagsK :: TH.DecsQ

17−makeTupleInstancesTagsK = do

18− for [2..tupCount] $ \n -> do

19− let

20− tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $

21− (\k -> TH.ConT ''Tagged `TH.AppT`

22− TH.VarT (tagName k) `TH.AppT`

23− TH.VarT (varName k)) <$> [0..n-1]

24− tagsList = List.foldr

25− (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)

26− TH.PromotedNilT

27− (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1])

28− return $

29− TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)

30−

31−makeTupleInstancesTags :: TH.DecsQ

32−makeTupleInstancesTags = do

33− for [2..tupCount] $ \n -> do

34− let

35− tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $

36− (\k -> TH.ConT ''Tagged `TH.AppT`

37− TH.VarT (tagName k) `TH.AppT`

38− TH.VarT (varName k)) <$> [0..n-1]

39− tagsList = List.foldr

40− (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)

41− (TH.PromotedT 'HNil)

42− (TH.VarT . tagName <$> [0..n-1])

43− return $

44− TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)

45−

46−makeTupleInstancesHasLens :: [Int] -> TH.DecsQ

47−makeTupleInstancesHasLens range = List.concat <$> do

48− for range $ \n ->

49− for [0..n-1] $ \k -> do

50− let

51− tag = TH.mkName "tag"

52− prev = varName <$> [0..k-1]

53− cur = varName k

54− next = varName <$> [k+1..n-1]

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

56− ( map TH.VarT prev ++

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

58− map TH.VarT next )

59− let

60− cur' = TH.mkName "x"

61− f = TH.mkName "f"

62− return $

63− TH.InstanceD Nothing []

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

65− [ TH.FunD 'lensOf

66− [ TH.Clause

67− [TH.VarP f, TH.TupP

68− ( map TH.VarP prev ++

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

70− map TH.VarP next )]

71− (TH.NormalB $

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

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

74− (TH.TupE

75− ( map TH.VarE prev ++

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

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

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

79− [] ] ]

src/Ether/Internal/TH_Utils.hsdeleted−14

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

1−module Ether.Internal.TH_Utils

2− ( tupCount

3− , varName

4− , tagName

5− ) where

6−

7−import qualified Language.Haskell.TH as TH

8−

9−tupCount :: Int

10−tupCount = 62

11−

12−varName, tagName :: Int -> TH.Name

13−varName k = TH.mkName ('a' : show k)

14−tagName k = TH.mkName ('t' : show k)

src/Ether/Internal/Tags.hsdeleted−18

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

1−module Ether.Internal.Tags

2− ( Tags

3− , TagsK

4− , HList(..)

5− , KindOf

6− ) where

7−

8−import Data.Kind

9−

10−data HList xs where

11− HNil :: HList '[]

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

13−

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

15−

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

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

18−

src/Ether/Internal/TupleInstances.hsdeleted−24

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

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

2−{-# LANGUAGE CPP #-}

3−

4−module Ether.Internal.TupleInstances () where

5−

6−import Data.Tagged

7−import Ether.Internal.Tags

8−import Ether.Internal.TH_TupleInstances

9−

10−type instance TagsK () = '[]

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

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

13−

14−makeTupleInstancesTagsK

15−

16−type instance Tags () = 'HNil

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

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

19−

20−makeTupleInstancesTags

21−

22−#ifndef DISABLE_TUP_INSTANCES

23−makeTupleInstancesHasLens [2..62]

24−#endif

src/Ether/Reader.hs+30−2

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

77 , MonadReader tag r m

78 ) => MonadReader tag r (t m)

79 where

80+

80 ask = Lift.lift (ask @tag)

81 ask = Lift.lift (ask @tag)

82+ {-# INLINE ask #-}

83+

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

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

85+ {-# INLINE local #-}

86+

82 reader = Lift.lift . reader @tag

87 reader = Lift.lift . reader @tag

88+ {-# INLINE reader #-}

84instance {-# OVERLAPPABLE #-}

90instance {-# OVERLAPPABLE #-}

85 ( Monad (trans m)

91 ( Monad (trans m)

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

92 TaggedTrans effs trans m r ->

98 TaggedTrans effs trans m r ->

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

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

94 (ask @tag)

100 (ask @tag)

101+ {-# INLINE ask #-}

102

96 local =

103 local =

97 (coerce :: forall a .

104 (coerce :: forall a .

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

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

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

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

100 (local @tag)

107 (local @tag)

108+ {-# INLINE local #-}

101

109

102 reader =

110 reader =

103 (coerce :: forall a .

111 (coerce :: forall a .

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

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

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

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

106 (reader @tag)

114 (reader @tag)

115+ {-# INLINE reader #-}

107

116

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

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

109asks

118asks

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

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

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

114 -> m a

123 -> m a

115asks = reader @tag

124asks = reader @tag

125+{-# INLINE asks #-}

116

126

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

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

118data READER

128data READER

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

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

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

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

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

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

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

148+{-# INLINE readerT #-}

138

149

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

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

140-- and returns the final value.

151-- and returns the final value.

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

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

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

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

154+{-# INLINE runReaderT #-}

143

155

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

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

145-- and returns the final value.

157-- and returns the final value.

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

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

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

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

160+{-# INLINE runReader #-}

148

161

149type instance HandleSuper READER r trans = ()

162type instance HandleSuper READER r trans = ()

150type instance HandleConstraint READER r trans m =

163type instance HandleConstraint READER r trans m =

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

152

165

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

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

154 handling r = r

167 handling r = r

168+ {-# INLINE handling #-}

155

169

156instance

170instance

157 ( Handle READER r trans

171 ( Handle READER r trans

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

162 ask =

176 ask =

163 handling @READER @r @trans @m $

177 handling @READER @r @trans @m $

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

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

179+ {-# INLINE ask #-}

165

180

166 local =

181 local =

167 handling @READER @r @trans @m $

182 handling @READER @r @trans @m $

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

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

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

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

185+ {-# INLINE local #-}

170

186

171 reader =

187 reader =

172 handling @READER @r @trans @m $

188 handling @READER @r @trans @m $

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

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

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

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

191+ {-# INLINE reader #-}

175

192

176instance

193instance

177 ( HasLens tag payload r

194 ( HasLens tag payload r

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

186 trans m a ->

203 trans m a ->

187 TaggedTrans eff trans m a)

204 TaggedTrans eff trans m a)

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

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

206+ {-# INLINE ask #-}

189

207

190 local f =

208 local f =

191 handling @READER @payload @trans @m $

209 handling @READER @payload @trans @m $

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

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

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

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

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

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

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

214+ {-# INLINE local #-}

196

215

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

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

198 READERS 'HNil = '[]

217 READERS 'HNil = '[]

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

203type Readers r = ReadersT r Identity

222type Readers r = ReadersT r Identity

204

223

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

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

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

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

226+{-# INLINE runReadersT #-}

207

227

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

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

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

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

230+{-# INLINE runReaders #-}

210

231

211type ReaderT' r = ReaderT r r

232type ReaderT' r = ReaderT r r

212

233

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

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

214readerT' = readerT

235readerT' = readerT

236+{-# INLINE readerT' #-}

215

237

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

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

217runReaderT' = runReaderT

239runReaderT' = runReaderT

240+{-# INLINE runReaderT' #-}

218

241

219type Reader' r = Reader r r

242type Reader' r = Reader r r

220

243

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

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

222runReader' = runReader

245runReader' = runReader

246+{-# INLINE runReader' #-}

223

247

224type MonadReader' r = MonadReader r r

248type MonadReader' r = MonadReader r r

225

249

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

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

227local' = local @r

251local' = local @r

252+{-# INLINE local' #-}

228

253

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

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

230ask' = ask @r

255ask' = ask @r

256+{-# INLINE ask' #-}

231

257

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

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

233reader' = reader @r

259reader' = reader @r

260+{-# INLINE reader' #-}

234

261

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

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

236asks' = asks @r

263asks' = asks @r

264+{-# INLINE asks' #-}

src/Ether/State.hs+56

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

114 , MonadState tag s m

115 ) => MonadState tag s (t m)

116 where

117+

117 get = Lift.lift (get @tag)

118 get = Lift.lift (get @tag)

119+ {-# INLINE get #-}

120+

118 put = Lift.lift . put @tag

121 put = Lift.lift . put @tag

122+ {-# INLINE put #-}

123+

119 state = Lift.lift . state @tag

124 state = Lift.lift . state @tag

125+ {-# INLINE state #-}

120

126

121instance {-# OVERLAPPABLE #-}

127instance {-# OVERLAPPABLE #-}

122 ( Monad (trans m)

128 ( Monad (trans m)

@@ -129,26 +135,31 @@ instance {-# OVERLAPPABLE #-}

129 TaggedTrans effs trans m s ->

135 TaggedTrans effs trans m s ->

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

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

131 (get @tag)

137 (get @tag)

138+ {-# INLINE get #-}

132

139

133 put =

140 put =

134 (coerce ::

141 (coerce ::

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

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

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

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

137 (put @tag)

144 (put @tag)

145+ {-# INLINE put #-}

138

146

139 state =

147 state =

140 (coerce :: forall a .

148 (coerce :: forall a .

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

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

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

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

143 (state @tag)

151 (state @tag)

152+ {-# INLINE state #-}

144

153

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

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

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

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

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

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

157+{-# INLINABLE modify #-}

148

158

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

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

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

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

151gets f = fmap f (get @tag)

161gets f = fmap f (get @tag)

162+{-# INLINABLE gets #-}

152

163

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

164-- | Encode type-level information for 'StateT'.

154data STATE

165data STATE

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

159

170

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

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

161 handling r = r

172 handling r = r

173+ {-# INLINE handling #-}

162

174

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

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

164 handling r = r

176 handling r = r

177+ {-# INLINE handling #-}

165

178

166instance

179instance

167 ( Handle STATE s trans

180 ( Handle STATE s trans

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

172 get =

185 get =

173 handling @STATE @s @trans @m $

186 handling @STATE @s @trans @m $

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

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

188+ {-# INLINE get #-}

175

189

176 put =

190 put =

177 handling @STATE @s @trans @m $

191 handling @STATE @s @trans @m $

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

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

193+ {-# INLINE put #-}

179

194

180 state =

195 state =

181 handling @STATE @s @trans @m $

196 handling @STATE @s @trans @m $

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

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

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

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

199+ {-# INLINE state #-}

184

200

185instance

201instance

186 ( HasLens tag payload s

202 ( HasLens tag payload s

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

195 trans m a ->

211 trans m a ->

196 TaggedTrans eff trans m a)

212 TaggedTrans eff trans m a)

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

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

214+ {-# INLINE get #-}

198

215

199 put s =

216 put s =

200 handling @STATE @payload @trans @m $

217 handling @STATE @payload @trans @m $

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

202 trans m a ->

219 trans m a ->

203 TaggedTrans eff trans m a)

220 TaggedTrans eff trans m a)

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

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

222+ {-# INLINE put #-}

205

223

206 state f =

224 state f =

207 handling @STATE @payload @trans @m $

225 handling @STATE @payload @trans @m $

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

209 trans m a ->

227 trans m a ->

210 TaggedTrans eff trans m a)

228 TaggedTrans eff trans m a)

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

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

230+ {-# INLINE state #-}

212

231

213-- | The parametrizable state monad.

232-- | The parametrizable state monad.

214--

233--

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

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

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

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

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

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

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

249+{-# INLINE stateT #-}

230

250

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

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

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

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

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

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

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

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

255+{-# INLINE runStateT #-}

235

256

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

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

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

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

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

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

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

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

261+{-# INLINE evalStateT #-}

240

262

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

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

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

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

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

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

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

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

267+{-# INLINE execStateT #-}

245

268

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

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

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

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

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

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

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

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

273+{-# INLINE runState #-}

250

274

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

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

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

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

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

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

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

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

279+{-# INLINE evalState #-}

255

280

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

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

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

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

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

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

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

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

285+{-# INLINE execState #-}

260

286

261-- | The parametrizable state monad.

287-- | The parametrizable state monad.

262--

288--

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

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

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

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

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

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

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

304+{-# INLINE lazyStateT #-}

278

305

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

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

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

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

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

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

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

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

310+{-# INLINE runLazyStateT #-}

283

311

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

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

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

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

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

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

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

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

316+{-# INLINE evalLazyStateT #-}

288

317

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

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

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

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

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

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

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

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

322+{-# INLINE execLazyStateT #-}

293

323

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

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

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

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

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

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

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

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

328+{-# INLINE runLazyState #-}

298

329

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

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

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

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

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

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

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

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

334+{-# INLINE evalLazyState #-}

303

335

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

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

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

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

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

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

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

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

340+{-# INLINE execLazyState #-}

308

341

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

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

310 STATES 'HNil = '[]

343 STATES 'HNil = '[]

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

316

349

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

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

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

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

352+{-# INLINE runStatesT #-}

319

353

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

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

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

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

356+{-# INLINE runStates #-}

322

357

323type StateT' s = StateT s s

358type StateT' s = StateT s s

324

359

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

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

326stateT' = stateT

361stateT' = stateT

362+{-# INLINE stateT' #-}

327

363

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

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

329runStateT' = runStateT

365runStateT' = runStateT

366+{-# INLINE runStateT' #-}

330

367

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

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

332runState' = runState

369runState' = runState

370+{-# INLINE runState' #-}

333

371

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

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

335evalStateT' = evalStateT

373evalStateT' = evalStateT

374+{-# INLINE evalStateT' #-}

336

375

337type State' s = State s s

376type State' s = State s s

338

377

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

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

340evalState' = evalState

379evalState' = evalState

380+{-# INLINE evalState' #-}

341

381

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

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

343execStateT' = execStateT

383execStateT' = execStateT

384+{-# INLINE execStateT' #-}

344

385

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

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

346execState' = execState

387execState' = execState

388+{-# INLINE execState' #-}

347

389

348type LazyStateT' s = LazyStateT s s

390type LazyStateT' s = LazyStateT s s

349

391

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

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

351lazyStateT' = lazyStateT

393lazyStateT' = lazyStateT

394+{-# INLINE lazyStateT' #-}

352

395

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

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

354runLazyStateT' = runLazyStateT

397runLazyStateT' = runLazyStateT

398+{-# INLINE runLazyStateT' #-}

355

399

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

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

357runLazyState' = runLazyState

401runLazyState' = runLazyState

402+{-# INLINE runLazyState' #-}

358

403

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

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

360evalLazyStateT' = evalLazyStateT

405evalLazyStateT' = evalLazyStateT

406+{-# INLINE evalLazyStateT' #-}

361

407

362type LazyState' s = LazyState s s

408type LazyState' s = LazyState s s

363

409

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

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

365evalLazyState' = evalLazyState

411evalLazyState' = evalLazyState

412+{-# INLINE evalLazyState' #-}

366

413

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

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

368execLazyStateT' = execLazyStateT

415execLazyStateT' = execLazyStateT

416+{-# INLINE execLazyStateT' #-}

369

417

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

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

371execLazyState' = execLazyState

419execLazyState' = execLazyState

420+{-# INLINE execLazyState' #-}

372

421

373type MonadState' s = MonadState s s

422type MonadState' s = MonadState s s

374

423

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

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

376get' = get @s

425get' = get @s

426+{-# INLINE get' #-}

377

427

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

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

379gets' = gets @s

429gets' = gets @s

430+{-# INLINE gets' #-}

380

431

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

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

382put' = put @s

433put' = put @s

434+{-# INLINE put' #-}

383

435

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

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

385state' = state @s

437state' = state @s

438+{-# INLINE state' #-}

386

439

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

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

388modify' = modify @s

441modify' = modify @s

442+{-# INLINE modify' #-}

389

443

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

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

391data ZOOM t z

445data ZOOM t z

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

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

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

400 -> m a

454 -> m a

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

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

456+{-# INLINE zoom #-}

402

457

403instance

458instance

404 ( MonadState tag sOuter m

459 ( MonadState tag sOuter m

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

413 (state @tag . l)

468 (state @tag . l)

414 where

469 where

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

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

471+ {-# INLINE state #-}

src/Ether/TagDispatch.hs+50

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

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

67instance {-# OVERLAPPING #-}

68instance {-# OVERLAPPING #-}

68 ( MonadReader tag r m, trans ~ IdentityT

69 ( MonadReader tag r m, trans ~ IdentityT

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

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

70 where

71 where

72+

71 ask = ask @tag

73 ask = ask @tag

74+ {-# INLINE ask #-}

75+

72 local = local @tag

76 local = local @tag

77+ {-# INLINE local #-}

78+

73 reader = reader @tag

79 reader = reader @tag

80+ {-# INLINE reader #-}

75instance {-# OVERLAPPING #-}

82instance {-# OVERLAPPING #-}

76 ( MonadState tag s m, trans ~ IdentityT

83 ( MonadState tag s m, trans ~ IdentityT

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

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

78 where

85 where

86+

79 get = get @tag

87 get = get @tag

88+ {-# INLINE get #-}

89+

80 put = put @tag

90 put = put @tag

91+ {-# INLINE put #-}

92+

81 state = state @tag

93 state = state @tag

94+ {-# INLINE state #-}

83instance {-# OVERLAPPING #-}

96instance {-# OVERLAPPING #-}

84 ( MonadExcept tag e m, trans ~ IdentityT

97 ( MonadExcept tag e m, trans ~ IdentityT

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

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

86 where

99 where

100+

87 throwError = throw @tag

101 throwError = throw @tag

102+ {-# INLINE throwError #-}

103+

88 catchError = catch @tag

104 catchError = catch @tag

105+ {-# INLINE catchError #-}

106

90instance {-# OVERLAPPING #-}

107instance {-# OVERLAPPING #-}

91 ( MonadWriter tag w m, trans ~ IdentityT

108 ( MonadWriter tag w m, trans ~ IdentityT

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

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

93 where

110 where

111+

94 writer = writer @tag

112 writer = writer @tag

113+ {-# INLINE writer #-}

114+

95 tell = tell @tag

115 tell = tell @tag

116+ {-# INLINE tell #-}

117+

96 listen = listen @tag

118 listen = listen @tag

119+ {-# INLINE listen #-}

120+

97 pass = pass @tag

121 pass = pass @tag

122+ {-# INLINE pass #-}

123

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

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

100data TAG_REPLACE tOld tNew

125data TAG_REPLACE tOld tNew

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

104-- | Replace a tag with another tag.

129-- | Replace a tag with another tag.

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

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

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

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

132+{-# INLINE tagReplace #-}

107

133

108instance

134instance

109 ( MonadReader tNew r m, trans ~ IdentityT

135 ( MonadReader tNew r m, trans ~ IdentityT

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

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

111 where

137 where

138+

112 ask = ask @tNew

139 ask = ask @tNew

140+ {-# INLINE ask #-}

141+

113 local = local @tNew

142 local = local @tNew

143+ {-# INLINE local #-}

144+

114 reader = reader @tNew

145 reader = reader @tNew

146+ {-# INLINE reader #-}

115

147

116instance

148instance

117 ( MonadState tNew s m, trans ~ IdentityT

149 ( MonadState tNew s m, trans ~ IdentityT

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

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

119 where

151 where

152+

120 get = get @tNew

153 get = get @tNew

154+ {-# INLINE get #-}

155+

121 put = put @tNew

156 put = put @tNew

157+ {-# INLINE put #-}

158+

122 state = state @tNew

159 state = state @tNew

160+ {-# INLINE state #-}

123

161

124instance

162instance

125 ( MonadExcept tNew e m, trans ~ IdentityT

163 ( MonadExcept tNew e m, trans ~ IdentityT

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

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

127 where

165 where

166+

128 throw = throw @tNew

167 throw = throw @tNew

168+ {-# INLINE throw #-}

169+

129 catch = catch @tNew

170 catch = catch @tNew

171+ {-# INLINE catch #-}

130

172

131instance

173instance

132 ( MonadWriter tNew w m, trans ~ IdentityT

174 ( MonadWriter tNew w m, trans ~ IdentityT

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

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

134 where

176 where

177+

135 writer = writer @tNew

178 writer = writer @tNew

179+ {-# INLINE writer #-}

180+

136 tell = tell @tNew

181 tell = tell @tNew

182+ {-# INLINE tell #-}

183+

137 listen = listen @tNew

184 listen = listen @tNew

185+ {-# INLINE listen #-}

186+

138 pass = pass @tNew

187 pass = pass @tNew

188+ {-# INLINE pass #-}

src/Ether/TaggedTrans.hs+8−32

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

1−-- The use of ImpredicativeTypes here is safe, see discussion under GitHub issue

2−-- #35. It's only needed to allow the visible type application of a polytype.

3−{-# LANGUAGE ImpredicativeTypes #-}

4−

5module Ether.TaggedTrans

1module Ether.TaggedTrans

6 ( TaggedTrans(..)

2 ( TaggedTrans(..)

7 ) where

3 ) where

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

11import Control.Monad.Fix (MonadFix)

7import Control.Monad.Fix (MonadFix)

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

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

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

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

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

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

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

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

17import qualified Control.Monad.Base as MB

13import qualified Control.Monad.Base as MB

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

37 deriving

33 deriving

38 ( Generic

34 ( Generic

39 , Functor, Applicative, Alternative, Monad, MonadPlus

35 , Functor, Applicative, Alternative, Monad, MonadPlus

40− , MonadFix, MonadTrans, MonadIO

36+ , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad

41 , MonadThrow, MonadCatch, MonadMask )

37 , MonadThrow, MonadCatch, MonadMask )

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

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

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

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

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

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

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

55 MB.liftBase

51 MB.liftBase

52+ {-# INLINE liftBase #-}

57instance

54instance

58 ( MC.MonadTransControl trans

55 ( MC.MonadTransControl trans

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

63 liftWith = MC.defaultLiftWith

60 liftWith = MC.defaultLiftWith

64 (coerce :: Pack tag trans m a)

61 (coerce :: Pack tag trans m a)

65 (coerce :: Unpack tag trans m a)

62 (coerce :: Unpack tag trans m a)

63+ {-# INLINE liftWith #-}

67 restoreT = MC.defaultRestoreT

65 restoreT = MC.defaultRestoreT

68 (coerce :: Pack tag trans m a)

66 (coerce :: Pack tag trans m a)

67+ {-# INLINE restoreT #-}

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

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

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

76 LiftBaseWith b (TaggedTrans tag trans m) a

75 LiftBaseWith b (TaggedTrans tag trans m) a

77coerceLiftBaseWith lbw =

76coerceLiftBaseWith lbw =

78 unLBW (coerce (LBW lbw))

77 unLBW (coerce (LBW lbw))

78+{-# INLINE coerceLiftBaseWith #-}

80instance

81 ( MC.MonadBaseControl b (trans m)

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

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

86 liftBaseWith = coerceLiftBaseWith MC.liftBaseWith

87+ {-# INLINE liftBaseWith #-}

88 restoreM =

89 restoreM =

89 (coerce :: forall a .

90 (coerce :: forall a .

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

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

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

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

92 MC.restoreM

93 MC.restoreM

94+ {-# INLINE restoreM #-}

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

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

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

178 where

180 where

179 throwError = lift . Mtl.throwError

181 throwError = lift . Mtl.throwError

180 catchError = Lift.liftCatch Mtl.catchError

182 catchError = Lift.liftCatch Mtl.catchError

181−

182−type Hoist trans =

183− forall m n b . Monad m =>

184− (forall a . m a -> n a) -> trans m b -> trans n b

185−

186−-- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will

187−-- trigger GHC Trac #11837 on GHC 8.0.1 and older.

188−instance MFunctor trans => MFunctor (TaggedTrans tag trans) where

189− hoist =

190− coerce

191− @(Hoist trans)

192− @(Hoist (TaggedTrans tag trans))

193− hoist

194−

195−type Embed trans =

196− forall n m b . Monad n =>

197− (forall a . m a -> trans n a) -> trans m b -> trans n b

198−

199−-- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will

200−-- trigger GHC Trac #11837 on GHC 8.0.1 and older.

201−instance MMonad trans => MMonad (TaggedTrans tag trans) where

202− embed =

203− coerce

204− @(Embed trans)

205− @(Embed (TaggedTrans tag trans))

206− embed

src/Ether/Writer.hs+40

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

96 , MonadWriter tag w m

97 , Monoid w

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

99+

99 writer = Lift.lift . writer @tag

100 writer = Lift.lift . writer @tag

101+ {-# INLINE writer #-}

102+

100 tell = Lift.lift . tell @tag

103 tell = Lift.lift . tell @tag

104+ {-# INLINE tell #-}

105+

101 listen = Lift.liftListen (listen @tag)

106 listen = Lift.liftListen (listen @tag)

107+ {-# INLINE listen #-}

108+

102 pass = Lift.liftPass (pass @tag)

109 pass = Lift.liftPass (pass @tag)

110+ {-# INLINE pass #-}

103

111

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

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

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

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

@@ -123,9 +131,11 @@ type instance HandleConstraint WRITER w trans m =

123

131

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

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

125 handling r = r

133 handling r = r

134+ {-# INLINE handling #-}

126

135

127instance Monoid w => Handle WRITER w (T.Lazy.WriterT w) where

136instance Monoid w => Handle WRITER w (T.Lazy.WriterT w) where

128 handling r = r

137 handling r = r

138+ {-# INLINE handling #-}

129

139

130instance

140instance

131 ( Handle WRITER w trans

141 ( Handle WRITER w trans

@@ -137,20 +147,24 @@ instance

137 handling @WRITER @w @trans @m $

147 handling @WRITER @w @trans @m $

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

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

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

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

150+ {-# INLINE writer #-}

140

151

141 tell =

152 tell =

142 handling @WRITER @w @trans @m $

153 handling @WRITER @w @trans @m $

143 coerce (T.tell @w @(trans m))

154 coerce (T.tell @w @(trans m))

155+ {-# INLINE tell #-}

144

156

145 listen =

157 listen =

146 handling @WRITER @w @trans @m $

158 handling @WRITER @w @trans @m $

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

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

148 forall eff a . Listen w (TaggedTrans eff trans m) a

160 forall eff a . Listen w (TaggedTrans eff trans m) a

161+ {-# INLINE listen #-}

149

162

150 pass =

163 pass =

151 handling @WRITER @w @trans @m $

164 handling @WRITER @w @trans @m $

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

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

153 forall eff a . Pass w (TaggedTrans eff trans m) a

166 forall eff a . Pass w (TaggedTrans eff trans m) a

167+ {-# INLINE pass #-}

154

168

155-- | The parametrizable writer monad.

169-- | The parametrizable writer monad.

156--

170--

@@ -169,26 +183,31 @@ type WriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.CPS.WriterT w)

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

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

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

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

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

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

186+{-# INLINE writerT #-}

172

187

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

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

174-- and the final accumulator.

189-- and the final accumulator.

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

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

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

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

192+{-# INLINE runWriterT #-}

177

193

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

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

179-- and the final accumulator.

195-- and the final accumulator.

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

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

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

197runWriter = coerce (T.CPS.runWriter @w @a)

198+{-# INLINE runWriter #-}

182

199

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

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

184-- discarding the normal value.

201-- discarding the normal value.

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

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

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

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

204+{-# INLINE execWriterT #-}

187

205

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

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

189-- discarding the normal value.

207-- discarding the normal value.

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

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

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

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

210+{-# INLINE execWriter #-}

192

211

193-- | The parametrizable writer monad.

212-- | The parametrizable writer monad.

194--

213--

@@ -207,81 +226,102 @@ type LazyWriterT tag w = TaggedTrans (TAGGED WRITER tag) (T.Lazy.WriterT w)

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

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

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

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

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

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

229+{-# INLINE lazyWriterT #-}

210

230

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

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

212-- and the final accumulator.

232-- and the final accumulator.

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

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

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

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

235+{-# INLINE runLazyWriterT #-}

215

236

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

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

217-- and the final accumulator.

238-- and the final accumulator.

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

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

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

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

241+{-# INLINE runLazyWriter #-}

220

242

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

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

222-- discarding the normal value.

244-- discarding the normal value.

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

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

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

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

247+{-# INLINE execLazyWriterT #-}

225

248

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

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

227-- discarding the normal value.

250-- discarding the normal value.

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

251execLazyWriter :: forall tag w a . LazyWriter tag w a -> w

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

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

253+{-# INLINE execLazyWriter #-}

230

254

231type Writer' w = Writer w w

255type Writer' w = Writer w w

232

256

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

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

234runWriter' = runWriter

258runWriter' = runWriter

259+{-# INLINE runWriter' #-}

235

260

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

261execWriter' :: Monoid w => Writer' w a -> w

237execWriter' = execWriter

262execWriter' = execWriter

263+{-# INLINE execWriter' #-}

238

264

239type WriterT' w = WriterT w w

265type WriterT' w = WriterT w w

240

266

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

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

242writerT' = writerT

268writerT' = writerT

269+{-# INLINE writerT' #-}

243

270

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

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

245runWriterT' = runWriterT

272runWriterT' = runWriterT

273+{-# INLINE runWriterT' #-}

246

274

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

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

248execWriterT' = execWriterT

276execWriterT' = execWriterT

277+{-# INLINE execWriterT' #-}

249

278

250type LazyWriter' w = LazyWriter w w

279type LazyWriter' w = LazyWriter w w

251

280

252runLazyWriter' :: LazyWriter' w a -> (a, w)

281runLazyWriter' :: LazyWriter' w a -> (a, w)

253runLazyWriter' = runLazyWriter

282runLazyWriter' = runLazyWriter

283+{-# INLINE runLazyWriter' #-}

254

284

255execLazyWriter' :: LazyWriter' w a -> w

285execLazyWriter' :: LazyWriter' w a -> w

256execLazyWriter' = execLazyWriter

286execLazyWriter' = execLazyWriter

287+{-# INLINE execLazyWriter' #-}

257

288

258type LazyWriterT' w = LazyWriterT w w

289type LazyWriterT' w = LazyWriterT w w

259

290

260lazyWriterT' :: m (a, w) -> LazyWriterT' w m a

291lazyWriterT' :: m (a, w) -> LazyWriterT' w m a

261lazyWriterT' = lazyWriterT

292lazyWriterT' = lazyWriterT

293+{-# INLINE lazyWriterT' #-}

262

294

263runLazyWriterT' :: LazyWriterT' w m a -> m (a, w)

295runLazyWriterT' :: LazyWriterT' w m a -> m (a, w)

264runLazyWriterT' = runLazyWriterT

296runLazyWriterT' = runLazyWriterT

297+{-# INLINE runLazyWriterT' #-}

265

298

266execLazyWriterT' :: Monad m => LazyWriterT' w m a -> m w

299execLazyWriterT' :: Monad m => LazyWriterT' w m a -> m w

267execLazyWriterT' = execLazyWriterT

300execLazyWriterT' = execLazyWriterT

301+{-# INLINE execLazyWriterT' #-}

268

302

269type MonadWriter' w = MonadWriter w w

303type MonadWriter' w = MonadWriter w w

270

304

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

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

272writer' = writer @w

306writer' = writer @w

307+{-# INLINE writer' #-}

273

308

274tell' :: forall w m . MonadWriter' w m => w -> m ()

309tell' :: forall w m . MonadWriter' w m => w -> m ()

275tell' = tell @w

310tell' = tell @w

311+{-# INLINE tell' #-}

276

312

277listen' :: forall w m a . MonadWriter' w m => m a -> m (a, w)

313listen' :: forall w m a . MonadWriter' w m => m a -> m (a, w)

278listen' = listen @w

314listen' = listen @w

315+{-# INLINE listen' #-}

279

316

280pass' :: forall w m a . MonadWriter' w m => m (a, w -> w) -> m a

317pass' :: forall w m a . MonadWriter' w m => m (a, w -> w) -> m a

281pass' = pass @w

318pass' = pass @w

319+{-# INLINE pass' #-}

282

320

283listens' :: forall w m a b . MonadWriter' w m => (w -> b) -> m a -> m (a, b)

321listens' :: forall w m a b . MonadWriter' w m => (w -> b) -> m a -> m (a, b)

284listens' = listens @w

322listens' = listens @w

323+{-# INLINE listens' #-}

285

324

286censor' :: forall w m a . MonadWriter' w m => (w -> w) -> m a -> m a

325censor' :: forall w m a . MonadWriter' w m => (w -> w) -> m a -> m a

287censor' = censor @w

326censor' = censor @w

327+{-# INLINE censor' #-}

stack.yamlnew file+5

@@ -0,0 +1,5 @@

1+resolver: lts-8.13

2+packages: ['.']

4+extra-deps:

5+- transformers-lift-0.2.0.1

test/Regression/T1.hs−1

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

1module Regression.T1 (test1) where

3import Ether

4−import TupleInstances ()

5import Data.List (group)

4import Data.List (group)

7import Test.Tasty

6import Test.Tasty

test/TupleInstances.hsdeleted−9

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

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

2−{-# LANGUAGE CPP #-}

3−

4−module TupleInstances () where

5−

6−#ifdef DISABLE_TUP_INSTANCES

7−import Ether.Internal (makeTupleInstancesHasLens)

8−makeTupleInstancesHasLens [2]

9−#endif