{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | This is essentially an addition to the @exceptions@ API. Note we do
-- __not__ export that API. This is merely some useful additional utilities.
--
-- @since 0.1
module Control.Exception.Utils
  ( -- * Throwing

    -- ** Text exception
    TextException (..),
    throwText,
    throwString,

    -- * Catching
    catchDeep,
    catchDeepSync,
    catchSync,
    catchIf,
    handleDeep,
    handleDeepSync,
    handleSync,
    handleIf,
    tryDeep,
    tryDeepSync,
    trySync,
    tryIf,

    -- * Cleanup
    onSyncException,

    -- * Exiting
    exitFailure,
    exitSuccess,
    exitWith,

    -- * Misc
    isSyncException,
    isAsyncException,
  )
where

import Control.DeepSeq (NFData, force)
import Control.Exception
  ( Exception (fromException, toException),
    SomeAsyncException (SomeAsyncException),
    SomeException,
  )
import Control.Exception qualified as E
import Control.Monad.Catch (MonadCatch, MonadThrow (throwM))
import Control.Monad.Catch qualified as C
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Text (Text)
import Data.Text qualified as T
import GHC.IO.Exception (IOErrorType (InvalidArgument), IOException (IOError))
import GHC.Stack (HasCallStack, withFrozenCallStack)
import System.Exit (ExitCode (ExitFailure, ExitSuccess))

-- | Exception that contains a text description.
--
-- @since 0.1
newtype TextException = MkTextException Text
  deriving stock (TextException -> TextException -> Bool
(TextException -> TextException -> Bool)
-> (TextException -> TextException -> Bool) -> Eq TextException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TextException -> TextException -> Bool
== :: TextException -> TextException -> Bool
$c/= :: TextException -> TextException -> Bool
/= :: TextException -> TextException -> Bool
Eq, Int -> TextException -> ShowS
[TextException] -> ShowS
TextException -> String
(Int -> TextException -> ShowS)
-> (TextException -> String)
-> ([TextException] -> ShowS)
-> Show TextException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextException -> ShowS
showsPrec :: Int -> TextException -> ShowS
$cshow :: TextException -> String
show :: TextException -> String
$cshowList :: [TextException] -> ShowS
showList :: [TextException] -> ShowS
Show)

instance Exception TextException where
  displayException :: TextException -> String
displayException (MkTextException Text
t) = Text -> String
T.unpack Text
t

-- | Throws an exception with the 'Text' description.
--
-- @since 0.1
throwText :: forall m a. (HasCallStack, MonadThrow m) => Text -> m a
throwText :: forall (m :: * -> *) a. (HasCallStack, MonadThrow m) => Text -> m a
throwText = TextException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TextException -> m a) -> (Text -> TextException) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TextException
MkTextException
{-# INLINEABLE throwText #-}

-- | Throws an exception with the 'String' description.
--
-- @since 0.1
throwString :: forall m a. (HasCallStack, MonadThrow m) => String -> m a
throwString :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwString = Text -> m a
forall (m :: * -> *) a. (HasCallStack, MonadThrow m) => Text -> m a
throwText (Text -> m a) -> (String -> Text) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
{-# INLINEABLE throwString #-}

-- | Like 'C.catch', except it fully evaluates the result to find impure
-- exceptions.
--
-- @since 0.1
catchDeep ::
  forall m e a.
  ( Exception e,
    HasCallStack,
    MonadCatch m,
    MonadIO m,
    NFData a
  ) =>
  m a ->
  -- | The exception handler.
  (e -> m a) ->
  m a
catchDeep :: forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadCatch m, MonadIO m, NFData a) =>
m a -> (e -> m a) -> m a
catchDeep m a
action = m a -> (e -> m a) -> m a
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
C.catch (a -> m a
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m a
action)
{-# INLINEABLE catchDeep #-}

-- | 'catchDeep' specialized to synchronous 'SomeException'.
--
-- @since 0.1
catchDeepSync ::
  forall m a.
  ( HasCallStack,
    MonadCatch m,
    MonadIO m,
    NFData a
  ) =>
  m a ->
  -- | The exception handler.
  (SomeException -> m a) ->
  m a
catchDeepSync :: forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadIO m, NFData a) =>
m a -> (SomeException -> m a) -> m a
catchDeepSync m a
action = m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
catchSync (a -> m a
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m a
action)
{-# INLINEABLE catchDeepSync #-}

-- | 'C.catch' specialized to catch all synchronous 'SomeException's.
catchSync ::
  forall m a.
  (HasCallStack, MonadCatch m) =>
  m a ->
  -- | The exception handler.
  (SomeException -> m a) ->
  m a
catchSync :: forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
catchSync = forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadCatch m) =>
(e -> Bool) -> m a -> (e -> m a) -> m a
catchIf @_ @SomeException SomeException -> Bool
forall e. Exception e => e -> Bool
isSyncException
{-# INLINEABLE catchSync #-}

-- | Catch an exception only if it satisfies a specific predicate.
catchIf ::
  forall m e a.
  (Exception e, HasCallStack, MonadCatch m) =>
  -- | The predicate.
  (e -> Bool) ->
  m a ->
  -- | The exception handler.
  (e -> m a) ->
  m a
catchIf :: forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadCatch m) =>
(e -> Bool) -> m a -> (e -> m a) -> m a
catchIf e -> Bool
p = (e -> Maybe e) -> m a -> (e -> m a) -> m a
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> (b -> m a) -> m a
C.catchJust (\e
e -> if e -> Bool
p e
e then e -> Maybe e
forall a. a -> Maybe a
Just e
e else Maybe e
forall a. Maybe a
Nothing)
{-# INLINEABLE catchIf #-}

-- TODO: We might want to eventually make a tryWithContextX for the following
-- tryX functions i.e. implement the same wrappers over base 4.21's (GHC 9.12)
-- tryWithContext. Realistically, we need tryWithContext to be implemented
-- in exceptions first.
--
-- See https://github.com/ekmett/exceptions/issues/100 for further
-- discussion on what exactly will be implemented in exceptions.

-- | Like 'C.try', except it fully evaluates the result to find impure
-- exceptions.
--
-- @since 0.1
tryDeep ::
  forall m e a.
  ( E.Exception e,
    MonadCatch m,
    MonadIO m,
    NFData a
  ) =>
  -- | The action.
  m a ->
  m (Either e a)
tryDeep :: forall (m :: * -> *) e a.
(Exception e, MonadCatch m, MonadIO m, NFData a) =>
m a -> m (Either e a)
tryDeep m a
action = m a -> m (Either e a)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
C.try (a -> m a
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m a
action)
{-# INLINEABLE tryDeep #-}

-- | 'tryDeep' specialized to synchronous 'SomeException'.
--
-- @since 0.1
tryDeepSync ::
  forall m a.
  ( MonadCatch m,
    MonadIO m,
    NFData a
  ) =>
  -- | The action.
  m a ->
  m (Either SomeException a)
tryDeepSync :: forall (m :: * -> *) a.
(MonadCatch m, MonadIO m, NFData a) =>
m a -> m (Either SomeException a)
tryDeepSync m a
action = m a -> m (Either SomeException a)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
trySync (a -> m a
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m a
action)
{-# INLINEABLE tryDeepSync #-}

-- | 'C.try' specialized to catch all synchronous 'SomeException's.
trySync ::
  forall m a.
  (HasCallStack, MonadCatch m) =>
  m a ->
  m (Either SomeException a)
trySync :: forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
trySync = forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadCatch m) =>
(e -> Bool) -> m a -> m (Either e a)
tryIf @_ @SomeException SomeException -> Bool
forall e. Exception e => e -> Bool
isSyncException
{-# INLINEABLE trySync #-}

-- | Catch an exception only if it satisfies a specific predicate.
tryIf ::
  forall m e a.
  (Exception e, HasCallStack, MonadCatch m) =>
  -- | The predicate.
  (e -> Bool) ->
  m a ->
  m (Either e a)
tryIf :: forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadCatch m) =>
(e -> Bool) -> m a -> m (Either e a)
tryIf e -> Bool
p = (e -> Maybe e) -> m a -> m (Either e a)
forall (m :: * -> *) e b a.
(HasCallStack, MonadCatch m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
C.tryJust (\e
e -> if e -> Bool
p e
e then e -> Maybe e
forall a. a -> Maybe a
Just e
e else Maybe e
forall a. Maybe a
Nothing)
{-# INLINEABLE tryIf #-}

-- | Flipped 'catchDeep'.
--
-- @since 0.1
handleDeep ::
  forall m e a.
  ( Exception e,
    MonadCatch m,
    MonadIO m,
    NFData a
  ) =>
  -- | The exception handler.
  (e -> m a) ->
  m a ->
  m a
handleDeep :: forall (m :: * -> *) e a.
(Exception e, MonadCatch m, MonadIO m, NFData a) =>
(e -> m a) -> m a -> m a
handleDeep = (m a -> (e -> m a) -> m a) -> (e -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadCatch m, MonadIO m, NFData a) =>
m a -> (e -> m a) -> m a
catchDeep
{-# INLINEABLE handleDeep #-}

-- | Flipped 'catchDeepSync'.
--
-- @since 0.1
handleDeepSync ::
  forall m a.
  (MonadCatch m, MonadIO m, NFData a) =>
  -- | The exception handler.
  (SomeException -> m a) ->
  m a ->
  m a
handleDeepSync :: forall (m :: * -> *) a.
(MonadCatch m, MonadIO m, NFData a) =>
(SomeException -> m a) -> m a -> m a
handleDeepSync = (m a -> (SomeException -> m a) -> m a)
-> (SomeException -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadIO m, NFData a) =>
m a -> (SomeException -> m a) -> m a
catchDeepSync
{-# INLINEABLE handleDeepSync #-}

-- | Flipped 'catchSync'.
--
-- @since 0.1
handleSync ::
  forall m a.
  (HasCallStack, MonadCatch m) =>
  (SomeException -> m a) ->
  m a ->
  m a
handleSync :: forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
(SomeException -> m a) -> m a -> m a
handleSync = (m a -> (SomeException -> m a) -> m a)
-> (SomeException -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
catchSync
{-# INLINEABLE handleSync #-}

-- | Flipped 'catchIf'.
--
-- @since 0.1
handleIf ::
  forall m e a.
  (Exception e, HasCallStack, MonadCatch m) =>
  -- | The predicate.
  (e -> Bool) ->
  -- | The exception handler.
  (e -> m a) ->
  m a ->
  m a
handleIf :: forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadCatch m) =>
(e -> Bool) -> (e -> m a) -> m a -> m a
handleIf e -> Bool
p = (m a -> (e -> m a) -> m a) -> (e -> m a) -> m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((e -> Bool) -> m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(Exception e, HasCallStack, MonadCatch m) =>
(e -> Bool) -> m a -> (e -> m a) -> m a
catchIf e -> Bool
p)
{-# INLINEABLE handleIf #-}

-- | Like 'C.onException', except it does not catch asynchronous exception.
--
-- @since 0.1
onSyncException ::
  forall m a b.
  (HasCallStack, MonadCatch m) =>
  m a ->
  m b ->
  m a
onSyncException :: forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
onSyncException m a
action m b
handler =
  (HasCallStack => m a -> (SomeException -> m a) -> m a)
-> m a -> (SomeException -> m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack m a -> (SomeException -> m a) -> m a
HasCallStack => m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
catchSync m a
action (\SomeException
e -> m b
handler m b -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SomeException
e)
{-# INLINEABLE onSyncException #-}

-- | The computation 'exitFailure' is equivalent to
-- 'exitWith' @(@'ExitFailure' /exitfail/@)@,
-- where /exitfail/ is implementation-dependent.
--
-- @since 0.1
exitFailure :: forall m a. (HasCallStack, MonadThrow m) => m a
exitFailure :: forall (m :: * -> *) a. (HasCallStack, MonadThrow m) => m a
exitFailure = ExitCode -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
ExitCode -> m a
exitWith (Int -> ExitCode
ExitFailure Int
1)
{-# INLINEABLE exitFailure #-}

-- | The computation 'exitSuccess' is equivalent to
-- 'exitWith' 'ExitSuccess', It terminates the program
-- successfully.
--
-- @since 0.1
exitSuccess :: forall m a. (HasCallStack, MonadThrow m) => m a
exitSuccess :: forall (m :: * -> *) a. (HasCallStack, MonadThrow m) => m a
exitSuccess = ExitCode -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
ExitCode -> m a
exitWith ExitCode
ExitSuccess
{-# INLINEABLE exitSuccess #-}

-- | Lifted 'System.Exit.exitWith'.
--
-- @since 0.1
exitWith :: forall m a. (HasCallStack, MonadThrow m) => ExitCode -> m a
exitWith :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
ExitCode -> m a
exitWith ExitCode
ExitSuccess = ExitCode -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM ExitCode
ExitSuccess
exitWith code :: ExitCode
code@(ExitFailure Int
n)
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = ExitCode -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM ExitCode
code
  | Bool
otherwise =
      IOException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM
        ( Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError
            Maybe Handle
forall a. Maybe a
Nothing
            IOErrorType
InvalidArgument
            String
"exitWith"
            String
"ExitFailure 0"
            Maybe CInt
forall a. Maybe a
Nothing
            Maybe String
forall a. Maybe a
Nothing
        )
{-# INLINEABLE exitWith #-}

-- | Returns 'True' iff the exception is not a subtype of
-- 'Control.Exception.SomeAsyncException'.
--
-- @since 0.1
isSyncException :: forall e. (Exception e) => e -> Bool
isSyncException :: forall e. Exception e => e -> Bool
isSyncException e
e = case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e) of
  Just SomeAsyncException {} -> Bool
False
  Maybe SomeAsyncException
Nothing -> Bool
True

-- | Negation of 'isSyncException'.
--
-- @since 0.1
isAsyncException :: forall e. (Exception e) => e -> Bool
isAsyncException :: forall e. Exception e => e -> Bool
isAsyncException = Bool -> Bool
not (Bool -> Bool) -> (e -> Bool) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Bool
forall e. Exception e => e -> Bool
isSyncException

-- | Evaluates a value deeply.
--
-- @since 0.1
evaluateDeep :: (MonadIO m, NFData a) => a -> m a
evaluateDeep :: forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (a -> IO a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall a. a -> IO a
E.evaluate (a -> IO a) -> (a -> a) -> a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. NFData a => a -> a
force
{-# INLINEABLE evaluateDeep #-}