diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for located-exception + +## Unreleased changes + +## 0.1.0.0 + +- Initial Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/annotated-exception.cabal b/annotated-exception.cabal new file mode 100644 --- /dev/null +++ b/annotated-exception.cabal @@ -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 +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 diff --git a/src/Control/Exception/Annotated.hs b/src/Control/Exception/Annotated.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception/Annotated.hs @@ -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 diff --git a/src/Data/Annotation.hs b/src/Data/Annotation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Annotation.hs @@ -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) diff --git a/test/Control/Exception/AnnotatedSpec.hs b/test/Control/Exception/AnnotatedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Exception/AnnotatedSpec.hs @@ -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 diff --git a/test/Data/AnnotationSpec.hs b/test/Data/AnnotationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/AnnotationSpec.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +