{-# 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.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
    { AnnotatedException exception -> [Annotation]
annotations :: [Annotation]
    , AnnotatedException exception -> exception
exception   :: exception
    }
    deriving (Int -> AnnotatedException exception -> ShowS
[AnnotatedException exception] -> ShowS
AnnotatedException exception -> String
(Int -> AnnotatedException exception -> ShowS)
-> (AnnotatedException exception -> String)
-> ([AnnotatedException exception] -> ShowS)
-> Show (AnnotatedException exception)
forall exception.
Show exception =>
Int -> AnnotatedException exception -> ShowS
forall exception.
Show exception =>
[AnnotatedException exception] -> ShowS
forall exception.
Show exception =>
AnnotatedException exception -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AnnotatedException exception] -> ShowS
$cshowList :: forall exception.
Show exception =>
[AnnotatedException exception] -> ShowS
show :: AnnotatedException exception -> String
$cshow :: forall exception.
Show exception =>
AnnotatedException exception -> String
showsPrec :: Int -> AnnotatedException exception -> ShowS
$cshowsPrec :: forall exception.
Show exception =>
Int -> AnnotatedException exception -> ShowS
Show, a -> AnnotatedException b -> AnnotatedException a
(a -> b) -> AnnotatedException a -> AnnotatedException b
(forall a b.
 (a -> b) -> AnnotatedException a -> AnnotatedException b)
-> (forall a b. a -> AnnotatedException b -> AnnotatedException a)
-> Functor AnnotatedException
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
<$ :: a -> AnnotatedException b -> AnnotatedException a
$c<$ :: forall a b. a -> AnnotatedException b -> AnnotatedException a
fmap :: (a -> b) -> AnnotatedException a -> AnnotatedException b
$cfmap :: forall a b.
(a -> b) -> AnnotatedException a -> AnnotatedException b
Functor, AnnotatedException a -> Bool
(a -> m) -> AnnotatedException a -> m
(a -> b -> b) -> b -> AnnotatedException a -> b
(forall m. Monoid m => AnnotatedException m -> m)
-> (forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m)
-> (forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m)
-> (forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b)
-> (forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b)
-> (forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b)
-> (forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b)
-> (forall a. (a -> a -> a) -> AnnotatedException a -> a)
-> (forall a. (a -> a -> a) -> AnnotatedException a -> a)
-> (forall a. AnnotatedException a -> [a])
-> (forall a. AnnotatedException a -> Bool)
-> (forall a. AnnotatedException a -> Int)
-> (forall a. Eq a => a -> AnnotatedException a -> Bool)
-> (forall a. Ord a => AnnotatedException a -> a)
-> (forall a. Ord a => AnnotatedException a -> a)
-> (forall a. Num a => AnnotatedException a -> a)
-> (forall a. Num a => AnnotatedException a -> a)
-> Foldable AnnotatedException
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 :: AnnotatedException a -> a
$cproduct :: forall a. Num a => AnnotatedException a -> a
sum :: AnnotatedException a -> a
$csum :: forall a. Num a => AnnotatedException a -> a
minimum :: AnnotatedException a -> a
$cminimum :: forall a. Ord a => AnnotatedException a -> a
maximum :: AnnotatedException a -> a
$cmaximum :: forall a. Ord a => AnnotatedException a -> a
elem :: a -> AnnotatedException a -> Bool
$celem :: forall a. Eq a => a -> AnnotatedException a -> Bool
length :: AnnotatedException a -> Int
$clength :: forall a. AnnotatedException a -> Int
null :: AnnotatedException a -> Bool
$cnull :: forall a. AnnotatedException a -> Bool
toList :: AnnotatedException a -> [a]
$ctoList :: forall a. AnnotatedException a -> [a]
foldl1 :: (a -> a -> a) -> AnnotatedException a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> AnnotatedException a -> a
foldr1 :: (a -> a -> a) -> AnnotatedException a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> AnnotatedException a -> a
foldl' :: (b -> a -> b) -> b -> AnnotatedException a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b
foldl :: (b -> a -> b) -> b -> AnnotatedException a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> AnnotatedException a -> b
foldr' :: (a -> b -> b) -> b -> AnnotatedException a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b
foldr :: (a -> b -> b) -> b -> AnnotatedException a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> AnnotatedException a -> b
foldMap' :: (a -> m) -> AnnotatedException a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m
foldMap :: (a -> m) -> AnnotatedException a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> AnnotatedException a -> m
fold :: AnnotatedException m -> m
$cfold :: forall m. Monoid m => AnnotatedException m -> m
Foldable, Functor AnnotatedException
Foldable AnnotatedException
Functor AnnotatedException
-> Foldable AnnotatedException
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> AnnotatedException a -> f (AnnotatedException b))
-> (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 (m :: * -> *) a.
    Monad m =>
    AnnotatedException (m a) -> m (AnnotatedException a))
