1{-# LANGUAGE CPP #-} 2 3#ifndef MIN_VERSION_base 4#define MIN_VERSION_base(x,y,z) 1 5#endif 6 7#ifndef MIN_VERSION_mtl 8#define MIN_VERSION_mtl(x,y,z) 1 9#endif 10 11#ifndef HASKELL98 12{-# LANGUAGE TypeFamilies #-} 13{-# LANGUAGE TypeOperators #-} 14# ifdef MTL 15{-# LANGUAGE FlexibleInstances #-} 16{-# LANGUAGE MultiParamTypeClasses #-} 17{-# LANGUAGE UndecidableInstances #-} 18# if __GLASGOW_HASKELL__ >= 704 19{-# LANGUAGE Safe #-} 20# elif __GLASGOW_HASKELL__ >= 702 21{-# LANGUAGE Trustworthy #-} 22# endif 23# endif 24#endif 25----------------------------------------------------------------------------- 26-- | 27-- Module : Control.Monad.Trans.Except 28-- Copyright : (C) 2013 Ross Paterson 29-- (C) 2015 Edward Kmett 30-- License : BSD-style (see the file LICENSE) 31-- 32-- Maintainer : ross@soi.city.ac.uk 33-- Stability : experimental 34-- Portability : portable 35-- 36-- This monad transformer extends a monad with the ability throw exceptions. 37-- 38-- A sequence of actions terminates normally, producing a value, 39-- only if none of the actions in the sequence throws an exception. 40-- If one throws an exception, the rest of the sequence is skipped and 41-- the composite action exits with that exception. 42-- 43-- If the value of the exception is not required, the variant in 44-- "Control.Monad.Trans.Maybe" may be used instead. 45----------------------------------------------------------------------------- 46 47module Control.Monad.Trans.Except ( 48 -- * The Except monad 49 Except, 50 except, 51 runExcept, 52 mapExcept, 53 withExcept, 54 -- * The ExceptT monad transformer 55 ExceptT(..), 56 mapExceptT, 57 withExceptT, 58 -- * Exception operations 59 throwE, 60 catchE, 61 handleE, 62 tryE, 63 finallyE, 64 -- * Lifting other operations 65 liftCallCC, 66 liftListen, 67 liftPass, 68 ) where 69 70import Control.Applicative 71import Control.Monad 72import qualified Control.Monad.Fail as Fail 73import Control.Monad.Fix 74import Control.Monad.IO.Class 75import Control.Monad.Signatures 76import Control.Monad.Trans.Class 77#if MIN_VERSION_base(4,4,0) 78import Control.Monad.Zip (MonadZip(mzipWith)) 79#endif 80 81#ifdef MTL 82import Control.Monad.Writer.Class 83import Control.Monad.State.Class 84import Control.Monad.Reader.Class 85import Control.Monad.Cont.Class 86import Control.Monad.Error.Class 87import Control.Monad.RWS.Class 88#endif 89 90import Data.Foldable (Foldable(foldMap)) 91import Data.Functor.Classes 92import Data.Functor.Identity 93import Data.Monoid 94import Data.Traversable (Traversable(traverse)) 95 96#ifndef HASKELL98 97# ifdef GENERIC_DERIVING 98import Generics.Deriving.Base 99# elif __GLASGOW_HASKELL__ >= 702 100import GHC.Generics 101# endif 102#endif 103 104-- | The parameterizable exception monad. 105-- 106-- Computations are either exceptions or normal values. 107-- 108-- The 'return' function returns a normal value, while @>>=@ exits 109-- on the first exception. 110type Except e = ExceptT e Identity 111 112-- | Constructor for computations in the exception monad. 113-- (The inverse of 'runExcept'). 114except :: (Monad m) => Either e a -> ExceptT e m a 115except m = ExceptT (return m) 116{-# INLINE except #-} 117 118-- | Extractor for computations in the exception monad. 119-- (The inverse of 'except'). 120runExcept :: Except e a -> Either e a 121runExcept (ExceptT m) = runIdentity m 122{-# INLINE runExcept #-} 123 124-- | Map the unwrapped computation using the given function. 125-- 126-- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@ 127mapExcept :: (Either e a -> Either e' b) 128 -> Except e a 129 -> Except e' b 130mapExcept f = mapExceptT (Identity . f . runIdentity) 131{-# INLINE mapExcept #-} 132 133-- | Transform any exceptions thrown by the computation using the given 134-- function (a specialization of 'withExceptT'). 135withExcept :: (e -> e') -> Except e a -> Except e' a 136withExcept = withExceptT 137{-# INLINE withExcept #-} 138 139-- | A monad transformer that adds exceptions to other monads. 140-- 141-- @ExceptT@ constructs a monad parameterized over two things: 142-- 143-- * e - The exception type. 144-- 145-- * m - The inner monad. 146-- 147-- The 'return' function yields a computation that produces the given 148-- value, while @>>=@ sequences two subcomputations, exiting on the 149-- first exception. 150newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) } 151 152#ifndef HASKELL98 153# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING) 154-- Generic(1) instances for ExceptT 155instance Generic (ExceptT e m a) where 156 type Rep (ExceptT e m a) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (Rec0 (m (Either e a))))) 157 from (ExceptT x) = M1 (M1 (M1 (K1 x))) 158 to (M1 (M1 (M1 (K1 x)))) = ExceptT x 159 160instance Functor m => Generic1 (ExceptT e m) where 161 type Rep1 (ExceptT e m) = D1 D1'ExceptT (C1 C1_0'ExceptT (S1 NoSelector (m :.: Rec1 (Either e)))) 162 from1 (ExceptT x) = M1 (M1 (M1 ((.) Comp1 (fmap Rec1) x))) 163 to1 (M1 (M1 (M1 x))) = ExceptT ((.) (fmap unRec1) unComp1 x) 164 165instance Datatype D1'ExceptT where 166 datatypeName _ = "ExceptT" 167 moduleName _ = "Control.Monad.Trans.Except" 168# if MIN_VERSION_base(4,7,0) 169 isNewtype _ = True 170# endif 171 172instance Constructor C1_0'ExceptT where 173 conName _ = "ExceptT" 174 175data D1'ExceptT 176data C1_0'ExceptT 177# endif 178#endif 179 180instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where 181 liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y 182 {-# INLINE liftEq #-} 183 184instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where 185 liftCompare comp (ExceptT x) (ExceptT y) = 186 liftCompare (liftCompare comp) x y 187 {-# INLINE liftCompare #-} 188 189instance (Read e, Read1 m) => Read1 (ExceptT e m) where 190 liftReadsPrec rp rl = readsData $ 191 readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT 192 where 193 rp' = liftReadsPrec rp rl 194 rl' = liftReadList rp rl 195 196instance (Show e, Show1 m) => Show1 (ExceptT e m) where 197 liftShowsPrec sp sl d (ExceptT m) = 198 showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m 199 where 200 sp' = liftShowsPrec sp sl 201 sl' = liftShowList sp sl 202 203instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1 204instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1 205instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where 206 readsPrec = readsPrec1 207instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where 208 showsPrec = showsPrec1 209 210-- | Map the unwrapped computation using the given function. 211-- 212-- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@ 213mapExceptT :: (m (Either e a) -> n (Either e' b)) 214 -> ExceptT e m a 215 -> ExceptT e' n b 216mapExceptT f m = ExceptT $ f (runExceptT m) 217{-# INLINE mapExceptT #-} 218 219-- | Transform any exceptions thrown by the computation using the 220-- given function. 221withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a 222withExceptT f = mapExceptT $ fmap $ either (Left . f) Right 223{-# INLINE withExceptT #-} 224 225instance (Functor m) => Functor (ExceptT e m) where 226 fmap f = ExceptT . fmap (fmap f) . runExceptT 227 {-# INLINE fmap #-} 228 229instance (Foldable f) => Foldable (ExceptT e f) where 230 foldMap f (ExceptT a) = foldMap (either (const mempty) f) a 231 {-# INLINE foldMap #-} 232 233instance (Traversable f) => Traversable (ExceptT e f) where 234 traverse f (ExceptT a) = 235 ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a 236 {-# INLINE traverse #-} 237 238instance (Functor m, Monad m) => Applicative (ExceptT e m) where 239 pure a = ExceptT $ return (Right a) 240 {-# INLINE pure #-} 241 ExceptT f <*> ExceptT v = ExceptT $ do 242 mf <- f 243 case mf of 244 Left e -> return (Left e) 245 Right k -> do 246 mv <- v 247 case mv of 248 Left e -> return (Left e) 249 Right x -> return (Right (k x)) 250 {-# INLINEABLE (<*>) #-} 251 m *> k = m >>= \_ -> k 252 {-# INLINE (*>) #-} 253 254instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where 255 empty = ExceptT $ return (Left mempty) 256 {-# INLINE empty #-} 257 ExceptT mx <|> ExceptT my = ExceptT $ do 258 ex <- mx 259 case ex of 260 Left e -> liftM (either (Left . mappend e) Right) my 261 Right x -> return (Right x) 262 {-# INLINEABLE (<|>) #-} 263 264instance (Monad m) => Monad (ExceptT e m) where 265 return a = ExceptT $ return (Right a) 266 {-# INLINE return #-} 267 m >>= k = ExceptT $ do 268 a <- runExceptT m 269 case a of 270 Left e -> return (Left e) 271 Right x -> runExceptT (k x) 272 {-# INLINE (>>=) #-} 273#if !(MIN_VERSION_base(4,13,0)) 274 fail = ExceptT . fail 275 {-# INLINE fail #-} 276#endif 277 278instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where 279 fail = ExceptT . Fail.fail 280 {-# INLINE fail #-} 281 282instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where 283 mzero = ExceptT $ return (Left mempty) 284 {-# INLINE mzero #-} 285 ExceptT m `mplus` ExceptT n = ExceptT $ do 286 a <- m 287 case a of 288 Left e -> liftM (either (Left . mappend e) Right) n 289 Right x -> return (Right x) 290 {-# INLINEABLE mplus #-} 291 292instance (MonadFix m) => MonadFix (ExceptT e m) where 293 mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id)) 294 where bomb = error "mfix (ExceptT): inner computation returned Left value" 295 {-# INLINE mfix #-} 296 297instance MonadTrans (ExceptT e) where 298 lift = ExceptT . liftM Right 299 {-# INLINE lift #-} 300 301instance (MonadIO m) => MonadIO (ExceptT e m) where 302 liftIO = lift . liftIO 303 {-# INLINE liftIO #-} 304 305#if MIN_VERSION_base(4,4,0) 306instance (MonadZip m) => MonadZip (ExceptT e m) where 307 mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b 308 {-# INLINE mzipWith #-} 309#endif 310 311-- | Signal an exception value @e@. 312-- 313-- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@ 314-- 315-- * @'throwE' e >>= m = 'throwE' e@ 316throwE :: (Monad m) => e -> ExceptT e m a 317throwE = ExceptT . return . Left 318{-# INLINE throwE #-} 319 320-- | Handle an exception. 321-- 322-- * @'catchE' h ('lift' m) = 'lift' m@ 323-- 324-- * @'catchE' h ('throwE' e) = h e@ 325catchE :: (Monad m) => 326 ExceptT e m a -- ^ the inner computation 327 -> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner 328 -- computation 329 -> ExceptT e' m a 330m `catchE` h = ExceptT $ do 331 a <- runExceptT m 332 case a of 333 Left l -> runExceptT (h l) 334 Right r -> return (Right r) 335{-# INLINE catchE #-} 336 337-- | The same as @'flip' 'catchE'@, which is useful in situations where 338-- the code for the handler is shorter. 339handleE :: Monad m => (e -> ExceptT e' m a) -> ExceptT e m a -> ExceptT e' m a 340handleE = flip catchE 341{-# INLINE handleE #-} 342 343-- | Similar to 'catchE', but returns an 'Either' result which is 344-- @('Right' a)@ if no exception was thown, or @('Left' ex)@ if an 345-- exception @ex@ was thrown. 346tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a) 347tryE m = catchE (liftM Right m) (return . Left) 348{-# INLINE tryE #-} 349 350-- | @'finallyE' a b@ executes computation @a@ followed by computation @b@, 351-- even if @a@ exits early by throwing an exception. In the latter case, 352-- the exception is re-thrown after @b@ has been executed. 353finallyE :: Monad m => ExceptT e m a -> ExceptT e m () -> ExceptT e m a 354finallyE m closer = do 355 res <- tryE m 356 closer 357 either throwE return res 358{-# INLINE finallyE #-} 359 360-- | Lift a @callCC@ operation to the new monad. 361liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b 362liftCallCC callCC f = ExceptT $ 363 callCC $ \ c -> 364 runExceptT (f (\ a -> ExceptT $ c (Right a))) 365{-# INLINE liftCallCC #-} 366 367-- | Lift a @listen@ operation to the new monad. 368liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a 369liftListen listen = mapExceptT $ \ m -> do 370 (a, w) <- listen m 371 return $! fmap (\ r -> (r, w)) a 372{-# INLINE liftListen #-} 373 374-- | Lift a @pass@ operation to the new monad. 375liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a 376liftPass pass = mapExceptT $ \ m -> pass $ do 377 a <- m 378 return $! case a of 379 Left l -> (Left l, id) 380 Right (r, f) -> (Right r, f) 381{-# INLINE liftPass #-} 382 383-- incurring the mtl dependency for these avoids packages that need them introducing orphans. 384 385#ifdef MTL 386 387instance Monad m => MonadError e (ExceptT e m) where 388 throwError = throwE 389 catchError = catchE 390 391instance MonadWriter w m => MonadWriter w (ExceptT e m) where 392 tell = lift . tell 393 listen = liftListen listen 394 pass = liftPass pass 395#if MIN_VERSION_mtl(2,1,0) 396 writer = lift . writer 397#endif 398 399instance MonadState s m => MonadState s (ExceptT e m) where 400 get = lift get 401 put = lift . put 402#if MIN_VERSION_mtl(2,1,0) 403 state = lift . state 404#endif 405 406instance MonadReader r m => MonadReader r (ExceptT e m) where 407 ask = lift ask 408 local = mapExceptT . local 409#if MIN_VERSION_mtl(2,1,0) 410 reader = lift . reader 411#endif 412 413instance MonadRWS r w s m => MonadRWS r w s (ExceptT e m) 414 415instance MonadCont m => MonadCont (ExceptT e m) where 416 callCC = liftCallCC callCC 417 418#endif 419