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

-- | Provides utilities for working with GHC's native Exception annotations.
--
-- @since 0.1
module Control.Exception.Annotation.Utils
  ( -- * Exception matching
    ExceptionProxy (..),
    matchesException,

    -- * Ignoring known callstacks
    setIgnoreKnownCallStackHandler,
    ignoreKnownCallStackHandler,
    ignoreCallStackHandler,
  )
where

import Control.Monad.Catch
  ( Exception (displayException, fromException, toException),
    SomeException,
  )
import Data.List qualified as L
import Data.Maybe qualified as Maybe
import GHC.Conc (getUncaughtExceptionHandler, setUncaughtExceptionHandler)

-- | Proxy for exception types. Used for matching multiple exception types.
--
-- @since 0.1
data ExceptionProxy = forall e. (Exception e) => MkExceptionProxy

-- | Augments the current global exception handler with the logic to ignore
-- callstacks on known exceptions, per the parameter proxy list. In other
-- words, merely calls 'displayException' on known exceptions. Note that
-- on older GHCs (< 9.12), this may still print a callstack as the callstack
-- is part of the 'SomeException' type, prior to the exceptions redesign.
--
-- @since 0.1
setIgnoreKnownCallStackHandler :: [ExceptionProxy] -> IO ()
setIgnoreKnownCallStackHandler :: [ExceptionProxy] -> IO ()
setIgnoreKnownCallStackHandler [ExceptionProxy]
proxies =
  IO (SomeException -> IO ())
getUncaughtExceptionHandler
    IO (SomeException -> IO ())
-> ((SomeException -> IO ()) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO ()) -> IO ()
setUncaughtExceptionHandler ((SomeException -> IO ()) -> IO ())
-> ((SomeException -> IO ()) -> SomeException -> IO ())
-> (SomeException -> IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ExceptionProxy]
-> (SomeException -> IO ()) -> SomeException -> IO ()
ignoreKnownCallStackHandler [ExceptionProxy]
proxies

-- | Augments the parameter handler with logic to avoid callstacks when
-- the exception matches one of the proxies.
--
-- @since 0.1
ignoreKnownCallStackHandler ::
  -- | Exception proxies to match.
  [ExceptionProxy] ->
  -- | Previous handler, to use when we do not have a match.
  (SomeException -> IO ()) ->
  -- | Augmented handler.
  SomeException ->
  IO ()
ignoreKnownCallStackHandler :: [ExceptionProxy]
-> (SomeException -> IO ()) -> SomeException -> IO ()
ignoreKnownCallStackHandler [ExceptionProxy]
proxies SomeException -> IO ()
prevHandler SomeException
ex =
  if [ExceptionProxy] -> SomeException -> Bool
forall e. Exception e => [ExceptionProxy] -> e -> Bool
matchesException [ExceptionProxy]
proxies SomeException
ex
    then SomeException -> IO ()
ignoreCallStackHandler SomeException
ex
    else SomeException -> IO ()
prevHandler SomeException
ex

-- | Exception handler that merely calls 'displayException', thereby avoiding
-- callstacks for GHC >= 9.12.
--
-- @since 0.1
ignoreCallStackHandler :: SomeException -> IO ()
ignoreCallStackHandler :: SomeException -> IO ()
ignoreCallStackHandler = String -> IO ()
putStrLn (String -> IO ())
-> (SomeException -> String) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
displayException

-- | Returns true iff e matches some ExceptionProxy.
--
-- @since 0.1
matchesException :: (Exception e) => [ExceptionProxy] -> e -> Bool
matchesException :: forall e. Exception e => [ExceptionProxy] -> e -> Bool
matchesException [ExceptionProxy]
proxies e
ex = (ExceptionProxy -> Bool) -> [ExceptionProxy] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any ExceptionProxy -> Bool
isMatch [ExceptionProxy]
proxies
  where
    se :: SomeException
se = e -> SomeException
forall e. Exception e => e -> SomeException
toException e
ex
    isMatch :: ExceptionProxy -> Bool
isMatch (MkExceptionProxy @ex) = Maybe e -> Bool
forall a. Maybe a -> Bool
Maybe.isJust (forall e. Exception e => SomeException -> Maybe e
fromException @ex SomeException
se)