Skip to content

Commit

Permalink
improve exceptions rethrown by unwrapAnnotatedHUnitFailure (#202)
Browse files Browse the repository at this point in the history
closes #201
  • Loading branch information
chris-martin authored Sep 20, 2024
1 parent 5b40191 commit 3b99f3a
Show file tree
Hide file tree
Showing 5 changed files with 259 additions and 7 deletions.
9 changes: 8 additions & 1 deletion freckle-app/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -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)

Expand Down
6 changes: 5 additions & 1 deletion freckle-app/freckle-app.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ cabal-version: 1.22
-- see: https://github.com/sol/hpack

name: freckle-app
version: 1.20.1.2
version: 1.20.2.0
synopsis: Haskell application toolkit used at Freckle
description: Please see README.md
category: Utils
Expand Down Expand Up @@ -102,6 +102,7 @@ library
, MonadRandom
, QuickCheck
, aeson
, annotated-exception
, autodocodec
, autodocodec-openapi3
, base <5
Expand Down Expand Up @@ -204,6 +205,7 @@ test-suite spec
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
Expand All @@ -228,8 +230,10 @@ test-suite spec
ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N"
build-depends:
Blammo
, HUnit
, QuickCheck
, aeson
, annotated-exception
, async
, base <5
, bugsnag
Expand Down
93 changes: 89 additions & 4 deletions freckle-app/library/Freckle/App/Test/Hspec/AnnotatedException.hs
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -17,6 +23,85 @@ import Test.Hspec
-- 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
5 changes: 4 additions & 1 deletion freckle-app/package.yaml
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -80,6 +80,7 @@ library:
- HUnit
- MonadRandom
- QuickCheck
- annotated-exception
- autodocodec
- autodocodec-openapi3
- aeson
Expand Down Expand Up @@ -150,7 +151,9 @@ tests:
source-dirs: tests
ghc-options: -threaded -rtsopts "-with-rtsopts=-N"
dependencies:
- annotated-exception
- Blammo
- HUnit
- QuickCheck
- aeson
- async
Expand Down
153 changes: 153 additions & 0 deletions freckle-app/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs
Original file line number Diff line number Diff line change
@@ -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"
]
)

0 comments on commit 3b99f3a

Please sign in to comment.