{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Control.Monad.Error.Lens
(
catching, catching_
, handling, handling_
, trying
, 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 qualified Data.Monoid as M
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..))
#endif
catching :: MonadError e m => Getting (M.First a) e a -> m r -> (a -> m r) -> m r
catching :: forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> (a -> m r) -> m r
catching Getting (First a) e a
l = forall e (m :: * -> *) t a.
MonadError e m =>
(e -> Maybe t) -> m a -> (t -> m a) -> m a
catchJust (forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First a) e a
l)
{-# INLINE catching #-}
catching_ :: MonadError e m => Getting (M.First a) e a -> m r -> m r -> m r
catching_ :: forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> m r -> m r
catching_ Getting (First a) e a
l m r
a m r
b = forall e (m :: * -> *) t a.
MonadError e m =>
(e -> Maybe t) -> m a -> (t -> m a) -> m a
catchJust (forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First a) e a
l) m r
a (forall a b. a -> b -> a
const m r
b)
{-# INLINE catching_ #-}
handling :: MonadError e m => Getting (M.First a) e a -> (a -> m r) -> m r -> m r
handling :: forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> (a -> m r) -> m r -> m r
handling Getting (First a) e a
l = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> (a -> m r) -> m r
catching Getting (First a) e a
l)
{-# INLINE handling #-}
handling_ :: MonadError e m => Getting (M.First a) e a -> m r -> m r -> m r
handling_ :: forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> m r -> m r
handling_ Getting (First a) e a
l = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> m r -> m r
catching_ Getting (First a) e a
l)
{-# INLINE handling_ #-}
trying :: MonadError e m => Getting (M.First a) e a -> m r -> m (Either a r)
trying :: forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> m (Either a r)
trying Getting (First a) e a
l m r
m = forall e (m :: * -> *) a r.
MonadError e m =>
Getting (First a) e a -> m r -> (a -> m r) -> m r
catching Getting (First a) e a
l (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. b -> Either a b
Right m r
m) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
catches :: MonadError e m => m a -> [Handler e m a] -> m a
catches :: forall e (m :: * -> *) a.
MonadError e m =>
m a -> [Handler e m a] -> m a
catches m a
m [Handler e m a]
hs = forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m a
m e -> m a
go where
go :: e -> m a
go e
e = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {m :: * -> *} {r}. Handler e m r -> m r -> m r
tryHandler (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e) [Handler e m a]
hs where
tryHandler :: Handler e m r -> m r -> m r
tryHandler (Handler e -> Maybe a
ema a -> m r
amr) m r
res = forall b a. b -> (a -> b) -> Maybe a -> b
maybe m r
res a -> m r
amr (e -> Maybe a
ema e
e)
data Handler e m r = forall a. Handler (e -> Maybe a) (a -> m r)
instance Monad m => Functor (Handler e m) where
fmap :: forall a b. (a -> b) -> Handler e m a -> Handler e m b
fmap a -> b
f (Handler e -> Maybe a
ema a -> m a
amr) = forall e (m :: * -> *) r a.
(e -> Maybe a) -> (a -> m r) -> Handler e m r
Handler e -> Maybe a
ema forall a b. (a -> b) -> a -> b
$ \a
a -> do
a
r <- a -> m a
amr a
a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
r)
{-# INLINE fmap #-}
instance Monad m => Semigroup (Handler e m a) where
<> :: Handler e m a -> Handler e m a -> Handler e m a
(<>) = forall (f :: * -> *) a. Alt f => f a -> f a -> f a
(<!>)
{-# INLINE (<>) #-}
instance Monad m => Alt (Handler e m) where
Handler e -> Maybe a
ema a -> m a
amr <!> :: forall a. Handler e m a -> Handler e m a -> Handler e m a
<!> Handler e -> Maybe a
emb a -> m a
bmr = forall e (m :: * -> *) r a.
(e -> Maybe a) -> (a -> m r) -> Handler e m r
Handler e -> Maybe (Either a a)
emab Either a a -> m a
abmr where
emab :: e -> Maybe (Either a a)
emab e
e = forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> Maybe a
ema e
e forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> Maybe a
emb e
e
abmr :: Either a a -> m a
abmr = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m a
amr a -> m a
bmr
{-# INLINE (<!>) #-}
instance Monad m => Plus (Handler e m) where
zero :: forall a. Handler e m a
zero = forall e (m :: * -> *) r a.
(e -> Maybe a) -> (a -> m r) -> Handler e m r
Handler (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. HasCallStack => a
undefined
{-# INLINE zero #-}
instance Monad m => M.Monoid (Handler e m a) where
mempty :: Handler e m a
mempty = forall (f :: * -> *) a. Plus f => f a
zero
{-# INLINE mempty #-}
#if !(MIN_VERSION_base(4,11,0))
mappend = (<!>)
{-# INLINE mappend #-}
#endif
instance Handleable e m (Handler e m) where
handler :: forall a r.
Typeable a =>
Getting (First a) e a -> (a -> m r) -> Handler e m r
handler = forall e (m :: * -> *) r a.
(e -> Maybe a) -> (a -> m r) -> Handler e m r
Handler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview
{-# INLINE handler #-}
throwing :: MonadError e m => AReview e t -> t -> m x
throwing :: forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e t
l = forall b (m :: * -> *) t r.
MonadReader b m =>
AReview t b -> (t -> r) -> m r
reviews AReview e t
l forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
{-# INLINE throwing #-}
catchJust :: MonadError e m => (e -> Maybe t) -> m a -> (t -> m a) -> m a
catchJust :: forall e (m :: * -> *) t a.
MonadError e m =>
(e -> Maybe t) -> m a -> (t -> m a) -> m a
catchJust e -> Maybe t
f m a
m t -> m a
k = forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m a
m forall a b. (a -> b) -> a -> b
$ \ e
e -> case e -> Maybe t
f e
e of
Maybe t
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
Just t
x -> t -> m a
k t
x
{-# INLINE catchJust #-}
throwing_ :: MonadError e m => AReview e () -> m x
throwing_ :: forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ AReview e ()
l = forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e ()
l ()
{-# INLINE throwing_ #-}