{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Control.Exception.Annotated
(
AnnotatedException(..)
, exceptionWithCallStack
, throw
, throwWithCallStack
, checkpoint
, checkpointMany
, checkpointCallStack
, checkpointCallStackWith
, catch
, catches
, tryAnnotated
, try
, check
, hide
, annotatedExceptionCallStack
, addCallStackToException
, Annotation(..)
, CallStackAnnotation(..)
, 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
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)
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
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]
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
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
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 :: (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]
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)
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
]
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)
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)
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
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)
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
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])
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`." #-}
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))
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
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
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
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
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
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