annotated-exception 0.1.2.1 → 0.2.0.0

raw patch · 7 files changed

+443/−142 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• annotated-exception.cabal +1/−1
• src/Control/Exception/Annotated.hs +108/−59
• src/Control/Exception/Annotated/UnliftIO.hs +24/−21
• src/Data/Annotation.hs +68/−28
• test/Control/Exception/AnnotatedSpec.hs +206/−23
• test/Data/AnnotationSpec.hs +22/−10

@@ -2,6 +2,20 @@  ## Unreleased changes +## 0.2.0.0++- [#12](https://github.com/parsonsmatt/annotated-exception/pull/12)+    - Removed the `Eq` instance for `Annotation` as well as the `Eq` constraint+      in `AnnC`. These instances were only used for testing, and prevented the+      natural use of `CallStack` in a `[Annotation]`.+    - Removed the `Eq` instance for `AnnotatedException` as a consequence of+      dropping the `Eq` instance on `Annotation`.+    - Removed the `new` function. Use `pure` or `exceptionWithCallStack` instead.+    - Fixed a double-annotation bug in `checkpointCallStackWith`.+    - `checkpointCallStack` appends to the call-site list.+    - Pretty much everything now merges the `CallStack`s together. `throw`+      includes a `CallStack`, as do `checkpoint` and `checkpointMany`.+ ## 0.1.2.1  - [#8](https://github.com/parsonsmatt/annotated-exception/pull/8)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           annotated-exception-version:        0.1.2.1+version:        0.2.0.0 synopsis:       Exceptions, with checkpoints and context. description:    Please see the README on Github at <https://github.com/parsonsmatt/annotated-exception#readme> category:       Control

