1{-# LANGUAGE CPP #-} 2#if __GLASGOW_HASKELL__ >= 702 3{-# LANGUAGE Safe #-} 4#endif 5#if __GLASGOW_HASKELL__ >= 710 6{-# LANGUAGE AutoDeriveTypeable #-} 7#endif 8----------------------------------------------------------------------------- 9-- | 10-- Module : Control.Monad.Trans.Maybe 11-- Copyright : (c) 2007 Yitzak Gale, Eric Kidd 12-- License : BSD-style (see the file LICENSE) 13-- 14-- Maintainer : R.Paterson@city.ac.uk 15-- Stability : experimental 16-- Portability : portable 17-- 18-- The 'MaybeT' monad transformer extends a monad with the ability to exit 19-- the computation without returning a value. 20-- 21-- A sequence of actions produces a value only if all the actions in 22-- the sequence do. If one exits, the rest of the sequence is skipped 23-- and the composite action exits. 24-- 25-- For a variant allowing a range of exception values, see 26-- "Control.Monad.Trans.Except". 27----------------------------------------------------------------------------- 28 29module Control.Monad.Trans.Maybe ( 30 -- * The MaybeT monad transformer 31 MaybeT(..), 32 mapMaybeT, 33 -- * Monad transformations 34 maybeToExceptT, 35 exceptToMaybeT, 36 -- * Lifting other operations 37 liftCallCC, 38 liftCatch, 39 liftListen, 40 liftPass, 41 ) where 42 43import Control.Monad.IO.Class 44import Control.Monad.Signatures 45import Control.Monad.Trans.Class 46import Control.Monad.Trans.Except (ExceptT(..)) 47import Data.Functor.Classes 48#if MIN_VERSION_base(4,12,0) 49import Data.Functor.Contravariant 50#endif 51 52import Control.Applicative 53import Control.Monad (MonadPlus(mzero, mplus), liftM) 54#if MIN_VERSION_base(4,9,0) 55import qualified Control.Monad.Fail as Fail 56#endif 57import Control.Monad.Fix (MonadFix(mfix)) 58#if MIN_VERSION_base(4,4,0) 59import Control.Monad.Zip (MonadZip(mzipWith)) 60#endif 61import Data.Foldable (Foldable(foldMap)) 62import Data.Maybe (fromMaybe) 63import Data.Traversable (Traversable(traverse)) 64 65-- | The parameterizable maybe monad, obtained by composing an arbitrary 66-- monad with the 'Maybe' monad. 67-- 68-- Computations are actions that may produce a value or exit. 69-- 70-- The 'return' function yields a computation that produces that 71-- value, while @>>=@ sequences two subcomputations, exiting if either 72-- computation does. 73newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } 74 75instance (Eq1 m) => Eq1 (MaybeT m) where 76 liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y 77 {-# INLINE liftEq #-} 78 79instance (Ord1 m) => Ord1 (MaybeT m) where 80 liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y 81 {-# INLINE liftCompare #-} 82 83instance (Read1 m) => Read1 (MaybeT m) where 84 liftReadsPrec rp rl = readsData $ 85 readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT 86 where 87 rp' = liftReadsPrec rp rl 88 rl' = liftReadList rp rl 89 90instance (Show1 m) => Show1 (MaybeT m) where 91 liftShowsPrec sp sl d (MaybeT m) = 92 showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m 93 where 94 sp' = liftShowsPrec sp sl 95 sl' = liftShowList sp sl 96 97instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1 98instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1 99instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1 100instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1 101 102-- | Transform the computation inside a @MaybeT@. 103-- 104-- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@ 105mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b 106mapMaybeT f = MaybeT . f . runMaybeT 107{-# INLINE mapMaybeT #-} 108 109-- | Convert a 'MaybeT' computation to 'ExceptT', with a default 110-- exception value. 111maybeToExceptT :: (Functor m) => e -> MaybeT m a -> ExceptT e m a 112maybeToExceptT e (MaybeT m) = ExceptT $ fmap (maybe (Left e) Right) m 113{-# INLINE maybeToExceptT #-} 114 115-- | Convert a 'ExceptT' computation to 'MaybeT', discarding the 116-- value of any exception. 117exceptToMaybeT :: (Functor m) => ExceptT e m a -> MaybeT m a 118exceptToMaybeT (ExceptT m) = MaybeT $ fmap (either (const Nothing) Just) m 119{-# INLINE exceptToMaybeT #-} 120 121instance (Functor m) => Functor (MaybeT m) where 122 fmap f = mapMaybeT (fmap (fmap f)) 123 {-# INLINE fmap #-} 124 125instance (Foldable f) => Foldable (MaybeT f) where 126 foldMap f (MaybeT a) = foldMap (foldMap f) a 127 {-# INLINE foldMap #-} 128 129instance (Traversable f) => Traversable (MaybeT f) where 130 traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a 131 {-# INLINE traverse #-} 132 133instance (Functor m, Monad m) => Applicative (MaybeT m) where 134 pure = MaybeT . return . Just 135 {-# INLINE pure #-} 136 mf <*> mx = MaybeT $ do 137 mb_f <- runMaybeT mf 138 case mb_f of 139 Nothing -> return Nothing 140 Just f -> do 141 mb_x <- runMaybeT mx 142 case mb_x of 143 Nothing -> return Nothing 144 Just x -> return (Just (f x)) 145 {-# INLINE (<*>) #-} 146 m *> k = m >>= \_ -> k 147 {-# INLINE (*>) #-} 148 149instance (Functor m, Monad m) => Alternative (MaybeT m) where 150 empty = MaybeT (return Nothing) 151 {-# INLINE empty #-} 152 x <|> y = MaybeT $ do 153 v <- runMaybeT x 154 case v of 155 Nothing -> runMaybeT y 156 Just _ -> return v 157 {-# INLINE (<|>) #-} 158 159instance (Monad m) => Monad (MaybeT m) where 160#if !(MIN_VERSION_base(4,8,0)) 161 return = MaybeT . return . Just 162 {-# INLINE return #-} 163#endif 164 x >>= f = MaybeT $ do 165 v <- runMaybeT x 166 case v of 167 Nothing -> return Nothing 168 Just y -> runMaybeT (f y) 169 {-# INLINE (>>=) #-} 170#if !(MIN_VERSION_base(4,13,0)) 171 fail _ = MaybeT (return Nothing) 172 {-# INLINE fail #-} 173#endif 174 175#if MIN_VERSION_base(4,9,0) 176instance (Monad m) => Fail.MonadFail (MaybeT m) where 177 fail _ = MaybeT (return Nothing) 178 {-# INLINE fail #-} 179#endif 180 181instance (Monad m) => MonadPlus (MaybeT m) where 182 mzero = MaybeT (return Nothing) 183 {-# INLINE mzero #-} 184 mplus x y = MaybeT $ do 185 v <- runMaybeT x 186 case v of 187 Nothing -> runMaybeT y 188 Just _ -> return v 189 {-# INLINE mplus #-} 190 191instance (MonadFix m) => MonadFix (MaybeT m) where 192 mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb)) 193 where bomb = error "mfix (MaybeT): inner computation returned Nothing" 194 {-# INLINE mfix #-} 195 196instance MonadTrans MaybeT where 197 lift = MaybeT . liftM Just 198 {-# INLINE lift #-} 199 200instance (MonadIO m) => MonadIO (MaybeT m) where 201 liftIO = lift . liftIO 202 {-# INLINE liftIO #-} 203 204#if MIN_VERSION_base(4,4,0) 205instance (MonadZip m) => MonadZip (MaybeT m) where 206 mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b 207 {-# INLINE mzipWith #-} 208#endif 209 210#if MIN_VERSION_base(4,12,0) 211instance Contravariant m => Contravariant (MaybeT m) where 212 contramap f = MaybeT . contramap (fmap f) . runMaybeT 213 {-# INLINE contramap #-} 214#endif 215 216-- | Lift a @callCC@ operation to the new monad. 217liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b 218liftCallCC callCC f = 219 MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just)) 220{-# INLINE liftCallCC #-} 221 222-- | Lift a @catchE@ operation to the new monad. 223liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a 224liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h) 225{-# INLINE liftCatch #-} 226 227-- | Lift a @listen@ operation to the new monad. 228liftListen :: (Monad m) => Listen w m (Maybe a) -> Listen w (MaybeT m) a 229liftListen listen = mapMaybeT $ \ m -> do 230 (a, w) <- listen m 231 return $! fmap (\ r -> (r, w)) a 232{-# INLINE liftListen #-} 233 234-- | Lift a @pass@ operation to the new monad. 235liftPass :: (Monad m) => Pass w m (Maybe a) -> Pass w (MaybeT m) a 236liftPass pass = mapMaybeT $ \ m -> pass $ do 237 a <- m 238 return $! case a of 239 Nothing -> (Nothing, id) 240 Just (v, f) -> (Just v, f) 241{-# INLINE liftPass #-} 242