d7afb54..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+6−1

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

@@ -5,7 +10,7 @@

5* Use the `TypeApplications` extension to get rid of `Proxy`.

10* Use the `TypeApplications` extension to get rid of `Proxy`.

6* Remove `Control.Ether.TH`.

11* Remove `Control.Ether.TH`.

7* Remove `Control.Ether.Abbr`.

12* Remove `Control.Ether.Abbr`.

8−* Unify `Dispatch` and `TaggedTrans` as `Handler`.

13+* Unify `Dispatch` and `TaggedTrans`.

9* Better `MonadBase` and `MonadBaseControl` instances.

14* Better `MonadBase` and `MonadBaseControl` instances.

10* Add flattening for `ReaderT` and `StateT`.

15* Add flattening for `ReaderT` and `StateT`.

11* Add zooming for `MonadState`.

16* Add zooming for `MonadState`.

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+48−17

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

@@ -32,18 +42,26 @@ library

32 Ether.State

42 Ether.State

33 Ether.Writer

43 Ether.Writer

34 Ether.Except

44 Ether.Except

35− Ether.Handler

45+ Ether.TaggedTrans

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.hs+2−2

@@ -9,7 +9,7 @@ module Ether

9 , module Ether.State

10 , module Ether.Except

11 , module Ether.TagDispatch

12− , module Ether.Handler

12+ , module Ether.TaggedTrans

13 ) where

15import Control.Monad

@@ -22,4 +22,4 @@ import Ether.Writer

22import Ether.State

23import Ether.Except

24import Ether.TagDispatch

25−import Ether.Handler

25+import Ether.TaggedTrans

src/Ether/Except.hs+7−21

@@ -33,7 +33,7 @@ import qualified Control.Monad.Trans.Lift.Catch as Lift

33import Data.Coerce

34import Data.Functor.Identity

36−import Ether.Handler

36+import Ether.TaggedTrans

37import Ether.Internal

39class Monad m => MonadExcept tag e m | m tag -> e where

@@ -41,7 +41,7 @@ class Monad m => MonadExcept tag e m | m tag -> e where

41 -- | Is used within a monadic computation to begin exception processing.

42 throw :: e -> m a

44− -- | A handler function to handle previous exceptions and return to

44+ -- | A TaggedTrans function to handle previous exceptions and return to

45 -- normal execution.

46 catch :: m a -> (e -> m a) -> m a

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

@@ -72,22 +68,19 @@ type Except tag e = ExceptT tag e Identity

72--

68--

73-- The 'return' function returns a normal value, while '>>=' exits on

69-- The 'return' function returns a normal value, while '>>=' exits on

74-- the first exception.

70-- the first exception.

75−type ExceptT tag e = Handler (TAGGED EXCEPT tag) (T.ExceptT e)

