{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Error.Lens -- Copyright : (C) 2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional -- Portability : Control.Monad.Error -- ---------------------------------------------------------------------------- module Control.Monad.Error.Lens ( -- * Catching catching, catching_ -- * Handling , handling, handling_ -- * Trying , trying -- * Handlers , catches , Handler(..) , Handleable(..) -- * Throwing , throwing ) where import Control.Applicative import Control.Lens import Control.Lens.Internal.Exception import Control.Monad import Control.Monad.Error.Class import Data.Functor.Plus import Data.Monoid import Data.Semigroup (Semigroup(..)) ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ -- | Catch exceptions that match a given 'Prism' (or any 'Getter', really). -- -- @ -- 'catching' :: 'MonadError' e m => 'Prism'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Lens'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Traversal'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Iso'' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Getter' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Fold' e a -> m r -> (a -> m r) -> m r -- @ catching :: MonadError e m => Getting (First a) e a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} -- | Catch exceptions that match a given 'Prism' (or any 'Getter'), discarding -- the information about the match. This is particuarly useful when you have -- a @'Prism'' e ()@ where the result of the 'Prism' or 'Fold' isn't -- particularly valuable, just the fact that it matches. -- -- @ -- 'catching_' :: 'MonadError' e m => 'Prism'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r -- @ catching_ :: MonadError e m => Getting (First a) e a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) {-# INLINE catching_ #-} ------------------------------------------------------------------------------ -- Handling ------------------------------------------------------------------------------ -- | A version of 'catching' with the arguments swapped around; useful in -- situations where the code for the handler is shorter. -- -- @ -- 'handling' :: 'MonadError' e m => 'Prism'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Lens'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Traversal'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Iso'' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Fold' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Getter' e a -> (a -> m r) -> m r -> m r -- @ handling :: MonadError e m => Getting (First a) e a -> (a -> m r) -> m r -> m r handling l = flip (catching l) {-# INLINE handling #-} -- | A version of 'catching_' with the arguments swapped around; useful in -- situations where the code for the handler is shorter. -- -- @ -- 'handling_' :: 'MonadError' e m => 'Prism'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Lens'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Iso'' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r -- @ handling_ :: MonadError e m => Getting (First a) e a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} ------------------------------------------------------------------------------ -- Trying ------------------------------------------------------------------------------ -- | 'trying' takes a 'Prism' (or any 'Getter') to select which exceptions are caught -- If the 'Exception' does not match the predicate, it is re-thrown. -- -- @ -- 'trying' :: 'MonadError' e m => 'Prism'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Lens'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Traversal'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Iso'' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Getter' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Fold' e a -> m r -> m ('Either' a r) -- @ trying :: MonadError e m => Getting (First a) e a -> m r -> m (Either a r) trying l m = catching l (liftM Right m) (return . Left) ------------------------------------------------------------------------------ -- Catches ------------------------------------------------------------------------------ -- | -- This function exists to remedy a gap between the functionality of @Control.Exception@ -- and @Control.Monad.Error@. @Control.Exception@ supplies 'Control.Exception.catches' and -- a notion of 'Control.Exception.Handler', which we duplicate here in a form suitable for -- working with any 'MonadError' instance. -- -- Sometimes you want to catch two different sorts of error. You could -- do something like -- -- @ -- f = 'handling' _Foo handleFoo ('handling' _Bar handleBar expr) -- @ -- -- -- However, there are a couple of problems with this approach. The first is -- that having two exception handlers is inefficient. However, the more -- serious issue is that the second exception handler will catch exceptions -- in the first, e.g. in the example above, if @handleFoo@ uses 'throwError' -- then the second exception handler will catch it. -- -- Instead, we provide a function 'catches', which would be used thus: -- -- @ -- f = 'catches' expr [ 'handler' _Foo handleFoo -- , 'handler' _Bar handleBar -- ] -- @ catches :: MonadError e m => m a -> [Handler e m a] -> m a catches m hs = catchError m go where go e = foldr tryHandler (throwError e) hs where tryHandler (Handler ema amr) res = maybe res amr (ema e) ------------------------------------------------------------------------------ -- Handlers ------------------------------------------------------------------------------ -- | You need this when using 'catches'. data Handler e m r = forall a. Handler (e -> Maybe a) (a -> m r) instance Monad m => Functor (Handler e m) where fmap f (Handler ema amr) = Handler ema $ \a -> do r <- amr a return (f r) {-# INLINE fmap #-} instance Monad m => Semigroup (Handler e m a) where (<>) = mappend {-# INLINE (<>) #-} instance Monad m => Alt (Handler e m) where Handler ema amr <!> Handler emb bmr = Handler emab abmr where emab e = Left <$> ema e <|> Right <$> emb e abmr = either amr bmr {-# INLINE (<!>) #-} instance Monad m => Plus (Handler e m) where zero = Handler (const Nothing) undefined {-# INLINE zero #-} instance Monad m => Monoid (Handler e m a) where mempty = zero {-# INLINE mempty #-} mappend = (<!>) {-# INLINE mappend #-} instance Handleable e m (Handler e m) where handler = Handler . preview {-# INLINE handler #-} ------------------------------------------------------------------------------ -- Throwing ------------------------------------------------------------------------------ -- | Throw an 'Exception' described by a 'Prism'. -- -- @'throwing' l ≡ 'reviews' l 'throwError'@ -- -- @ -- 'throwing' :: 'MonadError' e m => 'Prism'' e t -> t -> a -- 'throwing' :: 'MonadError' e m => 'Iso'' e t -> t -> a -- @ throwing :: MonadError e m => AReview e e t t -> t -> m x throwing l = reviews l throwError {-# INLINE throwing #-} ------------------------------------------------------------------------------ -- Misc. ------------------------------------------------------------------------------ -- | Helper function to provide conditional catch behavior. catchJust :: MonadError e m => (e -> Maybe t) -> m a -> (t -> m a) -> m a catchJust f m k = catchError m $ \ e -> case f e of Nothing -> throwError e Just x -> k x {-# INLINE catchJust #-}