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, 0 insertions, 316 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 deleted file mode 100644 index 477b9dd482..0000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# 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 #-} |