71+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 (Handler (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 -> Handler 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 (Handler 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/Handler.hsdeleted−177

@@ -1,177 +0,0 @@

1−module Ether.Handler

2− ( Handler(..)

3− ) where

4−

5−import Control.Applicative

6−import Control.Monad (MonadPlus)

7−import Control.Monad.Fix (MonadFix)

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

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

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

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

12−

13−import qualified Control.Monad.Base as MB

14−import qualified Control.Monad.Trans.Control as MC

15−

16−import qualified Control.Monad.Trans.Lift.StT as Lift

17−import qualified Control.Monad.Trans.Lift.Local as Lift

18−import qualified Control.Monad.Trans.Lift.Catch as Lift

19−import qualified Control.Monad.Trans.Lift.Listen as Lift

20−import qualified Control.Monad.Trans.Lift.Pass as Lift

21−import qualified Control.Monad.Trans.Lift.CallCC as Lift

22−

23−import qualified Control.Monad.Cont.Class as Mtl

24−import qualified Control.Monad.Reader.Class as Mtl

25−import qualified Control.Monad.State.Class as Mtl

26−import qualified Control.Monad.Writer.Class as Mtl

27−import qualified Control.Monad.Error.Class as Mtl

28−

29−import GHC.Generics (Generic)

30−import Data.Coerce (coerce)

31−

32−newtype Handler eff trans m a = Handler (trans m a)

33− deriving

34− ( Generic

35− , Functor, Applicative, Alternative, Monad, MonadPlus

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

37− , MonadThrow, MonadCatch, MonadMask )

38−

39−type Pack eff trans m a = trans m a -> Handler eff trans m a

40−

41−type Unpack eff trans m a = Handler eff trans m a -> trans m a

42−

43−instance

44− ( MB.MonadBase b (trans m)

45− ) => MB.MonadBase b (Handler eff trans m)

46− where

47− liftBase =

48− (coerce :: forall a .

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

50− (b a -> Handler eff trans m a))

51− MB.liftBase

52−

53−instance

54− ( MC.MonadTransControl trans

55− ) => MC.MonadTransControl (Handler eff trans)

56− where

57− type StT (Handler eff trans) a = MC.StT trans a

58− liftWith = MC.defaultLiftWith

59− (coerce :: Pack eff trans m a)

60− (coerce :: Unpack eff trans m a)

61− restoreT = MC.defaultRestoreT

62− (coerce :: Pack eff trans m a)

63−

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

65−

66−newtype LiftBaseWith' b m a = LBW { unLBW :: LiftBaseWith b m a }

67−

68−coerceLiftBaseWith ::

69− LiftBaseWith b (trans m) a ->

70− LiftBaseWith b (Handler eff trans m) a

71−coerceLiftBaseWith lbw =

72− unLBW (coerce (LBW lbw))

73−{-# INLINE coerceLiftBaseWith #-}

74−

75−instance

76− ( MC.MonadBaseControl b (trans m)

77− ) => MC.MonadBaseControl b (Handler eff trans m)

78− where

79− type StM (Handler eff trans m) a = MC.StM (trans m) a

80−

81− liftBaseWith = coerceLiftBaseWith MC.liftBaseWith

82− {-# INLINE liftBaseWith #-}

83−

84− restoreM =

85− (coerce :: forall a .

86− (MC.StM (trans m) a -> trans m a) ->

87− (MC.StM (trans m) a -> Handler eff trans m a))

88− MC.restoreM

89− {-# INLINE restoreM #-}

90−

91−type instance Lift.StT (Handler eff trans) a = Lift.StT trans a

92−

93−instance Lift.LiftLocal trans => Lift.LiftLocal (Handler eff trans) where

94− liftLocal =

95− Lift.defaultLiftLocal

96− (coerce :: Pack eff trans m a)

97− (coerce :: Unpack eff trans m a)

98−

99−instance Lift.LiftCatch trans => Lift.LiftCatch (Handler eff trans) where

100− liftCatch =

101− Lift.defaultLiftCatch

102− (coerce :: Pack eff trans m a)

103− (coerce :: Unpack eff trans m a)

104−

105−instance Lift.LiftListen trans => Lift.LiftListen (Handler eff trans) where

106− liftListen =

107− Lift.defaultLiftListen

108− (coerce :: Pack eff trans m a)

109− (coerce :: Unpack eff trans m a)

110−

111−instance Lift.LiftPass trans => Lift.LiftPass (Handler eff trans) where

112− liftPass =

113− Lift.defaultLiftPass

114− (coerce :: Pack eff trans m a)

115− (coerce :: Unpack eff trans m a)

116−

117−instance Lift.LiftCallCC trans => Lift.LiftCallCC (Handler eff trans) where

118− liftCallCC =

119− Lift.defaultLiftCallCC

120− (coerce :: Pack eff trans m a)

121− (coerce :: Unpack eff trans m a)

122− liftCallCC' =

123− Lift.defaultLiftCallCC'

124− (coerce :: Pack eff trans m a)

125− (coerce :: Unpack eff trans m a)

126−

127−

128−-- Instances for mtl Mtles

129−

130−instance {-# OVERLAPPABLE #-}

131− ( Mtl.MonadCont m

132− , Lift.LiftCallCC trans

133− , Monad (trans m)

134− ) => Mtl.MonadCont (Handler eff trans m)

135− where

136− callCC = Lift.liftCallCC' Mtl.callCC

137−

138−instance {-# OVERLAPPABLE #-}

139− ( Mtl.MonadReader r m

140− , Lift.LiftLocal trans

141− , Monad (trans m)

142− ) => Mtl.MonadReader r (Handler eff trans m)

143− where

144− ask = lift Mtl.ask

145− local = Lift.liftLocal Mtl.ask Mtl.local

146− reader = lift . Mtl.reader

147−

148−instance {-# OVERLAPPABLE #-}

149− ( Mtl.MonadState s m

150− , MonadTrans trans

151− , Monad (trans m)

152− ) => Mtl.MonadState s (Handler eff trans m)

153− where

154− get = lift Mtl.get

155− put = lift . Mtl.put

156− state = lift . Mtl.state

157−

158−instance {-# OVERLAPPABLE #-}

159− ( Mtl.MonadWriter w m

160− , Lift.LiftListen trans

161− , Lift.LiftPass trans

162− , Monad (trans m)

163− ) => Mtl.MonadWriter w (Handler eff trans m)

164− where

165− writer = lift . Mtl.writer

166− tell = lift . Mtl.tell

167− listen = Lift.liftListen Mtl.listen

168− pass = Lift.liftPass Mtl.pass

169−

170−instance {-# OVERLAPPABLE #-}

171− ( Mtl.MonadError e m

172− , Lift.LiftCatch trans

173− , Monad (trans m)

174− ) => Mtl.MonadError e (Handler eff trans m)

175− where

176− throwError = lift . Mtl.throwError

177− catchError = Lift.liftCatch Mtl.catchError

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+19−47

@@ -45,7 +45,7 @@ import Data.Coerce

45import Data.Functor.Identity

46import Data.Kind

48−import Ether.Handler

48+import Ether.TaggedTrans

49import Ether.Internal

51class Monad m => MonadReader tag r m | m tag -> r where

@@ -77,42 +77,33 @@ 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)

92− , MonadReader tag r (Handler effs trans m)

86+ , MonadReader tag r (TaggedTrans effs trans m)

93− ) => MonadReader tag r (Handler (eff ': effs) trans (m :: Type -> Type))

87+ ) => MonadReader tag r (TaggedTrans (eff ': effs) trans (m :: Type -> Type))

94 where

88 where

96 ask =

90 ask =

97 (coerce ::

91 (coerce ::

98− Handler effs trans m r ->

92+ TaggedTrans effs trans m r ->

99− Handler (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 (Handler effs trans m) a ->

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

106− Lift.Local r (Handler (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) -> Handler effs trans m a) ->

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

113− ((r -> a) -> Handler (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

@@ -140,24 +130,21 @@ type Reader tag r = ReaderT tag r Identity

140--

130--

141-- The 'return' function ignores the environment, while '>>=' passes

131-- The 'return' function ignores the environment, while '>>=' passes

142-- the inherited environment to both subcomputations.

132-- the inherited environment to both subcomputations.

143−type ReaderT tag r = Handler (TAGGED READER tag) (T.ReaderT r)

133+type ReaderT tag r = TaggedTrans (TAGGED READER tag) (T.ReaderT r)

144

134

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,100 +152,85 @@ 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

172 , Monad m, Monad (trans m)

158 , Monad m, Monad (trans m)

173− ) => MonadReader tag r (Handler (TAGGED READER tag) trans m)

159+ ) => MonadReader tag r (TaggedTrans (TAGGED READER tag) trans m)

174 where

160 where

175

161

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

195 , Handle READER payload trans

178 , Handle READER payload trans

196 , Monad m, Monad (trans m)

179 , Monad m, Monad (trans m)

197− ) => MonadReader tag r (Handler (TAGGED READER tag ': effs) trans m)

180+ ) => MonadReader tag r (TaggedTrans (TAGGED READER tag ': effs) trans m)

198 where

181 where

199

182

200 ask =

183 ask =

201 handling @READER @payload @trans @m $

184 handling @READER @payload @trans @m $

202 (coerce :: forall eff a .

185 (coerce :: forall eff a .

203 trans m a ->

186 trans m a ->

204− Handler 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 $

210 (coerce :: forall eff a .

192 (coerce :: forall eff a .

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

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

212− (Handler eff trans m a -> Handler 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 = '[]

218 READERS ('HCons t ts) = TAGGED READER t ': READERS ts

199 READERS ('HCons t ts) = TAGGED READER t ': READERS ts

219

200

220−type ReadersT r = Handler (READERS (Tags r)) (T.ReaderT r)

201+type ReadersT r = TaggedTrans (READERS (Tags r)) (T.ReaderT r)

221

202

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

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

85import Data.Proxy

86import Data.Reflection

88−import Ether.Handler

89import Ether.Internal

88import Ether.Internal

89+import Ether.TaggedTrans

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

@@ -114,55 +114,44 @@ 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)

129− , MonadState tag s (Handler effs trans m)

123+ , MonadState tag s (TaggedTrans effs trans m)

130− ) => MonadState tag s (Handler (eff ': effs) trans (m :: Type -> Type))

124+ ) => MonadState tag s (TaggedTrans (eff ': effs) trans (m :: Type -> Type))

131 where

125 where

132

126

133 get =

127 get =

134 (coerce ::

128 (coerce ::

135− Handler effs trans m s ->

129+ TaggedTrans effs trans m s ->

136− Handler (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 -> Handler effs trans m ()) ->

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

143− (s -> Handler (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)) -> Handler effs trans m a) ->

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

150− ((s -> (a, s)) -> Handler (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,64 +159,56 @@ 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

181 , Monad m, Monad (trans m)

168 , Monad m, Monad (trans m)

182− ) => MonadState tag s (Handler (TAGGED STATE tag) trans m)

169+ ) => MonadState tag s (TaggedTrans (TAGGED STATE tag) trans m)

183 where

170 where

184

171

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)) -> Handler 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

203 , Handle STATE payload trans

187 , Handle STATE payload trans

204 , Monad m, Monad (trans m)

188 , Monad m, Monad (trans m)

205− ) => MonadState tag s (Handler (TAGGED STATE tag ': effs) trans m)

189+ ) => MonadState tag s (TaggedTrans (TAGGED STATE tag ': effs) trans m)

206 where

190 where

207

191

208 get =

192 get =

209 handling @STATE @payload @trans @m $

193 handling @STATE @payload @trans @m $

210 (coerce :: forall eff a .

194 (coerce :: forall eff a .

211 trans m a ->

195 trans m a ->

212− Handler 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 $

218 (coerce :: forall eff a .

201 (coerce :: forall eff a .

219 trans m a ->

202 trans m a ->

220− Handler 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 $

226 (coerce :: forall eff a .

208 (coerce :: forall eff a .

227 trans m a ->

209 trans m a ->

228− Handler 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--

@@ -241,48 +222,41 @@ type State tag r = StateT tag r Identity

241--

222--

242-- The 'return' function leaves the state unchanged, while '>>=' uses

223-- The 'return' function leaves the state unchanged, while '>>=' uses

243-- the final state of the first computation as the initial state of the second.

224-- the final state of the first computation as the initial state of the second.

244−type StateT tag s = Handler (TAGGED STATE tag) (T.Strict.StateT s)

225+type StateT tag s = TaggedTrans (TAGGED STATE tag) (T.Strict.StateT s)

245

226

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

@@ -296,159 +270,127 @@ type LazyState tag r = LazyStateT tag r Identity

296--

270--

297-- The 'return' function leaves the state unchanged, while '>>=' uses

271-- The 'return' function leaves the state unchanged, while '>>=' uses

298-- the final state of the first computation as the initial state of the second.

272-- the final state of the first computation as the initial state of the second.

299−type LazyStateT tag s = Handler (TAGGED STATE tag) (T.Lazy.StateT s)

273+type LazyStateT tag s = TaggedTrans (TAGGED STATE tag) (T.Lazy.StateT s)

300

274

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 = '[]

344 STATES ('HCons t ts) = TAGGED STATE t ': STATES ts

311 STATES ('HCons t ts) = TAGGED STATE t ': STATES ts

345

312

346−type StatesT s = Handler (STATES (Tags s)) (T.Strict.StateT s)

313+type StatesT s = TaggedTrans (STATES (Tags s)) (T.Strict.StateT s)

347

314

348type States s = StatesT s Identity

315type 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

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

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

448−

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

450−

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

452

394

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

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

454zoom

396zoom

@@ -457,19 +399,17 @@ 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

464 , Reifies z (ReifiedLens' sOuter sInner)

405 , Reifies z (ReifiedLens' sOuter sInner)

465 , trans ~ IdentityT

406 , trans ~ IdentityT

466− ) => MonadState tag sInner (Handler (ZOOM tag z) trans m)

407+ ) => MonadState tag sInner (TaggedTrans (ZOOM tag z) trans m)

467 where

408 where

468 state =

409 state =

469 (coerce :: forall eff r a .

410 (coerce :: forall eff r a .

470− (r -> m a) ->

411+ (r -> m a) ->

471− (r -> Handler eff trans m a))

412+ (r -> TaggedTrans eff trans m a))

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

@@ -50,7 +50,7 @@ import Ether.Except

50import Ether.Reader

51import Ether.State

52import Ether.Writer

53−import Ether.Handler

53+import Ether.TaggedTrans

55import Control.Monad.Trans.Identity

56import Data.Coerce

@@ -58,131 +58,81 @@ import Data.Coerce

58-- | Encode type-level information for 'tagAttach'.

59data TAG_ATTACH t

61−type TagAttachT t = Handler (TAG_ATTACH t) IdentityT

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

68−instance

67+instance {-# OVERLAPPING #-}

69 ( MonadReader tag r m, trans ~ IdentityT

68 ( MonadReader tag r m, trans ~ IdentityT

70− ) => Mtl.MonadReader r (Handler (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 #-}

82−instance

75+instance {-# OVERLAPPING #-}

83 ( MonadState tag s m, trans ~ IdentityT

76 ( MonadState tag s m, trans ~ IdentityT

84− ) => Mtl.MonadState s (Handler (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 #-}

96−instance

83+instance {-# OVERLAPPING #-}

97 ( MonadExcept tag e m, trans ~ IdentityT

84 ( MonadExcept tag e m, trans ~ IdentityT

98− ) => Mtl.MonadError e (Handler (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

107−instance

90+instance {-# OVERLAPPING #-}

108 ( MonadWriter tag w m, trans ~ IdentityT

91 ( MonadWriter tag w m, trans ~ IdentityT

109− ) => Mtl.MonadWriter w (Handler (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

126

101

127−type TagReplaceT tOld tNew = Handler (TAG_REPLACE tOld tNew) IdentityT

102+type TagReplaceT tOld tNew = TaggedTrans (TAG_REPLACE tOld tNew) IdentityT

128

103

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 (Handler (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 (Handler (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 (Handler (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 (Handler (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.hsnew file+206

@@ -0,0 +1,206 @@

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

5+module Ether.TaggedTrans

6+ ( TaggedTrans(..)

7+ ) where

9+import Control.Applicative

10+import Control.Monad (MonadPlus)

11+import Control.Monad.Fix (MonadFix)

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

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

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

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

16+

17+import qualified Control.Monad.Base as MB

18+import qualified Control.Monad.Trans.Control as MC

19+

20+import qualified Control.Monad.Trans.Lift.StT as Lift

21+import qualified Control.Monad.Trans.Lift.Local as Lift

22+import qualified Control.Monad.Trans.Lift.Catch as Lift

23+import qualified Control.Monad.Trans.Lift.Listen as Lift

24+import qualified Control.Monad.Trans.Lift.Pass as Lift

25+import qualified Control.Monad.Trans.Lift.CallCC as Lift

26+

27+import qualified Control.Monad.Cont.Class as Mtl

28+import qualified Control.Monad.Reader.Class as Mtl

29+import qualified Control.Monad.State.Class as Mtl

30+import qualified Control.Monad.Writer.Class as Mtl

31+import qualified Control.Monad.Error.Class as Mtl

32+

33+import GHC.Generics (Generic)

34+import Data.Coerce (coerce)

35+

36+newtype TaggedTrans tag trans m a = TaggedTrans (trans m a)

37+ deriving

38+ ( Generic

39+ , Functor, Applicative, Alternative, Monad, MonadPlus

40+ , MonadFix, MonadTrans, MonadIO

41+ , MonadThrow, MonadCatch, MonadMask )

42+

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

44+

45+type Unpack tag trans m a = TaggedTrans tag trans m a -> trans m a

46+

47+instance

48+ ( MB.MonadBase b (trans m)

49+ ) => MB.MonadBase b (TaggedTrans tag trans m)

50+ where

51+ liftBase =

52+ (coerce :: forall a .

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

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

55+ MB.liftBase

56+

57+instance

58+ ( MC.MonadTransControl trans

59+ ) => MC.MonadTransControl (TaggedTrans tag trans)

60+ where

61+ type StT (TaggedTrans tag trans) a = MC.StT trans a

62+

63+ liftWith = MC.defaultLiftWith

64+ (coerce :: Pack tag trans m a)

65+ (coerce :: Unpack tag trans m a)

66+

67+ restoreT = MC.defaultRestoreT

68+ (coerce :: Pack tag trans m a)

69+

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

71+

72+newtype LiftBaseWith' b m a = LBW { unLBW :: LiftBaseWith b m a }

73+

74+coerceLiftBaseWith ::

75+ LiftBaseWith b (trans m) a ->

76+ LiftBaseWith b (TaggedTrans tag trans m) a

77+coerceLiftBaseWith lbw =

78+ unLBW (coerce (LBW lbw))

79+

80+instance

81+ ( MC.MonadBaseControl b (trans m)

82+ ) => MC.MonadBaseControl b (TaggedTrans tag trans m)

83+ where

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

85+

86+ liftBaseWith = coerceLiftBaseWith MC.liftBaseWith

87+

88+ restoreM =

89+ (coerce :: forall a .

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

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

92+ MC.restoreM

93+

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

95+

96+instance Lift.LiftLocal trans => Lift.LiftLocal (TaggedTrans tag trans) where

97+ liftLocal =

98+ Lift.defaultLiftLocal

99+ (coerce :: Pack tag trans m a)

100+ (coerce :: Unpack tag trans m a)

101+

102+instance Lift.LiftCatch trans => Lift.LiftCatch (TaggedTrans tag trans) where

103+ liftCatch =

104+ Lift.defaultLiftCatch

105+ (coerce :: Pack tag trans m a)

106+ (coerce :: Unpack tag trans m a)

107+

108+instance Lift.LiftListen trans => Lift.LiftListen (TaggedTrans tag trans) where

109+ liftListen =

110+ Lift.defaultLiftListen

111+ (coerce :: Pack tag trans m a)

112+ (coerce :: Unpack tag trans m a)

113+

114+instance Lift.LiftPass trans => Lift.LiftPass (TaggedTrans tag trans) where

115+ liftPass =

116+ Lift.defaultLiftPass

117+ (coerce :: Pack tag trans m a)

118+ (coerce :: Unpack tag trans m a)

119+

120+instance Lift.LiftCallCC trans => Lift.LiftCallCC (TaggedTrans tag trans) where

121+ liftCallCC =

122+ Lift.defaultLiftCallCC

123+ (coerce :: Pack tag trans m a)

124+ (coerce :: Unpack tag trans m a)

125+ liftCallCC' =

126+ Lift.defaultLiftCallCC'

127+ (coerce :: Pack tag trans m a)

128+ (coerce :: Unpack tag trans m a)

129+

130+

131+-- Instances for mtl classes

132+

133+instance

134+ ( Mtl.MonadCont m

135+ , Lift.LiftCallCC trans

136+ , Monad (trans m)

137+ ) => Mtl.MonadCont (TaggedTrans tag trans m)

138+ where

139+ callCC = Lift.liftCallCC' Mtl.callCC

140+

141+instance

142+ ( Mtl.MonadReader r m

143+ , Lift.LiftLocal trans

144+ , Monad (trans m)

145+ ) => Mtl.MonadReader r (TaggedTrans tag trans m)

146+ where

147+ ask = lift Mtl.ask

148+ local = Lift.liftLocal Mtl.ask Mtl.local

149+ reader = lift . Mtl.reader

150+

151+instance

152+ ( Mtl.MonadState s m

153+ , MonadTrans trans

154+ , Monad (trans m)

155+ ) => Mtl.MonadState s (TaggedTrans tag trans m)

156+ where

157+ get = lift Mtl.get

158+ put = lift . Mtl.put

159+ state = lift . Mtl.state

160+

161+instance

162+ ( Mtl.MonadWriter w m

163+ , Lift.LiftListen trans

164+ , Lift.LiftPass trans

165+ , Monad (trans m)

166+ ) => Mtl.MonadWriter w (TaggedTrans tag trans m)

167+ where

168+ writer = lift . Mtl.writer

169+ tell = lift . Mtl.tell

170+ listen = Lift.liftListen Mtl.listen

171+ pass = Lift.liftPass Mtl.pass

172+

173+instance

174+ ( Mtl.MonadError e m

175+ , Lift.LiftCatch trans

176+ , Monad (trans m)

177+ ) => Mtl.MonadError e (TaggedTrans tag trans m)

178+ where

179+ throwError = lift . Mtl.throwError

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.Handler

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 = Handler (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 (Handler (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) -> Handler 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 (Handler 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 (Handler 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