{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif
#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE AutoDeriveTypeable #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.Trans.Except
-- Copyright : (C) 2013 Ross Paterson
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : R.Paterson@city.ac.uk
-- Stability : experimental
-- Portability : portable
--
-- This monad transformer extends a monad with the ability to throw exceptions.
--
-- A sequence of actions terminates normally, producing a value,
-- only if none of the actions in the sequence throws an exception.
-- If one throws an exception, the rest of the sequence is skipped and
-- the composite action exits with that exception.
--
-- If the value of the exception is not required, the variant in
-- "Control.Monad.Trans.Maybe" may be used instead.
-----------------------------------------------------------------------------
module Control.Monad.Trans.Except (
-- * The Except monad
Except,
except,
runExcept,
mapExcept,
withExcept,
-- * The ExceptT monad transformer
ExceptT(ExceptT),
runExceptT,
mapExceptT,
withExceptT,
-- * Exception operations
throwE,
catchE,
-- * Lifting other operations
liftCallCC,
liftListen,
liftPass,
) where
import Control.Monad.IO.Class
import Control.Monad.Signatures
import Control.Monad.Trans.Class
import Data.Functor.Classes
#if MIN_VERSION_base(4,12,0)
import Data.Functor.Contravariant
#endif
import Data.Functor.Identity
import Control.Applicative
import Control.Monad
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
import Control.Monad.Fix
#if MIN_VERSION_base(4,4,0)
import Control.Monad.Zip (MonadZip(mzipWith))
#endif
import Data.Foldable (Foldable(foldMap))
import Data.Monoid
import Data.Traversable (Traversable(traverse))
-- | The parameterizable exception monad.
--
-- Computations are either exceptions or normal values.
--
-- The 'return' function returns a normal value, while @>>=@ exits on
-- the first exception. For a variant that continues after an error
-- and collects all the errors, see 'Control.Applicative.Lift.Errors'.
type Except e = ExceptT e Identity
-- | Constructor for computations in the exception monad.
-- (The inverse of 'runExcept').
except :: (Monad m) => Either e a -> ExceptT e m a
except m = ExceptT (return m)
{-# INLINE except #-}
-- | Extractor for computations in the exception monad.
-- (The inverse of 'except').
runExcept :: Except e a -> Either e a
runExcept (ExceptT m) = runIdentity m
{-# INLINE runExcept #-}
-- | Map the unwrapped computation using the given function.
--
-- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@
mapExcept :: (Either e a -> Either e' b)
-> Except e a
-> Except e' b
mapExcept f = mapExceptT (Identity . f . runIdentity)
{-# INLINE mapExcept #-}
-- | Transform any exceptions thrown by the computation using the given
-- function (a specialization of 'withExceptT').
withExcept :: (e -> e') -> Except e a -> Except e' a
withExcept = withExceptT
{-# INLINE withExcept #-}
-- | A monad transformer that adds exceptions to other monads.
--
-- @ExceptT@ constructs a monad parameterized over two things:
--
-- * e - The exception type.
--
-- * m - The inner monad.
--
-- The 'return' function yields a computation that produces the given
-- value, while @>>=@ sequences two subcomputations, exiting on the
-- first exception.
newtype ExceptT e m a = ExceptT (m (Either e a))
instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where
liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y
{-# INLINE liftEq #-}
instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where
liftCompare comp (ExceptT x) (ExceptT y) =
liftCompare (liftCompare comp) x y
{-# INLINE liftCompare #-}
instance (Read e, Read1 m) => Read1 (ExceptT e m) where
liftReadsPrec rp rl = readsData $
readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT
where
rp' = liftReadsPrec rp rl
rl' = liftReadList rp rl
instance (Show e, Show1 m) => Show1 (ExceptT e m) where
liftShowsPrec sp sl d (ExceptT m) =
showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m
where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a)
where (==) = eq1
instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a)
where compare = compare1
instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where
readsPrec = readsPrec1
instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where
showsPrec = showsPrec1
-- | The inverse of 'ExceptT'.
runExceptT :: ExceptT e m a -> m (Either e a)
runExceptT (ExceptT m) = m
{-# INLINE runExceptT #-}
-- | Map the unwrapped computation using the given function.
--
-- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@
mapExceptT :: (m (Either e a) -> n (Either e' b))
-> ExceptT e m a
-> ExceptT e' n b
mapExceptT f m = ExceptT $ f (runExceptT m)
{-# INLINE mapExceptT #-}
-- | Transform any exceptions thrown by the computation using the
-- given function.
withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f = mapExceptT $ fmap $ either (Left . f) Right
{-# INLINE withExceptT #-}
instance (Functor m) => Functor (ExceptT e m) where
fmap f = ExceptT . fmap (fmap f) . runExceptT
{-# INLINE fmap #-}
instance (Foldable f) => Foldable (ExceptT e f) where
foldMap f (ExceptT a) = foldMap (either (const mempty) f) a
{-# INLINE foldMap #-}
instance (Traversable f) => Traversable (ExceptT e f) where
traverse f (ExceptT a) =
ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a
{-# INLINE traverse #-}
instance (Functor m, Monad m) => Applicative (ExceptT e m) where
pure a = ExceptT $ return (Right a)
{-# INLINE pure #-}
ExceptT f <*> ExceptT v = ExceptT $ do
mf <- f
case mf of
Left e -> return (Left e)
Right k -> do
mv <- v
case mv of
Left e -> return (Left e)
Right x -> return (Right (k x))
{-# INLINEABLE (<*>) #-}
m *> k = m >>= \_ -> k
{-# INLINE (*>) #-}
instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where
empty = ExceptT $ return (Left mempty)
{-# INLINE empty #-}
ExceptT mx <|> ExceptT my = ExceptT $ do
ex <- mx
case ex of
Left e -> liftM (either (Left . mappend e) Right) my
Right x -> return (Right x)
{-# INLINEABLE (<|>) #-}
instance (Monad m) => Monad (ExceptT e m) where
#if !(MIN_VERSION_base(4,8,0))
return a = ExceptT $ return (Right a)
{-# INLINE return #-}
#endif
m >>= k = ExceptT $ do
a <- runExceptT m
case a of
Left e -> return (Left e)
Right x -> runExceptT (k x)
{-# INLINE (>>=) #-}
#if !(MIN_VERSION_base(4,13,0))
fail = ExceptT . fail
{-# INLINE fail #-}
#endif
#if MIN_VERSION_base(4,9,0)
instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where
fail = ExceptT . Fail.fail
{-# INLINE fail #-}
#endif
instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where
mzero = ExceptT $ return (Left mempty)
{-# INLINE mzero #-}
ExceptT mx `mplus` ExceptT my = ExceptT $ do
ex <- mx
case ex of
Left e -> liftM (either (Left . mappend e) Right) my
Right x -> return (Right x)
{-# INLINEABLE mplus #-}
instance (MonadFix m) => MonadFix (ExceptT e m) where
mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id))
where bomb = error "mfix (ExceptT): inner computation returned Left value"
{-# INLINE mfix #-}
instance MonadTrans (ExceptT e) where
lift = ExceptT . liftM Right
{-# INLINE lift #-}
instance (MonadIO m) => MonadIO (ExceptT e m) where
liftIO = lift . liftIO
{-# INLINE liftIO #-}
#if MIN_VERSION_base(4,4,0)
instance (MonadZip m) => MonadZip (ExceptT e m) where
mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b
{-# INLINE mzipWith #-}
#endif
#if MIN_VERSION_base(4,12,0)
instance Contravariant m => Contravariant (ExceptT e m) where
contramap f = ExceptT . contramap (fmap f) . runExceptT
{-# INLINE contramap #-}
#endif
-- | Signal an exception value @e@.
--
-- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@
--
-- * @'throwE' e >>= m = 'throwE' e@
throwE :: (Monad m) => e -> ExceptT e m a
throwE = ExceptT . return . Left
{-# INLINE throwE #-}
-- | Handle an exception.
--
-- * @'catchE' ('lift' m) h = 'lift' m@
--
-- * @'catchE' ('throwE' e) h = h e@
catchE :: (Monad m) =>
ExceptT e m a -- ^ the inner computation
-> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner
-- computation
-> ExceptT e' m a
m `catchE` h = ExceptT $ do
a <- runExceptT m
case a of
Left l -> runExceptT (h l)
Right r -> return (Right r)
{-# INLINE catchE #-}
-- | Lift a @callCC@ operation to the new monad.
liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b
liftCallCC callCC f = ExceptT $
callCC $ \ c ->
runExceptT (f (\ a -> ExceptT $ c (Right a)))
{-# INLINE liftCallCC #-}
-- | Lift a @listen@ operation to the new monad.
liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a
liftListen listen = mapExceptT $ \ m -> do
(a, w) <- listen m
return $! fmap (\ r -> (r, w)) a
{-# INLINE liftListen #-}
-- | Lift a @pass@ operation to the new monad.
liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a
liftPass pass = mapExceptT $ \ m -> pass $ do
a <- m
return $! case a of
Left l -> (Left l, id)
Right (r, f) -> (Right r, f)
{-# INLINE liftPass #-}