packages feed

annotated-exception (empty) → 0.1.0.0

raw patch · 10 files changed

+827/−0 lines, 10 filesdep +annotated-exceptiondep +basedep +containerssetup-changed

Dependencies added: annotated-exception, base, containers, hspec, safe-exceptions, text

Files

+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Changelog for located-exception++## Unreleased changes++## 0.1.0.0++- Initial Release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,68 @@+# `annotated-exception`++This library provides a special `AnnotatedException` type which allows you to decorate Haskell exceptions with additional information.+This decoration is totally transparent, and even works with exceptions thrown outside of your application code.++To provide an annotation, you'd use the function `checkpoint`.+This will attach the provided value to any exception that bubbles up through it.++```haskell+import Control.Exception.Annotated++data MyException = MyException+    deriving (Show, Exception)++main :: IO ()+main = do+    checkpoint "Foo" $ do+        throw MyException+```++When this program crashes, it will crash with an `AnnotatedException` that contains the annotation `"Foo"`.++```+λ> checkpoint "Foo" $ throw MyException+*** Exception: AnnotatedException {annotations = ["Foo"], exception = MyException}+```++These annotations survive, even if you catch and rethrow with a different exception.++```haskell+data OtherException = OtherException+    deriving (Show, Exception)++woah :: IO ()+woah = do+    let+        checkpointed =+            checkpoint "Foo" (throw MyException)+        handler MyException =+            throw OtherException++    checkpointed+        `catch`+            handler++```++Notice how the `checkpoint` call doesn't cover the `throw OtherException` - the exception `[Annotation]` lives on the thrown exception itself, and this library's `catch` function ensures that we don't lose that context.++```+λ> (checkpoint "Foo" (throw MyException)) `catch` \MyException -> throw OtherException+*** Exception: AnnotatedException {annotations = ["Foo"], exception = OtherException}+```++You can also attach a `CallStack` to any exception using `throwWithCallStack`.++Now, you're about to report your exceptions, up near `main`.+We can use `try` in this module to always get the annotations.++```haskell+main = do+    eresult <- try $ myProgram+    case eresult of+        Left (AnnotatedException annotations exception) ->+            reportException annotations exception+        Right a ->+            pure a+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ annotated-exception.cabal view
@@ -0,0 +1,63 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           annotated-exception+version:        0.1.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+homepage:       https://github.com/parsonsmatt/annotated-exception#readme+bug-reports:    https://github.com/parsonsmatt/annotated-exception/issues+author:         Matt Parsons+maintainer:     parsonsmatt@gmail.com+copyright:      2018 Matt Parsons+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/parsonsmatt/annotated-exception++library+  exposed-modules:+      Control.Exception.Annotated+      Data.Annotation+  other-modules:+      Paths_annotated_exception+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , containers+    , safe-exceptions+    , text+  default-language: Haskell2010++test-suite annotated-exception-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Control.Exception.AnnotatedSpec+      Data.AnnotationSpec+      Paths_annotated_exception+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      annotated-exception+    , base >=4.7 && <5+    , containers+    , hspec+    , safe-exceptions+    , text+  default-language: Haskell2010
+ src/Control/Exception/Annotated.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++-- | This module defines an exception wrapper 'AnnotatedException' that+-- carries a list of 'Annotation's, along with some helper methods for+-- throwing and catching that can make the annotations transparent.+--+-- While this library can be used directly, it is recommended that you+-- define your own types and functions specific to your domain. As an+-- example, 'checkpoint' is useful *only* for providing exception+-- annotation information. However, you probably want to use 'checkpoint'+-- in concert with other context adding features, like logging.+--+-- Likewise, the 'Annotation' type defined in "Data.Annotation" is+-- essentially a wrapper for a dynamically typed value. So you probably+-- want to define your own 'checkpoint' that uses a custom type that you+-- want to enforce throughout your application.+module Control.Exception.Annotated+    ( -- * The Main Type+      AnnotatedException(..)+    , new+    , throwWithCallStack+    -- * Annotating Exceptions+    , checkpoint+    , checkpointMany+    , checkpointCallStack+    , checkpointCallStackWith+    -- * Handling Exceptions+    , catch+    , tryAnnotated++    -- * Manipulating Annotated Exceptions+    , check+    , hide+    , annotatedExceptionCallStack+    , addCallStackToException++    -- * Re-exports from "Data.Annotation"+    , Annotation(..)+    , CallStackAnnotation(..)+    -- * Re-exports from "Control.Exception.Safe"+    , Exception(..)+    , Safe.SomeException(..)+    , Safe.throw+    , Safe.try+    ) where++import Control.Exception.Safe+       (Exception, MonadCatch, MonadThrow, SomeException(..))+import qualified Control.Exception.Safe as Safe+import Data.Annotation+import Data.Maybe+import Data.Typeable+import GHC.Stack++-- | The 'AnnotatedException' type wraps an @exception@ with+-- a @['Annotation']@. This can provide a sort of a manual stack trace with+-- programmer provided data.+--+-- @since 0.1.0.0+data AnnotatedException exception+    = AnnotatedException+    { annotations :: [Annotation]+    , exception   :: exception+    }+    deriving (Eq, Show, Functor, Foldable, Traversable)++instance Applicative AnnotatedException where+    pure =+        AnnotatedException []++    AnnotatedException anns0 f <*> AnnotatedException anns1 a =+        AnnotatedException (anns0 <> anns1) (f a)++-- | This instance of 'Exception' is a bit interesting. It tries to do as+-- much hiding and packing and flattening as possible to ensure that even+-- exception handling machinery outside of this package can still+-- intelligently handle it.+--+-- Any 'Exception' can be caught as a 'AnnotatedException' with+-- an empty context, so catching a @'AnnotatedException' e@ will also catch+-- a regular @e@ and give it an empty set of annotations.+--+-- Likewise, if a @'AnnotatedException' ('AnnotatedException' e)@ is thrown+-- somehow, then the 'fromException' will flatten it and combine their+-- contexts.+--+-- For the most up to date details, see the test suite.+--+-- @since 0.1.0.0+instance (Exception exception) => Exception (AnnotatedException exception) where+    toException loc = SomeException $ hide loc+    fromException (SomeException exn)+        | Just x <- cast exn+        =+            pure x+        | Just (AnnotatedException ann (e :: SomeException)) <- cast exn+        , Just a <- Safe.fromException e+        =+            pure $ AnnotatedException ann a+    fromException exn+        | Just (e :: exception) <- Safe.fromException exn+        =+            pure $ new e+        | Just x <- flatten <$> Safe.fromException exn+        =+            pure x+        | otherwise+        =+            Nothing++-- | Attach an empty @['Annotation']@ to an exception.+--+-- @since 0.1.0.0+new :: e -> AnnotatedException e+new = pure++-- | Append the @['Annotation']@ to the 'AnnotatedException'.+--+-- @since 0.1.0.0+annotate :: [Annotation] -> AnnotatedException e -> AnnotatedException e+annotate ann (AnnotatedException anns e) = AnnotatedException (ann ++ anns) e++-- | Call '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+-- annotations to the result.+--+-- @since 0.1.0.0+check :: Exception e => AnnotatedException SomeException -> Maybe (AnnotatedException e)+check = traverse Safe.fromException++-- | Catch an exception. This works just like 'Safe.catch', but it also+-- will attempt to catch @'AnnotatedException' e@. The annotations will be+-- preserved in the handler, so rethrowing exceptions will retain the+-- context.+--+-- Let's consider a few examples, that share this import and exception+-- type.+--+-- > import qualified Control.Exception.Safe as Safe+-- > import Control.Exception.Annotated+-- >+-- > data TestException deriving (Show, Exception)+--+-- We can throw an exception and catch it as usual.+--+-- > throw TestException `catch` \TestException ->+-- >     putStrLn "ok!"+--+-- We can throw an exception and catch it with location.+--+-- > throw TestException `catch` \(AnnotatedException anns TestException) ->+-- >     putStrLn "ok!"+--+--+-- We can throw an exception and catch it as a @'AnnotatedException'+-- 'SomeException'@.+--+-- > throw TestException `catch` \(AnnotatedException anns (e :: SomeException) ->+-- >     putStrLn "ok!"+--+-- @since 0.1.0.0+catch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a+catch action handler =+    Safe.catches+        action+        [ Safe.Handler handler+        , Safe.Handler $ \(AnnotatedException anns e) ->+            checkpointMany anns $ handler e+        ]++-- | Like 'catch', but always returns a 'AnnotatedException'.+--+-- @since 0.1.0.0+tryAnnotated :: (Exception e, MonadCatch m) => m a -> m (Either (AnnotatedException e) a)+tryAnnotated action =+    (Right <$> action) `catch` (pure . Left)++-- | Attaches the 'CallStack' to the 'AnnotatedException' that is thrown.+--+-- The 'CallStack' will *not* be present as a 'CallStack' - it will be+-- a 'CallStackAnnotation'.+--+-- @since 0.1.0.0+throwWithCallStack+    :: (HasCallStack, MonadThrow m, Exception e)+    => e -> m a+throwWithCallStack e =+    Safe.throw (AnnotatedException [callStackAnnotation] e)++-- | Concatenate two lists of annotations.+--+-- @since 0.1.0.0+flatten :: AnnotatedException (AnnotatedException e)  -> AnnotatedException e+flatten (AnnotatedException a (AnnotatedException b c)) = AnnotatedException (a ++ b) c++-- | Add a single 'Annotation' to any exceptions thrown in the following+-- action.+--+-- Example:+--+-- > main = do+-- >     checkpoint "Foo" $ do+-- >         print =<< readFile "I don't exist.markdown"+--+-- The exception thrown due to a missing file will now have an 'Annotation'+-- @"Foo"@.+--+-- @since 0.1.0.0+checkpoint :: MonadCatch m => Annotation -> m a -> m a+checkpoint ann = 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.+--+-- Primarily useful when you're wrapping a third party library.+--+-- @since 0.1.0.0+checkpointCallStackWith+    :: (MonadCatch m, HasCallStack)+    => [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++-- | 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.+--+-- @since 0.1.0.0+checkpointCallStack+    :: (MonadCatch m, HasCallStack)+    => m a+    -> m a+checkpointCallStack =+    checkpointCallStackWith []++-- | Add the list of 'Annotations' to any exception thrown in the following+-- action.+--+-- @since 0.1.0.0+checkpointMany :: (MonadCatch m) => [Annotation] -> m a -> m a+checkpointMany ann action =+    action `Safe.catch` \(exn :: SomeException) ->+        Safe.throw . annotate ann $ case Safe.fromException exn of+            Just (e' :: AnnotatedException SomeException) ->+                e'+            Nothing -> do+                new exn++-- | Retrieves the 'CallStack' from an 'AnnotatedException' if one is present.+--+-- @since 0.1.0.0+annotatedExceptionCallStack :: AnnotatedException exception -> Maybe CallStack+annotatedExceptionCallStack exn =+    let (stacks, _rest) = callStackInAnnotations (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.+--+-- @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
+ src/Data/Annotation.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++-- | An 'Annotation' is attached to a 'LocatedException'. 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.+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+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String+import qualified Data.Text as Text+import Data.Typeable++-- | The constraints that the value inside an 'Annotation' must have.+--+-- We want 'Typeable' so we can do 'cast' and potentially get more useful+-- information out of it.+--+-- @since 0.1.0.0+type AnnC a = (Typeable a, Eq 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.+--+-- @since 0.1.0.0+data Annotation where+    Annotation+        :: AnnC a+        => a+        -> Annotation++-- |+--+-- @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++-- |+--+-- @since 0.1.0.0+instance IsString Annotation where+    fromString = Annotation . Text.pack++-- | Wrap a value in an 'Annotation'.+--+-- @since 0.1.0.0+toAnnotation :: (AnnC a) => a -> Annotation+toAnnotation = Annotation++-- | Attempt to 'cast' the underlying value out of an 'Annotation'.+--+-- @since 0.1.0.0+castAnnotation+    :: forall a. (Typeable a)+    => Annotation+    -> Maybe a+castAnnotation (Annotation ann) =+    cast ann++-- | Attempt to 'cast' the underlying value out of an 'Annotation'.+-- Returns the original 'Annotation' if the cast isn't right.+--+-- @since 0.1.0.0+tryAnnotation+    :: forall a. (Typeable a)+    => Annotation+    -> Either a Annotation+tryAnnotation a@(Annotation val) =+    case cast val of+        Just x ->+            Left x+        Nothing ->+            Right a++-- | Attempt to 'cast' list of 'Annotation' into the given type. Any+-- 'Annotation' that is not in that form is left untouched.+--+-- @since 0.1.0.0+tryAnnotations+    :: forall a. (Typeable a)+    => [Annotation]+    -> ([a], [Annotation])+tryAnnotations = partitionEithers . map tryAnnotation++-- | Returns the 'Set' of types that are in the given annotations.+--+-- @since 0.1.0.0+annotationTypes+    :: [Annotation]+    -> Set TypeRep+annotationTypes = Set.fromList . map (\(Annotation a) -> typeOf a)++-- | Map a function over the given 'Annotation'. If the types don't match+-- up, then the whole thing returns 'Nothing'.+--+-- @since 0.1.0.0+mapAnnotation+    :: ((AnnC a, AnnC b))+    => (a -> b)+    -> Annotation+    -> Maybe Annotation+mapAnnotation f (Annotation ann) =+    Annotation . f <$> cast ann++-- | Map a function over the 'Annotation', leaving it unchanged if the+-- types don't match.+--+-- @since 0.1.0.0+mapMaybeAnnotation+    :: (AnnC a, AnnC b)+    => (a -> b)+    -> Annotation+    -> Annotation+mapMaybeAnnotation f ann =+    fromMaybe ann (mapAnnotation f ann)++-- | A wrapper type for putting a 'CallStack' into an 'Annotation'. We need+-- this because 'CallStack' does not have an 'Eq' instance.+--+-- @since 0.1.0.0+newtype CallStackAnnotation = CallStackAnnotation+    { unCallStackAnnotation :: [(String, SrcLoc)]+    }+    deriving (Eq, Show)++-- | Grab an 'Annotation' corresponding to the 'CallStack' that is+-- currently in scope.+--+-- @since 0.1.0.0+callStackAnnotation :: HasCallStack => Annotation+callStackAnnotation = callStackToAnnotation 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++-- | Attempt to convert an 'Annotation' back into a 'CallStack'.+--+-- @since 0.1.0.0+callStackFromAnnotation :: CallStackAnnotation -> CallStack+callStackFromAnnotation ann =+    fromCallSiteList $ unCallStackAnnotation ann++-- | 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)
+ test/Control/Exception/AnnotatedSpec.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# options_ghc -fno-warn-orphans -fno-warn-type-defaults #-}++module Control.Exception.AnnotatedSpec where++import Test.Hspec++import Control.Exception.Annotated+import qualified Control.Exception.Safe as Safe++data TextException = TestException+    deriving (Eq, Show, Exception)++instance Eq SomeException where+    e0 == e1 = show e0 == show e1++pass :: Expectation+pass = pure ()++spec :: Spec+spec = do+    describe "AnnotatedException can fromException a" $ do+        it "different type" $ do+            fromException (toException TestException)+                `shouldBe`+                    Just (new TestException)++        it "SomeException" $ do+            fromException (SomeException TestException)+                `shouldBe`+                    Just (new (SomeException TestException))++        it "nested AnnotatedException" $ do+            fromException (toException (new (new TestException)))+                `shouldBe`+                    Just (new TestException)++    describe "throw" $ do+        it "wraps exceptions" $ do+            throw TestException+                `shouldThrow`+                    \(AnnotatedException _ TestException) ->+                        True++    describe "catch" $ do+        it "catches located exceptions" $ do+            Safe.throw TestException+                `catch`+                    \(AnnotatedException [] TestException) ->+                        pass++        it "catches regular exceptions" $ do+            Safe.throw TestException+                `catch`+                    \TestException ->+                        pass++        it "catches SomeException" $ do+            throw TestException+                `catch`+                    \(SomeException _) ->+                        pass++        it "catches located SomeExceptions" $ do+            throw TestException+                `catch`+                    \(AnnotatedException _ (_ :: SomeException)) ->+                        pass++    describe "try" $ do+        it "always adds a location" $ do+            Left exn <- try (throw TestException)+            exn `shouldBe` AnnotatedException [] TestException++        it "does not nest locations" $ do+            Left exn <- try $ throw $ new $ new $ new TestException+            exn `shouldBe` new TestException++    describe "Safe.try" $ do+        it "can catch a located exception" $ do+            Left exn <- Safe.try (Safe.throw TestException)+            exn `shouldBe` new TestException++        it "does not catch a AnnotatedException" $ do+            let action = do+                    Left exn <- Safe.try (Safe.throw $ new TestException)+                    exn `shouldBe` TestException+            action `shouldThrow` (== new TestException)++    describe "checkpoint" $ do+        it "adds annotations" $ do+            Left exn <- try (checkpoint "Here" (throw TestException))+            exn `shouldBe` 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++        it "adds three annotations" $ do+            Left exn <- try $+                checkpoint "Here" $+                checkpoint "There" $+                checkpoint "Everywhere" $+                throw TestException+            exn `shouldBe` AnnotatedException ["Here", "There", "Everywhere"] TestException++        it "caught exceptions are propagated" $ do+            eresp <- try $+                checkpoint "Here" $+                flip catch (\TestException -> pure "Hello") $+                checkpoint "There" $+                checkpoint "Everywhere" $+                throw TestException+            case eresp of+                Left (AnnotatedException _ TestException) ->+                    expectationFailure "Should not be an exception"+                Right resp ->+                    resp `shouldBe` "Hello"++        it "works with error calls" $ do+            eresp <- checkpoint "Yes" (error "Oh no") `catch`+                \(SomeException _) -> pure "bar"+            eresp `shouldBe` "bar"++        it "works with non-handled exceptions" $ do+            Left exn <- try $+                checkpoint "Lmao" $+                Safe.throw TestException+            exn `shouldBe` AnnotatedException ["Lmao"] TestException++        it "supports rethrowing" $ do+            Left exn <- try $+                checkpoint "A" $+                flip catch (\TestException -> throw TestException) $+                checkpoint "B" $+                throw TestException+            exn `shouldBe` AnnotatedException ["A", "B"] TestException
+ test/Data/AnnotationSpec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}++module Data.AnnotationSpec where++import Data.Annotation+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))+                `shouldBe`+                    "3"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+