@@ -1,70 +1,146 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE UndecidableInstances #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE RankNTypes #-}
3+-- | Lifting the @callCC@ operation.
34module Control.Monad.Trans.Lift.CallCC
45 ( LiftCallCC(..)
56 , CallCC
7+ , defaultLiftCallCC
8+ , defaultLiftCallCC'
69 , module Control.Monad.Trans.Class
710 ) where
811
12+#if __GLASGOW_HASKELL__ < 710
913import Data.Monoid
14+#endif
1015
1116import Control.Monad.Signatures
1217import Control.Monad.Trans.Class
13−import Control.Monad.Trans.Control
1418
1519import qualified Control.Monad.Trans.Except as E
1620import qualified Control.Monad.Trans.Identity as I
1721import qualified Control.Monad.Trans.List as L
1822import qualified Control.Monad.Trans.Maybe as M
1923import qualified Control.Monad.Trans.Reader as R
20−import qualified Control.Monad.Trans.Cont as C
2124import qualified Control.Monad.Trans.RWS.Lazy as RWS.Lazy
2225import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict
26+import qualified Control.Monad.Trans.RWS.CPS as RWS.CPS
2327import qualified Control.Monad.Trans.State.Lazy as S.Lazy
2428import qualified Control.Monad.Trans.State.Strict as S.Strict
2529import qualified Control.Monad.Trans.Writer.Lazy as W.Lazy
2630import qualified Control.Monad.Trans.Writer.Strict as W.Strict
31+import qualified Control.Monad.Trans.Writer.CPS as W.CPS
2732
33+#if MIN_VERSION_transformers(0,5,3)
34+import qualified Control.Monad.Trans.Accum as Acc
35+#endif
36+
37+import Control.Monad.Trans.Lift.StT
38+
39+-- | The class of monad transformers capable of lifting 'callCC'.
2840class MonadTrans t => LiftCallCC t where
29− type CallCCStT t a
30− type CallCCStT t a = StT t a
31− liftCallCC :: Monad m => CallCC m (CallCCStT t a) (CallCCStT t b) -> CallCC (t m) a b
32− liftCallCC' :: Monad m => CallCC m (CallCCStT t a) (CallCCStT t b) -> CallCC (t m) a b
41+ -- | Lift the @callCC@ operation.
42+ -- Should satisfy the uniformity property
43+ --
44+ -- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = 'liftCallCC' cf f'@
45+ --
46+ liftCallCC :: Monad m => CallCC m (StT t a) (StT t b) -> CallCC (t m) a b
47+
48+ -- | Lift the @callCC@ operation.
49+ -- This is an alternative version of 'liftCallCC' included for historical
50+ -- reasons. It has a different lifting behavior for the @StateT@ and @RWST@
51+ -- monad transformers. Matches what @mtl@ does but doesn't satisfy the
52+ -- uniformity property.
53+ liftCallCC' :: Monad m => CallCC m (StT t a) (StT t b) -> CallCC (t m) a b
3354 liftCallCC' = liftCallCC
3455
56+-- | Default definition for the 'liftCallCC' method.
57+defaultLiftCallCC
58+ :: (Monad m, LiftCallCC n)
59+ => (forall x . n m x -> t m x)
60+ -- ^ Monad constructor
61+ -> (forall o x . t o x -> n o x)
62+ -- ^ Monad deconstructor
63+ -> CallCC m (StT n a) (StT n b)
64+ -> CallCC (t m) a b
65+defaultLiftCallCC t unT callCC f
66+ = t $ liftCallCC callCC (\g -> (unT . f) (t . g))
67+
68+-- | Default definition for the 'liftCallCC'' method.
69+defaultLiftCallCC'
70+ :: (Monad m, LiftCallCC n)
71+ => (forall x . n m x -> t m x)
72+ -- ^ Monad constructor
73+ -> (forall o x . t o x -> n o x)
74+ -- ^ Monad deconstructor
75+ -> CallCC m (StT n a) (StT n b)
76+ -> CallCC (t m) a b
77+defaultLiftCallCC' t unT callCC f
78+ = t $ liftCallCC' callCC (\g -> (unT . f) (t . g))
79+
3580instance LiftCallCC (E.ExceptT e) where
36− liftCallCC = E.liftCallCC
81+ liftCallCC = E.liftCallCC
82+ {-# INLINE liftCallCC #-}
3783
3884instance LiftCallCC I.IdentityT where
39− liftCallCC = I.liftCallCC
85+ liftCallCC = I.liftCallCC
86+ {-# INLINE liftCallCC #-}
4087
4188instance LiftCallCC L.ListT where
42− liftCallCC = L.liftCallCC
89+ liftCallCC = L.liftCallCC
90+ {-# INLINE liftCallCC #-}
4391
4492instance LiftCallCC M.MaybeT where
45− liftCallCC = M.liftCallCC
93+ liftCallCC = M.liftCallCC
94+ {-# INLINE liftCallCC #-}
4695
4796instance LiftCallCC (R.ReaderT r) where
48− liftCallCC = R.liftCallCC
97+ liftCallCC = R.liftCallCC
98+ {-# INLINE liftCallCC #-}
99+
100+instance Monoid w => LiftCallCC (W.Lazy.WriterT w) where
101+ liftCallCC = W.Lazy.liftCallCC
102+ {-# INLINE liftCallCC #-}
103+
104+instance Monoid w => LiftCallCC (W.Strict.WriterT w) where
105+ liftCallCC = W.Strict.liftCallCC
106+ {-# INLINE liftCallCC #-}
107+
108+instance Monoid w => LiftCallCC (W.CPS.WriterT w) where
109+ liftCallCC = W.CPS.liftCallCC
110+ {-# INLINE liftCallCC #-}
49111
50112instance Monoid w => LiftCallCC (RWS.Lazy.RWST r w s) where
51113 liftCallCC = RWS.Lazy.liftCallCC
114+ {-# INLINE liftCallCC #-}
52115 liftCallCC' = RWS.Lazy.liftCallCC'
116+ {-# INLINE liftCallCC' #-}
53117
54118instance Monoid w => LiftCallCC (RWS.Strict.RWST r w s) where
55119 liftCallCC = RWS.Strict.liftCallCC
120+ {-# INLINE liftCallCC #-}
56121 liftCallCC' = RWS.Strict.liftCallCC'
122+ {-# INLINE liftCallCC' #-}
123+
124+instance Monoid w => LiftCallCC (RWS.CPS.RWST r w s) where
125+ liftCallCC = RWS.CPS.liftCallCC
126+ {-# INLINE liftCallCC #-}
127+ liftCallCC' = RWS.CPS.liftCallCC'
128+ {-# INLINE liftCallCC' #-}
57129
58130instance LiftCallCC (S.Lazy.StateT s) where
59131 liftCallCC = S.Lazy.liftCallCC
132+ {-# INLINE liftCallCC #-}
60133 liftCallCC' = S.Lazy.liftCallCC'
134+ {-# INLINE liftCallCC' #-}
61135
62136instance LiftCallCC (S.Strict.StateT s) where
63137 liftCallCC = S.Strict.liftCallCC
138+ {-# INLINE liftCallCC #-}
64139 liftCallCC' = S.Strict.liftCallCC'
140+ {-# INLINE liftCallCC' #-}
65141
66−instance Monoid w => LiftCallCC (W.Lazy.WriterT w) where
67− liftCallCC = W.Lazy.liftCallCC
68−
69−instance Monoid w => LiftCallCC (W.Strict.WriterT w) where
70− liftCallCC = W.Strict.liftCallCC
142+#if MIN_VERSION_transformers(0,5,3)
143+instance Monoid w => LiftCallCC (Acc.AccumT w) where
144+ liftCallCC = Acc.liftCallCC
145+ {-# INLINE liftCallCC #-}
146+#endif