@@ -28,7 +28,8 @@ module Control.Exception.Annotated     ( -- * The Main Type       AnnotatedException(..)-    , new+    , exceptionWithCallStack+    , throw     , throwWithCallStack     -- * Annotating Exceptions     , checkpoint@@ -53,7 +54,6 @@     -- * Re-exports from "Control.Exception.Safe"     , Exception(..)     , Safe.SomeException(..)-    , Safe.throw     , Handler (..)     ) where @@ -62,10 +62,10 @@ 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.@@ -76,7 +76,7 @@     { annotations :: [Annotation]     , exception   :: exception     }-    deriving (Eq, Show, Functor, Foldable, Traversable)+    deriving (Show, Functor, Foldable, Traversable)  instance Applicative AnnotatedException where     pure =@@ -112,30 +112,40 @@     fromException exn         | Just (e :: exception) <- Safe.fromException exn         =-            pure $ new e+            pure $ pure e         | otherwise         =             Nothing --- | Attach an empty @['Annotation']@ to an exception.+-- | Annotate the underlying exception with a 'CallStack'. ----- @since 0.1.0.0-new :: e -> AnnotatedException e-new = pure+-- @since 0.2.0.0+exceptionWithCallStack :: (Exception e, HasCallStack) => e -> AnnotatedException e+exceptionWithCallStack =+    AnnotatedException [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 ann (AnnotatedException anns e) = AnnotatedException (ann ++ anns) e+annotate newAnnotations (AnnotatedException oldAnnotations e) =+    let+        (callStacks, other) =+            tryAnnotations (newAnnotations <> oldAnnotations)+    in+        foldr addCallStackToException (AnnotatedException other e) callStacks --- | Call 'toException' on the underlying 'Exception'.+-- | Call 'Safe.toException' on the underlying 'Exception'. -- -- @since 0.1.0.0 hide :: Exception e => AnnotatedException e -> AnnotatedException SomeException hide = fmap Safe.toException --- | Call 'fromException' on the underlying 'Exception', attaching the+-- | Call 'Safe.fromException' on the underlying 'Exception', attaching the -- annotations to the result. -- -- @since 0.1.0.0@@ -160,7 +170,7 @@ -- > throw TestException `catch` \TestException -> -- >     putStrLn "ok!" ----- We can throw an exception and catch it with location.+-- We can throw an exception and catch it with annotations. -- -- > throw TestException `catch` \(AnnotatedException anns TestException) -> -- >     putStrLn "ok!"@@ -224,17 +234,23 @@       `catch`           (\exn -> pure $ Left exn) --- | Attaches the 'CallStack' to the 'AnnotatedException' that is thrown.+-- | Throws an 'Exception' and annotates it with the current 'CallStack'. ----- The 'CallStack' will *not* be present as a 'CallStack' - it will be--- a 'CallStackAnnotation'.+-- An alias for 'throwWithCallStack'. --+-- @since 0.2.0.0+throw :: (HasCallStack, MonadThrow m, Exception e) => e -> m a+throw = withFrozenCallStack 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 =-    Safe.throw (AnnotatedException [callStackAnnotation] e)+    withFrozenCallStack $+        Safe.throw (AnnotatedException [callStackAnnotation] e)  -- | Concatenate two lists of annotations. --@@ -251,7 +267,8 @@             exn  -- | Add a single 'Annotation' to any exceptions thrown in the following--- action.+-- action. The 'CallStack' present on any 'AnnotatedException' will also be+-- updated to include this location. -- -- Example: --@@ -263,14 +280,14 @@ -- @"Foo"@. -- -- @since 0.1.0.0-checkpoint :: MonadCatch m => Annotation -> m a -> m a-checkpoint ann = checkpointMany [ann]+checkpoint :: (HasCallStack, MonadCatch m) => Annotation -> m a -> m a+checkpoint ann = withFrozenCallStack (checkpointMany [ann]) --- | Add the current 'CallStack' to the checkpoint. This function searches any--- thrown exception for a pre-existing 'CallStack' and will not overwrite or--- replace the 'CallStack' if one is already present.+-- | 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. ----- Primarily useful when you're wrapping a third party library.+-- As of 0.2.0.0, an alias for 'checkpointMany'. -- -- @since 0.1.0.0 checkpointCallStackWith@@ -278,26 +295,15 @@     => [Annotation]     -> m a     -> m a-checkpointCallStackWith ann action =-    action `Safe.catch` \(exn :: SomeException) ->-        Safe.throw-            . annotate ann-            . addCallStackToException callStack-            $ case Safe.fromException exn of-                Just (e' :: AnnotatedException SomeException) ->-                    case annotatedExceptionCallStack e' of-                        Nothing ->-                            annotate ann e'-                        Just _preexistingCallstack ->-                            e'-                Nothing -> do-                    annotate ann $ new exn+checkpointCallStackWith anns =+    withFrozenCallStack (checkpointMany anns) --- | Add the current 'CallStack' to the checkpoint. This function searches any--- thrown exception for a pre-existing 'CallStack' and will not overwrite or--- replace the 'CallStack' if one is already present.------ Primarily useful when you're wrapping a third party library.+{-# 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@@ -305,41 +311,84 @@     => m a     -> m a checkpointCallStack =-    checkpointCallStackWith []+    withFrozenCallStack (checkpoint (Annotation callStack))  -- | Add the list of 'Annotation' to any exception thrown in the following -- action. -- -- @since 0.1.0.0-checkpointMany :: (MonadCatch m) => [Annotation] -> m a -> m a-checkpointMany ann action =+checkpointMany :: (MonadCatch m, HasCallStack) => [Annotation] -> m a -> m a+checkpointMany anns action =     action `Safe.catch` \(exn :: SomeException) ->-        Safe.throw . annotate ann $ case Safe.fromException exn of-            Just (e' :: AnnotatedException SomeException) ->-                e'-            Nothing -> do-                new exn+        Safe.throw+            . addCallStackToException callStack+            . annotate anns+            $ case Safe.fromException exn of+                Just (e' :: AnnotatedException SomeException) ->+                    e'+                Nothing -> do+                    pure 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 exn =-    let (stacks, _rest) = callStackInAnnotations (annotations exn)+    let (stacks, _rest) = tryAnnotations (annotations exn)     in listToMaybe 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.+-- '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 cs exn =-    case annotatedExceptionCallStack exn of-        Nothing ->-            annotate [callStackToAnnotation cs] exn-        Just _ ->-            exn+addCallStackToException cs (AnnotatedException annotations' e) =+    AnnotatedException anns' e+  where+    anns' = go annotations'+    -- not a huge fan of the direct recursion, but it seems easier than trying+    -- to finagle a `foldr` or something+    go [] =+        [Annotation cs]+    go (ann : anns) =+        case castAnnotation ann of+            Just preexistingCallStack ->+                mergeCallStack preexistingCallStack cs : anns+            Nothing ->+                ann : go anns++    -- we want to merge callstack but not duplicate entries+    mergeCallStack pre new =+        Annotation+            $ fromCallSiteList+            $ fmap (fmap fromSrcLocOrd)+            $ ordNub+            $ fmap (fmap toSrcLocOrd)+            $ getCallStack pre <> getCallStack new++toSrcLocOrd (SrcLoc a b c d e f g) =+    (a, b, c, d, e, f, g)+fromSrcLocOrd (a, b, c, d, e, f, g) =+    SrcLoc a b c d e f g++-- | Remove duplicates but keep elements in order.+--   O(n * log n)+-- Vendored from GHC+ordNub :: Ord a => [a] -> [a]+ordNub = go Set.empty+  where+    go _ [] = []+    go s (x:xs)+      | Set.member x s = go s xs+      | otherwise = x : go (Set.insert x s) xs

@@ -1,14 +1,14 @@-{-# language ExplicitForAll #-}+{-# LANGUAGE ExplicitForAll #-}  -- | This module presents the same interface as -- "Control.Exception.Annotated", but uses 'MonadUnliftIO' instead of--- 'MonadCatch' or 'MonadThrow'.+-- 'Control.Monad.Catch.MonadCatch' or 'Control.Monad.Catch.MonadThrow'. -- -- @since 0.1.2.0 module Control.Exception.Annotated.UnliftIO     ( -- * The Main Type       AnnotatedException(..)-    , new+    , exceptionWithCallStack     , throwWithCallStack     -- * Annotating Exceptions     , checkpoint@@ -56,48 +56,52 @@ import GHC.Stack  -- | Like 'Catch.throwWithCallStack', but uses 'MonadIO' instead of--- 'MonadThrow'.+-- 'Control.Monad.Catch.MonadThrow'. -- -- @since 0.1.2.0 throwWithCallStack     :: forall e m a. (MonadIO m, Exception e, HasCallStack)     => e -> m a-throwWithCallStack = liftIO . Catch.throwWithCallStack+throwWithCallStack = liftIO . withFrozenCallStack Catch.throwWithCallStack --- | Like 'Catch.throw', but uses 'MonadIO' instead of 'MonadThrow'.+-- | Like 'Catch.throw', but uses 'MonadIO' instead of 'Control.Monad.Catch.MonadThrow'. -- -- @since 0.1.2.0-throw :: forall e m a. (MonadIO m, Exception e) => e -> m a-throw = liftIO . Catch.throw+throw :: forall e m a. (MonadIO m, Exception e, HasCallStack) => e -> m a+throw = liftIO . withFrozenCallStack Catch.throw --- | Like 'Catch.checkpoint', but uses 'MonadUnliftIO' instead of 'MonadCatch'.+-- | Like 'Catch.checkpoint', but uses 'MonadUnliftIO' instead of 'Control.Monad.Catch.MonadCatch'. -- -- @since 0.1.2.0-checkpoint :: forall m a. (MonadUnliftIO m) => Annotation -> m a -> m a+checkpoint :: forall m a. (MonadUnliftIO m, HasCallStack) => Annotation -> m a -> m a checkpoint ann action = withRunInIO $ \runInIO ->-    liftIO $ Catch.checkpoint ann (runInIO action)+    liftIO $ withFrozenCallStack (Catch.checkpoint ann) (runInIO action)  -- | Like 'Catch.checkpointMany', but uses 'MonadUnliftIO' instead of--- 'MonadCatch'.+-- 'Control.Monad.Catch.MonadCatch'. -- -- @since 0.1.2.0-checkpointMany :: forall m a. (MonadUnliftIO m) => [Annotation] -> m a -> m a+checkpointMany :: forall m a. (MonadUnliftIO m, HasCallStack) => [Annotation] -> m a -> m a checkpointMany anns action =     withRunInIO $ \runInIO ->-        liftIO $ Catch.checkpointMany anns (runInIO action)+        liftIO $ withFrozenCallStack Catch.checkpointMany anns (runInIO action)  -- | Like 'Catch.checkpointCallStackWith', but uses 'MonadUnliftIO' instead of--- 'MonadCatch'.+-- 'Control.Monad.Catch.MonadCatch'. --+-- Deprecated in 0.2.0.0 as it is now an alias for 'checkpointMany'.+-- -- @since 0.1.2.0 checkpointCallStackWith     :: forall m a. (MonadUnliftIO m, HasCallStack)     => [Annotation] -> m a -> m a checkpointCallStackWith anns action =     withRunInIO $ \runInIO ->-        liftIO $ Catch.checkpointCallStackWith anns (runInIO action)+        liftIO $ withFrozenCallStack Catch.checkpointCallStackWith anns (runInIO action) --- | Like 'Catch.catch', but uses 'MonadUnliftIO' instead of 'MonadCatch'.+{-# DEPRECATED checkpointCallStackWith "As of annotated-exception-0.2.0.0, this is an alias for checkpointMany" #-}++-- | Like 'Catch.catch', but uses 'MonadUnliftIO' instead of 'Control.Monad.Catch.MonadCatch'. -- -- @since 0.1.2.0 catch@@ -109,7 +113,7 @@     withRunInIO $ \runInIO ->         liftIO $ Catch.catch (runInIO action) (\e -> runInIO $ handler e) --- | Like 'Catch.tryAnnotated' but uses 'MonadUnliftIO' instead of 'MonadCatch'.+-- | Like 'Catch.tryAnnotated' but uses 'MonadUnliftIO' instead of 'Control.Monad.Catch.MonadCatch'. -- -- @since 0.1.2.0 tryAnnotated@@ -120,7 +124,7 @@     withRunInIO $ \runInIO ->         liftIO $ Catch.tryAnnotated (runInIO action) --- | Like 'Catch.try' but uses 'MonadUnliftIO' instead of 'MonadCatch'.+-- | Like 'Catch.try' but uses 'MonadUnliftIO' instead of 'Control.Monad.Catch.MonadCatch'. -- -- @since 0.1.2.0 try@@ -131,7 +135,7 @@     withRunInIO $ \runInIO ->         liftIO $ Catch.try (runInIO action) --- | Like 'Catch.catches', bt uses 'MonadUnliftIO' instead of 'MonadCatch'.+-- | Like 'Catch.catches', bt uses 'MonadUnliftIO' instead of 'Control.Monad.Catch.MonadCatch'. -- -- @since 0.1.2.0 catches@@ -143,4 +147,3 @@     withRunInIO $ \runInIO -> do         let f (Handler k) = Handler (\e -> runInIO (k e))         liftIO $ catches (runInIO action) (map f handlers)-  where

@@ -7,17 +7,53 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} --- | An 'Annotation' is attached to a 'LocatedException'. They're+-- | An 'Annotation' is attached to an 'Control.Exception.Annotated.AnnotatedException'. They're -- essentially a dynamically typed value with a convenient 'IsString'--- instance. I'd recommend using something like @Data.Aeson.Value@ or--- possibly something more strongly typed.+-- instance.+--+-- When integrating into your own application, you will likely want to do more+-- than just have the 'String' you get from 'show'ing the 'Annotation'. You can+-- do this by creating a special wrapper type that carries a class constraint.+-- This allows you to also pluck out the 'Annotation's from your library or+-- executable independently and treat them differently from unknonwn+-- annotations.+--+-- As an example, here's one that requires a 'Data.Aeson.ToJSON' constraint on the+-- underlying value. This means that you can convert any annotated value to+-- JSON, and then use that JSON in bug reports or logging.+--+-- @+-- data JsonAnnotation where+--   JsonAnnotation :: (ToJSON a, Typeable a) => a -> JsonAnnotation+--+-- instance Show JsonANnotation where+--   show (JsonAnnotation a) = concat+--      [ "(JsonAnnotation ("+--      , show (toJSON a)+--      , "))"+--      ]+--+-- jsonCheckpoint :: (Typeable a, ToJSON a, 'HasCallStack', MonadCatch m) => a -> m a -> m a+-- jsonCheckpoint val = 'withFrozenCallStack' checkpoint (JsonAnnotation val)+-- @+--+-- When handling the @['Annotation']@ carried on the+-- 'Control.Exception.Annotated.AnnotatedException', you can use+-- 'tryAnnotations' to pick out the JSON annotations.+--+-- @+-- jsonAnnotations :: [Annotation] -> ([JsonAnnotation], [Annotation])+-- jsonAnnotations = tryAnnotations+-- @+--+-- and handle them however you please.+--+-- @since 0.1.0.0 module Data.Annotation     ( module Data.Annotation     , module Data.Proxy     ) where -import GHC.Stack-import Data.Dynamic import Data.Either import Data.Maybe import Data.Proxy@@ -26,6 +62,7 @@ import Data.String import qualified Data.Text as Text import Data.Typeable+import GHC.Stack  -- | The constraints that the value inside an 'Annotation' must have. --@@ -33,11 +70,12 @@ -- information out of it. -- -- @since 0.1.0.0-type AnnC a = (Typeable a, Eq a, Show a)+type AnnC a = (Typeable a, Show a)  -- | An 'Annotation' is a wrapper around a value that includes a 'Typeable'--- constraint so we can later unpack it. It is essentially a 'Dynamic, but--- we also include 'Show' and 'Eq' so it's more useful.+-- constraint so we can later unpack it. It is essentially a 'Data.Dynamic.Dynamic', but+-- we also include 'Show' so that you can always fall back to simply 'show'ing+-- the 'Annotation' if it is otherwise unrecognized. -- -- @since 0.1.0.0 data Annotation where@@ -49,19 +87,13 @@ -- | -- -- @since 0.1.0.0-instance Eq Annotation where-    Annotation (a :: a) == Annotation (b :: b) =-        case eqT @a @b of-            Just Refl ->-                a == b-            Nothing ->-                False---- |------ @since 0.1.0.0 instance Show Annotation where-    show (Annotation a) = show a+    showsPrec p (Annotation a) =+        showParen (p > 10) $+            showString "Annotation @"+            . showsPrec 11 (typeOf a)+            . showString " "+            . showsPrec 11 a  -- | --@@ -145,41 +177,49 @@ -- | A wrapper type for putting a 'CallStack' into an 'Annotation'. We need -- this because 'CallStack' does not have an 'Eq' instance. --+-- Deprecated in 0.2.0.0 since you can just put a 'CallStack' directly in an+-- 'Annotation' now that we have no need for an 'Eq' constraint on it.+-- -- @since 0.1.0.0 newtype CallStackAnnotation = CallStackAnnotation     { unCallStackAnnotation :: [(String, SrcLoc)]     }     deriving (Eq, Show) +{-# DEPRECATED CallStackAnnotation "You can just use `CallStack` directly now." #-}+ -- | Grab an 'Annotation' corresponding to the 'CallStack' that is -- currently in scope. -- -- @since 0.1.0.0 callStackAnnotation :: HasCallStack => Annotation-callStackAnnotation = callStackToAnnotation callStack+callStackAnnotation = Annotation callStack  -- | Stuff a 'CallStack' into an 'Annotation' via the 'CallStackAnnotation' -- newtype wrapper. -- -- @since 0.1.0.0 callStackToAnnotation :: CallStack -> Annotation-callStackToAnnotation cs = Annotation $ CallStackAnnotation $ getCallStack cs+callStackToAnnotation = Annotation --- | Attempt to convert an 'Annotation' back into a 'CallStack'.+-- | Convert the legacy 'CallStackAnnotation' into a 'CallStack'. --+-- Deprecated in 0.2.0.0 since you can use 'CallStack' directly.+-- -- @since 0.1.0.0 callStackFromAnnotation :: CallStackAnnotation -> CallStack callStackFromAnnotation ann =     fromCallSiteList $ unCallStackAnnotation ann +{-# DEPRECATED callStackFromAnnotation "You can use 'CallStack' directly in annotations as of 0.2.0.0." #-}+ -- | Extract the 'CallStack's from the @['Annotation']@. Any 'Annotation' -- not corresponding to a 'CallStack' will be in the second element of the -- tuple. -- -- @since 0.1.0.0 callStackInAnnotations :: [Annotation] -> ([CallStack], [Annotation])-callStackInAnnotations anns =-    let (callStacks, rest) =-            tryAnnotations anns-    in-        (fmap callStackFromAnnotation callStacks, rest)+callStackInAnnotations =+    tryAnnotations++{-# DEPRECATED callStackInAnnotations "You can just use 'tryAnnotations' directly as of 0.2.0.0." #-}

@@ -1,7 +1,9 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}  {-# options_ghc -fno-warn-orphans -fno-warn-type-defaults #-} @@ -11,8 +13,18 @@  import Control.Exception.Annotated import qualified Control.Exception.Safe as Safe+import Data.Annotation+import GHC.Stack -data TextException = TestException+import Data.AnnotationSpec ()+import Data.Maybe++instance Eq CallStack where+    a == b = show a == show b++deriving stock instance (Eq e) => Eq (AnnotatedException e)++data TestException = TestException     deriving (Eq, Show, Exception)  instance Eq SomeException where@@ -21,33 +33,36 @@ pass :: Expectation pass = pure () +emptyAnnotation :: e -> AnnotatedException e+emptyAnnotation = pure+ spec :: Spec spec = do     describe "AnnotatedException can fromException a" $ do         it "different type" $ do             fromException (toException TestException)                 `shouldBe`-                    Just (new TestException)+                    Just (emptyAnnotation TestException)          it "SomeException" $ do             fromException (SomeException TestException)                 `shouldBe`-                    Just (new (SomeException TestException))+                    Just (emptyAnnotation (SomeException TestException))          it "nested AnnotatedException" $ do-            fromException (toException (new (new TestException)))+            fromException (toException (emptyAnnotation (emptyAnnotation TestException)))                 `shouldBe`-                    Just (new TestException)+                    Just (emptyAnnotation TestException)          it "can i guess also parse into a nested Annotated" $ do-            fromException (toException (new TestException))+            fromException (toException (emptyAnnotation TestException))                 `shouldBe`-                    Just (new (new TestException))+                    Just (emptyAnnotation (emptyAnnotation TestException))          it "does not loop infinitely if the wrong type is selected" $ do             fromException (toException TestException)                 `shouldNotBe`-                    Just (new $ userError "uh oh")+                    Just (emptyAnnotation $ userError "uh oh")      describe "throw" $ do         it "wraps exceptions" $ do@@ -91,6 +106,57 @@                 `shouldThrow`                     (userError "uh oh" ==) +    describe "tryAnnotated" $ do+        let subject :: (Exception e, Exception e') => e -> IO (AnnotatedException e')+            subject exn = do+                Left exn' <- tryAnnotated (throw exn)+                pure exn'++        it "promotes to empty with no annotations" $ do+            exn <- subject TestException+            exn `shouldBeWithoutCallStackInAnnotations` AnnotatedException [] TestException++        it "preserves annotations" $ do+            exn <- subject $ AnnotatedException ["hello"] TestException+            exn `shouldBeWithoutCallStackInAnnotations` AnnotatedException ["hello"] TestException++        it "preserves annotations added via checkpoint" $ do+            Left exn <- tryAnnotated $ do+                checkpoint "hello" $ do+                    throw TestException+            exn `shouldBeWithoutCallStackInAnnotations`+                AnnotatedException ["hello"] TestException++        it "doesn't mess up if trying the wrong type" $ do+            let+                action = do+                    Left exn <- tryAnnotated $ do+                        checkpoint "hello" $ do+                            throw TestException+                    exn `shouldBe` AnnotatedException ["hello"] (userError "oh no")+            action `catch` \ann ->+                ann `shouldBeWithoutCallStackInAnnotations`+                    AnnotatedException ["hello"] TestException++    describe "throwWithCallstack" $ do+        it "includes a CallStack on the given exception" $ do+            throwWithCallStack TestException+                `shouldThrow`+                    isJust . annotatedExceptionCallStack @TestException+        describe "interaction with checkpointCallStack" $ do+            it "only has one CallStack" $ do+                let+                    action = do+                        checkpointCallStack $ do+                            throwWithCallStack TestException+                action+                    `Safe.catch` \(e :: AnnotatedException TestException) -> do+                        annotations e+                            `callStackFunctionNamesShouldBe`+                                ["throwWithCallStack"+                                , "checkpointCallStack"+                                ]+     describe "try" $ do         let subject :: (Exception e, Exception e') => e -> IO e'             subject exn = do@@ -100,7 +166,7 @@         describe "when throwing non-Annotated" $ do             it "can add an empty annotation for a non-Annotated exception" $ do                 exn <- subject TestException-                exn `shouldBe` AnnotatedException [] TestException+                exn `shouldBeWithoutCallStackInAnnotations` AnnotatedException [] TestException              it "can catch a usual exception" $ do                 exn <- subject TestException@@ -108,12 +174,12 @@          describe "when throwing Annotated" $ do             it "can catch a non-Annotated exception" $ do-                exn <- subject $ new TestException+                exn <- subject $ emptyAnnotation TestException                 exn `shouldBe` TestException              it "can catch an Annotated exception" $ do                 exn <- subject TestException-                exn `shouldBe` new TestException+                exn `shouldBeWithoutCallStackInAnnotations` emptyAnnotation TestException          describe "when the wrong error is tried " $ do             let@@ -136,22 +202,22 @@         describe "nesting behavior" $ do             it "can catch at any level of nesting" $ do                 subject TestException-                    >>= (`shouldBe` new TestException)+                    >>= (`shouldBeWithoutCallStackInAnnotations` emptyAnnotation TestException)                 subject TestException-                    >>= (`shouldBe` new (new TestException))+                    >>= (`shouldBeWithoutCallStackInAnnotations` emptyAnnotation (emptyAnnotation TestException))                 subject TestException-                    >>= (`shouldBe` new (new (new TestException)))+                    >>= (`shouldBeWithoutCallStackInAnnotations` emptyAnnotation (emptyAnnotation (emptyAnnotation TestException)))      describe "Safe.try" $ do         it "can catch a located exception" $ do             Left exn <- Safe.try (Safe.throw TestException)-            exn `shouldBe` new TestException+            exn `shouldBe` emptyAnnotation TestException          it "does not catch an AnnotatedException" $ do             let action = do-                    Left exn <- Safe.try (Safe.throw $ new TestException)+                    Left exn <- Safe.try (Safe.throw $ emptyAnnotation TestException)                     exn `shouldBe` TestException-            action `shouldThrow` (== new TestException)+            action `shouldThrow` (== emptyAnnotation TestException)      describe "catches" $ do         it "is exported" $ do@@ -164,14 +230,16 @@     describe "checkpoint" $ do         it "adds annotations" $ do             Left exn <- try (checkpoint "Here" (throw TestException))-            exn `shouldBe` AnnotatedException ["Here"] TestException+            exn `shouldBeWithoutCallStackInAnnotations`+                AnnotatedException ["Here"] TestException          it "adds two annotations" $ do             Left exn <- try $ do                 checkpoint "Here" $ do                     checkpoint "There" $ do                         throw TestException-            exn `shouldBe` AnnotatedException ["Here", "There"] TestException+            exn `shouldBeWithoutCallStackInAnnotations`+                AnnotatedException ["Here", "There"] TestException          it "adds three annotations" $ do             Left exn <- try $@@ -179,7 +247,8 @@                 checkpoint "There" $                 checkpoint "Everywhere" $                 throw TestException-            exn `shouldBe` AnnotatedException ["Here", "There", "Everywhere"] TestException+            exn `shouldBeWithoutCallStackInAnnotations`+                AnnotatedException ["Here", "There", "Everywhere"] TestException          it "caught exceptions are propagated" $ do             eresp <- try $@@ -203,7 +272,8 @@             Left exn <- try $                 checkpoint "Lmao" $                 Safe.throw TestException-            exn `shouldBe` AnnotatedException ["Lmao"] TestException+            exn `shouldBeWithoutCallStackInAnnotations`+                AnnotatedException ["Lmao"] TestException          it "supports rethrowing" $ do             Left exn <- try $@@ -211,4 +281,117 @@                 flip catch (\TestException -> throw TestException) $                 checkpoint "B" $                 throw TestException-            exn `shouldBe` AnnotatedException ["A", "B"] TestException+            exn `shouldBeWithoutCallStackInAnnotations` AnnotatedException ["A", "B"] TestException++        it "handles CallStack nicely" $ do+            Left (AnnotatedException anns TestException) <- try $+                checkpoint (Annotation callStack) $+                    checkpoint (Annotation callStack) $+                        throwWithCallStack TestException++            anns `callStackFunctionNamesShouldBe`+                [ "throwWithCallStack"+                , "checkpoint"+                , "checkpoint"+                ]++    describe "HasCallStack behavior" $ do+        -- This section of the test suite exists to verify that some behavior+        -- acts how I expect it to. And/or learn how it behaves. Lol.+        let foo :: HasCallStack => IO ()+            foo = throwWithCallStack TestException+            bar :: HasCallStack => IO ()+            bar = foo+            baz :: HasCallStack => IO ()+            baz = bar++        it "should have source location" $ do+            foo+                `Safe.catch`+                    \(AnnotatedException anns TestException) -> do+                        anns+                            `callStackFunctionNamesShouldBe`+                                [ "throwWithCallStack"+                                , "foo"+                                ]++        it "appears to be throw-site first, then other entires" $ do+            baz+                `Safe.catch`+                    \(AnnotatedException anns TestException) -> do+                        anns+                            `callStackFunctionNamesShouldBe`+                                [ "throwWithCallStack"+                                , "foo"+                                , "bar"+                                , "baz"+                                ]++        describe "addCallstackToException" $ do+            let+                makeCs0 :: HasCallStack => IO CallStack+                makeCs0 = pure callStack+                makeCs1 :: HasCallStack => IO CallStack+                makeCs1 = pure callStack++            (cs0, cs1) <- runIO $ (,) <$> makeCs0 <*> makeCs1++            let baseException =+                    AnnotatedException [] TestException++            it "does not drop any other annotations" $ do+                addCallStackToException cs0 (AnnotatedException ["hello"] TestException)+                    `shouldBe`+                        AnnotatedException ["hello", Annotation cs0] TestException+            it "should add a CallStack to an empty AnnotatedException" $ do+                addCallStackToException cs0 baseException+                    `shouldBe`+                        AnnotatedException [Annotation cs0] TestException++            it "should not add a second CallStack to an AnnotatedException" $ do+                annotations (addCallStackToException cs1 (addCallStackToException cs0 baseException))+                    `shouldSatisfy` (1 ==) . length++            it "should merge CallStack as HasCallStack does" $ do+                [expectedAnnotation] <-+                    (undefined <$ foo) `Safe.catch`+                        \(AnnotatedException anns TestException) ->+                            pure anns+                Just expectedCallStack <- pure $ castAnnotation expectedAnnotation++                let+                    fooCS =+                        callStackFromFunctionName "foo"+                    throwWithCallStackCS =+                        callStackFromFunctionName "throwWithCallStack"+                    actualAnnotations =+                        annotations $+                            addCallStackToException fooCS  $+                                addCallStackToException+                                    throwWithCallStackCS+                                    baseException+                actualAnnotations+                    `callStackFunctionNamesShouldBe`+                        map fst (getCallStack expectedCallStack)++callStackFunctionNamesShouldBe :: HasCallStack => [Annotation] -> [String] -> IO ()+callStackFunctionNamesShouldBe anns names = do+    let ([callStack], []) = tryAnnotations anns+    map fst (getCallStack callStack)+        `shouldBe`+            names++shouldBeWithoutCallStackInAnnotations+    :: (HasCallStack, Eq e, Show e, Exception e)+    => AnnotatedException e+    -> AnnotatedException e+    -> IO ()+shouldBeWithoutCallStackInAnnotations (AnnotatedException exp e0) e1 = do+    AnnotatedException (filterCallStack exp) e0 `shouldBe` e1+  where+    filterCallStack anns =+        snd $ tryAnnotations @CallStack anns++callStackFromFunctionName :: String -> CallStack+callStackFromFunctionName str =+    fromCallSiteList [(str, undefined)]

@@ -1,23 +1,35 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}  module Data.AnnotationSpec where  import Data.Annotation+import Data.Typeable import Test.Hspec  spec :: Spec spec = do-    describe "Eq" $ do-        it "works for equal values" $ do-            toAnnotation "hello" == toAnnotation "hello"-        it "works for non-equal values of same type" $ do-            toAnnotation "a" /= toAnnotation "b"-        it "works for values of different types" $ do-            toAnnotation (1 :: Int) /= toAnnotation "a"     describe "Show" $ do-        it "works" $ do-            show (toAnnotation (3 :: Int))+        it "includes type information" $ do+            show (Annotation @Int 3)                 `shouldBe`-                    "3"+                    "Annotation @Int 3"+        it "uses parens" $ do+            show (Annotation @(Maybe Int) (Just 3))+                `shouldBe`+                    "Annotation @(Maybe Int) (Just 3)"+        it "is cool with strings" $ do+            show (Annotation @String "Hello")+                `shouldBe`+                    "Annotation @[Char] \"Hello\""++instance Eq Annotation where+    Annotation (a :: a) == Annotation (b :: b) =+        case eqT @a @b of+            Just Refl ->+                show a == show b+            Nothing ->+                False