81d0c219a7d1d8375309c3011ef30611de351a4a
[packages/transformers.git] / Control / Monad / Trans / Identity.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__ >= 702
3 {-# LANGUAGE Safe #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 706
6 {-# LANGUAGE PolyKinds #-}
7 #endif
8 #if __GLASGOW_HASKELL__ >= 710
9 {-# LANGUAGE AutoDeriveTypeable #-}
10 #endif
11 -----------------------------------------------------------------------------
12 -- |
13 -- Module : Control.Monad.Trans.Identity
14 -- Copyright : (c) 2007 Magnus Therning
15 -- License : BSD-style (see the file LICENSE)
16 --
17 -- Maintainer : R.Paterson@city.ac.uk
18 -- Stability : experimental
19 -- Portability : portable
20 --
21 -- The identity monad transformer.
22 --
23 -- This is useful for functions parameterized by a monad transformer.
24 -----------------------------------------------------------------------------
25
26 module Control.Monad.Trans.Identity (
27 -- * The identity monad transformer
28 IdentityT(..),
29 mapIdentityT,
30 -- * Lifting other operations
31 liftCatch,
32 liftCallCC,
33 ) where
34
35 import Control.Monad.IO.Class (MonadIO(liftIO))
36 import Control.Monad.Signatures
37 import Control.Monad.Trans.Class (MonadTrans(lift))
38 import Data.Functor.Classes
39 #if MIN_VERSION_base(4,12,0)
40 import Data.Functor.Contravariant
41 #endif
42
43 import Control.Applicative
44 import Control.Monad (MonadPlus(mzero, mplus))
45 #if MIN_VERSION_base(4,9,0)
46 import qualified Control.Monad.Fail as Fail
47 #endif
48 import Control.Monad.Fix (MonadFix(mfix))
49 #if MIN_VERSION_base(4,4,0)
50 import Control.Monad.Zip (MonadZip(mzipWith))
51 #endif
52 import Data.Foldable
53 import Data.Traversable (Traversable(traverse))
54 import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length)
55
56 -- | The trivial monad transformer, which maps a monad to an equivalent monad.
57 newtype IdentityT f a = IdentityT { runIdentityT :: f a }
58
59 instance (Eq1 f) => Eq1 (IdentityT f) where
60 liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y
61 {-# INLINE liftEq #-}
62
63 instance (Ord1 f) => Ord1 (IdentityT f) where
64 liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y
65 {-# INLINE liftCompare #-}
66
67 instance (Read1 f) => Read1 (IdentityT f) where
68 liftReadsPrec rp rl = readsData $
69 readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT
70
71 instance (Show1 f) => Show1 (IdentityT f) where
72 liftShowsPrec sp sl d (IdentityT m) =
73 showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m
74
75 instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1
76 instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1
77 instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1
78 instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1
79
80 instance (Functor m) => Functor (IdentityT m) where
81 fmap f = mapIdentityT (fmap f)
82 {-# INLINE fmap #-}
83
84 instance (Foldable f) => Foldable (IdentityT f) where
85 foldMap f (IdentityT t) = foldMap f t
86 {-# INLINE foldMap #-}
87 foldr f z (IdentityT t) = foldr f z t
88 {-# INLINE foldr #-}
89 foldl f z (IdentityT t) = foldl f z t
90 {-# INLINE foldl #-}
91 foldr1 f (IdentityT t) = foldr1 f t
92 {-# INLINE foldr1 #-}
93 foldl1 f (IdentityT t) = foldl1 f t
94 {-# INLINE foldl1 #-}
95 #if MIN_VERSION_base(4,8,0)
96 null (IdentityT t) = null t
97 length (IdentityT t) = length t
98 #endif
99
100 instance (Traversable f) => Traversable (IdentityT f) where
101 traverse f (IdentityT a) = IdentityT <$> traverse f a
102 {-# INLINE traverse #-}
103
104 instance (Applicative m) => Applicative (IdentityT m) where
105 pure x = IdentityT (pure x)
106 {-# INLINE pure #-}
107 (<*>) = lift2IdentityT (<*>)
108 {-# INLINE (<*>) #-}
109 (*>) = lift2IdentityT (*>)
110 {-# INLINE (*>) #-}
111 (<*) = lift2IdentityT (<*)
112 {-# INLINE (<*) #-}
113
114 instance (Alternative m) => Alternative (IdentityT m) where
115 empty = IdentityT empty
116 {-# INLINE empty #-}
117 (<|>) = lift2IdentityT (<|>)
118 {-# INLINE (<|>) #-}
119
120 instance (Monad m) => Monad (IdentityT m) where
121 #if !(MIN_VERSION_base(4,8,0))
122 return = IdentityT . return
123 {-# INLINE return #-}
124 #endif
125 m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m
126 {-# INLINE (>>=) #-}
127 fail msg = IdentityT $ fail msg
128 {-# INLINE fail #-}
129
130 #if MIN_VERSION_base(4,9,0)
131 instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where
132 fail msg = IdentityT $ Fail.fail msg
133 {-# INLINE fail #-}
134 #endif
135
136 instance (MonadPlus m) => MonadPlus (IdentityT m) where
137 mzero = IdentityT mzero
138 {-# INLINE mzero #-}
139 mplus = lift2IdentityT mplus
140 {-# INLINE mplus #-}
141
142 instance (MonadFix m) => MonadFix (IdentityT m) where
143 mfix f = IdentityT (mfix (runIdentityT . f))
144 {-# INLINE mfix #-}
145
146 instance (MonadIO m) => MonadIO (IdentityT m) where
147 liftIO = IdentityT . liftIO
148 {-# INLINE liftIO #-}
149
150 #if MIN_VERSION_base(4,4,0)
151 instance (MonadZip m) => MonadZip (IdentityT m) where
152 mzipWith f = lift2IdentityT (mzipWith f)
153 {-# INLINE mzipWith #-}
154 #endif
155
156 instance MonadTrans IdentityT where
157 lift = IdentityT
158 {-# INLINE lift #-}
159
160 #if MIN_VERSION_base(4,12,0)
161 instance Contravariant f => Contravariant (IdentityT f) where
162 contramap f = IdentityT . contramap f . runIdentityT
163 {-# INLINE contramap #-}
164 #endif
165
166 -- | Lift a unary operation to the new monad.
167 mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b
168 mapIdentityT f = IdentityT . f . runIdentityT
169 {-# INLINE mapIdentityT #-}
170
171 -- | Lift a binary operation to the new monad.
172 lift2IdentityT ::
173 (m a -> n b -> p c) -> IdentityT m a -> IdentityT n b -> IdentityT p c
174 lift2IdentityT f a b = IdentityT (f (runIdentityT a) (runIdentityT b))
175 {-# INLINE lift2IdentityT #-}
176
177 -- | Lift a @callCC@ operation to the new monad.
178 liftCallCC :: CallCC m a b -> CallCC (IdentityT m) a b
179 liftCallCC callCC f =
180 IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c))
181 {-# INLINE liftCallCC #-}
182
183 -- | Lift a @catchE@ operation to the new monad.
184 liftCatch :: Catch e m a -> Catch e (IdentityT m) a
185 liftCatch f m h = IdentityT $ f (runIdentityT m) (runIdentityT . h)
186 {-# INLINE liftCatch #-}