diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs')
| -rw-r--r-- | third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs | 316 |
1 files changed, 316 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs new file mode 100644 index 0000000000..477b9dd482 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs @@ -0,0 +1,316 @@ +{-# 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 #-} |