@@ -0,0 +1,184 @@
1+{-# LANGUAGE CPP #-}
2+
3+#if __GLASGOW_HASKELL__ >= 710
4+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
5+#endif
6+
7+{-# LANGUAGE DeriveGeneric #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE FlexibleInstances #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE DataKinds #-}
14+{-# LANGUAGE PolyKinds #-}
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+
17+{- |
18+
19+-}
20+
21+module Control.Monad.Trans.Ether.Dispatch
22+ (
23+ -- * The DispatchT monad transformer
24+ DispatchT
25+ -- * Dispatch types and functions
26+ , K_TagAttach(..)
27+ , K_TagReplace(..)
28+ , tagAttach
29+ , tagReplace
30+ -- * Newtype operations
31+ , pack
32+ , unpack
33+ ) where
34+
35+import Control.Applicative
36+import Control.Monad (MonadPlus)
37+import Control.Monad.Fix (MonadFix)
38+import Control.Monad.Trans.Class (MonadTrans)
39+import Control.Monad.IO.Class (MonadIO)
40+import Control.Monad.Morph (MFunctor, MMonad)
41+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
42+import GHC.Generics (Generic)
43+import Data.Coerce (coerce)
44+import Data.Proxy
45+
46+import qualified Control.Monad.Base as MB
47+import qualified Control.Monad.Trans.Control as MC
48+import qualified Control.Monad.Trans.Identity as Trans
49+
50+import qualified Control.Monad.Trans.Lift.StT as Lift
51+import qualified Control.Monad.Trans.Lift.Local as Lift
52+import qualified Control.Monad.Trans.Lift.Catch as Lift
53+import qualified Control.Monad.Trans.Lift.Listen as Lift
54+import qualified Control.Monad.Trans.Lift.Pass as Lift
55+import qualified Control.Monad.Trans.Lift.CallCC as Lift
56+
57+import Control.Monad.Ether.Reader.Class
58+import Control.Monad.Ether.State.Class
59+import Control.Monad.Ether.Except.Class
60+import Control.Monad.Ether.Writer.Class
61+
62+import qualified Control.Monad.Reader as Class
63+import qualified Control.Monad.State as Class
64+import qualified Control.Monad.Except as Class
65+import qualified Control.Monad.Writer as Class
66+
67+-- | Encode type-level information for 'tagAttach'.
68+data K_TagAttach t = TagAttach t
69+
70+-- | Encode type-level information for 'tagReplace'.
71+data K_TagReplace tOld tNew = TagReplace tOld tNew
72+
73+-- | Wrap a monad to change its tags. Under the hood this is
74+-- simply 'Trans.IdentityT', all the work is happening on the type level.
75+newtype DispatchT dp m a = DispatchT (Trans.IdentityT m a)
76+ deriving
77+ ( Generic
78+ , Functor, Applicative, Alternative, Monad, MonadPlus
79+ , MonadFix, MonadTrans, MonadIO, MFunctor, MMonad
80+ , MonadThrow, MonadCatch, MonadMask )
81+
82+type DispatchTagAttachT t = DispatchT (TagAttach t)
83+type DispatchTagReplaceT tOld tNew = DispatchT (TagReplace tOld tNew)
84+
85+-- | Type-restricted 'coerce'.
86+pack :: Trans.IdentityT m a -> DispatchT dp m a
87+pack = coerce
88+
89+-- | Type-restricted 'coerce'.
90+unpack :: DispatchT dp m a -> Trans.IdentityT m a
91+unpack = coerce
92+
93+instance MB.MonadBase b m => MB.MonadBase b (DispatchT dp m) where
94+ liftBase = MB.liftBaseDefault
95+
96+instance MC.MonadTransControl (DispatchT dp) where
97+ type StT (DispatchT dp) a = MC.StT Trans.IdentityT a
98+ liftWith = MC.defaultLiftWith pack unpack
99+ restoreT = MC.defaultRestoreT pack
100+
101+instance MC.MonadBaseControl b m => MC.MonadBaseControl b (DispatchT dp m) where
102+ type StM (DispatchT dp m) a = MC.ComposeSt (DispatchT dp) m a
103+ liftBaseWith = MC.defaultLiftBaseWith
104+ restoreM = MC.defaultRestoreM
105+
106+type instance Lift.StT (DispatchT dp) a = MC.StT (DispatchT dp) a
107+
108+instance Lift.LiftLocal (DispatchT dp) where
109+ liftLocal = Lift.defaultLiftLocal pack unpack
110+
111+instance Lift.LiftCatch (DispatchT dp) where
112+ liftCatch = Lift.defaultLiftCatch pack unpack
113+
114+instance Lift.LiftListen (DispatchT dp) where
115+ liftListen = Lift.defaultLiftListen pack unpack
116+
117+instance Lift.LiftPass (DispatchT dp) where
118+ liftPass = Lift.defaultLiftPass pack unpack
119+
120+instance Lift.LiftCallCC (DispatchT dp) where
121+ liftCallCC = Lift.defaultLiftCallCC pack unpack
122+ liftCallCC' = Lift.defaultLiftCallCC' pack unpack
123+
124+-- | Attach a tag to untagged transformers.
125+tagAttach :: proxy t -> DispatchTagAttachT t m a -> m a
126+tagAttach _ = coerce
127+
128+-- | Replace a tag with another tag.
129+tagReplace
130+ :: proxy tOld
131+ -> proxy tNew
132+ -> DispatchTagReplaceT tOld tNew m a
133+ -> m a
134+tagReplace _ _ = coerce
135+
136+
137+-- TagAttach instances
138+
139+instance MonadReader tag r m
140+ => Class.MonadReader r (DispatchTagAttachT tag m) where
141+ ask = let t = Proxy :: Proxy tag in Lift.lift (ask t)
142+ local = let t = Proxy :: Proxy tag in Lift.liftLocal (ask t) (local t)
143+
144+instance MonadState tag s m
145+ => Class.MonadState s (DispatchTagAttachT tag m) where
146+ get = let t = Proxy :: Proxy tag in Lift.lift (get t)
147+ put = let t = Proxy :: Proxy tag in Lift.lift . put t
148+
149+instance MonadExcept tag e m
150+ => Class.MonadError e (DispatchTagAttachT tag m) where
151+ throwError = let t = Proxy :: Proxy tag in Lift.lift . throw t
152+ catchError = let t = Proxy :: Proxy tag in Lift.liftCatch (catch t)
153+
154+instance MonadWriter tag w m
155+ => Class.MonadWriter w (DispatchTagAttachT tag m) where
156+ writer = let t = Proxy :: Proxy tag in Lift.lift . writer t
157+ tell = let t = Proxy :: Proxy tag in Lift.lift . tell t
158+ listen = let t = Proxy :: Proxy tag in Lift.liftListen (listen t)
159+ pass = let t = Proxy :: Proxy tag in Lift.liftPass (pass t)
160+
161+
162+-- TagReplace instances
163+
164+instance MonadReader tNew r m
165+ => MonadReader tOld r (DispatchTagReplaceT tOld tNew m) where
166+ ask _ = let t = Proxy :: Proxy tNew in Lift.lift (ask t)
167+ local _ = let t = Proxy :: Proxy tNew in Lift.liftLocal (ask t) (local t)
168+
169+instance MonadState tNew s m
170+ => MonadState tOld s (DispatchTagReplaceT tOld tNew m) where
171+ get _ = let t = Proxy :: Proxy tNew in Lift.lift (get t)
172+ put _ = let t = Proxy :: Proxy tNew in Lift.lift . put t
173+
174+instance MonadExcept tNew e m
175+ => MonadExcept tOld e (DispatchTagReplaceT tOld tNew m) where
176+ throw _ = let t = Proxy :: Proxy tNew in Lift.lift . throw t
177+ catch _ = let t = Proxy :: Proxy tNew in Lift.liftCatch (catch t)
178+
179+instance MonadWriter tNew w m
180+ => MonadWriter tOld w (DispatchTagReplaceT tOld tNew m) where
181+ writer _ = let t = Proxy :: Proxy tNew in Lift.lift . writer t
182+ tell _ = let t = Proxy :: Proxy tNew in Lift.lift . tell t
183+ listen _ = let t = Proxy :: Proxy tNew in Lift.liftListen (listen t)
184+ pass _ = let t = Proxy :: Proxy tNew in Lift.liftPass (pass t)