{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

-- | This module defines an exception wrapper 'AnnotatedException' that
-- carries a list of 'Annotation's, along with some helper methods for
-- throwing and catching that can make the annotations transparent.
--
-- While this library can be used directly, it is recommended that you
-- define your own types and functions specific to your domain. As an
-- example, 'checkpoint' is useful *only* for providing exception
-- annotation information. However, you probably want to use 'checkpoint'
-- in concert with other context adding features, like logging.
--
-- Likewise, the 'Annotation' type defined in "Data.Annotation" is
-- essentially a wrapper for a dynamically typed value. So you probably
-- want to define your own 'checkpoint' that uses a custom type that you
-- want to enforce throughout your application.
module Control.Exception.Annotated
    ( -- * The Main Type
      AnnotatedException(..)
    , exceptionWithCallStack
    , throw
    , throwWithCallStack
    -- * Annotating Exceptions
    , checkpoint
    , checkpointMany
    , checkpointCallStack
    , checkpointCallStackWith
    -- * Handling Exceptions
    , catch
    , catches
    , tryAnnotated
    , try

    -- * Manipulating Annotated Exceptions
    , check
    , hide
    , annotatedExceptionCallStack
    , addCallStackToException

    -- * Re-exports from "Data.Annotation"
    , Annotation(..)
    , CallStackAnnotation(..)
    -- * Re-exports from "Control.Exception.Safe"
    , Exception(..)
    , Safe.SomeException(..)
    , Handler (..)
    ) where

import Control.Applicative ((<|>))
import Control.Exception.Safe
       (Exception, Handler(..), MonadCatch, MonadThrow, SomeException(..))
import qualified Control.Exception.Safe as Safe
import Data.Annotation
import Data.Maybe
import qualified Data.Set as Set
import Data.Typeable
import GHC.Stack

-- | The 'AnnotatedException' type wraps an @exception@ with
-- a @['Annotation']@. This can provide a sort of a manual stack trace with
-- programmer provided data.
--
-- @since 0.1.0.0
data AnnotatedException exception
    = AnnotatedException
    { forall exception. AnnotatedException exception -> [Annotation]
annotations :: [Annotation]
    , forall exception. AnnotatedException exception -> exception
exception   :: exception
    }
    deriving (Int -> AnnotatedException exception -> ShowS
forall exception.
Show exception =>
Int -> AnnotatedException exception -> ShowS
forall exception.
Show exception =>
[AnnotatedException exception] -> ShowS
forall exception.
Show exception =>
AnnotatedException exception -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AnnotatedException exception] -> ShowS
$cshowList :: forall exception.
Show exception =>
[AnnotatedException exception] -> ShowS
show :: AnnotatedException exception -> [Char]
$cshow :: forall exception.
Show exception =>
AnnotatedException exception -> [Char]
showsPrec :: Int -> AnnotatedException exception -> ShowS
$cshowsPrec :: forall exception.
Show exception =>
Int -> AnnotatedException exception -> ShowS
Show, forall a b. a -> AnnotatedException b -> AnnotatedException a
forall a b.
(a -> b) -> AnnotatedException a -> AnnotatedException b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AnnotatedException b -> AnnotatedException a
$c<$ :: forall a b. a -> AnnotatedException b -> AnnotatedException a
fmap :: forall a b.
(a -> b) -> AnnotatedException a -> AnnotatedException b
$cfmap :: forall a b.
(a -> b) -> AnnotatedException a -> AnnotatedException b
Functor, forall a. Eq a => a -> AnnotatedException a -> Bool
forall a. Num a => AnnotatedException a -> a
forall a. Ord a => AnnotatedException a -> a
forall m. Monoid m => AnnotatedException m -> m
forall a. AnnotatedException a -> Bool
forall a. AnnotatedException a -> Int
forall a. AnnotatedException a -> [a]
forall a. (a -> a -> a) -> AnnotatedException a -> a
forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m
forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b
forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => AnnotatedException a -> a
$cproduct :: forall a. Num a => AnnotatedException a -> a
sum :: forall a. Num a => AnnotatedException a -> a
$csum :: forall a. Num a => AnnotatedException a -> a
minimum :: forall a. Ord a => AnnotatedException a -> a
$cminimum :: forall a. Ord a => AnnotatedException a -> a
maximum :: forall a. Ord a => AnnotatedException a -> a
$cmaximum :: forall a. Ord a => AnnotatedException a -> a
elem :: forall a. Eq a => a -> AnnotatedException a -> Bool
$celem :: forall a. Eq a => a -> AnnotatedException a -> Bool
length :: forall a. AnnotatedException a -> Int
$clength :: forall a. AnnotatedException a -> Int
null :: forall a. AnnotatedException a -> Bool
$cnull :: forall a. AnnotatedException a -> Bool
toList :: forall a. AnnotatedException a -> [a]
$ctoList :: forall a. AnnotatedException a -> [a]
foldl1 :: forall a. (a -> a -> a) -> AnnotatedException a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> AnnotatedException a -> a
foldr1 :: forall a. (a -> a -> a) -> AnnotatedException a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> AnnotatedException a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b
foldl :: forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b
foldr :: forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m
fold :: forall m. Monoid m => AnnotatedException m -> m
$cfold :: forall m. Monoid m => AnnotatedException m -> m
Foldable, Functor AnnotatedException
Foldable AnnotatedException
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
AnnotatedException (m a) -> m (AnnotatedException a)
forall (f :: * -> *) a.
Applicative f =>
AnnotatedException (f a) -> f (AnnotatedException a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AnnotatedException a -> m (AnnotatedException b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AnnotatedException a -> f (AnnotatedException b)
sequence :: forall (m :: * -> *) a.
Monad m =>
AnnotatedException (m a) -> m (AnnotatedException a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
AnnotatedException (m a) -> m (AnnotatedException a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AnnotatedException a -> m (AnnotatedException b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AnnotatedException a -> m (AnnotatedException b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
AnnotatedException (f a) -> f (AnnotatedException a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
AnnotatedException (f a) -> f (AnnotatedException a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AnnotatedException a -> f (AnnotatedException b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AnnotatedException a -> f (AnnotatedException b)
Traversable)

instance Applicative AnnotatedException where
    pure :: forall a. a -> AnnotatedException a
pure =
        forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException []

    AnnotatedException [Annotation]
anns0 a -> b
f <*> :: forall a b.
AnnotatedException (a -> b)
-> AnnotatedException a -> AnnotatedException b
<*> AnnotatedException [Annotation]
anns1 a
a =
        forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException ([Annotation]
anns0 forall a. Semigroup a => a -> a -> a
<> [Annotation]
anns1) (a -> b
f a
a)

-- | This instance of 'Exception' is a bit interesting. It tries to do as
-- much hiding and packing and flattening as possible to ensure that even
-- exception handling machinery outside of this package can still
-- intelligently handle it.
--
-- Any 'Exception' can be caught as a 'AnnotatedException' with
-- an empty context, so catching a @'AnnotatedException' e@ will also catch
-- a regular @e@ and give it an empty set of annotations.
--
-- For the most up to date details, see the test suite.
--
-- @since 0.1.0.0
instance (Exception exception) => Exception (AnnotatedException exception) where
    toException :: AnnotatedException exception -> SomeException
toException AnnotatedException exception
loc =
        SomeException -> SomeException
tryFlatten forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ forall e.
Exception e =>
AnnotatedException e -> AnnotatedException SomeException
hide AnnotatedException exception
loc

    fromException :: SomeException -> Maybe (AnnotatedException exception)
fromException (SomeException e
exn)
        | Just AnnotatedException exception
x <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
exn
        =
            forall (f :: * -> *) a. Applicative f => a -> f a
pure AnnotatedException exception
x
        | Just (AnnotatedException [Annotation]
ann (SomeException
e :: SomeException)) <- forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
exn
        , Just exception
a <- forall e. Exception e => SomeException -> Maybe e
Safe.fromException SomeException
e
        =
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException [Annotation]
ann exception
a
    fromException SomeException
exn
        | Just (exception
e :: exception) <- forall e. Exception e => SomeException -> Maybe e
Safe.fromException SomeException
exn
        =
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure exception
e
        | Bool
otherwise
        =
            forall a. Maybe a
Nothing

-- | Annotate the underlying exception with a 'CallStack'.
--
-- @since 0.2.0.0
exceptionWithCallStack :: (Exception e, HasCallStack) => e -> AnnotatedException e
exceptionWithCallStack :: forall e. (Exception e, HasCallStack) => e -> AnnotatedException e
exceptionWithCallStack =
    forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException [HasCallStack => Annotation
callStackAnnotation]

-- | Append the @['Annotation']@ to the 'AnnotatedException'.
--
-- 'CallStack' is a special case - if a 'CallStack' is present in both the
-- 'AnnotatedException' and the @['Annotation']@, then this will append the
-- 'CallStack's in the new list and concatenate them all together.
--
-- @since 0.1.0.0
annotate :: [Annotation] -> AnnotatedException e -> AnnotatedException e
annotate :: forall e.
[Annotation] -> AnnotatedException e -> AnnotatedException e
annotate [Annotation]
newAnnotations (AnnotatedException [Annotation]
oldAnnotations e
e) =
    let
        ([CallStack]
callStacks, [Annotation]
other) =
            forall a. Typeable a => [Annotation] -> ([a], [Annotation])
tryAnnotations ([Annotation]
newAnnotations forall a. Semigroup a => a -> a -> a
<> [Annotation]
oldAnnotations)
    in
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall exception.
CallStack
-> AnnotatedException exception -> AnnotatedException exception
addCallStackToException (forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException [Annotation]
other e
e) [CallStack]
callStacks

-- | Call 'Safe.toException' on the underlying 'Exception'.
--
-- @since 0.1.0.0
hide :: Exception e => AnnotatedException e -> AnnotatedException SomeException
hide :: forall e.
Exception e =>
AnnotatedException e -> AnnotatedException SomeException
hide = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Exception e => e -> SomeException
Safe.toException

-- | Call 'Safe.fromException' on the underlying 'Exception', attaching the
-- annotations to the result.
--
-- @since 0.1.0.0
check :: Exception e => AnnotatedException SomeException -> Maybe (AnnotatedException e)
check :: forall e.
Exception e =>
AnnotatedException SomeException -> Maybe (AnnotatedException e)
check = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e. Exception e => SomeException -> Maybe e
Safe.fromException

-- | Catch an exception. This works just like 'Safe.catch', but it also
-- will attempt to catch @'AnnotatedException' e@. The annotations will be
-- preserved in the handler, so rethrowing exceptions will retain the
-- context.
--
-- Let's consider a few examples, that share this import and exception
-- type.
--
-- > import qualified Control.Exception.Safe as Safe
-- > import Control.Exception.Annotated
-- >
-- > data TestException deriving (Show, Exception)
--
-- We can throw an exception and catch it as usual.
--
-- > throw TestException `catch` \TestException ->
-- >     putStrLn "ok!"
--
-- We can throw an exception and catch it with annotations.
--
-- > throw TestException `catch` \(AnnotatedException anns TestException) ->
-- >     putStrLn "ok!"
--
--
-- We can throw an exception and catch it as a @'AnnotatedException'
-- 'SomeException'@.
--
-- > throw TestException `catch` \(AnnotatedException anns (e :: SomeException) ->
-- >     putStrLn "ok!"
--
-- @since 0.1.0.0
catch :: (HasCallStack, Exception e, MonadCatch m) => m a -> (e -> m a) -> m a
catch :: forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
catch m a
action e -> m a
handler =
    forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
m a -> [Handler m a] -> m a
catches m a
action [forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler e -> m a
handler]

-- | Like 'Safe.catches', but this function enhance the provided 'Handler's
-- to "see through" any 'AnnotatedException's.
--
-- @since 0.1.2.0
catches :: (MonadCatch m, HasCallStack) => m a -> [Handler m a] -> m a
catches :: forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
m a -> [Handler m a] -> m a
catches m a
action [Handler m a]
handlers =
    forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
Safe.catches m a
action (forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
[Handler m a] -> [Handler m a]
mkAnnotatedHandlers [Handler m a]
handlers)

-- | Extends each 'Handler' in the list with a variant that sees through
-- the 'AnnotatedException' and re-annotates any rethrown exceptions.
--
-- @since 0.1.1.0
mkAnnotatedHandlers :: (HasCallStack, MonadCatch m) => [Handler m a] -> [Handler m a]
mkAnnotatedHandlers :: forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
[Handler m a] -> [Handler m a]
mkAnnotatedHandlers [Handler m a]
xs =
    [Handler m a]
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Handler e -> m a
hndlr) ->
        [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \e
e ->
            forall (m :: * -> *) a. (MonadCatch m, HasCallStack) => m a -> m a
checkpointCallStack forall a b. (a -> b) -> a -> b
$ e -> m a
hndlr e
e
        , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \(AnnotatedException [Annotation]
anns e
e) ->
            forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
[Annotation] -> m a -> m a
checkpointMany [Annotation]
anns forall a b. (a -> b) -> a -> b
$ e -> m a
hndlr e
e
        ]

-- | Like 'catch', but always returns a 'AnnotatedException'.
--
-- @since 0.1.0.0
tryAnnotated :: (Exception e, MonadCatch m) => m a -> m (Either (AnnotatedException e) a)
tryAnnotated :: forall e (m :: * -> *) a.
(Exception e, MonadCatch m) =>
m a -> m (Either (AnnotatedException e) a)
tryAnnotated m a
action =
    (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action) forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
`catch` (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)

-- | Like 'Safe.try', but can also handle an 'AnnotatedException' or the
-- underlying value. Useful when you want to 'try' to catch a type of
-- exception, but you may not care about the 'Annotation's that it may or
-- may not have.
--
-- Example:
--
-- > Left exn <- try $ throw (AnnotatedException [] TestException)
-- > exn == TestException
--
-- > Left exn <- try $ throw TestException
-- > exn == AnnotatedException [] TestException
--
-- @since 0.1.0.1
try :: (Exception e, MonadCatch m) => m a -> m (Either e a)
try :: forall e (m :: * -> *) a.
(Exception e, MonadCatch m) =>
m a -> m (Either e a)
try m a
action =
    (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action)
      forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
`catch`
          (\e
exn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left e
exn)

-- | Throws an 'Exception' and annotates it with the current 'CallStack'.
--
-- An alias for 'throwWithCallStack'.
--
-- @since 0.2.0.0
throw :: (HasCallStack, MonadThrow m, Exception e) => e -> m a
throw :: forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throw = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwWithCallStack

-- | Attaches the 'CallStack' to the 'AnnotatedException' that is thrown.
--
-- @since 0.1.0.0
throwWithCallStack
    :: (HasCallStack, MonadThrow m, Exception e)
    => e -> m a
throwWithCallStack :: forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throwWithCallStack e
e =
    forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw (forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException [HasCallStack => Annotation
callStackAnnotation] e
e)

-- | Concatenate two lists of annotations.
--
-- @since 0.1.0.0
flatten :: AnnotatedException (AnnotatedException e)  -> AnnotatedException e
flatten :: forall e.
AnnotatedException (AnnotatedException e) -> AnnotatedException e
flatten (AnnotatedException [Annotation]
a (AnnotatedException [Annotation]
b e
c)) = forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException (Maybe CallStack -> [Annotation] -> [Annotation] -> [Annotation]
go forall a. Maybe a
Nothing [Annotation]
a [Annotation]
b) e
c
  where
    go :: Maybe CallStack -> [Annotation] -> [Annotation] -> [Annotation]
    go :: Maybe CallStack -> [Annotation] -> [Annotation] -> [Annotation]
go Maybe CallStack
mcallstack [] [Annotation]
bs =
        case Maybe CallStack
mcallstack of
            Just CallStack
cs ->
                CallStack -> [Annotation] -> [Annotation]
addCallStackToAnnotations CallStack
cs [Annotation]
bs
            Maybe CallStack
Nothing ->
                [Annotation]
bs
    go Maybe CallStack
mcallstack (Annotation
a : [Annotation]
as) [Annotation]
bs =
        case forall a. Typeable a => Annotation -> Maybe a
castAnnotation Annotation
a of
            Just CallStack
cs ->
                let newAcc :: Maybe CallStack
newAcc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CallStack -> CallStack -> CallStack
mergeCallStack CallStack
cs) Maybe CallStack
mcallstack forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just CallStack
cs
                 in Maybe CallStack -> [Annotation] -> [Annotation] -> [Annotation]
go Maybe CallStack
newAcc [Annotation]
as [Annotation]
bs
            Maybe CallStack
Nothing ->
                Annotation
a forall a. a -> [a] -> [a]
: Maybe CallStack -> [Annotation] -> [Annotation] -> [Annotation]
go Maybe CallStack
mcallstack [Annotation]
as [Annotation]
bs

tryFlatten :: SomeException -> SomeException
tryFlatten :: SomeException -> SomeException
tryFlatten SomeException
exn =
    case forall e. Exception e => SomeException -> Maybe e
Safe.fromException SomeException
exn of
        Just (AnnotatedException (AnnotatedException SomeException)
a :: AnnotatedException (AnnotatedException SomeException)) ->
            forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ forall e.
AnnotatedException (AnnotatedException e) -> AnnotatedException e
flatten AnnotatedException (AnnotatedException SomeException)
a
        Maybe (AnnotatedException (AnnotatedException SomeException))
Nothing ->
            SomeException
exn

-- | Add a single 'Annotation' to any exceptions thrown in the following
-- action. The 'CallStack' present on any 'AnnotatedException' will also be
-- updated to include this location.
--
-- Example:
--
-- > main = do
-- >     checkpoint "Foo" $ do
-- >         print =<< readFile "I don't exist.markdown"
--
-- The exception thrown due to a missing file will now have an 'Annotation'
-- @"Foo"@.
--
-- @since 0.1.0.0
checkpoint :: (HasCallStack, MonadCatch m) => Annotation -> m a -> m a
checkpoint :: forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
Annotation -> m a -> m a
checkpoint Annotation
ann = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
[Annotation] -> m a -> m a
checkpointMany [Annotation
ann])

-- | Add the current 'CallStack' to the checkpoint, along with the given
-- annotations. This function merges 'CallStack's together, attempting to
-- preserve the call site ordering as GHC does it.
--
-- As of 0.2.0.0, an alias for 'checkpointMany'.
--
-- @since 0.1.0.0
checkpointCallStackWith
    :: (MonadCatch m, HasCallStack)
    => [Annotation]
    -> m a
    -> m a
checkpointCallStackWith :: forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
[Annotation] -> m a -> m a
checkpointCallStackWith [Annotation]
anns =
    forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
[Annotation] -> m a -> m a
checkpointMany [Annotation]
anns)

{-# DEPRECATED checkpointCallStackWith "As of 0.2.0.0 this is exactly equivalent to `checkpointMany`." #-}

-- | Adds only the current 'CallStack' to the checkpoint. This function searches
-- any thrown exception for a pre-existing 'CallStack' and will merge the given
-- pre-existing 'CallStack' with the one on this function, in an attempt to
-- preserve the actual call history.
--
-- @since 0.1.0.0
checkpointCallStack
    :: (MonadCatch m, HasCallStack)
    => m a
    -> m a
checkpointCallStack :: forall (m :: * -> *) a. (MonadCatch m, HasCallStack) => m a -> m a
checkpointCallStack =
    forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
Annotation -> m a -> m a
checkpoint (forall a. AnnC a => a -> Annotation
Annotation HasCallStack => CallStack
callStack))

-- | Add the list of 'Annotation' to any exception thrown in the following
-- action.
--
-- @since 0.1.0.0
checkpointMany :: (MonadCatch m, HasCallStack) => [Annotation] -> m a -> m a
checkpointMany :: forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
[Annotation] -> m a -> m a
checkpointMany [Annotation]
anns m a
action =
    m a
action forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Safe.catch` \(SomeException
exn :: SomeException) ->
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall exception.
CallStack
-> AnnotatedException exception -> AnnotatedException exception
addCallStackToException HasCallStack => CallStack
callStack
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e.
[Annotation] -> AnnotatedException e -> AnnotatedException e
annotate [Annotation]
anns
            forall a b. (a -> b) -> a -> b
$ case forall e. Exception e => SomeException -> Maybe e
Safe.fromException SomeException
exn of
                Just (AnnotatedException SomeException
e' :: AnnotatedException SomeException) ->
                    AnnotatedException SomeException
e'
                Maybe (AnnotatedException SomeException)
Nothing -> do
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure SomeException
exn

-- | Retrieves the 'CallStack' from an 'AnnotatedException' if one is present.
--
-- The library maintains an internal check that a single 'CallStack' is present
-- in the list, so this only returns the first one found. If you have added
-- a 'CallStack' directly to the @['Annotation']@, then this will likely break.
--
-- @since 0.1.0.0
annotatedExceptionCallStack :: AnnotatedException exception -> Maybe CallStack
annotatedExceptionCallStack :: forall exception. AnnotatedException exception -> Maybe CallStack
annotatedExceptionCallStack AnnotatedException exception
exn =
    let ([CallStack]
stacks, [Annotation]
_rest) = forall a. Typeable a => [Annotation] -> ([a], [Annotation])
tryAnnotations (forall exception. AnnotatedException exception -> [Annotation]
annotations AnnotatedException exception
exn)
    in forall a. [a] -> Maybe a
listToMaybe [CallStack]
stacks

-- | Adds a 'CallStack' to the given 'AnnotatedException'. This function will
-- search through the existing annotations, and it will not add a second
-- 'CallStack' to the list. Instead, it will append the contents of the given
-- 'CallStack' to the existing one.
--
-- This mirrors the behavior of the way 'HasCallStack' actually works.
--
-- @since 0.1.0.0
addCallStackToException
    :: CallStack
    -> AnnotatedException exception
    -> AnnotatedException exception
addCallStackToException :: forall exception.
CallStack
-> AnnotatedException exception -> AnnotatedException exception
addCallStackToException CallStack
cs (AnnotatedException [Annotation]
anns exception
e) =
    forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException (CallStack -> [Annotation] -> [Annotation]
addCallStackToAnnotations CallStack
cs [Annotation]
anns) exception
e

addCallStackToAnnotations :: CallStack -> [Annotation] -> [Annotation]
addCallStackToAnnotations :: CallStack -> [Annotation] -> [Annotation]
addCallStackToAnnotations CallStack
cs [Annotation]
anns = [Annotation] -> [Annotation]
go [Annotation]
anns
  where
    -- not a huge fan of the direct recursion, but it seems easier than trying
    -- to finagle a `foldr` or something
    go :: [Annotation] -> [Annotation]
go [] =
        [forall a. AnnC a => a -> Annotation
Annotation CallStack
cs]
    go (Annotation
ann : [Annotation]
anns) =
        case forall a. Typeable a => Annotation -> Maybe a
castAnnotation Annotation
ann of
            Just CallStack
preexistingCallStack ->
                forall a. AnnC a => a -> Annotation
Annotation (CallStack -> CallStack -> CallStack
mergeCallStack CallStack
preexistingCallStack CallStack
cs) forall a. a -> [a] -> [a]
: [Annotation]
anns
            Maybe CallStack
Nothing ->
                Annotation
ann forall a. a -> [a] -> [a]
: [Annotation] -> [Annotation]
go [Annotation]
anns

-- we want to merge callstack but not duplicate entries
mergeCallStack :: CallStack -> CallStack -> CallStack
mergeCallStack :: CallStack -> CallStack -> CallStack
mergeCallStack CallStack
pre CallStack
new =
        [([Char], SrcLoc)] -> CallStack
fromCallSiteList
        forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], [Char], [Char], Int, Int, Int, Int) -> SrcLoc
fromSrcLocOrd)
        forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
ordNub
        forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SrcLoc -> ([Char], [Char], [Char], Int, Int, Int, Int)
toSrcLocOrd)
        forall a b. (a -> b) -> a -> b
$ CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
pre forall a. Semigroup a => a -> a -> a
<> CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
new
  where
    toSrcLocOrd :: SrcLoc -> ([Char], [Char], [Char], Int, Int, Int, Int)
toSrcLocOrd (SrcLoc [Char]
a [Char]
b [Char]
c Int
d Int
e Int
f Int
g) =
        ([Char]
a, [Char]
b, [Char]
c, Int
d, Int
e, Int
f, Int
g)
    fromSrcLocOrd :: ([Char], [Char], [Char], Int, Int, Int, Int) -> SrcLoc
fromSrcLocOrd ([Char]
a, [Char]
b, [Char]
c, Int
d, Int
e, Int
f, Int
g) =
        [Char] -> [Char] -> [Char] -> Int -> Int -> Int -> Int -> SrcLoc
SrcLoc [Char]
a [Char]
b [Char]
c Int
d Int
e Int
f Int
g

-- | Remove duplicates but keep elements in order.
--   O(n * log n)
-- Vendored from GHC
ordNub :: Ord a => [a] -> [a]
ordNub :: forall a. Ord a => [a] -> [a]
ordNub = forall {a}. Ord a => Set a -> [a] -> [a]
go forall a. Set a
Set.empty
  where
    go :: Set a -> [a] -> [a]
go Set a
_ [] = []
    go Set a
s (a
x:[a]
xs)
      | forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
s = Set a -> [a] -> [a]
go Set a
s [a]
xs
      | Bool
otherwise = a
x forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs