diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,11 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.1.2...main) +## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.2.0...main) + +## [v1.20.2.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.1.2...freckle-app-v1.20.2.0) + +- Add `Freckle.App.Test.Hspec.AnnotatedException.annotateHUnitFailure` +- Improve quality of exceptions rethrown by `unwrapAnnotatedHUnitFailure`. + Previously any `Annotation`s were discarded. Now they are incorporated into + the `HUnitFailure`, including pretty-printing of a call stack if present. ## [v1.20.1.1](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.1.1...freckle-app-v1.20.1.2) diff --git a/freckle-app.cabal b/freckle-app.cabal --- a/freckle-app.cabal +++ b/freckle-app.cabal @@ -1,6 +1,6 @@ cabal-version: 1.22 name: freckle-app -version: 1.20.1.2 +version: 1.20.2.0 license: MIT license-file: LICENSE maintainer: Freckle Education @@ -97,6 +97,7 @@ MonadRandom >=0.5.3, QuickCheck >=2.14.3, aeson >=2.0.3.0, + annotated-exception >=0.2.0.4, autodocodec >=0.2.0.3, autodocodec-openapi3 >=0.2.1.1, base >=4.16.4.0 && <5, @@ -201,6 +202,7 @@ Freckle.App.Bugsnag.MetaDataSpec Freckle.App.BugsnagSpec Freckle.App.CsvSpec + Freckle.App.Test.Hspec.AnnotatedExceptionSpec Freckle.App.Test.Http.MatchRequestSpec Freckle.App.Test.Properties.JSONSpec Freckle.App.Test.Properties.PathPieceSpec @@ -225,8 +227,10 @@ build-depends: Blammo >=2.1.0.0, + HUnit >=1.6.2.0, QuickCheck >=2.14.3, aeson >=2.0.3.0, + annotated-exception >=0.2.0.4, async >=2.2.4, base >=4.16.4.0 && <5, bugsnag >=1.1.0.0, diff --git a/library/Freckle/App/Test/Hspec/AnnotatedException.hs b/library/Freckle/App/Test/Hspec/AnnotatedException.hs --- a/library/Freckle/App/Test/Hspec/AnnotatedException.hs +++ b/library/Freckle/App/Test/Hspec/AnnotatedException.hs @@ -1,12 +1,18 @@ module Freckle.App.Test.Hspec.AnnotatedException ( unwrapAnnotatedHUnitFailure + , annotateHUnitFailure ) where import Freckle.App.Prelude import Control.Exception qualified +import Control.Lens (Lens', lens, over) +import Data.Annotation (Annotation, tryAnnotations) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.Text qualified as T import Freckle.App.Exception (AnnotatedException (..)) -import Test.HUnit.Lang (HUnitFailure) +import GHC.Stack (CallStack, prettyCallStack) +import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..)) import Test.Hspec -- | An hspec hook that lets hspec catch and pretty-print 'HUnitFailure', the @@ -17,6 +23,85 @@ -- you end up with an @'AnnotatedException' 'HUnitFailure'@, hspec doesn't recognize -- it as an assertion failure and you get ugly output instead of nice output. unwrapAnnotatedHUnitFailure :: Spec -> Spec -unwrapAnnotatedHUnitFailure = around_ $ - Control.Exception.handle $ \AnnotatedException {exception = e} -> - Control.Exception.throw (e :: HUnitFailure) +unwrapAnnotatedHUnitFailure = around_ $ mapException annotateHUnitFailure + +mapException :: (Exception e, Exception e') => (e -> e') -> IO a -> IO a +mapException f = Control.Exception.handle $ Control.Exception.throw . f + +annotateHUnitFailure :: AnnotatedException HUnitFailure -> HUnitFailure +annotateHUnitFailure + AnnotatedException {exception, annotations} = + over hUnitFailureReason (annotateFailureReason annotations) exception + +hUnitFailureReason :: Lens' HUnitFailure FailureReason +hUnitFailureReason = + lens + (\(HUnitFailure _ x) -> x) + (\(HUnitFailure l _) x -> HUnitFailure l x) + +-- | Augment a 'FailureReason' with extra information derived from 'Annotation's +annotateFailureReason :: [Annotation] -> FailureReason -> FailureReason +annotateFailureReason as = + \case + Reason m -> Reason (makeMessage m as) + ExpectedButGot m e g -> ExpectedButGot (makeMessageMaybe m as) e g + +-- | Construct a message that consists of an introductory paragraph plus +-- some additional paragraphs based on annotations, separated by blank lines +makeMessage :: String -> [Annotation] -> String +makeMessage m as = + combineParagraphs $ stringParagraph m :| annotationParagraphs as + +-- | Like 'makeMessage' but without necessarily having an introductory paragraph present +-- +-- If there is neither an introductory paragraph nor any annotations, the result is 'Nothing'. +makeMessageMaybe :: Maybe String -> [Annotation] -> Maybe String +makeMessageMaybe mm as = + fmap combineParagraphs $ + nonEmpty $ + fmap stringParagraph (toList mm) <> annotationParagraphs as + +-- | Text that constitutes a paragraph in a potentially lengthy error message +-- +-- Construct with 'stringParagraph' or 'textParagraph', which strip the text of +-- surrounding whitespace. +newtype Paragraph = Paragraph {paragraphText :: Text} + +stringParagraph :: String -> Paragraph +stringParagraph = textParagraph . T.pack + +textParagraph :: Text -> Paragraph +textParagraph = Paragraph . T.strip + +-- | Combine a list of paragraphs into a single string for the final output +combineParagraphs :: Foldable t => t Paragraph -> String +combineParagraphs = + T.unpack . T.intercalate "\n\n" . fmap paragraphText . toList + +-- | Render a list of annotations as a list of paragraphs +-- +-- The paragraphs, depending on how much information there is to display, are: +-- +-- * a summary of any annotations that aren't call stacks, if any +-- * the first call stack, if there are any call stacks +annotationParagraphs :: [Annotation] -> [Paragraph] +annotationParagraphs annotations = + catMaybes + [ otherAnnotationsPart <$> nonEmpty otherAnnotations + , callStackPart <$> listToMaybe callStacks + ] + where + (callStacks, otherAnnotations) = tryAnnotations @CallStack annotations + +-- | Construct a paragraph consisting of a bullet list of annotations +otherAnnotationsPart :: Foldable t => t Annotation -> Paragraph +otherAnnotationsPart = + textParagraph + . T.intercalate "\n" + . ("Annotations:" :) + . fmap (("\t * " <>) . T.pack . show) + . toList + +-- | Construct a paragraph that displays a call stack +callStackPart :: CallStack -> Paragraph +callStackPart = textParagraph . T.pack . prettyCallStack diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: freckle-app -version: 1.20.1.2 +version: 1.20.2.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app @@ -80,6 +80,7 @@ - HUnit - MonadRandom - QuickCheck + - annotated-exception - autodocodec - autodocodec-openapi3 - aeson @@ -150,7 +151,9 @@ source-dirs: tests ghc-options: -threaded -rtsopts "-with-rtsopts=-N" dependencies: + - annotated-exception - Blammo + - HUnit - QuickCheck - aeson - async diff --git a/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs b/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs @@ -0,0 +1,153 @@ +module Freckle.App.Test.Hspec.AnnotatedExceptionSpec + ( spec + ) where + +import Freckle.App.Prelude + +import Data.Annotation (toAnnotation) +import Data.List (intercalate) +import Freckle.App.Exception (AnnotatedException (..)) +import Freckle.App.Test.Hspec.AnnotatedException (annotateHUnitFailure) +import GHC.Exts (fromList) +import GHC.Stack (CallStack, SrcLoc (..)) +import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..)) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = do + describe "annotateHUnitFailure" $ do + describe "does nothing if there are no annotations" $ do + it "when the failure is Reason" $ + let e = HUnitFailure Nothing (Reason "x") + in annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e + + it "when the failure is ExpectedButGot with no message" $ + let e = HUnitFailure Nothing (ExpectedButGot Nothing "a" "b") + in annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e + + it "when the failure is ExpectedButGot with a message" $ + let e = HUnitFailure Nothing (ExpectedButGot (Just "x") "a" "b") + in annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e + + describe "can show an annotation" $ do + it "when the failure is Reason" $ + annotateHUnitFailure + AnnotatedException + { annotations = [toAnnotation @Int 56] + , exception = HUnitFailure Nothing (Reason "x") + } + `shouldBe` HUnitFailure + Nothing + ( Reason . intercalate "\n" $ + [ "x" + , "" + , "Annotations:" + , "\t * Annotation @Int 56" + ] + ) + + it "when the failure is ExpectedButGot with no message" $ do + annotateHUnitFailure + AnnotatedException + { annotations = [toAnnotation @Int 56] + , exception = HUnitFailure Nothing (ExpectedButGot Nothing "a" "b") + } + `shouldBe` HUnitFailure + Nothing + ( ExpectedButGot + ( Just . intercalate "\n" $ + [ "Annotations:" + , "\t * Annotation @Int 56" + ] + ) + "a" + "b" + ) + + it "when the failure is ExpectedButGot with a message" $ + annotateHUnitFailure + AnnotatedException + { annotations = [toAnnotation @Int 56] + , exception = HUnitFailure Nothing (ExpectedButGot (Just "x") "a" "b") + } + `shouldBe` HUnitFailure + Nothing + ( ExpectedButGot + ( Just . intercalate "\n" $ + [ "x" + , "" + , "Annotations:" + , "\t * Annotation @Int 56" + ] + ) + "a" + "b" + ) + + it "can show a stack trace" $ + annotateHUnitFailure + AnnotatedException + { annotations = + [ toAnnotation @CallStack $ + fromList + [ + ( "abc" + , SrcLoc + { srcLocPackage = "thepackage" + , srcLocModule = "Foo" + , srcLocFile = "src/Foo.hs" + , srcLocStartLine = 7 + , srcLocStartCol = 50 + , srcLocEndLine = 8 + , srcLocEndCol = 23 + } + ) + ] + ] + , exception = HUnitFailure Nothing (Reason "x") + } + `shouldBe` HUnitFailure + Nothing + ( Reason . intercalate "\n" $ + [ "x" + , "" + , "CallStack (from HasCallStack):" + , " abc, called at src/Foo.hs:7:50 in thepackage:Foo" + ] + ) + + it "can show both an annotation and a stack trace" $ + annotateHUnitFailure + AnnotatedException + { annotations = + [ toAnnotation @Text "Visibility is poor" + , toAnnotation @CallStack $ + fromList + [ + ( "abc" + , SrcLoc + { srcLocPackage = "thepackage" + , srcLocModule = "Foo" + , srcLocFile = "src/Foo.hs" + , srcLocStartLine = 7 + , srcLocStartCol = 50 + , srcLocEndLine = 8 + , srcLocEndCol = 23 + } + ) + ] + ] + , exception = HUnitFailure Nothing (Reason "x") + } + `shouldBe` HUnitFailure + Nothing + ( Reason . intercalate "\n" $ + [ "x" + , "" + , "Annotations:" + , "\t * Annotation @Text \"Visibility is poor\"" + , "" + , "CallStack (from HasCallStack):" + , " abc, called at src/Foo.hs:7:50 in thepackage:Foo" + ] + )