@@ -43,22 +43,23 @@ module Control.Monad.Trans.Ether.Dispatch
4343 (
4444 -- * The DispatchT monad transformer
4545 DispatchT
46+ , dispatchT
47+ , runDispatchT
48+ , redispatch
4649 -- * Dispatch types and functions
4750 , K_TagAttach(..)
48− , K_TagReplace(..)
4951 , tagAttach
52+ , K_TagReplace(..)
5053 , tagReplace
5154 ) where
5255
5356import Control.Applicative
5457import Control.Monad (MonadPlus)
5558import Control.Monad.Fix (MonadFix)
56−import Control.Monad.Trans.Class (MonadTrans)
59+import Control.Monad.Trans.Class (MonadTrans, lift)
5760import Control.Monad.IO.Class (MonadIO)
5861import Control.Monad.Morph (MFunctor, MMonad)
5962import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
60−import GHC.Generics (Generic)
61−import Data.Coerce (coerce)
6263
6364import qualified Control.Monad.Base as MB
6465import qualified Control.Monad.Trans.Control as MC
@@ -81,16 +82,14 @@ import Control.Monad.Ether.State.Common as A
8182import Control.Monad.Ether.Except as A
8283import Control.Monad.Ether.Writer as A
8384
84−import qualified Control.Monad.Reader as Class
85−import qualified Control.Monad.State as Class
86−import qualified Control.Monad.Except as Class
87−import qualified Control.Monad.Writer as Class
85+import qualified Control.Monad.Cont.Class as Class
86+import qualified Control.Monad.Reader.Class as Class
87+import qualified Control.Monad.State.Class as Class
88+import qualified Control.Monad.Writer.Class as Class
89+import qualified Control.Monad.Error.Class as Class
8890
89−-- | Encode type-level information for 'tagAttach'.
90−data K_TagAttach t = TagAttach t
91−
92−-- | Encode type-level information for 'tagReplace'.
93−data K_TagReplace tOld tNew = TagReplace tOld tNew
91+import GHC.Generics (Generic)
92+import Data.Coerce (coerce)
9493
9594-- | Wrap a monad to change its tags. Under the hood this is
9695-- simply 'Trans.IdentityT', all the work is happening on the type level.
@@ -101,17 +100,26 @@ newtype DispatchT dp m a = DispatchT (Trans.IdentityT m a)
101100 , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
102101 , MonadThrow, MonadCatch, MonadMask )
103102
104−type DispatchTagAttachT t = DispatchT (TagAttach t)
105−type DispatchTagReplaceT tOld tNew = DispatchT (TagReplace tOld tNew)
106−
107103-- | Type-restricted 'coerce'.
108−pack :: Trans.IdentityT m a -> DispatchT dp m a
104+pack :: forall dp m a . Trans.IdentityT m a -> DispatchT dp m a
109105pack = coerce
110106
111107-- | Type-restricted 'coerce'.
112−unpack :: DispatchT dp m a -> Trans.IdentityT m a
108+unpack :: forall dp m a . DispatchT dp m a -> Trans.IdentityT m a
113109unpack = coerce
114110
111+-- | Type-restricted 'coerce'.
112+dispatchT :: forall dp m a . m a -> DispatchT dp m a
113+dispatchT = coerce
114+
115+-- | Type-restricted 'coerce'.
116+runDispatchT :: forall dp m a . DispatchT dp m a -> m a
117+runDispatchT = coerce
118+
119+-- | Type-restricted 'coerce'.
120+redispatch :: forall dp dp' m a . DispatchT dp m a -> DispatchT dp' m a
121+redispatch = coerce
122+
115123instance MB.MonadBase b m => MB.MonadBase b (DispatchT dp m) where
116124 liftBase = MB.liftBaseDefault
117125
@@ -143,16 +151,62 @@ instance Lift.LiftCallCC (DispatchT dp) where
143151 liftCallCC = Lift.defaultLiftCallCC pack unpack
144152 liftCallCC' = Lift.defaultLiftCallCC' pack unpack
145153
146−-- | Attach a tag to untagged transformers.
147−tagAttach :: forall tag m a . DispatchTagAttachT tag m a -> m a
148−tagAttach = coerce
154+-- Instances for mtl classes
155+
156+instance {-# OVERLAPPABLE #-}
157+ ( Class.MonadCont m
158+ , Monad m
159+ ) => Class.MonadCont (DispatchT dp m)
160+ where
161+ callCC = Lift.liftCallCC' Class.callCC
162+
163+instance {-# OVERLAPPABLE #-}
164+ ( Class.MonadReader r m
165+ , Monad m
166+ ) => Class.MonadReader r (DispatchT dp m)
167+ where
168+ ask = lift Class.ask
169+ local = Lift.liftLocal Class.ask Class.local
170+ reader = lift . Class.reader
171+
172+instance {-# OVERLAPPABLE #-}
173+ ( Class.MonadState s m
174+ , Monad m
175+ ) => Class.MonadState s (DispatchT dp m)
176+ where
177+ get = lift Class.get
178+ put = lift . Class.put
179+ state = lift . Class.state
180+
181+instance {-# OVERLAPPABLE #-}
182+ ( Class.MonadWriter w m
183+ , Monad m
184+ ) => Class.MonadWriter w (DispatchT dp m)
185+ where
186+ writer = lift . Class.writer
187+ tell = lift . Class.tell
188+ listen = Lift.liftListen Class.listen
189+ pass = Lift.liftPass Class.pass
190+
191+instance {-# OVERLAPPABLE #-}
192+ ( Class.MonadError e m
193+ , Monad m
194+ ) => Class.MonadError e (DispatchT dp m)
195+ where
196+ throwError = lift . Class.throwError
197+ catchError = Lift.liftCatch Class.catchError
198+
199+
200+-- TagAttach
149201
150−-- | Replace a tag with another tag.
151−tagReplace :: forall tOld tNew m a . DispatchTagReplaceT tOld tNew m a -> m a
152−tagReplace = coerce
202+-- | Encode type-level information for 'tagAttach'.
203+data K_TagAttach t = TagAttach t
153204
205+type DispatchTagAttachT t = DispatchT (TagAttach t)
154206
155−-- TagAttach instances
207+-- | Attach a tag to untagged transformers.
208+tagAttach :: forall tag m a . DispatchTagAttachT tag m a -> m a
209+tagAttach = coerce
156210
157211instance MonadReader tag r m
158212 => Class.MonadReader r (DispatchTagAttachT tag m) where
@@ -177,7 +231,16 @@ instance MonadWriter tag w m
177231 pass = Lift.liftPass (A.pass @tag)
178232
179233
180−-- TagReplace instances
234+-- TagReplace
235+
236+-- | Encode type-level information for 'tagReplace'.
237+data K_TagReplace tOld tNew = TagReplace tOld tNew
238+
239+type DispatchTagReplaceT tOld tNew = DispatchT (TagReplace tOld tNew)
240+
241+-- | Replace a tag with another tag.
242+tagReplace :: forall tOld tNew m a . DispatchTagReplaceT tOld tNew m a -> m a
243+tagReplace = coerce
181244
182245instance MonadReader tNew r m
183246 => MonadReader tOld r (DispatchTagReplaceT tOld tNew m) where