master..d7afb54 · typeable/ether

git.iko.soy/typeable/ether

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

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

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

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

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

11* Remove `Control.Ether.TH`.

6* Remove `Control.Ether.TH`.

12* Remove `Control.Ether.Abbr`.

7* Remove `Control.Ether.Abbr`.

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

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

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

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

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

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

16* Add zooming for `MonadState`.

11* Add zooming for `MonadState`.

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

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

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

42 Ether.State

32 Ether.State

43 Ether.Writer

33 Ether.Writer

44 Ether.Except

34 Ether.Except

45− Ether.TaggedTrans

35+ Ether.Handler

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.4.2,

59− transformers-lift >=0.2.0.1,

42+ transformers-lift >=0.1.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,

64− writer-cps-mtl >= 0.1.1.4,

65 exceptions >=0.8,

47 exceptions >=0.8,

66 template-haskell >=2.11,

48 template-haskell >=2.11,

67 tagged >=0.8.5,

49 tagged >=0.8.5,

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

101 ghc-options:

83 ghc-options:

102 -Wall -O2

84 -Wall -O2

103

104− if flag(disable-tup-instances)

105− cpp-options: -DDISABLE_TUP_INSTANCES

106−

107test-suite regression

86test-suite regression

108

109 build-depends:

88 build-depends:

110− base >=4.9 && <4.13,

89+ base >=4.9 && <4.11,

111 transformers >=0.4.2,

90 transformers >=0.4.2,

112 mtl >=2.2.1,

91 mtl >=2.2.1,

113 tasty >=0.10,

92 tasty >=0.10,

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

121 Regression.hs

100 Regression.hs

122

101

123 other-modules:

102 other-modules:

124− TupleInstances

125 Regression.T1

103 Regression.T1

126 Regression.T2

104 Regression.T2

127 Regression.T3

105 Regression.T3

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

172 ghc-options:

150 ghc-options:

173 -Wall -fno-warn-missing-signatures

151 -Wall -fno-warn-missing-signatures

174

152

175− if flag(disable-tup-instances)

176− cpp-options: -DDISABLE_TUP_INSTANCES

177−

178

153

179benchmark bench

154benchmark bench

180

155

181 build-depends:

156 build-depends:

182− base >=4.9 && <4.13,

157+ base >=4.9 && <4.11,

183 mtl >=2.2.1,

158 mtl >=2.2.1,

184 transformers >=0.4.2,

159 transformers >=0.4.2,

185 criterion >=1.1,

160 criterion >=1.1,

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

190 main-is:

165 main-is:

191 Bench.hs

166 Bench.hs

192

167

193− other-modules:

194− TupleInstances

195−

196 type:

168 type:

197 exitcode-stdio-1.0

169 exitcode-stdio-1.0

198

170

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

232

204

233 ghc-prof-options:

205 ghc-prof-options:

234 -fprof-auto

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

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

9 , module Ether.State

10 , module Ether.Except

11 , module Ether.TagDispatch

12− , module Ether.TaggedTrans

12+ , module Ether.Handler

13 ) where

15import Control.Monad

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

22import Ether.State

23import Ether.Except

24import Ether.TagDispatch

25−import Ether.TaggedTrans

25+import Ether.Handler

src/Ether/Except.hs+21−7

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

33import Data.Coerce

34import Data.Functor.Identity

36−import Ether.TaggedTrans

36+import Ether.Handler

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 TaggedTrans function to handle previous exceptions and return to

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

45 -- normal execution.

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

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

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

68--

72--

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

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

70-- the first exception.

74-- the first exception.

71−type ExceptT tag e = TaggedTrans (TAGGED EXCEPT tag) (T.ExceptT e)

