diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/annotated-exception.cabal b/annotated-exception.cabal --- a/annotated-exception.cabal +++ b/annotated-exception.cabal @@ -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 category: Control diff --git a/src/Control/Exception/Annotated.hs b/src/Control/Exception/Annotated.hs --- a/src/Control/Exception/Annotated.hs +++ b/src/Control/Exception/Annotated.hs @@ -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 diff --git a/src/Control/Exception/Annotated/UnliftIO.hs b/src/Control/Exception/Annotated/UnliftIO.hs --- a/src/Control/Exception/Annotated/UnliftIO.hs +++ b/src/Control/Exception/Annotated/UnliftIO.hs @@ -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 diff --git a/src/Data/Annotation.hs b/src/Data/Annotation.hs --- a/src/Data/Annotation.hs +++ b/src/Data/Annotation.hs @@ -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." #-} diff --git a/test/Control/Exception/AnnotatedSpec.hs b/test/Control/Exception/AnnotatedSpec.hs --- a/test/Control/Exception/AnnotatedSpec.hs +++ b/test/Control/Exception/AnnotatedSpec.hs @@ -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)] diff --git a/test/Data/AnnotationSpec.hs b/test/Data/AnnotationSpec.hs --- a/test/Data/AnnotationSpec.hs +++ b/test/Data/AnnotationSpec.hs @@ -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