{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Error.Lens
-- Copyright   :  (C) 2014-2016 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, 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
------------------------------------------------------------------------------

-- | 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 (M.First a) e a -> m r -> (a -> m r) -> m r
catching :: Getting (First a) e a -> m r -> (a -> m r) -> m r
catching Getting (First a) e a
l = (e -> Maybe a) -> m r -> (a -> m r) -> m r
forall e (m :: * -> *) t a.
MonadError e m =>
(e -> Maybe t) -> m a -> (t -> m a) -> m a
catchJust (Getting (First a) e a -> e -> Maybe a
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First a) e a
l)
{-# INLINE catching #-}

-- | Catch exceptions that match a given 'Prism' (or any 'Getter'), discarding
-- the information about the match. This is particularly 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 (M.First a) e a -> m r -> m r -> m r
catching_ :: Getting (First a) e a -> m r -> m r -> m r
catching_ Getting (First a) e a
l m r
a m r
b = (e -> Maybe a) -> m r -> (a -> m r) -> m r
forall e (m :: * -> *) t a.
MonadError e m =>
(e -> Maybe t) -> m a -> (t -> m a) -> m a
catchJust (Getting (First a) e a -> e -> Maybe a
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 (m r -> a -> m r
forall a b. a -> b -> a
const m r
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 (M.First a) e a -> (a -> m r) -> m r -> m r
handling :: Getting (First a) e a -> (a -> m r) -> m r -> m r
handling Getting (First a) e a
l = (m r -> (a -> m r) -> m r) -> (a -> m r) -> m r -> m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Getting (First a) e a -> m r -> (a -> m r) -> m r
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 #-}

-- | 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 (M.First a) e a -> m r -> m r -> m r
handling_ :: Getting (First a) e a -> m r -> m r -> m r
handling_ Getting (First a) e a
l = (m r -> m r -> m r) -> m r -> m r -> m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Getting (First a) e a -> m r -> m r -> m r
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
------------------------------------------------------------------------------

-- | '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 (M.First a) e a -> m r -> m (Either a r)
trying :: Getting (First a) e a -> m r -> m (Either a r)
trying Getting (First a) e a
l m r
m = Getting (First a) e a
-> m (Either a r) -> (a -> m (Either a r)) -> m (Either a r)
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 ((r -> Either a r) -> m r -> m (Either a r)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM r -> Either a r
forall a b. b -> Either a b
Right m r
m) (Either a r -> m (Either a r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a r -> m (Either a r))
-> (a -> Either a r) -> a -> m (Either a r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a r
forall a b. a -> Either a b
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 a -> [Handler e m a] -> m a
catches m a
m [Handler e m a]
hs = m a -> (e -> m a) -> m a
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 = (Handler e m a -> m a -> m a) -> m a -> [Handler e m a] -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Handler e m a -> m a -> m a
forall (m :: * -> *) r. Handler e m r -> m r -> m r
tryHandler (e -> m a
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 = m r -> (a -> m r) -> Maybe a -> m r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m r
res a -> m r
amr (e -> Maybe a
ema e
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 :: (a -> b) -> Handler e m a -> Handler e m b
fmap a -> b
f (Handler e -> Maybe a
ema a -> m a
amr) = (e -> Maybe a) -> (a -> m b) -> Handler e m b
forall e (m :: * -> *) r a.
(e -> Maybe a) -> (a -> m r) -> Handler e m r
Handler e -> Maybe a
ema ((a -> m b) -> Handler e m b) -> (a -> m b) -> Handler e m b
forall a b. (a -> b) -> a -> b
$ \a
a -> do
     a
r <- a -> m a
amr a
a
     b -> m b
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
(<>) = Handler e m a -> Handler e m a -> Handler e m a
forall a. Monoid a => a -> a -> a
M.mappend
  {-# INLINE (<>) #-}

instance Monad m => Alt (Handler e m) where
  Handler e -> Maybe a
ema a -> m a
amr <!> :: Handler e m a -> Handler e m a -> Handler e m a
<!> Handler e -> Maybe a
emb a -> m a
bmr = (e -> Maybe (Either a a)) -> (Either a a -> m a) -> Handler e m a
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 = a -> Either a a
forall a b. a -> Either a b
Left (a -> Either a a) -> Maybe a -> Maybe (Either a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> Maybe a
ema e
e Maybe (Either a a) -> Maybe (Either a a) -> Maybe (Either a a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Either a a
forall a b. b -> Either a b
Right (a -> Either a a) -> Maybe a -> Maybe (Either a a)
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 = (a -> m a) -> (a -> m a) -> Either a a -> m a
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 :: Handler e m a
zero = (e -> Maybe Any) -> (Any -> m a) -> Handler e m a
forall e (m :: * -> *) r a.
(e -> Maybe a) -> (a -> m r) -> Handler e m r
Handler (Maybe Any -> e -> Maybe Any
forall a b. a -> b -> a
const Maybe Any
forall a. Maybe a
Nothing) Any -> m a
forall a. HasCallStack => a
undefined
  {-# INLINE zero #-}

instance Monad m => M.Monoid (Handler e m a) where
  mempty :: Handler e m a
mempty = Handler e m a
forall (f :: * -> *) a. Plus f => f a
zero
  {-# INLINE mempty #-}
  mappend :: Handler e m a -> Handler e m a -> Handler e m a
mappend = Handler e m a -> Handler e m a -> Handler e m a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
(<!>)
  {-# INLINE mappend #-}

instance Handleable e m (Handler e m) where
  handler :: Getting (First a) e a -> (a -> m r) -> Handler e m r
handler = (e -> Maybe a) -> (a -> m r) -> Handler e m r
forall e (m :: * -> *) r a.
(e -> Maybe a) -> (a -> m r) -> Handler e m r
Handler ((e -> Maybe a) -> (a -> m r) -> Handler e m r)
-> (Getting (First a) e a -> e -> Maybe a)
-> Getting (First a) e a
-> (a -> m r)
-> Handler e m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First a) e a -> e -> Maybe a
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
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 t -> t -> m x
throwing :: AReview e t -> t -> m x
throwing AReview e t
l = AReview e t -> (e -> m x) -> t -> m x
forall b (m :: * -> *) t r.
MonadReader b m =>
AReview t b -> (t -> r) -> m r
reviews AReview e t
l e -> m x
forall e (m :: * -> *) a. MonadError e m => e -> m a
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 :: (e -> Maybe t) -> m a -> (t -> m a) -> m a
catchJust e -> Maybe t
f m a
m t -> m a
k = m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m a
m ((e -> m a) -> m a) -> (e -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \ e
e -> case e -> Maybe t
f e
e of
  Maybe t
Nothing -> e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
  Just t
x  -> t -> m a
k t
x
{-# INLINE catchJust #-}

-- | Similar to 'throwing' but specialised for the common case of
--   error constructors with no arguments.
--
-- @
-- data MyError = Foo | Bar
-- makePrisms ''MyError
-- 'throwing_' _Foo :: 'MonadError' MyError m => m a
-- @
throwing_ :: MonadError e m => AReview e () -> m x
throwing_ :: AReview e () -> m x
throwing_ AReview e ()
l = AReview e () -> () -> m x
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e ()
l ()
{-# INLINE throwing_ #-}