{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

-- | Rescue semantics & helpers
--
-- Essentially a type-directed version of 'Control.Monad.Catch'.
--
-- This is the opposite of 'Control.Monad.Raise', which embeds en error.
-- 'Rescue' takes a potential error out of the surrounding context
-- and either handles or exposes it.
module Control.Monad.Rescue
  ( attemptM

  -- * Recover from exceptions

  , rescue
  , rescueT
  , rescueM
  , rescueBase

  , rescueEach
  , rescueEachM
  , rescueEachT

  , rescueAll

  -- * Guaranteed runs

  , reattempt
  , report
  , lastly

  -- * Error access

  , mapError
  , replaceError
  , asNotFound

  -- * Reexports

  , module Control.Monad.Raise
  , module Control.Monad.Rescue.Class
  , module Control.Monad.Rescue.Constraint
  ) where

import           Numeric.Natural

import           Data.Bifunctor                  as Bifunctor
import           Data.Exception.Types
import           Data.WorldPeace

import           Control.Monad.Base
import           Control.Monad.Raise
import           Control.Monad.Rescue.Class
import           Control.Monad.Rescue.Constraint
import           Control.Monad.Trans.Error

-- $setup
--
-- >>> :set -XDataKinds
-- >>> :set -XFlexibleContexts
-- >>> :set -XTypeApplications
-- >>> :set -XLambdaCase
--
-- >>> import Control.Monad.Trans.Rescue
-- >>> import Data.Proxy
-- >>> import Data.WorldPeace as OpenUnion
--
-- >>> data FooErr  = FooErr  deriving Show
-- >>> data BarErr  = BarErr  deriving Show
-- >>> data QuuxErr = QuuxErr deriving Show

-- | Simpler helper to eliminate the bind operator from an attempt flow
--
-- >>> type MyErrs = '[FooErr, BarErr]
--
-- >>> :{
-- boom :: Rescue MyErrs String
-- boom = raise FooErr
-- :}
--
-- >>> :{
-- attempt boom >>= \case
--   Left  err -> return ("err: " ++ show err)
--   Right val -> return val
-- :}
-- RescueT (Identity (Right "err: Identity FooErr"))
--
-- >>> :{
-- attemptM boom $ \case
--   Left  err -> return ("err: " ++ show err)
--   Right val -> return val
-- :}
-- RescueT (Identity (Right "err: Identity FooErr"))
attemptM :: MonadRescue m => m a -> (Either (ErrorCase m) a -> m b) -> m b
attemptM :: m a -> (Either (ErrorCase m) a -> m b) -> m b
attemptM m a
action Either (ErrorCase m) a -> m b
handler = m a -> m (Either (ErrorCase m) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m a
action m (Either (ErrorCase m) a)
-> (Either (ErrorCase m) a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either (ErrorCase m) a -> m b
handler

rescue
  :: ( Bifunctor m
     , ElemRemove err errs
     )
  => (err -> OpenUnion (Remove err errs))
  -> m (OpenUnion             errs)  a
  -> m (OpenUnion (Remove err errs)) a
rescue :: (err -> OpenUnion (Remove err errs))
-> m (OpenUnion errs) a -> m (OpenUnion (Remove err errs)) a
rescue err -> OpenUnion (Remove err errs)
handler = (OpenUnion errs -> OpenUnion (Remove err errs))
-> m (OpenUnion errs) a -> m (OpenUnion (Remove err errs)) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first ((OpenUnion (Remove err errs) -> OpenUnion (Remove err errs))
-> (err -> OpenUnion (Remove err errs))
-> OpenUnion errs
-> OpenUnion (Remove err errs)
forall a (as :: [*]) b.
ElemRemove a as =>
(OpenUnion (Remove a as) -> b) -> (a -> b) -> OpenUnion as -> b
openUnionHandle OpenUnion (Remove err errs) -> OpenUnion (Remove err errs)
forall a. a -> a
id err -> OpenUnion (Remove err errs)
handler)

-- | Handle and eliminate a single error
rescueT ::
  ( MonadTransError t errs m
  , MonadRaise  (t (Remove err errs) m)
  , CheckErrors (t (Remove err errs) m)
  , ElemRemove err (Errors (t errs m))
  , Remove     err (Errors (t errs m)) ~ Errors (t (Remove err errs) m)
  )
  => (err -> (t (Remove err errs)) m a)
  -> t             errs  m a
  -> t (Remove err errs) m a
rescueT :: (err -> t (Remove err errs) m a)
-> t errs m a -> t (Remove err errs) m a
rescueT err -> t (Remove err errs) m a
handler = (OpenUnion (Errors (t errs m)) -> t (Remove err errs) m a)
-> t errs m a -> t (Remove err errs) m a
forall (t :: [*] -> (* -> *) -> * -> *) (sourceErrs :: [*])
       (m :: * -> *) (targetErrs :: [*]) a.
MonadTransError t sourceErrs m =>
(OpenUnion (Errors (t sourceErrs m)) -> t targetErrs m a)
-> t sourceErrs m a -> t targetErrs m a
onRaise ((OpenUnion (Remove err (Errors (t errs m)))
 -> t (Remove err errs) m a)
-> (err -> t (Remove err errs) m a)
-> OpenUnion (Errors (t errs m))
-> t (Remove err errs) m a
forall a (as :: [*]) b.
ElemRemove a as =>
(OpenUnion (Remove a as) -> b) -> (a -> b) -> OpenUnion as -> b
openUnionHandle OpenUnion (Remove err (Errors (t errs m)))
-> t (Remove err errs) m a
forall (m :: * -> *) err a.
(MonadRaise m, Subset err (ErrorCase m)) =>
err -> m a
raise err -> t (Remove err errs) m a
handler)

-- | The more generic (MonadBase-ified) version of handle
rescueBase
  :: ( MonadRescue wide
     , MonadBase   wide narrow
     , MonadRaise       narrow
     , CheckErrors      narrow
     , Remove     err (Errors wide) ~ Errors narrow
     , ElemRemove err (Errors wide)
     )
  => (err -> narrow a)
  -> wide   a
  -> narrow a
rescueBase :: (err -> narrow a) -> wide a -> narrow a
rescueBase err -> narrow a
handler wide a
action =
  wide (Either (OpenUnion (Errors wide)) a)
-> narrow (Either (OpenUnion (Errors wide)) a)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (wide a -> wide (Either (OpenUnion (Errors wide)) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt wide a
action) narrow (Either (OpenUnion (Errors wide)) a)
-> (Either (OpenUnion (Errors wide)) a -> narrow a) -> narrow a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left OpenUnion (Errors wide)
err    -> (OpenUnion (Remove err (Errors wide)) -> narrow a)
-> (err -> narrow a) -> OpenUnion (Errors wide) -> narrow a
forall a (as :: [*]) b.
ElemRemove a as =>
(OpenUnion (Remove a as) -> b) -> (a -> b) -> OpenUnion as -> b
openUnionHandle OpenUnion (Remove err (Errors wide)) -> narrow a
forall (m :: * -> *) err a.
(MonadRaise m, Subset err (ErrorCase m)) =>
err -> m a
raise err -> narrow a
handler OpenUnion (Errors wide)
err
    Right a
value -> a -> narrow a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value

rescueM
  :: ( MonadBase   (m (OpenUnion wide)) (m (OpenUnion (Remove err wide)))
     , MonadRescue (m (OpenUnion wide))
     , MonadRaise  (m (OpenUnion narrow))
     --
     , wide   ~ Errors (m (OpenUnion wide))
     , narrow ~ Errors (m (OpenUnion narrow))
     , narrow ~ Remove err wide
     , CheckErrors (m (OpenUnion narrow))
     , ElemRemove err wide
     )
  => (err -> m (OpenUnion narrow) a)
  -> m (OpenUnion wide)   a
  -> m (OpenUnion narrow) a
rescueM :: (err -> m (OpenUnion narrow) a)
-> m (OpenUnion wide) a -> m (OpenUnion narrow) a
rescueM err -> m (OpenUnion narrow) a
handler m (OpenUnion wide) a
action =
  m (OpenUnion wide) (Either (OpenUnion wide) a)
-> m (OpenUnion narrow) (Either (OpenUnion wide) a)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (m (OpenUnion wide) a
-> m (OpenUnion wide) (Either (ErrorCase (m (OpenUnion wide))) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m (OpenUnion wide) a
action) m (OpenUnion narrow) (Either (OpenUnion wide) a)
-> (Either (OpenUnion wide) a -> m (OpenUnion narrow) a)
-> m (OpenUnion narrow) a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right a
val ->
      a -> m (OpenUnion narrow) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

    Left OpenUnion wide
errs ->
      case OpenUnion wide -> Either (OpenUnion (Remove err wide)) err
forall a (as :: [*]).
ElemRemove a as =>
OpenUnion as -> Either (OpenUnion (Remove a as)) a
openUnionRemove OpenUnion wide
errs of
        Left  OpenUnion (Remove err wide)
remainingErrs -> OpenUnion narrow -> m (OpenUnion narrow) a
forall (m :: * -> *) err a.
(MonadRaise m, Subset err (ErrorCase m)) =>
err -> m a
raise OpenUnion narrow
OpenUnion (Remove err wide)
remainingErrs
        Right err
matchedErr    -> err -> m (OpenUnion narrow) a
handler err
matchedErr

rescueEach
  :: ( Bifunctor m
     , ToOpenProduct handlerTuple (ReturnX (OpenUnion targetErrs) errs)
     )
  => handlerTuple
  -> m (OpenUnion errs)       a
  -> m (OpenUnion targetErrs) a
rescueEach :: handlerTuple -> m (OpenUnion errs) a -> m (OpenUnion targetErrs) a
rescueEach handlerTuple
handleCases = (OpenUnion errs -> OpenUnion targetErrs)
-> m (OpenUnion errs) a -> m (OpenUnion targetErrs) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first (handlerTuple -> OpenUnion errs -> OpenUnion targetErrs
forall tuple x (as :: [*]).
ToOpenProduct tuple (ReturnX x as) =>
tuple -> OpenUnion as -> x
catchesOpenUnion handlerTuple
handleCases)

rescueEachM
  :: ( sourceErrs ~ Errors (m (OpenUnion sourceErrs))
     , MonadRescue         (m (OpenUnion sourceErrs))
     , MonadBase           (m (OpenUnion sourceErrs)) (m (OpenUnion targetErrs))
     , ToOpenProduct handlerTuple            (ReturnX (m (OpenUnion targetErrs) a) sourceErrs)
     )
  => handlerTuple
  -> m (OpenUnion sourceErrs) a
  -> m (OpenUnion targetErrs) a
rescueEachM :: handlerTuple
-> m (OpenUnion sourceErrs) a -> m (OpenUnion targetErrs) a
rescueEachM handlerTuple
handleCases m (OpenUnion sourceErrs) a
action =
  m (OpenUnion sourceErrs) (Either (OpenUnion sourceErrs) a)
-> m (OpenUnion targetErrs) (Either (OpenUnion sourceErrs) a)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (m (OpenUnion sourceErrs) a
-> m (OpenUnion sourceErrs)
     (Either (ErrorCase (m (OpenUnion sourceErrs))) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m (OpenUnion sourceErrs) a
action) m (OpenUnion targetErrs) (Either (OpenUnion sourceErrs) a)
-> (Either (OpenUnion sourceErrs) a -> m (OpenUnion targetErrs) a)
-> m (OpenUnion targetErrs) a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left OpenUnion sourceErrs
errs -> handlerTuple -> OpenUnion sourceErrs -> m (OpenUnion targetErrs) a
forall tuple x (as :: [*]).
ToOpenProduct tuple (ReturnX x as) =>
tuple -> OpenUnion as -> x
catchesOpenUnion handlerTuple
handleCases OpenUnion sourceErrs
errs
    Right a
val -> a -> m (OpenUnion targetErrs) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

rescueEachT
  :: ( sourceErrs ~ Errors (t sourceErrs m)
     , MonadTransError      t sourceErrs m
     , ToOpenProduct handlerTuple (ReturnX (t targetErrs m a) sourceErrs)
     )
  => handlerTuple
  -> t sourceErrs m a
  -> t targetErrs m a
rescueEachT :: handlerTuple -> t sourceErrs m a -> t targetErrs m a
rescueEachT handlerTuple
handleCases = (OpenUnion (Errors (t sourceErrs m)) -> t targetErrs m a)
-> t sourceErrs m a -> t targetErrs m a
forall (t :: [*] -> (* -> *) -> * -> *) (sourceErrs :: [*])
       (m :: * -> *) (targetErrs :: [*]) a.
MonadTransError t sourceErrs m =>
(OpenUnion (Errors (t sourceErrs m)) -> t targetErrs m a)
-> t sourceErrs m a -> t targetErrs m a
onRaise (handlerTuple -> OpenUnion sourceErrs -> t targetErrs m a
forall tuple x (as :: [*]).
ToOpenProduct tuple (ReturnX x as) =>
tuple -> OpenUnion as -> x
catchesOpenUnion handlerTuple
handleCases)

rescueAll
  :: ( MonadRescue   (m (OpenUnion errs))
     , MonadBase     (m (OpenUnion errs)) (m ())
     , errs ~ Errors (m (OpenUnion errs))
     )
  => (OpenUnion errs -> m () a)
  -> m (OpenUnion errs) a
  -> m () a
rescueAll :: (OpenUnion errs -> m () a) -> m (OpenUnion errs) a -> m () a
rescueAll OpenUnion errs -> m () a
handler m (OpenUnion errs) a
action =
  m (OpenUnion errs) (Either (OpenUnion errs) a)
-> m () (Either (OpenUnion errs) a)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (m (OpenUnion errs) a
-> m (OpenUnion errs) (Either (ErrorCase (m (OpenUnion errs))) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m (OpenUnion errs) a
action) m () (Either (OpenUnion errs) a)
-> (Either (OpenUnion errs) a -> m () a) -> m () a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left OpenUnion errs
errs -> OpenUnion errs -> m () a
handler OpenUnion errs
errs
    Right a
val -> a -> m () a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

report
  :: ( MonadRescue m
     , RaisesOnly  m errs
     , CheckErrors m
     )
  => (ErrorCase m -> m ())
  -> m a
  -> m a
report :: (ErrorCase m -> m ()) -> m a -> m a
report ErrorCase m -> m ()
withErr m a
action =
  m a -> m (Either (ErrorCase m) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m a
action m (Either (Union Identity errs) a)
-> (Either (Union Identity errs) a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Union Identity errs
err -> do
      ErrorCase m -> m ()
withErr Union Identity errs
ErrorCase m
err
      Union Identity errs -> m a
forall (m :: * -> *) err a.
(MonadRaise m, Subset err (ErrorCase m)) =>
err -> m a
raise Union Identity errs
err

    Right a
val ->
      a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | 'retry' without asynchoronous exception cleanup.
--   Useful when not dealing with external resources that may
--   be dangerous to close suddenly.
reattempt :: MonadRescue m => Natural -> m a -> m a
reattempt :: Natural -> m a -> m a
reattempt Natural
0     m a
action = m a
action
reattempt Natural
times m a
action =
  m a -> m (Either (ErrorCase m) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m a
action m (Either (ErrorCase m) a)
-> (Either (ErrorCase m) a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left  ErrorCase m
_   -> Natural -> m a -> m a
forall (m :: * -> *) a. MonadRescue m => Natural -> m a -> m a
reattempt (Natural
times Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) m a
action
    Right a
val -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | Run an additional step, and throw away the result.
--   Return the result of the action passed.
lastly :: (CheckErrors m, MonadRescue m) => m a -> m b -> m a
lastly :: m a -> m b -> m a
lastly m a
action m b
finalizer = do
  Either (OpenUnion (Errors m)) a
errOrOk <- m a -> m (Either (OpenUnion (Errors m)) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m a
action
  b
_       <- m b
finalizer
  Either (OpenUnion (Errors m)) a -> m a
forall (m :: * -> *) inner a.
(MonadRaise m, Raises m inner) =>
Either inner a -> m a
ensure Either (OpenUnion (Errors m)) a
errOrOk

-- AKA reinterpret
mapError
  :: ( MonadRescue m
     , MonadBase   m n
     , MonadRaise    n
     , CheckErrors   n
     )
  => (ErrorCase m -> ErrorCase n)
  -> m a
  -> n a
mapError :: (ErrorCase m -> ErrorCase n) -> m a -> n a
mapError ErrorCase m -> ErrorCase n
mapper m a
action =
  m (Either (ErrorCase m) a) -> n (Either (ErrorCase m) a)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (m a -> m (Either (ErrorCase m) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m a
action) n (Either (ErrorCase m) a)
-> (Either (ErrorCase m) a -> n a) -> n a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left  ErrorCase m
errCaseN -> ErrorCase n -> n a
forall (m :: * -> *) err a.
(MonadRaise m, Subset err (ErrorCase m)) =>
err -> m a
raise (ErrorCase n -> n a) -> ErrorCase n -> n a
forall a b. (a -> b) -> a -> b
$ ErrorCase m -> ErrorCase n
mapper ErrorCase m
errCaseN
    Right a
value    -> a -> n a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value

replaceError
  :: ( MonadRescue m
     , MonadBase   m n
     , MonadRaise    n
     , n `Raises` err
     )
  => err
  -> m a
  -> n a
replaceError :: err -> m a -> n a
replaceError err
err m a
action =
  m (Either (OpenUnion (Errors m)) a)
-> n (Either (OpenUnion (Errors m)) a)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (m a -> m (Either (OpenUnion (Errors m)) a)
forall (m :: * -> *) a.
MonadRescue m =>
m a -> m (Either (ErrorCase m) a)
attempt m a
action) n (Either (OpenUnion (Errors m)) a)
-> (Either (OpenUnion (Errors m)) a -> n a) -> n a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left  OpenUnion (Errors m)
_     -> err -> n a
forall (m :: * -> *) err a.
(MonadRaise m, Subset err (ErrorCase m)) =>
err -> m a
raise err
err
    Right a
value -> a -> n a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value

asNotFound
  :: forall n m a .
    ( MonadRescue m
    , MonadBase   m n
    , MonadRaise    n
    , n `Raises` NotFound a
    )
  => m a
  -> n a
asNotFound :: m a -> n a
asNotFound = NotFound a -> m a -> n a
forall (m :: * -> *) (n :: * -> *) err a.
(MonadRescue m, MonadBase m n, MonadRaise n, Raises n err) =>
err -> m a -> n a
replaceError (NotFound a
forall entity. NotFound entity
NotFound @a)