git.iko.soy/typeable/ether
on master help sign in
Replace ReaderT with TT
afe6eb8Index Int
ether.cabal+1
compare with master
unifiedsplit
@@ -27,6 +27,7 @@ library
27 exposed-modules: Control.Ether.Abbr
27 exposed-modules: Control.Ether.Abbr
28 Control.Ether.Implicit.Abbr
28 Control.Ether.Implicit.Abbr
29 Control.Ether.TH
29 Control.Ether.TH
30+ Control.Ether.TT
30 Control.Monad.Trans.Ether.Reader
31 Control.Monad.Trans.Ether.Reader
31 Control.Monad.Trans.Ether.Writer
32 Control.Monad.Trans.Ether.Writer
32 Control.Monad.Trans.Ether.State
33 Control.Monad.Trans.Ether.State
src/Control/Ether/TT.hsnew file+171
@@ -0,0 +1,171 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+{-# LANGUAGE TypeFamilies #-}
8+module Control.Ether.TT where
9+
10+import Control.Applicative
11+import Control.Monad (MonadPlus)
12+import Control.Monad.Fix (MonadFix)
13+import Control.Monad.Trans.Class (MonadTrans, lift)
14+import Control.Monad.IO.Class (MonadIO)
15+import Control.Monad.Morph (MFunctor, MMonad)
16+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
17+
18+import qualified Control.Monad.Base as MB
19+import qualified Control.Monad.Trans.Control as MC
20+
21+import qualified Control.Monad.Trans.Lift.StT as Lift
22+import qualified Control.Monad.Trans.Lift.Local as Lift
23+import qualified Control.Monad.Trans.Lift.Catch as Lift
24+import qualified Control.Monad.Trans.Lift.Listen as Lift
25+import qualified Control.Monad.Trans.Lift.Pass as Lift
26+import qualified Control.Monad.Trans.Lift.CallCC as Lift
27+
28+import qualified Control.Monad.Cont.Class as Class
29+import qualified Control.Monad.Reader.Class as Class
30+import qualified Control.Monad.State.Class as Class
31+import qualified Control.Monad.Writer.Class as Class
32+import qualified Control.Monad.Error.Class as Class
33+
34+import GHC.Generics (Generic)
35+import Data.Coerce (coerce)
36+
37+-- | Tagged monad transformer.
38+newtype TT tag trans (m :: * -> *) a = TT (trans m a)
39+ deriving
40+ ( Generic
41+ , Functor
42+ , Applicative
43+ , Alternative
44+ , Monad
45+ , MonadPlus
46+ , MonadFix
47+ , MonadTrans
48+ , MonadIO
49+ , MFunctor
50+ , MMonad
51+ , MonadThrow
52+ , MonadCatch
53+ , MonadMask )
54+
55+-- | Type-restricted 'coerce'.
56+pack :: trans m a -> TT tag trans m a
57+pack = coerce
58+
59+-- | Type-restricted 'coerce'.
60+unpack :: TT tag trans m a -> trans m a
61+unpack = coerce
62+
63+instance
64+ ( MB.MonadBase b m
65+ , MonadTrans trans
66+ , Monad (trans m)
67+ ) => MB.MonadBase b (TT tag trans m)
68+ where
69+ liftBase = MB.liftBaseDefault
70+
71+instance
72+ ( MC.MonadTransControl trans
73+ ) => MC.MonadTransControl (TT tag trans)
74+ where
75+ type StT (TT tag trans) a = MC.StT trans a
76+ liftWith = MC.defaultLiftWith pack unpack
77+ restoreT = MC.defaultRestoreT pack
78+
79+instance
80+ ( MC.MonadBaseControl b m
81+ , MC.MonadTransControl trans
82+ , Monad (trans m)
83+ ) => MC.MonadBaseControl b (TT tag trans m)
84+ where
85+ type StM (TT tag trans m) a = MC.ComposeSt trans m a
86+ liftBaseWith = MC.defaultLiftBaseWith
87+ restoreM = MC.defaultRestoreM
88+
89+type instance Lift.StT (TT tag trans) a = Lift.StT trans a
90+
91+instance
92+ ( Lift.LiftLocal trans
93+ ) => Lift.LiftLocal (TT tag trans)
94+ where
95+ liftLocal = Lift.defaultLiftLocal pack unpack
96+
97+instance
98+ ( Lift.LiftCatch trans
99+ ) => Lift.LiftCatch (TT tag trans)
100+ where
101+ liftCatch = Lift.defaultLiftCatch pack unpack
102+
103+instance
104+ ( Lift.LiftListen trans
105+ ) => Lift.LiftListen (TT tag trans)
106+ where
107+ liftListen = Lift.defaultLiftListen pack unpack
108+
109+instance
110+ ( Lift.LiftPass trans
111+ ) => Lift.LiftPass (TT tag trans)
112+ where
113+ liftPass = Lift.defaultLiftPass pack unpack
114+
115+instance
116+ ( Lift.LiftCallCC trans
117+ ) => Lift.LiftCallCC (TT tag trans)
118+ where
119+ liftCallCC = Lift.defaultLiftCallCC pack unpack
120+ liftCallCC' = Lift.defaultLiftCallCC' pack unpack
121+
122+-- Instances for mtl classes
123+
124+instance
125+ ( Class.MonadCont m
126+ , Lift.LiftCallCC trans
127+ , Monad (trans m)
128+ ) => Class.MonadCont (TT tag trans m)
129+ where
130+ callCC = Lift.liftCallCC Class.callCC
131+
132+instance
133+ ( Class.MonadReader r m
134+ , Lift.LiftLocal trans
135+ , Monad (trans m)
136+ ) => Class.MonadReader r (TT tag trans m)
137+ where
138+ ask = lift Class.ask
139+ local = Lift.liftLocal Class.ask Class.local
140+ reader = lift . Class.reader
141+
142+instance
143+ ( Class.MonadState s m
144+ , MonadTrans trans
145+ , Monad (trans m)
146+ ) => Class.MonadState s (TT tag trans m)
147+ where
148+ get = lift Class.get
149+ put = lift . Class.put
150+ state = lift . Class.state
151+
152+instance
153+ ( Class.MonadWriter w m
154+ , Lift.LiftListen trans
155+ , Lift.LiftPass trans
156+ , Monad (trans m)
157+ ) => Class.MonadWriter w (TT tag trans m)
158+ where
159+ writer = lift . Class.writer
160+ tell = lift . Class.tell
161+ listen = Lift.liftListen Class.listen
162+ pass = Lift.liftPass Class.pass
163+
164+instance
165+ ( Class.MonadError e m
166+ , Lift.LiftCatch trans
167+ , Monad (trans m)
168+ ) => Class.MonadError e (TT tag trans m)
169+ where
170+ throwError = lift . Class.throwError
171+ catchError = Lift.liftCatch Class.catchError
src/Control/Monad/Trans/Ether/Reader.hs+2−97
@@ -22,38 +22,11 @@ module Control.Monad.Trans.Ether.Reader
22 -- * Reader operations
22 -- * Reader operations
23 , ask
23 , ask
24 , local
24 , local
25− -- * Newtype operations
26− , pack
27− , unpack
28 ) where
25 ) where
29
26
30import Data.Functor.Identity (Identity(..))
27import Data.Functor.Identity (Identity(..))
31−import Control.Applicative
32−import Control.Monad (MonadPlus)
33−import Control.Monad.Fix (MonadFix)
34−import Control.Monad.Trans.Class (MonadTrans, lift)
35−import Control.Monad.IO.Class (MonadIO)
36−import Control.Monad.Morph (MFunctor, MMonad)
37−import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
38−import GHC.Generics (Generic)
39−import Data.Coerce (coerce)
40−
41−import qualified Control.Monad.Base as MB
42−import qualified Control.Monad.Trans.Control as MC
43import qualified Control.Monad.Trans.Reader as Trans
28import qualified Control.Monad.Trans.Reader as Trans
44−
29+import Control.Ether.TT
45−import qualified Control.Monad.Trans.Lift.StT as Lift
46−import qualified Control.Monad.Trans.Lift.Local as Lift
47−import qualified Control.Monad.Trans.Lift.Catch as Lift
48−import qualified Control.Monad.Trans.Lift.Listen as Lift
49−import qualified Control.Monad.Trans.Lift.Pass as Lift
50−import qualified Control.Monad.Trans.Lift.CallCC as Lift
51−
52−import qualified Control.Monad.Cont.Class as Class
53−import qualified Control.Monad.Reader.Class as Class
54−import qualified Control.Monad.State.Class as Class
55−import qualified Control.Monad.Writer.Class as Class
56−import qualified Control.Monad.Error.Class as Class
57
30
58-- | The parameterizable reader monad.
31-- | The parameterizable reader monad.
59--
32--
@@ -68,50 +41,7 @@ type Reader tag r = ReaderT tag r Identity
68--
41--
69-- The 'return' function ignores the environment, while '>>=' passes
42-- The 'return' function ignores the environment, while '>>=' passes
70-- the inherited environment to both subcomputations.
43-- the inherited environment to both subcomputations.
71−newtype ReaderT tag r m a = ReaderT (Trans.ReaderT r m a)
44+type ReaderT tag r = TT tag (Trans.ReaderT r)
72− deriving ( Generic
73− , Functor, Applicative, Alternative, Monad, MonadPlus
74− , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
75− , MonadThrow, MonadCatch, MonadMask )
76−
77−-- | Type-restricted 'coerce'.
78−pack :: Trans.ReaderT r m a -> ReaderT tag r m a
79−pack = coerce
80−
81−-- | Type-restricted 'coerce'.
82−unpack :: ReaderT tag r m a -> Trans.ReaderT r m a
83−unpack = coerce
84−
85−instance MB.MonadBase b m => MB.MonadBase b (ReaderT tag r m) where
86− liftBase = MB.liftBaseDefault
87−
88−instance MC.MonadTransControl (ReaderT tag r) where
89− type StT (ReaderT tag r) a = MC.StT (Trans.ReaderT r) a
90− liftWith = MC.defaultLiftWith pack unpack
91− restoreT = MC.defaultRestoreT pack
92−
93−instance MC.MonadBaseControl b m => MC.MonadBaseControl b (ReaderT tag r m) where
94− type StM (ReaderT tag r m) a = MC.ComposeSt (ReaderT tag r) m a
95− liftBaseWith = MC.defaultLiftBaseWith
96− restoreM = MC.defaultRestoreM
97−
98−type instance Lift.StT (ReaderT tag r) a = MC.StT (ReaderT tag r) a
99−
100−instance Lift.LiftLocal (ReaderT tag r) where
101− liftLocal = Lift.defaultLiftLocal pack unpack
102−
103−instance Lift.LiftCatch (ReaderT tag r) where
104− liftCatch = Lift.defaultLiftCatch pack unpack
105−
106−instance Lift.LiftListen (ReaderT tag r) where
107− liftListen = Lift.defaultLiftListen pack unpack
108−
109−instance Lift.LiftPass (ReaderT tag r) where
110− liftPass = Lift.defaultLiftPass pack unpack
111−
112−instance Lift.LiftCallCC (ReaderT tag r) where
113− liftCallCC = Lift.defaultLiftCallCC pack unpack
114− liftCallCC' = Lift.defaultLiftCallCC' pack unpack
115
45
116tagged :: proxy tag -> Trans.ReaderT r m a -> ReaderT tag r m a
46tagged :: proxy tag -> Trans.ReaderT r m a -> ReaderT tag r m a
117tagged _ = pack
47tagged _ = pack
@@ -154,28 +84,3 @@ local
154 -- ^ Computation to run in the modified environment.
84 -- ^ Computation to run in the modified environment.
155 -> ReaderT tag r m a
85 -> ReaderT tag r m a
156local t f m = tagged t $ Trans.withReaderT f (untagged t m)
86local t f m = tagged t $ Trans.withReaderT f (untagged t m)
157−
158−-- Instances for mtl classes
159−
160−instance Class.MonadCont m => Class.MonadCont (ReaderT tag r m) where
161− callCC = Lift.liftCallCC Class.callCC
162−
163−instance Class.MonadReader r' m => Class.MonadReader r' (ReaderT tag r m) where
164− ask = lift Class.ask
165− local = Lift.liftLocal Class.ask Class.local
166− reader = lift . Class.reader
167−
168−instance Class.MonadState s m => Class.MonadState s (ReaderT tag r m) where
169− get = lift Class.get
170− put = lift . Class.put
171− state = lift . Class.state
172−
173−instance Class.MonadWriter w m => Class.MonadWriter w (ReaderT tag r m) where
174− writer = lift . Class.writer
175− tell = lift . Class.tell
176− listen = Lift.liftListen Class.listen
177− pass = Lift.liftPass Class.pass
178−
179−instance Class.MonadError e m => Class.MonadError e (ReaderT tag r m) where
180− throwError = lift . Class.throwError
181− catchError = Lift.liftCatch Class.catchError