75+type ExceptT tag e = Handler (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 (Handler (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 -> Handler 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 (Handler 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/Handler.hsnew file+177

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

1+module Ether.Handler

2+ ( Handler(..)

3+ ) where

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

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

6 , LensLike

7 , Lens

8 , Lens'

9− , ReifiedLens(..)

10− , ReifiedLens'

11 , view

9 , view

12 , over

10 , over

13 , HList(..)

11 , HList(..)

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

16 , HandleSuper

14 , HandleSuper

17 , HandleConstraint

15 , HandleConstraint

18 , Handle(..)

16 , Handle(..)

19− , makeTupleInstancesHasLens

20 ) where

17 ) where

22import Control.Applicative

19import Control.Applicative

20+import Control.Monad

23import Data.Coerce

21import Data.Coerce

24import Data.Functor.Identity

22import Data.Functor.Identity

25import Data.Kind

23import Data.Kind

24+import Data.List as List

26import Data.Tagged

25import Data.Tagged

26+import Data.Traversable

27import GHC.Exts (Constraint)

28−

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

30data TAGGED e t

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

57 where

53 where

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

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

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

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

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−type ReifiedLens' s a = ReifiedLens s s a a

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

63+ lensOf :: Lens' outer inner

64+

65+instance HasLens a a a where

66+ lensOf = id

67+ {-# INLINE lensOf #-}

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

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

65view l = coerce (l Const)

70view l = coerce (l Const)

71+{-# INLINE view #-}

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

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

68over = coerce

74over = 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.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+47−19

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

45import Data.Functor.Identity

46import Data.Kind

48−import Ether.TaggedTrans

48+import Ether.Handler

49import Ether.Internal

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

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

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

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

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

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

88 where

94 where

90 ask =

96 ask =

91 (coerce ::

97 (coerce ::

92− TaggedTrans effs trans m r ->

98+ Handler effs trans m r ->

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

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

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

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

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

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

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

130--

140--

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

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

132-- the inherited environment to both subcomputations.

142-- the inherited environment to both subcomputations.

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

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

134

144

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

158 , Monad m, Monad (trans m)

172 , Monad m, Monad (trans m)

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

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

160 where

174 where

161

175

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 (Handler 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) -> Handler eff trans m a

191+ {-# INLINE reader #-}

175

192

176instance

193instance

177 ( HasLens tag payload r

194 ( HasLens tag payload r

178 , Handle READER payload trans

195 , Handle READER payload trans

179 , Monad m, Monad (trans m)

196 , Monad m, Monad (trans m)

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

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

181 where

198 where

182

199

183 ask =

200 ask =

184 handling @READER @payload @trans @m $

201 handling @READER @payload @trans @m $

185 (coerce :: forall eff a .

202 (coerce :: forall eff a .

186 trans m a ->

203 trans m a ->

187− TaggedTrans eff trans m a)

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

192 (coerce :: forall eff a .

210 (coerce :: forall eff a .

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

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

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

200

219

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

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

202

221

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

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

85import Data.Proxy

86import Data.Reflection

88+import Ether.Handler

88import Ether.Internal

89import Ether.Internal

89−import Ether.TaggedTrans

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

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

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

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

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

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

125 where

131 where

126

132

127 get =

133 get =

128 (coerce ::

134 (coerce ::

129− TaggedTrans effs trans m s ->

135+ Handler effs trans m s ->

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

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

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

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

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

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

143 (state @tag)

151 (state @tag)

152+ {-# INLINE state #-}

153+

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

155+data STATE

144

156

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

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

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

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

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

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

160+{-# INLINABLE modify #-}

148

161

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

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

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

151gets f = fmap f (get @tag)

164gets f = fmap f (get @tag)

152−

165+{-# INLINABLE gets #-}

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

154−data STATE

155

166

156type instance HandleSuper STATE s trans = ()

167type instance HandleSuper STATE s trans = ()

157type instance HandleConstraint STATE s trans m =

168type instance HandleConstraint STATE s trans m =

@@ -159,56 +170,64 @@ 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

168 , Monad m, Monad (trans m)

181 , Monad m, Monad (trans m)

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

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

170 where

183 where

171

184

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)) -> Handler eff trans m a

199+ {-# INLINE state #-}

184

200

185instance

201instance

186 ( HasLens tag payload s

202 ( HasLens tag payload s

187 , Handle STATE payload trans

203 , Handle STATE payload trans

188 , Monad m, Monad (trans m)

204 , Monad m, Monad (trans m)

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

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

190 where

206 where

191

207

192 get =

208 get =

193 handling @STATE @payload @trans @m $

209 handling @STATE @payload @trans @m $

194 (coerce :: forall eff a .

210 (coerce :: forall eff a .

195 trans m a ->

211 trans m a ->

196− TaggedTrans eff trans m a)

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

201 (coerce :: forall eff a .

218 (coerce :: forall eff a .

202 trans m a ->

219 trans m a ->

203− TaggedTrans eff trans m a)

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

208 (coerce :: forall eff a .

226 (coerce :: forall eff a .

209 trans m a ->

227 trans m a ->

210− TaggedTrans eff trans m a)

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

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

222--

241--

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

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

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

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

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

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

226

245

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

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

270--

296--

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

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

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

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

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

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

274

300

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

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

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

312

345

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

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

314

347

315type States s = StatesT s Identity

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

392

446

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

447+type ZoomT t (z :: Type) = Handler (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

394

452

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

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

396zoom

454zoom

@@ -399,17 +457,19 @@ zoom

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

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

400 -> m a

458 -> m a

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

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

460+{-# INLINE zoom #-}

402

461

403instance

462instance

404 ( MonadState tag sOuter m

463 ( MonadState tag sOuter m

405 , Reifies z (ReifiedLens' sOuter sInner)

464 , Reifies z (ReifiedLens' sOuter sInner)

406 , trans ~ IdentityT

465 , trans ~ IdentityT

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

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

408 where

467 where

409 state =

468 state =

410 (coerce :: forall eff r a .

469 (coerce :: forall eff r a .

411− (r -> m a) ->

470+ (r -> m a) ->

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

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

413 (state @tag . l)

472 (state @tag . l)

414 where

473 where

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

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

475+ {-# INLINE state #-}

src/Ether/TagDispatch.hs+65−15

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

50import Ether.Reader

51import Ether.State

52import Ether.Writer

53−import Ether.TaggedTrans

53+import Ether.Handler

55import Control.Monad.Trans.Identity

56import Data.Coerce

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

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

59data TAG_ATTACH t

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

61+type TagAttachT t = Handler (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 #-}

67−instance {-# OVERLAPPING #-}

68+instance

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

75−instance {-# OVERLAPPING #-}

82+instance

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

83−instance {-# OVERLAPPING #-}

96+instance

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

90−instance {-# OVERLAPPING #-}

107+instance

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

101

126

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

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

103

128

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 (Handler (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 (Handler (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 (Handler (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 (Handler (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.hsdeleted−206

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

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−

5−module Ether.TaggedTrans

6− ( TaggedTrans(..)

7− ) where

8−

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

@@ -17,15 +17,6 @@ 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

29 -- * MonadWriter class (implicit)

20 -- * MonadWriter class (implicit)

30 , MonadWriter'

21 , MonadWriter'

31 , writer'

22 , writer'

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

43 , writerT'

34 , writerT'

44 , runWriterT'

35 , runWriterT'

45 , execWriterT'

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

55 -- * Internal labels

37 -- * Internal labels

56 , TAGGED

38 , TAGGED

57 , WRITER

39 , WRITER

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

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

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

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

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

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

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

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

45+import qualified Control.Monad.Writer as T

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

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

66import Data.Coerce

46import Data.Coerce

67import Data.Functor.Identity

47import Data.Functor.Identity

49+import Ether.Handler

69import Ether.Internal

50import Ether.Internal

70−import Ether.TaggedTrans

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

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

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

96 , MonadWriter tag w m

76 , MonadWriter tag w m

97 , Monoid w

77 , Monoid w

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

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

79+

99 writer = Lift.lift . writer @tag

80 writer = Lift.lift . writer @tag

81+ {-# INLINE writer #-}

82+

100 tell = Lift.lift . tell @tag

83 tell = Lift.lift . tell @tag

84+ {-# INLINE tell #-}

85+

101 listen = Lift.liftListen (listen @tag)

86 listen = Lift.liftListen (listen @tag)

87+ {-# INLINE listen #-}

88+

102 pass = Lift.liftPass (pass @tag)

89 pass = Lift.liftPass (pass @tag)

90+ {-# INLINE pass #-}

103

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

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

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

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

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

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

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

118data WRITER

106data WRITER

119

107

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−

155-- | The parametrizable writer monad.

108-- | The parametrizable writer monad.

156--

109--

157-- Computations can accumulate a monoid value.

110-- Computations can accumulate a monoid value.

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

164--

117--

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

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

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

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

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

120+type WriterT tag w = Handler (TAGGED WRITER tag) (T.WriterT w)

168

121

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

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

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

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

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

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

172

125

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

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

174-- and the final accumulator.

127-- and the final accumulator.

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

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

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

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

177

130

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

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

179-- and the final accumulator.

132-- and the final accumulator.

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

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

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

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

182

135

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

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

184-- discarding the normal value.

137-- discarding the normal value.

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

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

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

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

187

140

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

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

189-- discarding the normal value.

142-- discarding the normal value.

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

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

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

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

192

145

193−-- | The parametrizable writer monad.

146+type instance HandleSuper WRITER w trans = Monoid w

194−--

147+type instance HandleConstraint WRITER w trans m =

195−-- Computations can accumulate a monoid value.

148+ T.MonadWriter w (trans m)

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

200

149

201−-- | The writer monad transformer.

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

202−--

151+ handling r = r

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

152+ {-# INLINE handling #-}

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

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

206

153

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

154+instance

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

155+ ( Handle WRITER w trans

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

156+ , Monad m, Monad (trans m)

157+ ) => MonadWriter tag w (Handler (TAGGED WRITER tag) trans m)

158+ where

210

159

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

160+ writer =

212−-- and the final accumulator.

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

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

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

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

163+ forall eff a . (a, w) -> Handler eff trans m a

164+ {-# INLINE writer #-}

215

165

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

166+ tell =

217−-- and the final accumulator.

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

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

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

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

169+ {-# INLINE tell #-}

220

170

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

171+ listen =

222−-- discarding the normal value.

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

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

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

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

174+ forall eff a . Listen w (Handler eff trans m) a

175+ {-# INLINE listen #-}

225

176

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

177+ pass =

227−-- discarding the normal value.

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

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

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

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

180+ forall eff a . Pass w (Handler eff trans m) a

181+ {-# INLINE pass #-}

230

182

231type Writer' w = Writer w w

183type Writer' w = Writer w w

232

184

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

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

234runWriter' = runWriter

186runWriter' = runWriter

235

187

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

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

237execWriter' = execWriter

189execWriter' = execWriter

238

190

239type WriterT' w = WriterT w w

191type WriterT' w = WriterT w w

240

192

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

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

242writerT' = writerT

194writerT' = writerT

243

195

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

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

245runWriterT' = runWriterT

197runWriterT' = runWriterT

246

198

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

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

248execWriterT' = execWriterT

200execWriterT' = execWriterT

249

201

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−

269type MonadWriter' w = MonadWriter w w

202type MonadWriter' w = MonadWriter w w

270

203

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

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

stack.yamlnew file+2

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

1+resolver: lts-8.12

2+packages: ['.']

test/Regression/T1.hs+2−14

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

1module Regression.T1 (test1) where

3import Ether

4−import TupleInstances ()

5−import Data.List (group)

7import Test.Tasty

5import Test.Tasty

8import Test.Tasty.QuickCheck

6import Test.Tasty.QuickCheck

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

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

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

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

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

33test1 :: TestTree

27test1 :: TestTree

34test1 = testGroup "T1: Reader local environment"

28test1 = testGroup "T1: Reader local environment"

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

38 , testProperty "runner₂ works"

32 , testProperty "runner₂ works"

39 $ \s1 s2 -> property

33 $ \s1 s2 -> property

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

34 $ 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))

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

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

45 $ \s1 s2 -> property

36 $ \s1 s2 -> property

46− $ same

47− [ runner1 s1 s2 testEther

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

48− , runner2 s1 s2 testEther

49− , runner3 s1 s2 testEther ]

50 ]

38 ]

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