@@ -1,10 +1,10 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TypeFamilies #-}
3−{-# LANGUAGE UndecidableInstances #-}
4−{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE RankNTypes #-}
3+-- | Lifting the @listen@ operation.
54module Control.Monad.Trans.Lift.Listen
65 ( LiftListen(..)
76 , Listen
7+ , defaultLiftListen
88 , module Control.Monad.Trans.Class
99 ) where
1010
@@ -14,37 +14,107 @@ import Data.Monoid
1414
1515import Control.Monad.Signatures
1616import Control.Monad.Trans.Class
17−import Control.Monad.Trans.Control
18−
19−import qualified Control.Monad.Trans.Except as E
20−import qualified Control.Monad.Trans.Identity as I
21−import qualified Control.Monad.Trans.Maybe as M
22−import qualified Control.Monad.Trans.Reader as R
23−import qualified Control.Monad.Trans.RWS.Lazy as RWS.Lazy
24−import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict
25−import qualified Control.Monad.Trans.State.Lazy as S.Lazy
26−import qualified Control.Monad.Trans.State.Strict as S.Strict
27−import qualified Control.Monad.Trans.Writer.Lazy as W.Lazy
28−import qualified Control.Monad.Trans.Writer.Strict as W.Strict
2917
18+import qualified Control.Monad.Trans.Except as E
19+import qualified Control.Monad.Trans.Identity as I
20+import qualified Control.Monad.Trans.Maybe as M
21+import qualified Control.Monad.Trans.Reader as R
22+import qualified Control.Monad.Trans.RWS.Lazy as RWS.Lazy
23+import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict
24+import qualified Control.Monad.Trans.RWS.CPS.Internal as RWS.CPS
25+import qualified Control.Monad.Trans.State.Lazy as S.Lazy
26+import qualified Control.Monad.Trans.State.Strict as S.Strict
27+import qualified Control.Monad.Trans.Writer.Lazy as W.Lazy
28+import qualified Control.Monad.Trans.Writer.Strict as W.Strict
29+import qualified Control.Monad.Trans.Writer.CPS.Internal as W.CPS
30+
31+#if MIN_VERSION_transformers(0,5,3)
32+import qualified Control.Monad.Trans.Accum as Acc
33+#endif
34+
35+import Control.Monad.Trans.Lift.StT
36+
37+-- | The class of monad transformers capable of lifting 'listen'.
3038class MonadTrans t => LiftListen t where
31− type ListenStT t a
32− type ListenStT t a = StT t a
33− liftListen :: Monad m => Listen w m (ListenStT t a) -> Listen w (t m) a
34− default liftListen
35− :: (MonadTransControl t, ListenStT t a ~ StT t a, Monad m, Monad (t m))
36− => Listen w m (ListenStT t a) -> Listen w (t m) a
37− liftListen listen m = do
38− (st, w) <- liftWith (\run -> listen (run m))
39− flip (,) w `fmap` restoreT (return st)
40−
41−instance LiftListen (E.ExceptT e)
42−instance LiftListen I.IdentityT
43−instance LiftListen M.MaybeT
44−instance LiftListen (R.ReaderT r)
45−instance LiftListen (S.Lazy.StateT s)
46−instance LiftListen (S.Strict.StateT s)
47−instance Monoid w => LiftListen (RWS.Lazy.RWST r w s) where
48−instance Monoid w => LiftListen (RWS.Strict.RWST r w s) where
49−instance Monoid w => LiftListen (W.Lazy.WriterT w)
50−instance Monoid w => LiftListen (W.Strict.WriterT w)
39+ -- | Lift the @listen@ operation.
40+ -- Should satisfy the uniformity property
41+ --
42+ -- * @'lift' . 'liftListen' = 'liftListen' . 'lift'@
43+ --
44+ liftListen :: Monad m => Listen w m (StT t a) -> Listen w (t m) a
45+
46+-- | Default definition for the `liftListen` method.
47+defaultLiftListen
48+ :: (Monad m, LiftListen n)
49+ => (forall x . n m x -> t m x)
50+ -- ^ Monad constructor
51+ -> (forall o x . t o x -> n o x)
52+ -- ^ Monad deconstructor
53+ -> Listen w m (StT n a) -> Listen w (t m) a
54+defaultLiftListen t unT listen m = t $ liftListen listen (unT m)
55+
56+instance LiftListen (E.ExceptT e) where
57+ liftListen = E.liftListen
58+ {-# INLINE liftListen #-}
59+
60+instance LiftListen I.IdentityT where
61+ liftListen = I.mapIdentityT
62+ {-# INLINE liftListen #-}
63+
64+instance LiftListen M.MaybeT where
65+ liftListen = M.liftListen
66+ {-# INLINE liftListen #-}
67+
68+instance LiftListen (R.ReaderT r) where
69+ liftListen = R.mapReaderT
70+ {-# INLINE liftListen #-}
71+
72+instance LiftListen (S.Lazy.StateT s) where
73+ liftListen = S.Lazy.liftListen
74+ {-# INLINE liftListen #-}
75+
76+instance LiftListen (S.Strict.StateT s) where
77+ liftListen = S.Strict.liftListen
78+ {-# INLINE liftListen #-}
79+
80+instance Monoid w' => LiftListen (RWS.Lazy.RWST r w' s) where
81+ liftListen listen m = RWS.Lazy.RWST $ \r s -> do
82+ ~((a, w', s'), w) <- listen (RWS.Lazy.runRWST m r s)
83+ return ((a, w), w', s')
84+ {-# INLINE liftListen #-}
85+
86+instance Monoid w' => LiftListen (RWS.Strict.RWST r w' s) where
87+ liftListen listen m = RWS.Strict.RWST $ \r s -> do
88+ ((a, w', s'), w) <- listen (RWS.Strict.runRWST m r s)
89+ return ((a, w), w', s')
90+ {-# INLINE liftListen #-}
91+
92+instance Monoid w' => LiftListen (RWS.CPS.RWST r w' s) where
93+ liftListen listen m = RWS.CPS.RWST $ \r w_ s -> do
94+ ((a, w', s'), w) <- listen (RWS.CPS.unRWST m r w_ s)
95+ return ((a, w), w', s')
96+ {-# INLINE liftListen #-}
97+
98+instance Monoid w' => LiftListen (W.Lazy.WriterT w') where
99+ liftListen listen m = W.Lazy.WriterT $ do
100+ ~((a, w'), w) <- listen (W.Lazy.runWriterT m)
101+ return ((a, w), w')
102+ {-# INLINE liftListen #-}
103+
104+instance Monoid w' => LiftListen (W.Strict.WriterT w') where
105+ liftListen listen m = W.Strict.WriterT $ do
106+ ((a, w'), w) <- listen (W.Strict.runWriterT m)
107+ return ((a, w), w')
108+ {-# INLINE liftListen #-}
109+
110+instance Monoid w' => LiftListen (W.CPS.WriterT w') where
111+ liftListen listen m = W.CPS.WriterT $ \w_ -> do
112+ ((a, w'), w) <- listen (W.CPS.unWriterT m w_)
113+ return ((a, w), w')
114+ {-# INLINE liftListen #-}
115+
116+#if MIN_VERSION_transformers(0,5,3)
117+instance Monoid w' => LiftListen (Acc.AccumT w') where
118+ liftListen = Acc.liftListen
119+ {-# INLINE liftListen #-}
120+#endif