-> Traversable AnnotatedException
(a -> f b) -> AnnotatedException a -> f (AnnotatedException b)
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 :: AnnotatedException (m a) -> m (AnnotatedException a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
AnnotatedException (m a) -> m (AnnotatedException a)
mapM :: (a -> m b) -> AnnotatedException a -> m (AnnotatedException b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AnnotatedException a -> m (AnnotatedException b)
sequenceA :: AnnotatedException (f a) -> f (AnnotatedException a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
AnnotatedException (f a) -> f (AnnotatedException a)
traverse :: (a -> f b) -> AnnotatedException a -> f (AnnotatedException b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AnnotatedException a -> f (AnnotatedException b)
$cp2Traversable :: Foldable AnnotatedException
$cp1Traversable :: Functor AnnotatedException
Traversable)

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

    AnnotatedException [Annotation]
anns0 a -> b
f <*> :: AnnotatedException (a -> b)
-> AnnotatedException a -> AnnotatedException b
<*> AnnotatedException [Annotation]
anns1 a
a =
        [Annotation] -> b -> AnnotatedException b
forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException ([Annotation]
anns0 [Annotation] -> [Annotation] -> [Annotation]
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 (SomeException -> SomeException) -> SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ AnnotatedException SomeException -> SomeException
forall e. Exception e => e -> SomeException
SomeException (AnnotatedException SomeException -> SomeException)
-> AnnotatedException SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ AnnotatedException exception -> AnnotatedException SomeException
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 <- e -> Maybe (AnnotatedException exception)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
exn
        =
            AnnotatedException exception
-> Maybe (AnnotatedException exception)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnnotatedException exception
x
        | Just (AnnotatedException [Annotation]
ann (SomeException
e :: SomeException)) <- e -> Maybe (AnnotatedException SomeException)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
exn
        , Just exception
a <- SomeException -> Maybe exception
forall e. Exception e => SomeException -> Maybe e
Safe.fromException SomeException
e
        =
            AnnotatedException exception
-> Maybe (AnnotatedException exception)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedException exception
 -> Maybe (AnnotatedException exception))
-> AnnotatedException exception
-> Maybe (AnnotatedException exception)
forall a b. (a -> b) -> a -> b
$ [Annotation] -> exception -> AnnotatedException exception
forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException [Annotation]
ann exception
a
    fromException SomeException
exn
        | Just (exception
e :: exception) <- SomeException -> Maybe exception
forall e. Exception e => SomeException -> Maybe e
Safe.fromException SomeException
exn
        =
            AnnotatedException exception
-> Maybe (AnnotatedException exception)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnnotatedException exception
 -> Maybe (AnnotatedException exception))
-> AnnotatedException exception
-> Maybe (AnnotatedException exception)
forall a b. (a -> b) -> a -> b
$ exception -> AnnotatedException exception
forall (f :: * -> *) a. Applicative f => a -> f a
pure exception
e
        | Bool
otherwise
        =
            Maybe (AnnotatedException exception)
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 :: e -> AnnotatedException e
exceptionWithCallStack =
    [Annotation] -> e -> AnnotatedException e
forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException [Annotation
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 :: [Annotation] -> AnnotatedException e -> AnnotatedException e
annotate [Annotation]
newAnnotations (AnnotatedException [Annotation]
oldAnnotations e
e) =
    let
        ([CallStack]
callStacks, [Annotation]
other) =
            [Annotation] -> ([CallStack], [Annotation])
forall a. Typeable a => [Annotation] -> ([a], [Annotation])
tryAnnotations ([Annotation]
newAnnotations [Annotation] -> [Annotation] -> [Annotation]
forall a. Semigroup a => a -> a -> a
<> [Annotation]
oldAnnotations)
    in
        (CallStack -> AnnotatedException e -> AnnotatedException e)
-> AnnotatedException e -> [CallStack] -> AnnotatedException e
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CallStack -> AnnotatedException e -> AnnotatedException e
forall exception.
CallStack
-> AnnotatedException exception -> AnnotatedException exception
addCallStackToException ([Annotation] -> e -> AnnotatedException e
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 :: AnnotatedException e -> AnnotatedException SomeException
hide = (e -> SomeException)
-> AnnotatedException e -> AnnotatedException SomeException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> SomeException
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 :: AnnotatedException SomeException -> Maybe (AnnotatedException e)
check = (SomeException -> Maybe e)
-> AnnotatedException SomeException -> Maybe (AnnotatedException e)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SomeException -> Maybe e
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 :: m a -> (e -> m a) -> m a
catch m a
action e -> m a
handler =
    (HasCallStack => m a -> [Handler m a] -> m a)
-> m a -> [Handler m a] -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => m a -> [Handler m a] -> m a
forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
m a -> [Handler m a] -> m a
catches m a
action [(e -> m a) -> Handler m a
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 :: m a -> [Handler m a] -> m a
catches m a
action [Handler m a]
handlers =
    m a -> [Handler m a] -> m a
forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
Safe.catches m a
action ((HasCallStack => [Handler m a] -> [Handler m a])
-> [Handler m a] -> [Handler m a]
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => [Handler m a] -> [Handler m a]
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 :: [Handler m a] -> [Handler m a]
mkAnnotatedHandlers [Handler m a]
xs =
    [Handler m a]
xs [Handler m a] -> (Handler m a -> [Handler m a]) -> [Handler m a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Handler e -> m a
hndlr) ->
        [ (e -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler e -> m a
hndlr
        , (AnnotatedException e -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((AnnotatedException e -> m a) -> Handler m a)
-> (AnnotatedException e -> m a) -> Handler m a
forall a b. (a -> b) -> a -> b
$ \(AnnotatedException [Annotation]
anns e
e) ->
            [Annotation] -> m a -> m a
forall (m :: * -> *) a.
(MonadCatch m, HasCallStack) =>
[Annotation] -> m a -> m a
checkpointMany [Annotation]
anns (m a -> m a) -> m a -> m a
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 :: m a -> m (Either (AnnotatedException e) a)
tryAnnotated m a
action =
    (a -> Either (AnnotatedException e) a
forall a b. b -> Either a b
Right (a -> Either (AnnotatedException e) a)
-> m a -> m (Either (AnnotatedException e) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action) m (Either (AnnotatedException e) a)
-> (AnnotatedException e -> m (Either (AnnotatedException e) a))
-> m (Either (AnnotatedException e) a)
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
`catch` (Either (AnnotatedException e) a
-> m (Either (AnnotatedException e) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (AnnotatedException e) a
 -> m (Either (AnnotatedException e) a))
-> (AnnotatedException e -> Either (AnnotatedException e) a)
-> AnnotatedException e
-> m (Either (AnnotatedException e) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnotatedException e -> Either (AnnotatedException e) a
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 :: m a -> m (Either e a)
try m a
action =
    (a -> Either e a
forall a b. b -> Either a b
Right (a -> Either e a) -> m a -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action)
      m (Either e a) -> (e -> m (Either e a)) -> m (Either e a)
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadCatch m) =>
m a -> (e -> m a) -> m a
`catch`
          (\e
exn -> Either e a -> m (Either e a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m (Either e a)) -> Either e a -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ e -> Either e a
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 :: e -> m a
throw = (HasCallStack => e -> m a) -> e -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => e -> m a
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 :: e -> m a
throwWithCallStack e
e =
    (HasCallStack => m a) -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m a) -> m a) -> (HasCallStack => m a) -> m a
forall a b. (a -> b) -> a -> b
$
        AnnotatedException e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw ([Annotation] -> e -> AnnotatedException e
forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException [Annotation
HasCallStack => Annotation
callStackAnnotation] e
e)

-- | Concatenate two lists of annotations.
--
-- @since 0.1.0.0
flatten :: AnnotatedException (AnnotatedException e)  -> AnnotatedException e
flatten :: AnnotatedException (AnnotatedException e) -> AnnotatedException e
flatten (AnnotatedException [Annotation]
a (AnnotatedException [Annotation]
b e
c)) = [Annotation] -> e -> AnnotatedException e
forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException ([Annotation]
a [Annotation] -> [Annotation] -> [Annotation]
forall a. [a] -> [a] -> [a]
++ [Annotation]
b) e
c

tryFlatten :: SomeException -> SomeException
tryFlatten :: SomeException -> SomeException
tryFlatten SomeException
exn =
    case SomeException
-> Maybe (AnnotatedException (AnnotatedException SomeException))
forall e. Exception e => SomeException -> Maybe e
Safe.fromException SomeException
exn of
        Just (AnnotatedException (AnnotatedException SomeException)
a :: AnnotatedException (AnnotatedException SomeException)) ->
            AnnotatedException SomeException -> SomeException
forall e. Exception e => e -> SomeException
SomeException (AnnotatedException SomeException -> SomeException)
-> AnnotatedException SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ AnnotatedException (AnnotatedException SomeException)
-> AnnotatedException SomeException
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 :: Annotation -> m a -> m a
checkpoint Annotation
ann = (HasCallStack => m a -> m a) -> m a -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ([Annotation] -> m a -> m a
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 :: [Annotation] -> m a -> m a
checkpointCallStackWith [Annotation]
anns =
    (HasCallStack => m a -> m a) -> m a -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ([Annotation] -> m a -> m a
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 :: m a -> m a
checkpointCallStack =
    (HasCallStack => m a -> m a) -> m a -> m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (Annotation -> m a -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
Annotation -> m a -> m a
checkpoint (CallStack -> Annotation
forall a. AnnC a => a -> Annotation
Annotation CallStack
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 :: [Annotation] -> m a -> m a
checkpointMany [Annotation]
anns m a
action =
    m a
action m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`Safe.catch` \(SomeException
exn :: SomeException) ->
        AnnotatedException SomeException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw
            (AnnotatedException SomeException -> m a)
-> (AnnotatedException SomeException
    -> AnnotatedException SomeException)
-> AnnotatedException SomeException
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack
-> AnnotatedException SomeException
-> AnnotatedException SomeException
forall exception.
CallStack
-> AnnotatedException exception -> AnnotatedException exception
addCallStackToException CallStack
HasCallStack => CallStack
callStack
            (AnnotatedException SomeException
 -> AnnotatedException SomeException)
-> (AnnotatedException SomeException
    -> AnnotatedException SomeException)
-> AnnotatedException SomeException
-> AnnotatedException SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Annotation]
-> AnnotatedException SomeException
-> AnnotatedException SomeException
forall e.
[Annotation] -> AnnotatedException e -> AnnotatedException e
annotate [Annotation]
anns
            (AnnotatedException SomeException -> m a)
-> AnnotatedException SomeException -> m a
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe (AnnotatedException SomeException)
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
                    SomeException -> AnnotatedException SomeException
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 :: AnnotatedException exception -> Maybe CallStack
annotatedExceptionCallStack AnnotatedException exception
exn =
    let ([CallStack]
stacks, [Annotation]
_rest) = [Annotation] -> ([CallStack], [Annotation])
forall a. Typeable a => [Annotation] -> ([a], [Annotation])
tryAnnotations (AnnotatedException exception -> [Annotation]
forall exception. AnnotatedException exception -> [Annotation]
annotations AnnotatedException exception
exn)
    in [CallStack] -> Maybe CallStack
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 :: CallStack
-> AnnotatedException exception -> AnnotatedException exception
addCallStackToException CallStack
cs (AnnotatedException [Annotation]
annotations' exception
e) =
    [Annotation] -> exception -> AnnotatedException exception
forall exception.
[Annotation] -> exception -> AnnotatedException exception
AnnotatedException [Annotation]
anns' exception
e
  where
    anns' :: [Annotation]
anns' = [Annotation] -> [Annotation]
go [Annotation]
annotations'
    -- not a huge fan of the direct recursion, but it seems easier than trying
    -- to finagle a `foldr` or something
    go :: [Annotation] -> [Annotation]
go [] =
        [CallStack -> Annotation
forall a. AnnC a => a -> Annotation
Annotation CallStack
cs]
    go (Annotation
ann : [Annotation]
anns) =
        case Annotation -> Maybe CallStack
forall a. Typeable a => Annotation -> Maybe a
castAnnotation Annotation
ann of
            Just CallStack
preexistingCallStack ->
                CallStack -> CallStack -> Annotation
mergeCallStack CallStack
preexistingCallStack CallStack
cs Annotation -> [Annotation] -> [Annotation]
forall a. a -> [a] -> [a]
: [Annotation]
anns
            Maybe CallStack
Nothing ->
                Annotation
ann Annotation -> [Annotation] -> [Annotation]
forall a. a -> [a] -> [a]
: [Annotation] -> [Annotation]
go [Annotation]
anns

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

toSrcLocOrd :: SrcLoc -> (String, String, String, Int, Int, Int, Int)
toSrcLocOrd (SrcLoc String
a String
b String
c Int
d Int
e Int
f Int
g) =
    (String
a, String
b, String
c, Int
d, Int
e, Int
f, Int
g)
fromSrcLocOrd :: (String, String, String, Int, Int, Int, Int) -> SrcLoc
fromSrcLocOrd (String
a, String
b, String
c, Int
d, Int
e, Int
f, Int
g) =
    String -> String -> String -> Int -> Int -> Int -> Int -> SrcLoc
SrcLoc String
a String
b String
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 :: [a] -> [a]
ordNub = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
go Set a
forall a. Set a
Set.empty
  where
    go :: Set a -> [a] -> [a]
go Set a
_ [] = []
    go Set a
s (a
x:[a]
xs)
      | a -> Set a -> Bool
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs