git.iko.soy/typeable/ether
on master help sign in
Unify TaggedTrans and DispatchT
0cd5cd6Index Int
ether-flatten/src/Control/Ether/Flatten.hs+5−4
compare with master
unifiedsplit
@@ -58,7 +58,8 @@ instance a ~ b => HasLens tag (Product (tag ': tags) (a ': as)) b where
58 {-# INLINE lensOf #-}
58 {-# INLINE lensOf #-}
59
59
60instance {-# OVERLAPPABLE #-}
60instance {-# OVERLAPPABLE #-}
61− ( HasLens tag (Product tags as) a
61+ ( HasLens tag (Product tags as) a
62− ) => HasLens tag (Product (t ': tags) (b ': as)) a where
62+ ) => HasLens tag (Product (t ': tags) (b ': as)) a
63+ where
63− lensOf t = productTail . lensOf t
64+ lensOf t = productTail . lensOf t
64− {-# INLINE lensOf #-}
65+ {-# INLINE lensOf #-}
ether-flatten/src/Control/Monad/Ether/Reader/Flatten.hs+38−24
@@ -24,43 +24,57 @@ import qualified Control.Monad.Trans.Reader as T
24import Control.Lens
24import Control.Lens
25import Control.Ether.Flatten
25import Control.Ether.Flatten
26
26
27−data K_Flatten t = Flatten [t]
27+data K_FLATTEN t = FLATTEN [t]
28
28
29−type DispatchFlattenT ts = DispatchT (Flatten ts)
29+type FlattenT ts r = Dispatch (FLATTEN ts) (T.ReaderT r)
30
30
31reflatten
31reflatten
32− :: forall tagsOld tagsNew m a
32+ :: forall tagsOld tagsNew r m a
33− . DispatchFlattenT tagsOld m a
33+ . FlattenT tagsOld r m a
34− -> DispatchFlattenT tagsNew m a
34+ -> FlattenT tagsNew r m a
35−reflatten = redispatch
35+reflatten = repack
36{-# INLINE reflatten #-}
36{-# INLINE reflatten #-}
37
37
38−type DispatchFlattenReaderT ts r m = DispatchFlattenT ts (T.ReaderT r m)
38+instance
39+ ( Monad m, Monad (trans m)
40+ , Lift.MonadTrans trans
41+ , Lift.LiftLocal trans
42+ , C.MonadReader tag r m
43+ ) => C.MonadReader tag r (Dispatch (FLATTEN '[]) trans m)
44+ where
45+ ask t = Lift.lift (ask t)
46+ local t = Lift.liftLocal (ask t) (local t)
39
47
40−instance (Monad m, C.MonadReader tag r m)
48+instance
41− => C.MonadReader tag r (DispatchFlattenReaderT '[] payload m) where
42− ask t = Lift.lift (ask t)
43− local t = Lift.liftLocal (ask t) (local t)
44−
45−instance (Monad m, HasLens tag payload r)
49+ ( Monad m, HasLens tag payload r
50+ , trans ~ T.ReaderT payload
46− => C.MonadReader tag r (DispatchFlattenReaderT (tag ': tags) payload m) where
51+ ) => C.MonadReader tag r (Dispatch (FLATTEN (tag ': tags)) trans m)
52+ where
47− ask t = dispatchT $ view (lensOf t)
53+ ask t = pack $ view (lensOf t)
48− local t f = dispatchT . T.local (over (lensOf t) f) . runDispatchT
54+ local t f = pack . T.local (over (lensOf t) f) . unpack
49
55
50instance {-# OVERLAPPABLE #-}
56instance {-# OVERLAPPABLE #-}
57+ ( Monad m
51− (Monad m, C.MonadReader tag r (DispatchFlattenReaderT tags payload m))
58+ , C.MonadReader tag r (Dispatch (FLATTEN tags) trans m)
59+ , trans ~ T.ReaderT payload
52− => C.MonadReader tag r (DispatchFlattenReaderT (t ': tags) payload m) where
60+ ) => C.MonadReader tag r (Dispatch (FLATTEN (t ': tags)) trans m)
61+ where
53− ask t = reflatten @tags @(t ': tags) (C.ask t)
62+ ask t = reflatten @tags @(t ': tags) (C.ask t)
63+ {-# INLINE ask #-}
64+ local t f
54− local t f = reflatten @tags @(t ': tags) . C.local t f . reflatten @(t ': tags) @tags
65+ = reflatten @tags @(t ': tags)
66+ . C.local t f
67+ . reflatten @(t ': tags) @tags
68+ {-# INLINE local #-}
55
69
56runReaderT
70runReaderT
57− :: DispatchFlattenReaderT tags (Product tags as) m a
71+ :: FlattenT tags (Product tags as) m a
58 -> Product tags as
72 -> Product tags as
59 -> m a
73 -> m a
60−runReaderT m = T.runReaderT (runDispatchT m)
74+runReaderT m = T.runReaderT (unpack m)
61
75
62runReader
76runReader
63− :: DispatchFlattenReaderT tags (Product tags as) Identity a
77+ :: FlattenT tags (Product tags as) Identity a
64 -> Product tags as
78 -> Product tags as
65 -> a
79 -> a
66−runReader m = T.runReader (runDispatchT m)
80+runReader m = T.runReader (unpack m)
ether-zoom/ether-zoom.cabal+1
@@ -26,6 +26,7 @@ library
26 exposed-modules: Control.Monad.Ether.State.Zoom
26 exposed-modules: Control.Monad.Ether.State.Zoom
27 build-depends: base >=4.9 && <4.10
27 build-depends: base >=4.9 && <4.10
28 , ether >=0.5 && <0.6
28 , ether >=0.5 && <0.6
29+ , transformers >=0.5
29 , lens >=4.14
30 , lens >=4.14
30 , reflection >=2.1
31 , reflection >=2.1
31
32
ether-zoom/src/Control/Monad/Ether/State/Zoom.hs+17−11
@@ -6,34 +6,40 @@
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE UndecidableInstances #-}
8{-# LANGUAGE UndecidableInstances #-}
9+{-# LANGUAGE TypeFamilies #-}
9
10
10module Control.Monad.Ether.State.Zoom
11module Control.Monad.Ether.State.Zoom
11− ( K_TagZoom(..)
12+ ( K_TAG_ZOOM(..)
13+ , TagZoomT
12 , tagZoom
14 , tagZoom
13 ) where
15 ) where
14
16
15import Control.Lens
17import Control.Lens
16import Data.Reflection
18import Data.Reflection
17import Control.Monad.Trans.Ether.Dispatch
19import Control.Monad.Trans.Ether.Dispatch
20+import Control.Monad.Trans.Identity
18import Control.Monad.Ether.State.Class
21import Control.Monad.Ether.State.Class
19import Data.Proxy
22import Data.Proxy
20
23
21-- | Encode type-level information for 'tagZoom'.
24-- | Encode type-level information for 'tagZoom'.
22−data K_TagZoom t z = TagZoom t z
25+data K_TAG_ZOOM t z = TAG_ZOOM t z
23
26
24−type DispatchTagZoomT t (z :: *) = DispatchT (TagZoom t z)
27+type TagZoomT t (z :: *) = Dispatch (TAG_ZOOM t z) IdentityT
25
28
26-- | Zoom into a part of a state using a lens.
29-- | Zoom into a part of a state using a lens.
27tagZoom
30tagZoom
28 :: forall tag sOuter sInner m a
31 :: forall tag sOuter sInner m a
29 . Lens' sOuter sInner
32 . Lens' sOuter sInner
30− -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => DispatchTagZoomT tag z m a)
33+ -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => TagZoomT tag z m a)
31 -> m a
34 -> m a
32−tagZoom l m = reify (Lens l) (\(_ :: Proxy z) -> runDispatchT (m @z))
35+tagZoom l m = reify (Lens l) (\(_ :: Proxy z) -> (runIdentityT . unpack) (m @z))
33
36
37+instance
34−instance ( MonadState tag sOuter m
38+ ( MonadState tag sOuter m
35− , Reifies z (ReifiedLens' sOuter sInner)
39+ , Reifies z (ReifiedLens' sOuter sInner)
40+ , trans ~ IdentityT
36− ) => MonadState tag sInner (DispatchTagZoomT tag z m) where
41+ ) => MonadState tag sInner (Dispatch (TAG_ZOOM tag z) trans m)
42+ where
37− state t = dispatchT . state t . l
43+ state t =
38− where
39− Lens l = reflect (Proxy :: Proxy z)
44+ let Lens l = reflect (Proxy :: Proxy z)
45+ in pack . IdentityT . state t . l
ether/ether.cabal+2−7
@@ -28,15 +28,10 @@ library
28
28
29 exposed-modules: Control.Ether.Abbr
29 exposed-modules: Control.Ether.Abbr
30 Control.Ether.Implicit.Abbr
30 Control.Ether.Implicit.Abbr
31− Control.Monad.Trans.Ether.Reader
32− Control.Monad.Trans.Ether.Writer
33− Control.Monad.Trans.Ether.State
34− Control.Monad.Trans.Ether.State.Lazy
35− Control.Monad.Trans.Ether.State.Strict
36− Control.Monad.Trans.Ether.Except
37 Control.Monad.Trans.Ether.Dispatch
31 Control.Monad.Trans.Ether.Dispatch
38− Control.Monad.Trans.Ether.Tagged
39 Control.Monad.Ether
32 Control.Monad.Ether
33+ Control.Monad.Ether.TagAttach
34+ Control.Monad.Ether.TagReplace
40 Control.Monad.Ether.Reader
35 Control.Monad.Ether.Reader
41 Control.Monad.Ether.Reader.Class
36 Control.Monad.Ether.Reader.Class
42 Control.Monad.Ether.Writer
37 Control.Monad.Ether.Writer
ether/src/Control/Monad/Ether.hs+2−1
@@ -10,4 +10,5 @@ import Control.Monad.Ether.Reader as X
10import Control.Monad.Ether.Writer as X
10import Control.Monad.Ether.Writer as X
11import Control.Monad.Ether.State as X
11import Control.Monad.Ether.State as X
12import Control.Monad.Ether.Except as X
12import Control.Monad.Ether.Except as X
13−import Control.Monad.Trans.Ether.Dispatch as X (tagAttach, tagReplace)
13+import Control.Monad.Ether.TagAttach as X
14+import Control.Monad.Ether.TagReplace as X
ether/src/Control/Monad/Ether/Except.hs+45−2
@@ -1,3 +1,9 @@
1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE TypeFamilies #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
7{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE MagicHash #-}
8{-# LANGUAGE MagicHash #-}
3
9
@@ -24,8 +30,9 @@ module Control.Monad.Ether.Except
24import GHC.Prim (Proxy#, proxy#)
30import GHC.Prim (Proxy#, proxy#)
25import Control.Monad.Ether.Except.Class (MonadExcept)
31import Control.Monad.Ether.Except.Class (MonadExcept)
26import qualified Control.Monad.Ether.Except.Class as C
32import qualified Control.Monad.Ether.Except.Class as C
27−import Control.Monad.Trans.Ether.Except hiding (throw, catch)
33+import qualified Control.Monad.Trans.Ether.Dispatch as D
34+import qualified Control.Monad.Trans.Except as T
28−import Data.Functor.Identity (Identity(..))
35+import Data.Functor.Identity
29
36
30-- | Is used within a monadic computation to begin exception processing.
37-- | Is used within a monadic computation to begin exception processing.
31throw :: forall tag e m a . MonadExcept tag e m => e -> m a
38throw :: forall tag e m a . MonadExcept tag e m => e -> m a
@@ -43,3 +50,39 @@ handle h m = runIdentity (handleT @tag h m)
43-- | Runs an 'ExceptT' and handles the exception with the given function.
50-- | Runs an 'ExceptT' and handles the exception with the given function.
44handleT :: forall tag e m a . Functor m => (e -> a) -> ExceptT tag e m a -> m a
51handleT :: forall tag e m a . Functor m => (e -> a) -> ExceptT tag e m a -> m a
45handleT h m = fmap (either h id) (runExceptT @tag m)
52handleT h m = fmap (either h id) (runExceptT @tag m)
53+
54+-- | Encode type-level information for 'ExceptT'.
55+data K_EXCEPT t e = EXCEPT t e
56+
57+-- | The parameterizable exception monad.
58+--
59+-- Computations are either exceptions or normal values.
60+--
61+-- The 'return' function returns a normal value, while '>>=' exits on
62+-- the first exception.
63+type Except tag e = ExceptT tag e Identity
64+
65+-- | The exception monad transformer.
66+--
67+-- The 'return' function returns a normal value, while '>>=' exits on
68+-- the first exception.
69+type ExceptT tag e = D.Dispatch (EXCEPT tag e) (T.ExceptT e)
70+
71+-- | Runs an 'Except' and returns either an exception or a normal value.
72+runExcept :: forall tag e a . Except tag e a -> Either e a
73+runExcept = T.runExcept . D.unpack
74+
75+-- | Runs an 'ExceptT' and returns either an exception or a normal value.
76+runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)
77+runExceptT = T.runExceptT . D.unpack
78+
79+-- | Constructor for computations in the exception monad transformer.
80+exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
81+exceptT = D.pack . T.ExceptT
82+
83+instance
84+ ( Monad m, e ~ e', trans ~ T.ExceptT e
85+ ) => MonadExcept tag e (D.Dispatch (EXCEPT tag e') trans m)
86+ where
87+ throw _ = D.pack . T.throwE
88+ catch _ m h = D.pack $ T.catchE (D.unpack m) (D.unpack . h)
ether/src/Control/Monad/Ether/Except/Class.hs−5
@@ -10,7 +10,6 @@ module Control.Monad.Ether.Except.Class
10 ) where
10 ) where
11
11
12import GHC.Prim (Proxy#)
12import GHC.Prim (Proxy#)
13−import qualified Control.Monad.Trans.Ether.Except as E
14import qualified Control.Monad.Trans.Lift.Catch as Lift
13import qualified Control.Monad.Trans.Lift.Catch as Lift
15
14
16-- | See 'Control.Monad.Except.MonadError'.
15-- | See 'Control.Monad.Except.MonadError'.
@@ -23,10 +22,6 @@ class Monad m => MonadExcept tag e m | m tag -> e where
23 -- normal execution.
22 -- normal execution.
24 catch :: Proxy# tag -> m a -> (e -> m a) -> m a
23 catch :: Proxy# tag -> m a -> (e -> m a) -> m a
25
24
26−instance (Monad m, e ~ e') => MonadExcept tag e (E.ExceptT tag e' m) where
27− throw _ = E.throw @tag
28− catch _ = E.catch @tag
29−
30instance {-# OVERLAPPABLE #-}
25instance {-# OVERLAPPABLE #-}
31 ( Lift.LiftCatch t
26 ( Lift.LiftCatch t
32 , Monad (t m)
27 , Monad (t m)
ether/src/Control/Monad/Ether/Implicit.hs+2−1
@@ -10,4 +10,5 @@ import Control.Monad.Ether.Implicit.Reader as X
10import Control.Monad.Ether.Implicit.Writer as X
10import Control.Monad.Ether.Implicit.Writer as X
11import Control.Monad.Ether.Implicit.State as X
11import Control.Monad.Ether.Implicit.State as X
12import Control.Monad.Ether.Implicit.Except as X
12import Control.Monad.Ether.Implicit.Except as X
13−import Control.Monad.Trans.Ether.Dispatch as X
13+import Control.Monad.Ether.TagAttach as X
14+import Control.Monad.Ether.TagReplace as X
ether/src/Control/Monad/Ether/Reader.hs+49−1
@@ -1,3 +1,9 @@
1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE TypeFamilies #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
7{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE MagicHash #-}
8{-# LANGUAGE MagicHash #-}
3
9
@@ -23,7 +29,9 @@ module Control.Monad.Ether.Reader
23import GHC.Prim (Proxy#, proxy#)
29import GHC.Prim (Proxy#, proxy#)
24import Control.Monad.Ether.Reader.Class (MonadReader)
30import Control.Monad.Ether.Reader.Class (MonadReader)
25import qualified Control.Monad.Ether.Reader.Class as C
31import qualified Control.Monad.Ether.Reader.Class as C
26−import Control.Monad.Trans.Ether.Reader hiding (reader, ask, local)
32+import qualified Control.Monad.Trans.Ether.Dispatch as D
33+import qualified Control.Monad.Trans.Reader as T
34+import Data.Functor.Identity
27
35
28-- | Retrieves the monad environment.
36-- | Retrieves the monad environment.
29ask :: forall tag r m . MonadReader tag r m => m r
37ask :: forall tag r m . MonadReader tag r m => m r
@@ -57,3 +65,43 @@ asks
57 -- ^ The selector function to apply to the environment.
65 -- ^ The selector function to apply to the environment.
58 -> m a
66 -> m a
59asks = C.reader (proxy# :: Proxy# tag)
67asks = C.reader (proxy# :: Proxy# tag)
68+
69+-- | Encode type-level information for 'ReaderT'.
70+data K_READER t r = READER t r
71+
72+-- | The parameterizable reader monad.
73+--
74+-- Computations are functions of a shared environment.
75+--
76+-- The 'return' function ignores the environment, while '>>=' passes
77+-- the inherited environment to both subcomputations.
78+type Reader tag r = ReaderT tag r Identity
79+
80+-- | The reader monad transformer,
81+-- which adds a read-only environment to the given monad.
82+--
83+-- The 'return' function ignores the environment, while '>>=' passes
84+-- the inherited environment to both subcomputations.
85+type ReaderT tag r = D.Dispatch (READER tag r) (T.ReaderT r)
86+
87+-- | Constructor for computations in the reader monad transformer.
88+readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
89+readerT = D.pack . T.ReaderT
90+
91+-- | Runs a 'ReaderT' with the given environment
92+-- and returns the final value.
93+runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a
94+runReaderT = T.runReaderT . D.unpack
95+
96+-- | Runs a 'ReaderT' with the given environment
97+-- and returns the final value.
98+runReader :: forall tag r a . Reader tag r a -> r -> a
99+runReader = T.runReader . D.unpack
100+
101+instance
102+ ( Monad m, r ~ r', trans ~ T.ReaderT r
103+ ) => MonadReader tag r (D.Dispatch (READER tag r') trans m)
104+ where
105+ ask _ = D.pack T.ask
106+ local _ f = D.pack . T.withReaderT f . D.unpack
107+ reader _ = D.pack . T.reader
ether/src/Control/Monad/Ether/Reader/Class.hs−6
@@ -10,7 +10,6 @@ module Control.Monad.Ether.Reader.Class
10 ) where
10 ) where
11
11
12import GHC.Prim (Proxy#)
12import GHC.Prim (Proxy#)
13−import qualified Control.Monad.Trans.Ether.Reader as R
14import qualified Control.Monad.Trans.Lift.Local as Lift
13import qualified Control.Monad.Trans.Lift.Local as Lift
15
14
16-- | See 'Control.Monad.Reader.MonadReader'.
15-- | See 'Control.Monad.Reader.MonadReader'.
@@ -39,11 +38,6 @@ class Monad m => MonadReader tag r m | m tag -> r where
39 -> m a
38 -> m a
40 reader t f = fmap f (ask t)
39 reader t f = fmap f (ask t)
41
40
42−instance (Monad m, r ~ r') => MonadReader tag r (R.ReaderT tag r' m) where
43− ask _ = R.ask @tag
44− local _ = R.local @tag
45− reader _ = R.reader @tag
46−
47instance {-# OVERLAPPABLE #-}
41instance {-# OVERLAPPABLE #-}
48 ( Lift.LiftLocal t
42 ( Lift.LiftLocal t
49 , Monad (t m)
43 , Monad (t m)
ether/src/Control/Monad/Ether/State/Class.hs−12
@@ -10,8 +10,6 @@ module Control.Monad.Ether.State.Class
10 ) where
10 ) where
11
11
12import GHC.Prim (Proxy#)
12import GHC.Prim (Proxy#)
13−import qualified Control.Monad.Trans.Ether.State.Lazy as S.L
14−import qualified Control.Monad.Trans.Ether.State.Strict as S.S
15import qualified Control.Monad.Trans as Lift
13import qualified Control.Monad.Trans as Lift
16
14
17-- | See 'Control.Monad.State.MonadState'.
15-- | See 'Control.Monad.State.MonadState'.
@@ -35,16 +33,6 @@ class Monad m => MonadState tag s m | m tag -> s where
35 put t s'
33 put t s'
36 return a
34 return a
37
35
38−instance (Monad m, s ~ s') => MonadState tag s (S.L.StateT tag s' m) where
39− get _ = S.L.get @tag
40− put _ = S.L.put @tag
41− state _ = S.L.state @tag
42−
43−instance (Monad m, s ~ s') => MonadState tag s (S.S.StateT tag s' m) where
44− get _ = S.S.get @tag
45− put _ = S.S.put @tag
46− state _ = S.S.state @tag
47−
48instance {-# OVERLAPPABLE #-}
36instance {-# OVERLAPPABLE #-}
49 ( Lift.MonadTrans t
37 ( Lift.MonadTrans t
50 , Monad (t m)
38 , Monad (t m)
ether/src/Control/Monad/Ether/State/Lazy.hs+69−1
@@ -1,3 +1,9 @@
1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE TypeFamilies #-}
1
7
2-- | See "Control.Monad.State.Lazy".
8-- | See "Control.Monad.State.Lazy".
3
9
@@ -24,4 +30,66 @@ module Control.Monad.Ether.State.Lazy
24 ) where
30 ) where
25
31
26import Control.Monad.Ether.State.Common
32import Control.Monad.Ether.State.Common
33+import qualified Control.Monad.Ether.State.Class as C
27−import Control.Monad.Trans.Ether.State.Lazy hiding (state, get, put)
34+import qualified Control.Monad.Trans.Ether.Dispatch as D
35+import qualified Control.Monad.Trans.State.Lazy as T
36+import Data.Functor.Identity
37+
38+-- | Encode type-level information for 'StateT'.
39+data K_STATE t s = STATE t s
40+
41+-- | The parametrizable state monad.
42+--
43+-- Computations have access to a mutable state.
44+--
45+-- The 'return' function leaves the state unchanged, while '>>=' uses
46+-- the final state of the first computation as the initial state of the second.
47+type State tag r = StateT tag r Identity
48+
49+-- | The state monad transformer.
50+--
51+-- The 'return' function leaves the state unchanged, while '>>=' uses
52+-- the final state of the first computation as the initial state of the second.
53+type StateT tag s = D.Dispatch (STATE tag s) (T.StateT s)
54+
55+-- | Constructor for computations in the state monad transformer.
56+stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
57+stateT = D.pack . T.StateT
58+
59+-- | Runs a 'StateT' with the given initial state
60+-- and returns both the final value and the final state.
61+runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
62+runStateT = T.runStateT . D.unpack
63+
64+-- | Runs a 'StateT' with the given initial state
65+-- and returns the final value, discarding the final state.
66+evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
67+evalStateT = T.evalStateT . D.unpack
68+
69+-- | Runs a 'StateT' with the given initial state
70+-- and returns the final state, discarding the final value.
71+execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
72+execStateT = T.execStateT . D.unpack
73+
74+-- | Runs a 'State' with the given initial state
75+-- and returns both the final value and the final state.
76+runState :: forall tag s a . State tag s a -> s -> (a, s)
77+runState = T.runState . D.unpack
78+
79+-- | Runs a 'State' with the given initial state
80+-- and returns the final value, discarding the final state.
81+evalState :: forall tag s a . State tag s a -> s -> a
82+evalState = T.evalState . D.unpack
83+
84+-- | Runs a 'State' with the given initial state
85+-- and returns the final state, discarding the final value.
86+execState :: forall tag s a . State tag s a -> s -> s
87+execState = T.execState . D.unpack
88+
89+instance
90+ ( Monad m, s ~ s', trans ~ T.StateT s
91+ ) => MonadState tag s (D.Dispatch (STATE tag s') trans m)
92+ where
93+ get _ = D.pack T.get
94+ put _ = D.pack . T.put
95+ state _ = D.pack . T.state
ether/src/Control/Monad/Ether/State/Strict.hs+69−1
@@ -1,3 +1,9 @@
1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE TypeFamilies #-}
1
7
2-- | See "Control.Monad.State.Strict".
8-- | See "Control.Monad.State.Strict".
3
9
@@ -24,4 +30,66 @@ module Control.Monad.Ether.State.Strict
24 ) where
30 ) where
25
31
26import Control.Monad.Ether.State.Common
32import Control.Monad.Ether.State.Common
33+import qualified Control.Monad.Ether.State.Class as C
27−import Control.Monad.Trans.Ether.State.Strict hiding (state, get, put)
34+import qualified Control.Monad.Trans.Ether.Dispatch as D
35+import qualified Control.Monad.Trans.State.Strict as T
36+import Data.Functor.Identity
37+
38+-- | Encode type-level information for 'StateT'.
39+data K_STATE t s = STATE t s
40+
41+-- | The parametrizable state monad.
42+--
43+-- Computations have access to a mutable state.
44+--
45+-- The 'return' function leaves the state unchanged, while '>>=' uses
46+-- the final state of the first computation as the initial state of the second.
47+type State tag r = StateT tag r Identity
48+
49+-- | The state monad transformer.
50+--
51+-- The 'return' function leaves the state unchanged, while '>>=' uses
52+-- the final state of the first computation as the initial state of the second.
53+type StateT tag s = D.Dispatch (STATE tag s) (T.StateT s)
54+
55+-- | Constructor for computations in the state monad transformer.
56+stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
57+stateT = D.pack . T.StateT
58+
59+-- | Runs a 'StateT' with the given initial state
60+-- and returns both the final value and the final state.
61+runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
62+runStateT = T.runStateT . D.unpack
63+
64+-- | Runs a 'StateT' with the given initial state
65+-- and returns the final value, discarding the final state.
66+evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
67+evalStateT = T.evalStateT . D.unpack
68+
69+-- | Runs a 'StateT' with the given initial state
70+-- and returns the final state, discarding the final value.
71+execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
72+execStateT = T.execStateT . D.unpack
73+
74+-- | Runs a 'State' with the given initial state
75+-- and returns both the final value and the final state.
76+runState :: forall tag s a . State tag s a -> s -> (a, s)
77+runState = T.runState . D.unpack
78+
79+-- | Runs a 'State' with the given initial state
80+-- and returns the final value, discarding the final state.
81+evalState :: forall tag s a . State tag s a -> s -> a
82+evalState = T.evalState . D.unpack
83+
84+-- | Runs a 'State' with the given initial state
85+-- and returns the final state, discarding the final value.
86+execState :: forall tag s a . State tag s a -> s -> s
87+execState = T.execState . D.unpack
88+
89+instance
90+ ( Monad m, s ~ s', trans ~ T.StateT s
91+ ) => MonadState tag s (D.Dispatch (STATE tag s') trans m)
92+ where
93+ get _ = D.pack T.get
94+ put _ = D.pack . T.put
95+ state _ = D.pack . T.state
ether/src/Control/Monad/Ether/TagAttach.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+{-# LANGUAGE DataKinds #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+
10+module Control.Monad.Ether.TagAttach
11+ ( K_TAG_ATTACH(..)
12+ , TagAttachT
13+ , tagAttach
14+ ) where
15+
16+import Control.Monad.Trans.Identity
17+
18+import Control.Monad.Ether.Reader.Class
19+import Control.Monad.Ether.State.Class
20+import Control.Monad.Ether.Except.Class
21+import Control.Monad.Ether.Writer.Class
22+
23+import Control.Monad.Ether.Reader as A
24+import Control.Monad.Ether.State.Common as A
25+import Control.Monad.Ether.Except as A
26+import Control.Monad.Ether.Writer as A
27+
28+import qualified Control.Monad.Reader.Class as Class
29+import qualified Control.Monad.State.Class as Class
30+import qualified Control.Monad.Writer.Class as Class
31+import qualified Control.Monad.Error.Class as Class
32+
33+import Control.Monad.Trans.Ether.Dispatch
34+
35+-- | Encode type-level information for 'tagAttach'.
36+data K_TAG_ATTACH t = TAG_ATTACH t
37+
38+type TagAttachT t = Dispatch (TAG_ATTACH t) IdentityT
39+
40+-- | Attach a tag to untagged transformers.
41+tagAttach :: forall tag m a . TagAttachT tag m a -> m a
42+tagAttach = runIdentityT . unpack
43+
44+instance
45+ ( MonadReader tag r m, trans ~ IdentityT
46+ ) => Class.MonadReader r (Dispatch (TAG_ATTACH tag) trans m)
47+ where
48+ ask = A.ask @tag
49+ local = A.local @tag
50+
51+instance
52+ ( MonadState tag s m, trans ~ IdentityT
53+ ) => Class.MonadState s (Dispatch (TAG_ATTACH tag) trans m)
54+ where
55+ get = A.get @tag
56+ put = A.put @tag
57+
58+instance
59+ ( MonadExcept tag e m, trans ~ IdentityT
60+ ) => Class.MonadError e (Dispatch (TAG_ATTACH tag) trans m)
61+ where
62+ throwError = A.throw @tag
63+ catchError = A.catch @tag
64+
65+instance
66+ ( MonadWriter tag w m, trans ~ IdentityT
67+ ) => Class.MonadWriter w (Dispatch (TAG_ATTACH tag) trans m)
68+ where
69+ writer = A.writer @tag
70+ tell = A.tell @tag
71+ listen = A.listen @tag
72+ pass = A.pass @tag
ether/src/Control/Monad/Ether/TagReplace.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+{-# LANGUAGE DataKinds #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+
10+module Control.Monad.Ether.TagReplace
11+ ( K_TAG_REPLACE(..)
12+ , TagReplaceT
13+ , tagReplace
14+ ) where
15+
16+import Control.Monad.Trans.Identity
17+
18+import Control.Monad.Ether.Reader.Class
19+import Control.Monad.Ether.State.Class
20+import Control.Monad.Ether.Except.Class
21+import Control.Monad.Ether.Writer.Class
22+
23+import Control.Monad.Ether.Reader as A
24+import Control.Monad.Ether.State.Common as A
25+import Control.Monad.Ether.Except as A
26+import Control.Monad.Ether.Writer as A
27+
28+import Control.Monad.Trans.Ether.Dispatch
29+
30+-- | Encode type-level information for 'tagReplace'.
31+data K_TAG_REPLACE tOld tNew = TAG_REPLACE tOld tNew
32+
33+type TagReplaceT tOld tNew = Dispatch (TAG_REPLACE tOld tNew) IdentityT
34+
35+-- | Replace a tag with another tag.
36+tagReplace :: forall tOld tNew m a . TagReplaceT tOld tNew m a -> m a
37+tagReplace = runIdentityT . unpack
38+
39+instance
40+ ( MonadReader tNew r m, trans ~ IdentityT
41+ ) => MonadReader tOld r (Dispatch (TAG_REPLACE tOld tNew) trans m)
42+ where
43+ ask _ = A.ask @tNew
44+ local _ = A.local @tNew
45+
46+instance
47+ ( MonadState tNew s m, trans ~ IdentityT
48+ ) => MonadState tOld s (Dispatch (TAG_REPLACE tOld tNew) trans m)
49+ where
50+ get _ = A.get @tNew
51+ put _ = A.put @tNew
52+
53+instance
54+ ( MonadExcept tNew e m, trans ~ IdentityT
55+ ) => MonadExcept tOld e (Dispatch (TAG_REPLACE tOld tNew) trans m)
56+ where
57+ throw _ = A.throw @tNew
58+ catch _ = A.catch @tNew
59+
60+instance
61+ ( MonadWriter tNew w m, trans ~ IdentityT
62+ ) => MonadWriter tOld w (Dispatch (TAG_REPLACE tOld tNew) trans m)
63+ where
64+ writer _ = A.writer @tNew
65+ tell _ = A.tell @tNew
66+ listen _ = A.listen @tNew
67+ pass _ = A.pass @tNew
ether/src/Control/Monad/Ether/Writer.hs+59−1
@@ -1,3 +1,9 @@
1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2+
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE TypeFamilies #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
7{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE MagicHash #-}
8{-# LANGUAGE MagicHash #-}
3
9
@@ -27,7 +33,9 @@ module Control.Monad.Ether.Writer
27import GHC.Prim (Proxy#, proxy#)
33import GHC.Prim (Proxy#, proxy#)
28import Control.Monad.Ether.Writer.Class (MonadWriter)
34import Control.Monad.Ether.Writer.Class (MonadWriter)
29import qualified Control.Monad.Ether.Writer.Class as C
35import qualified Control.Monad.Ether.Writer.Class as C
30−import Control.Monad.Trans.Ether.Writer hiding (writer, tell, listen, pass)
36+import qualified Control.Monad.Trans.Ether.Dispatch as D
37+import qualified Control.Monad.Trans.Writer as T
38+import Data.Functor.Identity
31
39
32-- | Embed a simple writer action.
40-- | Embed a simple writer action.
33writer :: forall tag w m a . MonadWriter tag w m => (a, w) -> m a
41writer :: forall tag w m a . MonadWriter tag w m => (a, w) -> m a
@@ -59,3 +67,53 @@ censor :: forall tag w m a . MonadWriter tag w m => (w -> w) -> m a -> m a
59censor f m = pass @tag $ do
67censor f m = pass @tag $ do
60 a <- m
68 a <- m
61 return (a, f)
69 return (a, f)
70+
71+-- | Encode type-level information for 'WriterT'.
72+data K_WRITER t w = WRITER t w
73+
74+-- | The parametrizable writer monad.
75+--
76+-- Computations can accumulate a monoid value.
77+--
78+-- The 'return' function produces the output 'mempty', while '>>=' combines
79+-- the outputs of the subcomputations using 'mappend'.
80+type Writer tag w = WriterT tag w Identity
81+
82+-- | The writer monad transformer.
83+--
84+-- The 'return' function produces the output 'mempty', while '>>=' combines
85+-- the outputs of the subcomputations using 'mappend'.
86+type WriterT tag w = D.Dispatch (WRITER tag w) (T.WriterT w)
87+
88+-- | Constructor for computations in the writer monad transformer.
89+writerT :: forall tag w m a . m (a, w) -> WriterT tag w m a
90+writerT = D.pack . T.WriterT
91+
92+-- | Runs a 'WriterT' and returns both the normal value
93+-- and the final accumulator.
94+runWriterT :: forall tag w m a . WriterT tag w m a -> m (a, w)
95+runWriterT = T.runWriterT . D.unpack
96+
97+-- | Runs a 'Writer' and returns both the normal value
98+-- and the final accumulator.
99+runWriter :: forall tag w a . Writer tag w a -> (a, w)
100+runWriter = T.runWriter . D.unpack
101+
102+-- | Runs a 'WriterT' and returns the final accumulator,
103+-- discarding the normal value.
104+execWriterT :: forall tag w m a . Monad m => WriterT tag w m a -> m w
105+execWriterT = T.execWriterT . D.unpack
106+
107+-- | Runs a 'Writer' and returns the final accumulator,
108+-- discarding the normal value.
109+execWriter :: forall tag w a . Writer tag w a -> w
110+execWriter = T.execWriter . D.unpack
111+
112+instance
113+ ( Monoid w, Monad m, w ~ w', trans ~ T.WriterT w
114+ ) => MonadWriter tag w (D.Dispatch (WRITER tag w') trans m)
115+ where
116+ writer _ = D.pack . T.writer
117+ tell _ = D.pack . T.tell
118+ listen _ = D.pack . T.listen . D.unpack
119+ pass _ = D.pack . T.pass . D.unpack
ether/src/Control/Monad/Ether/Writer/Class.hs−7
@@ -10,7 +10,6 @@ module Control.Monad.Ether.Writer.Class
10 ) where
10 ) where
11
11
12import GHC.Prim (Proxy#)
12import GHC.Prim (Proxy#)
13−import qualified Control.Monad.Trans.Ether.Writer as W
14import qualified Control.Monad.Trans.Lift.Listen as Lift
13import qualified Control.Monad.Trans.Lift.Listen as Lift
15import qualified Control.Monad.Trans.Lift.Pass as Lift
14import qualified Control.Monad.Trans.Lift.Pass as Lift
16
15
@@ -37,12 +36,6 @@ class (Monoid w, Monad m) => MonadWriter tag w m | m tag -> w where
37 -- and return the value, applying the function to the accumulator.
36 -- and return the value, applying the function to the accumulator.
38 pass :: Proxy# tag -> m (a, w -> w) -> m a
37 pass :: Proxy# tag -> m (a, w -> w) -> m a
39
38
40−instance (Monoid w, Monad m, w ~ w') => MonadWriter tag w (W.WriterT tag w' m) where
41− writer _ = W.writer @tag
42− tell _ = W.tell @tag
43− listen _ = W.listen @tag
44− pass _ = W.pass @tag
45−
46instance {-# OVERLAPPABLE #-}
39instance {-# OVERLAPPABLE #-}
47 ( Lift.LiftListen t
40 ( Lift.LiftListen t
48 , Lift.LiftPass t
41 , Lift.LiftPass t
ether/src/Control/Monad/Trans/Ether/Dispatch.hs+47−177
@@ -1,57 +1,11 @@
1−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
2−
3{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE UndecidableInstances #-}
4{-# LANGUAGE UndecidableInstances #-}
7−{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE ConstraintKinds #-}
8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE TypeFamilies #-}
9−
10−{- |
11−
12−Type-level machinery to manipulate constraints on the monad
13−transformer stack.
14−
15−Out of the box it provides the following dispatch strategies:
16−
17−* 'tagAttach' to use functions defined using untagged monad classes
18− as if they were defined using tagged ones.
19−
20−* 'tagReplace' to use functions defined using one tag
21− as if they were defined using another one.
22−
23−> import qualified Control.Monad.State as T
24−> import Control.Ether.TH (ethereal)
25−> import Control.Monad.Ether.State (MonadState)
26−> import Control.Monad.Trans.Ether.Dispatch (tagAttach, tagDispatch)
27−>
28−> ethereal "Foo" "foo"
29−> ethereal "Bar" "bar"
30−>
31−> f :: T.MonadState Int m => m String
32−> f = fmap show T.get
33−>
34−> g :: MonadState Foo Int m => m String
35−> g = tagAttach foo f
36−>
37−> h :: MonadState Bar Int m => m String
38−> h = tagReplace foo bar g
39−
40−-}
41
7
42−module Control.Monad.Trans.Ether.Dispatch
8+module Control.Monad.Trans.Ether.Dispatch where
43− (
44− -- * The DispatchT monad transformer
45− DispatchT
46− , dispatchT
47− , runDispatchT
48− , redispatch
49− -- * Dispatch types and functions
50− , K_TagAttach(..)
51− , tagAttach
52− , K_TagReplace(..)
53− , tagReplace
54− ) where
55
9
56import Control.Applicative
10import Control.Applicative
57import Control.Monad (MonadPlus)
11import Control.Monad (MonadPlus)
@@ -63,7 +17,6 @@ import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
63
17
64import qualified Control.Monad.Base as MB
18import qualified Control.Monad.Base as MB
65import qualified Control.Monad.Trans.Control as MC
19import qualified Control.Monad.Trans.Control as MC
66−import qualified Control.Monad.Trans.Identity as Trans
67
20
68import qualified Control.Monad.Trans.Lift.StT as Lift
21import qualified Control.Monad.Trans.Lift.StT as Lift
69import qualified Control.Monad.Trans.Lift.Local as Lift
22import qualified Control.Monad.Trans.Lift.Local as Lift
@@ -72,16 +25,6 @@ import qualified Control.Monad.Trans.Lift.Listen as Lift
72import qualified Control.Monad.Trans.Lift.Pass as Lift
25import qualified Control.Monad.Trans.Lift.Pass as Lift
73import qualified Control.Monad.Trans.Lift.CallCC as Lift
26import qualified Control.Monad.Trans.Lift.CallCC as Lift
74
27
75−import Control.Monad.Ether.Reader.Class
76−import Control.Monad.Ether.State.Class
77−import Control.Monad.Ether.Except.Class
78−import Control.Monad.Ether.Writer.Class
79−
80−import Control.Monad.Ether.Reader as A
81−import Control.Monad.Ether.State.Common as A
82−import Control.Monad.Ether.Except as A
83−import Control.Monad.Ether.Writer as A
84−
85import qualified Control.Monad.Cont.Class as Class
28import qualified Control.Monad.Cont.Class as Class
86import qualified Control.Monad.Reader.Class as Class
29import qualified Control.Monad.Reader.Class as Class
87import qualified Control.Monad.State.Class as Class
30import qualified Control.Monad.State.Class as Class
@@ -91,84 +34,75 @@ import qualified Control.Monad.Error.Class as Class
91import GHC.Generics (Generic)
34import GHC.Generics (Generic)
92import Data.Coerce (coerce)
35import Data.Coerce (coerce)
93
36
94−-- | Wrap a monad to change its tags. Under the hood this is
37+newtype Dispatch dp trans m a = Dispatch (trans m a)
95−-- simply 'Trans.IdentityT', all the work is happening on the type level.
96−newtype DispatchT dp m a = DispatchT (Trans.IdentityT m a)
97 deriving
38 deriving
98 ( Generic
39 ( Generic
99 , Functor, Applicative, Alternative, Monad, MonadPlus
40 , Functor, Applicative, Alternative, Monad, MonadPlus
100 , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
41 , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
101 , MonadThrow, MonadCatch, MonadMask )
42 , MonadThrow, MonadCatch, MonadMask )
102
43
103−-- | Type-restricted 'coerce'.
104−pack :: forall dp m a . Trans.IdentityT m a -> DispatchT dp m a
44+pack :: forall dp trans m a . trans m a -> Dispatch dp trans m a
105pack = coerce
45pack = coerce
106{-# INLINE pack #-}
46{-# INLINE pack #-}
107
47
108−-- | Type-restricted 'coerce'.
109−unpack :: forall dp m a . DispatchT dp m a -> Trans.IdentityT m a
48+unpack :: forall dp trans m a . Dispatch dp trans m a -> trans m a
110unpack = coerce
49unpack = coerce
111{-# INLINE unpack #-}
50{-# INLINE unpack #-}
112
51
113−-- | Type-restricted 'coerce'.
52+repack :: forall dp dp' trans m a . Dispatch dp trans m a -> Dispatch dp' trans m a
114−dispatchT :: forall dp m a . m a -> DispatchT dp m a
115−dispatchT = coerce
116−{-# INLINE dispatchT #-}
117−
118−-- | Type-restricted 'coerce'.
119−runDispatchT :: forall dp m a . DispatchT dp m a -> m a
120−runDispatchT = coerce
53+repack = coerce
121−{-# INLINE runDispatchT #-}
54+{-# INLINE repack #-}
122
55
123−-- | Type-restricted 'coerce'.
56+instance
124−redispatch :: forall dp dp' m a . DispatchT dp m a -> DispatchT dp' m a
57+ ( MB.MonadBase b m
125−redispatch = coerce
58+ , MonadTrans trans
126−{-# INLINE redispatch #-}
59+ , Monad (trans m)
127−
60+ ) => MB.MonadBase b (Dispatch dp trans m)
128−instance MB.MonadBase b m => MB.MonadBase b (DispatchT dp m) where
61+ where
129− liftBase = MB.liftBaseDefault
62+ liftBase = MB.liftBaseDefault
130−
131−instance MC.MonadTransControl (DispatchT dp) where
132− type StT (DispatchT dp) a = MC.StT Trans.IdentityT a
133− liftWith = MC.defaultLiftWith pack unpack
134− restoreT = MC.defaultRestoreT pack
135
63
136−instance MC.MonadBaseControl b m => MC.MonadBaseControl b (DispatchT dp m) where
64+instance
137− type StM (DispatchT dp m) a = MC.ComposeSt (DispatchT dp) m a
65+ ( MC.MonadTransControl trans
138− liftBaseWith = MC.defaultLiftBaseWith
66+ ) => MC.MonadTransControl (Dispatch dp trans)
139− restoreM = MC.defaultRestoreM
67+ where
68+ type StT (Dispatch dp trans) a = MC.StT trans a
69+ liftWith = MC.defaultLiftWith pack unpack
70+ restoreT = MC.defaultRestoreT pack
140
71
141−type instance Lift.StT (DispatchT dp) a = MC.StT (DispatchT dp) a
72+type instance Lift.StT (Dispatch dp trans) a = Lift.StT trans a
142
73
143−instance Lift.LiftLocal (DispatchT dp) where
74+instance Lift.LiftLocal trans => Lift.LiftLocal (Dispatch dp trans) where
144 liftLocal = Lift.defaultLiftLocal pack unpack
75 liftLocal = Lift.defaultLiftLocal pack unpack
145
76
146−instance Lift.LiftCatch (DispatchT dp) where
77+instance Lift.LiftCatch trans => Lift.LiftCatch (Dispatch dp trans) where
147 liftCatch = Lift.defaultLiftCatch pack unpack
78 liftCatch = Lift.defaultLiftCatch pack unpack
148
79
149−instance Lift.LiftListen (DispatchT dp) where
80+instance Lift.LiftListen trans => Lift.LiftListen (Dispatch dp trans) where
150 liftListen = Lift.defaultLiftListen pack unpack
81 liftListen = Lift.defaultLiftListen pack unpack
151
82
152−instance Lift.LiftPass (DispatchT dp) where
83+instance Lift.LiftPass trans => Lift.LiftPass (Dispatch dp trans) where
153 liftPass = Lift.defaultLiftPass pack unpack
84 liftPass = Lift.defaultLiftPass pack unpack
154
85
155−instance Lift.LiftCallCC (DispatchT dp) where
86+instance Lift.LiftCallCC trans => Lift.LiftCallCC (Dispatch dp trans) where
156 liftCallCC = Lift.defaultLiftCallCC pack unpack
87 liftCallCC = Lift.defaultLiftCallCC pack unpack
157 liftCallCC' = Lift.defaultLiftCallCC' pack unpack
88 liftCallCC' = Lift.defaultLiftCallCC' pack unpack
158
89
90+
159-- Instances for mtl classes
91-- Instances for mtl classes
160
92
161instance {-# OVERLAPPABLE #-}
93instance {-# OVERLAPPABLE #-}
162 ( Class.MonadCont m
94 ( Class.MonadCont m
95+ , Lift.LiftCallCC trans
163− , Monad m
96+ , Monad (trans m)
164− ) => Class.MonadCont (DispatchT dp m)
97+ ) => Class.MonadCont (Dispatch dp trans m)
165 where
98 where
166 callCC = Lift.liftCallCC' Class.callCC
99 callCC = Lift.liftCallCC' Class.callCC
167
100
168instance {-# OVERLAPPABLE #-}
101instance {-# OVERLAPPABLE #-}
169 ( Class.MonadReader r m
102 ( Class.MonadReader r m
103+ , Lift.LiftLocal trans
170− , Monad m
104+ , Monad (trans m)
171− ) => Class.MonadReader r (DispatchT dp m)
105+ ) => Class.MonadReader r (Dispatch dp trans m)
172 where
106 where
173 ask = lift Class.ask
107 ask = lift Class.ask
174 local = Lift.liftLocal Class.ask Class.local
108 local = Lift.liftLocal Class.ask Class.local
@@ -176,8 +110,9 @@ instance {-# OVERLAPPABLE #-}
176
110
177instance {-# OVERLAPPABLE #-}
111instance {-# OVERLAPPABLE #-}
178 ( Class.MonadState s m
112 ( Class.MonadState s m
113+ , MonadTrans trans
179− , Monad m
114+ , Monad (trans m)
180− ) => Class.MonadState s (DispatchT dp m)
115+ ) => Class.MonadState s (Dispatch dp trans m)
181 where
116 where
182 get = lift Class.get
117 get = lift Class.get
183 put = lift . Class.put
118 put = lift . Class.put
@@ -185,8 +120,10 @@ instance {-# OVERLAPPABLE #-}
185
120
186instance {-# OVERLAPPABLE #-}
121instance {-# OVERLAPPABLE #-}
187 ( Class.MonadWriter w m
122 ( Class.MonadWriter w m
123+ , Lift.LiftListen trans
124+ , Lift.LiftPass trans
188− , Monad m
125+ , Monad (trans m)
189− ) => Class.MonadWriter w (DispatchT dp m)
126+ ) => Class.MonadWriter w (Dispatch dp trans m)
190 where
127 where
191 writer = lift . Class.writer
128 writer = lift . Class.writer
192 tell = lift . Class.tell
129 tell = lift . Class.tell
@@ -195,76 +132,9 @@ instance {-# OVERLAPPABLE #-}
195
132
196instance {-# OVERLAPPABLE #-}
133instance {-# OVERLAPPABLE #-}
197 ( Class.MonadError e m
134 ( Class.MonadError e m
135+ , Lift.LiftCatch trans
198− , Monad m
136+ , Monad (trans m)
199− ) => Class.MonadError e (DispatchT dp m)
137+ ) => Class.MonadError e (Dispatch dp trans m)
200 where
138 where
201 throwError = lift . Class.throwError
139 throwError = lift . Class.throwError
202 catchError = Lift.liftCatch Class.catchError
140 catchError = Lift.liftCatch Class.catchError
203−
204−
205−-- TagAttach
206−
207−-- | Encode type-level information for 'tagAttach'.
208−data K_TagAttach t = TagAttach t
209−
210−type DispatchTagAttachT t = DispatchT (TagAttach t)
211−
212−-- | Attach a tag to untagged transformers.
213−tagAttach :: forall tag m a . DispatchTagAttachT tag m a -> m a
214−tagAttach = runDispatchT
215−
216−instance MonadReader tag r m
217− => Class.MonadReader r (DispatchTagAttachT tag m) where
218− ask = Lift.lift (A.ask @tag)
219− local = Lift.liftLocal (A.ask @tag) (A.local @tag)
220−
221−instance MonadState tag s m
222− => Class.MonadState s (DispatchTagAttachT tag m) where
223− get = Lift.lift (A.get @tag)
224− put = Lift.lift . A.put @tag
225−
226−instance MonadExcept tag e m
227− => Class.MonadError e (DispatchTagAttachT tag m) where
228− throwError = Lift.lift . A.throw @tag
229− catchError = Lift.liftCatch (A.catch @tag)
230−
231−instance MonadWriter tag w m
232− => Class.MonadWriter w (DispatchTagAttachT tag m) where
233− writer = Lift.lift . A.writer @tag
234− tell = Lift.lift . A.tell @tag
235− listen = Lift.liftListen (A.listen @tag)
236− pass = Lift.liftPass (A.pass @tag)
237−
238−
239−-- TagReplace
240−
241−-- | Encode type-level information for 'tagReplace'.
242−data K_TagReplace tOld tNew = TagReplace tOld tNew
243−
244−type DispatchTagReplaceT tOld tNew = DispatchT (TagReplace tOld tNew)
245−
246−-- | Replace a tag with another tag.
247−tagReplace :: forall tOld tNew m a . DispatchTagReplaceT tOld tNew m a -> m a
248−tagReplace = runDispatchT
249−
250−instance MonadReader tNew r m
251− => MonadReader tOld r (DispatchTagReplaceT tOld tNew m) where
252− ask _ = Lift.lift (A.ask @tNew)
253− local _ = Lift.liftLocal (A.ask @tNew) (A.local @tNew)
254−
255−instance MonadState tNew s m
256− => MonadState tOld s (DispatchTagReplaceT tOld tNew m) where
257− get _ = Lift.lift (A.get @tNew)
258− put _ = Lift.lift . A.put @tNew
259−
260−instance MonadExcept tNew e m
261− => MonadExcept tOld e (DispatchTagReplaceT tOld tNew m) where
262− throw _ = Lift.lift . A.throw @tNew
263− catch _ = Lift.liftCatch (A.catch @tNew)
264−
265−instance MonadWriter tNew w m
266− => MonadWriter tOld w (DispatchTagReplaceT tOld tNew m) where
267− writer _ = Lift.lift . A.writer @tNew
268− tell _ = Lift.lift . A.tell @tNew
269− listen _ = Lift.liftListen (A.listen @tNew)
270− pass _ = Lift.liftPass (A.pass @tNew)
ether/src/Control/Monad/Trans/Ether/Except.hsdeleted−70
@@ -1,70 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE UndecidableInstances #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE AllowAmbiguousTypes #-}
8−
9−-- | See "Control.Monad.Trans.Except".
10−
11−module Control.Monad.Trans.Ether.Except
12− (
13− -- * The Except monad
14− Except
15− , except
16− , runExcept
17− -- * The ExceptT monad transformer
18− , ExceptT
19− , exceptT
20− , runExceptT
21− -- * Exception operations
22− , throw
23− , catch
24− ) where
25−
26−import Data.Functor.Identity (Identity(..))
27−import qualified Control.Monad.Trans.Except as Trans
28−import Control.Monad.Trans.Ether.Tagged
29−
30−
31−-- | The parameterizable exception monad.
32−--
33−-- Computations are either exceptions or normal values.
34−--
35−-- The 'return' function returns a normal value, while '>>=' exits on
36−-- the first exception.
37−type Except tag e = ExceptT tag e Identity
38−
39−-- | Runs an 'Except' and returns either an exception or a normal value.
40−runExcept :: forall tag e a . Except tag e a -> Either e a
41−runExcept = Trans.runExcept . unpack
42−
43−-- | The exception monad transformer.
44−--
45−-- The 'return' function returns a normal value, while '>>=' exits on
46−-- the first exception.
47−type ExceptT tag e = TaggedTrans tag (Trans.ExceptT e)
48−
49−-- | Constructor for computations in the exception monad transformer.
50−exceptT :: forall tag e m a . m (Either e a) -> ExceptT tag e m a
51−exceptT = pack . Trans.ExceptT
52−
53−-- | Constructor for computations in the exception monad
54−-- (the inverse of 'runExcept').
55−except :: forall tag e m a . Monad m => Either e a -> ExceptT tag e m a
56−except = exceptT @tag . return
57−
58−-- | Runs an 'ExceptT' and returns either an exception or a normal value.
59−runExceptT :: forall tag e m a . ExceptT tag e m a -> m (Either e a)
60−runExceptT = Trans.runExceptT . unpack
61−
62−-- | Is used within a monadic computation to begin exception processing.
63−throw :: forall tag e m a . Monad m => e -> ExceptT tag e m a
64−throw = pack . Trans.throwE
65−
66−-- | A handler function to handle previous exceptions and return to normal execution.
67−catch
68− :: forall tag e m a . Monad m
69− => ExceptT tag e m a -> (e -> ExceptT tag e m a) -> ExceptT tag e m a
70−catch m h = pack $ Trans.catchE (unpack m) (unpack . h)
ether/src/Control/Monad/Trans/Ether/Reader.hsdeleted−79
@@ -1,79 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE UndecidableInstances #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE AllowAmbiguousTypes #-}
8−
9−-- | See "Control.Monad.Trans.Reader".
10−
11−module Control.Monad.Trans.Ether.Reader
12− (
13− -- * The Reader monad
14− Reader
15− , reader
16− , runReader
17− -- * The ReaderT monad transformer
18− , ReaderT
19− , readerT
20− , runReaderT
21− -- * Reader operations
22− , ask
23− , local
24− ) where
25−
26−import Data.Functor.Identity (Identity(..))
27−import qualified Control.Monad.Trans.Reader as Trans
28−import Control.Monad.Trans.Ether.Tagged
29−
30−-- | The parameterizable reader monad.
31−--
32−-- Computations are functions of a shared environment.
33−--
34−-- The 'return' function ignores the environment, while '>>=' passes
35−-- the inherited environment to both subcomputations.
36−type Reader tag r = ReaderT tag r Identity
37−
38−-- | The reader monad transformer,
39−-- which adds a read-only environment to the given monad.
40−--
41−-- The 'return' function ignores the environment, while '>>=' passes
42−-- the inherited environment to both subcomputations.
43−type ReaderT tag r = TaggedTrans tag (Trans.ReaderT r)
44−
45−-- | Constructor for computations in the reader monad transformer.
46−readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
47−readerT = pack . Trans.ReaderT
48−
49−-- | Constructor for computations in the reader monad
50−-- (the inverse of 'runReader').
51−reader :: forall tag r m a . Monad m => (r -> a) -> ReaderT tag r m a
52−reader = pack . Trans.reader
53−
54−-- | Runs a 'ReaderT' with the given environment
55−-- and returns the final value.
56−runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a
57−runReaderT = Trans.runReaderT . unpack
58−
59−-- | Runs a 'ReaderT' with the given environment
60−-- and returns the final value.
61−runReader :: forall tag r a . Reader tag r a -> r -> a
62−runReader = Trans.runReader . unpack
63−
64−-- | Fetch the value of the environment.
65−ask :: forall tag r m . Monad m => ReaderT tag r m r
66−ask = pack Trans.ask
67−
68−-- | Execute a computation in a modified environment
69−-- (a specialization of 'withReaderT').
70−--
71−-- * @'runReaderT' tag ('local' tag f m) = 'runReaderT' tag m . f@
72−local
73− :: forall tag r m a
74− . (r -> r)
75− -- ^ The function to modify the environment.
76− -> ReaderT tag r m a
77− -- ^ Computation to run in the modified environment.
78− -> ReaderT tag r m a
79−local f = pack . Trans.withReaderT f . unpack
ether/src/Control/Monad/Trans/Ether/State.hsdeleted−8
@@ -1,8 +0,0 @@
1−
2−-- | See "Control.Monad.Trans.State".
3−
4−module Control.Monad.Trans.Ether.State
5− ( module Control.Monad.Trans.Ether.State.Lazy
6− ) where
7−
8−import Control.Monad.Trans.Ether.State.Lazy
ether/src/Control/Monad/Trans/Ether/State/Lazy.hsdeleted−93
@@ -1,93 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE UndecidableInstances #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE AllowAmbiguousTypes #-}
8−
9−-- | See "Control.Monad.Trans.State.Lazy".
10−
11−module Control.Monad.Trans.Ether.State.Lazy
12− (
13− -- * The State monad
14− State
15− , state
16− , runState
17− , evalState
18− , execState
19− -- * The StateT monad transformer
20− , StateT
21− , stateT
22− , runStateT
23− , evalStateT
24− , execStateT
25− -- * State operations
26− , get
27− , put
28− ) where
29−
30−import Data.Functor.Identity (Identity(..))
31−import qualified Control.Monad.Trans.State.Lazy as Trans
32−import Control.Monad.Trans.Ether.Tagged
33−
34−-- | The parametrizable state monad.
35−--
36−-- Computations have access to a mutable state.
37−--
38−-- The 'return' function leaves the state unchanged, while '>>=' uses
39−-- the final state of the first computation as the initial state of the second.
40−type State tag r = StateT tag r Identity
41−
42−-- | The state monad transformer.
43−--
44−-- The 'return' function leaves the state unchanged, while '>>=' uses
45−-- the final state of the first computation as the initial state of the second.
46−type StateT tag s = TaggedTrans tag (Trans.StateT s)
47−
48−-- | Constructor for computations in the state monad transformer.
49−stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
50−stateT = pack . Trans.StateT
51−
52−-- | Constructor for computations in the state monad
53−-- (the inverse of 'runState').
54−state :: forall tag s m a . Monad m => (s -> (a, s)) -> StateT tag s m a
55−state = pack . Trans.state
56−
57−-- | Runs a 'StateT' with the given initial state
58−-- and returns both the final value and the final state.
59−runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
60−runStateT = Trans.runStateT . unpack
61−
62−-- | Runs a 'StateT' with the given initial state
63−-- and returns the final value, discarding the final state.
64−evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
65−evalStateT = Trans.evalStateT . unpack
66−
67−-- | Runs a 'StateT' with the given initial state
68−-- and returns the final state, discarding the final value.
69−execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
70−execStateT = Trans.execStateT . unpack
71−
72−-- | Runs a 'State' with the given initial state
73−-- and returns both the final value and the final state.
74−runState :: forall tag s a . State tag s a -> s -> (a, s)
75−runState = Trans.runState . unpack
76−
77−-- | Runs a 'State' with the given initial state
78−-- and returns the final value, discarding the final state.
79−evalState :: forall tag s a . State tag s a -> s -> a
80−evalState = Trans.evalState . unpack
81−
82−-- | Runs a 'State' with the given initial state
83−-- and returns the final state, discarding the final value.
84−execState :: forall tag s a . State tag s a -> s -> s
85−execState = Trans.execState . unpack
86−
87−-- | Fetch the current value of the state within the monad.
88−get :: forall tag s m . Monad m => StateT tag s m s
89−get = pack Trans.get
90−
91−-- | Set the value of the state within the monad.
92−put :: forall tag s m . Monad m => s -> StateT tag s m ()
93−put = pack . Trans.put
ether/src/Control/Monad/Trans/Ether/State/Strict.hsdeleted−93
@@ -1,93 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE UndecidableInstances #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE AllowAmbiguousTypes #-}
8−
9−-- | See "Control.Monad.Trans.State.Strict".
10−
11−module Control.Monad.Trans.Ether.State.Strict
12− (
13− -- * The State monad
14− State
15− , state
16− , runState
17− , evalState
18− , execState
19− -- * The StateT monad transformer
20− , StateT
21− , stateT
22− , runStateT
23− , evalStateT
24− , execStateT
25− -- * State operations
26− , get
27− , put
28− ) where
29−
30−import Data.Functor.Identity (Identity(..))
31−import qualified Control.Monad.Trans.State.Strict as Trans
32−import Control.Monad.Trans.Ether.Tagged
33−
34−-- | The parametrizable state monad.
35−--
36−-- Computations have access to a mutable state.
37−--
38−-- The 'return' function leaves the state unchanged, while '>>=' uses
39−-- the final state of the first computation as the initial state of the second.
40−type State tag r = StateT tag r Identity
41−
42−-- | The state monad transformer.
43−--
44−-- The 'return' function leaves the state unchanged, while '>>=' uses
45−-- the final state of the first computation as the initial state of the second.
46−type StateT tag s = TaggedTrans tag (Trans.StateT s)
47−
48−-- | Constructor for computations in the state monad transformer.
49−stateT :: forall tag s m a . (s -> m (a, s)) -> StateT tag s m a
50−stateT = pack . Trans.StateT
51−
52−-- | Constructor for computations in the state monad
53−-- (the inverse of 'runState').
54−state :: forall tag s m a . Monad m => (s -> (a, s)) -> StateT tag s m a
55−state = pack . Trans.state
56−
57−-- | Runs a 'StateT' with the given initial state
58−-- and returns both the final value and the final state.
59−runStateT :: forall tag s m a . StateT tag s m a -> s -> m (a, s)
60−runStateT = Trans.runStateT . unpack
61−
62−-- | Runs a 'StateT' with the given initial state
63−-- and returns the final value, discarding the final state.
64−evalStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m a
65−evalStateT = Trans.evalStateT . unpack
66−
67−-- | Runs a 'StateT' with the given initial state
68−-- and returns the final state, discarding the final value.
69−execStateT :: forall tag s m a . Monad m => StateT tag s m a -> s -> m s
70−execStateT = Trans.execStateT . unpack
71−
72−-- | Runs a 'State' with the given initial state
73−-- and returns both the final value and the final state.
74−runState :: forall tag s a . State tag s a -> s -> (a, s)
75−runState = Trans.runState . unpack
76−
77−-- | Runs a 'State' with the given initial state
78−-- and returns the final value, discarding the final state.
79−evalState :: forall tag s a . State tag s a -> s -> a
80−evalState = Trans.evalState . unpack
81−
82−-- | Runs a 'State' with the given initial state
83−-- and returns the final state, discarding the final value.
84−execState :: forall tag s a . State tag s a -> s -> s
85−execState = Trans.execState . unpack
86−
87−-- | Fetch the current value of the state within the monad.
88−get :: forall tag s m . Monad m => StateT tag s m s
89−get = pack Trans.get
90−
91−-- | Set the value of the state within the monad.
92−put :: forall tag s m . Monad m => s -> StateT tag s m ()
93−put = pack . Trans.put
ether/src/Control/Monad/Trans/Ether/Tagged.hsdeleted−150
@@ -1,150 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE UndecidableInstances #-}
5−{-# LANGUAGE ConstraintKinds #-}
6−{-# LANGUAGE TypeFamilies #-}
7−
8−-- | This module defines the core data type of Ether, 'TaggedTrans',
9−-- and a bunch of instances for it. 'TaggedTrans' attaches a tag to
10−-- an existing monad transformer.
11−
12−module Control.Monad.Trans.Ether.Tagged where
13−
14−import Control.Applicative
15−import Control.Monad (MonadPlus)
16−import Control.Monad.Fix (MonadFix)
17−import Control.Monad.Trans.Class (MonadTrans, lift)
18−import Control.Monad.IO.Class (MonadIO)
19−import Control.Monad.Morph (MFunctor, MMonad)
20−import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
21−
22−import qualified Control.Monad.Base as MB
23−import qualified Control.Monad.Trans.Control as MC
24−
25−import qualified Control.Monad.Trans.Lift.StT as Lift
26−import qualified Control.Monad.Trans.Lift.Local as Lift
27−import qualified Control.Monad.Trans.Lift.Catch as Lift
28−import qualified Control.Monad.Trans.Lift.Listen as Lift
29−import qualified Control.Monad.Trans.Lift.Pass as Lift
30−import qualified Control.Monad.Trans.Lift.CallCC as Lift
31−
32−import qualified Control.Monad.Cont.Class as Class
33−import qualified Control.Monad.Reader.Class as Class
34−import qualified Control.Monad.State.Class as Class
35−import qualified Control.Monad.Writer.Class as Class
36−import qualified Control.Monad.Error.Class as Class
37−
38−import GHC.Generics (Generic)
39−import Data.Coerce (coerce)
40−
41−-- | Tagged monad transformer.
42−newtype TaggedTrans tag trans (m :: * -> *) a = TaggedTrans (trans m a)
43− deriving
44− ( Generic
45− , Functor, Applicative, Alternative, Monad, MonadPlus
46− , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
47− , MonadThrow, MonadCatch, MonadMask )
48−
49−-- | Type-restricted 'coerce'.
50−pack :: trans m a -> TaggedTrans tag trans m a
51−pack = coerce
52−
53−-- | Type-restricted 'coerce'.
54−unpack :: TaggedTrans tag trans m a -> trans m a
55−unpack = coerce
56−
57−instance
58− ( MB.MonadBase b m
59− , MonadTrans trans
60− , Monad (trans m)
61− ) => MB.MonadBase b (TaggedTrans tag trans m)
62− where
63− liftBase = MB.liftBaseDefault
64−
65−instance
66− ( MC.MonadTransControl trans
67− ) => MC.MonadTransControl (TaggedTrans tag trans)
68− where
69− type StT (TaggedTrans tag trans) a = MC.StT trans a
70− liftWith = MC.defaultLiftWith pack unpack
71− restoreT = MC.defaultRestoreT pack
72−
73−instance
74− ( MC.MonadBaseControl b m
75− , MC.MonadTransControl trans
76− , Monad (trans m)
77− ) => MC.MonadBaseControl b (TaggedTrans tag trans m)
78− where
79− type StM (TaggedTrans tag trans m) a = MC.ComposeSt trans m a
80− liftBaseWith = MC.defaultLiftBaseWith
81− restoreM = MC.defaultRestoreM
82−
83−type instance Lift.StT (TaggedTrans tag trans) a = Lift.StT trans a
84−
85−instance Lift.LiftLocal trans => Lift.LiftLocal (TaggedTrans tag trans) where
86− liftLocal = Lift.defaultLiftLocal pack unpack
87−
88−instance Lift.LiftCatch trans => Lift.LiftCatch (TaggedTrans tag trans) where
89− liftCatch = Lift.defaultLiftCatch pack unpack
90−
91−instance Lift.LiftListen trans => Lift.LiftListen (TaggedTrans tag trans) where
92− liftListen = Lift.defaultLiftListen pack unpack
93−
94−instance Lift.LiftPass trans => Lift.LiftPass (TaggedTrans tag trans) where
95− liftPass = Lift.defaultLiftPass pack unpack
96−
97−instance Lift.LiftCallCC trans => Lift.LiftCallCC (TaggedTrans tag trans) where
98− liftCallCC = Lift.defaultLiftCallCC pack unpack
99− liftCallCC' = Lift.defaultLiftCallCC' pack unpack
100−
101−-- Instances for mtl classes
102−
103−instance
104− ( Class.MonadCont m
105− , Lift.LiftCallCC trans
106− , Monad (trans m)
107− ) => Class.MonadCont (TaggedTrans tag trans m)
108− where
109− callCC = Lift.liftCallCC' Class.callCC
110−
111−instance
112− ( Class.MonadReader r m
113− , Lift.LiftLocal trans
114− , Monad (trans m)
115− ) => Class.MonadReader r (TaggedTrans tag trans m)
116− where
117− ask = lift Class.ask
118− local = Lift.liftLocal Class.ask Class.local
119− reader = lift . Class.reader
120−
121−instance
122− ( Class.MonadState s m
123− , MonadTrans trans
124− , Monad (trans m)
125− ) => Class.MonadState s (TaggedTrans tag trans m)
126− where
127− get = lift Class.get
128− put = lift . Class.put
129− state = lift . Class.state
130−
131−instance
132− ( Class.MonadWriter w m
133− , Lift.LiftListen trans
134− , Lift.LiftPass trans
135− , Monad (trans m)
136− ) => Class.MonadWriter w (TaggedTrans tag trans m)
137− where
138− writer = lift . Class.writer
139− tell = lift . Class.tell
140− listen = Lift.liftListen Class.listen
141− pass = Lift.liftPass Class.pass
142−
143−instance
144− ( Class.MonadError e m
145− , Lift.LiftCatch trans
146− , Monad (trans m)
147− ) => Class.MonadError e (TaggedTrans tag trans m)
148− where
149− throwError = lift . Class.throwError
150− catchError = Lift.liftCatch Class.catchError
ether/src/Control/Monad/Trans/Ether/Writer.hsdeleted−87
@@ -1,87 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE UndecidableInstances #-}
5−{-# LANGUAGE DataKinds #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE AllowAmbiguousTypes #-}
8−
9−-- | See "Control.Monad.Trans.Writer".
10−
11−module Control.Monad.Trans.Ether.Writer
12− (
13− -- * The Writer monad
14− Writer
15− , writer
16− , runWriter
17− , execWriter
18− -- * The WriterT monad transformer
19− , WriterT
20− , writerT
21− , runWriterT
22− , execWriterT
23− -- * Writer operations
24− , tell
25− , listen
26− , pass
27− ) where
28−
29−import Data.Functor.Identity (Identity(..))
30−import qualified Control.Monad.Trans.Writer.Lazy as Trans
31−import Control.Monad.Trans.Ether.Tagged
32−
33−-- | The parametrizable writer monad.
34−--
35−-- Computations can accumulate a monoid value.
36−--
37−-- The 'return' function produces the output 'mempty', while '>>=' combines
38−-- the outputs of the subcomputations using 'mappend'.
39−type Writer tag w = WriterT tag w Identity
40−
41−-- | The writer monad transformer.
42−--
43−-- The 'return' function produces the output 'mempty', while '>>=' combines
44−-- the outputs of the subcomputations using 'mappend'.
45−type WriterT tag w = TaggedTrans tag (Trans.WriterT w)
46−
47−-- | Constructor for computations in the writer monad transformer.
48−writerT :: forall tag w m a . m (a, w) -> WriterT tag w m a
49−writerT = pack . Trans.WriterT
50−
51−-- | Constructor for computations in the writer monad
52−-- (the inverse of 'runWriter').
53−writer :: forall tag w m a . Monad m => (a, w) -> WriterT tag w m a
54−writer = pack . Trans.writer
55−
56−-- | Runs a 'WriterT' and returns both the normal value
57−-- and the final accumulator.
58−runWriterT :: forall tag w m a . WriterT tag w m a -> m (a, w)
59−runWriterT = Trans.runWriterT . unpack
60−
61−-- | Runs a 'Writer' and returns both the normal value
62−-- and the final accumulator.
63−runWriter :: forall tag w a . Writer tag w a -> (a, w)
64−runWriter = Trans.runWriter . unpack
65−
66−-- | Runs a 'WriterT' and returns the final accumulator,
67−-- discarding the normal value.
68−execWriterT :: forall tag w m a . Monad m => WriterT tag w m a -> m w
69−execWriterT = Trans.execWriterT . unpack
70−
71−-- | Runs a 'Writer' and returns the final accumulator,
72−-- discarding the normal value.
73−execWriter :: forall tag w a . Writer tag w a -> w
74−execWriter = Trans.execWriter . unpack
75−
76−-- | Appends a value to the accumulator within the monad.
77−tell :: forall tag w m . Monad m => w -> WriterT tag w m ()
78−tell w = writer @tag ((), w)
79−
80−-- | Executes an action and adds its accumulator to the value of the computation.
81−listen :: forall tag w m a . Monad m => WriterT tag w m a -> WriterT tag w m (a, w)
82−listen = pack . Trans.listen . unpack
83−
84−-- | Executes an action which returns a value and a function, and returns the
85−-- value, applying the function to the accumulator.
86−pass :: forall tag w m a . Monad m => WriterT tag w m (a, w -> w) -> WriterT tag w m a
87−pass = pack . Trans.pass . unpack