Skip to content

Commit 3b99f3a

Browse files
chris-martinchris-martin
authored
improve exceptions rethrown by unwrapAnnotatedHUnitFailure (#202)
closes #201
1 parent 5b40191 commit 3b99f3a

File tree

5 files changed

+259
-7
lines changed

5 files changed

+259
-7
lines changed

‎freckle-app/CHANGELOG.md

+8-1
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,11 @@
1-
## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.1.2...main)
1+
## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.2.0...main)
2+
3+
## [v1.20.2.0](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.1.2...freckle-app-v1.20.2.0)
4+
5+
- Add `Freckle.App.Test.Hspec.AnnotatedException.annotateHUnitFailure`
6+
- Improve quality of exceptions rethrown by `unwrapAnnotatedHUnitFailure`.
7+
Previously any `Annotation`s were discarded. Now they are incorporated into
8+
the `HUnitFailure`, including pretty-printing of a call stack if present.
29

310
## [v1.20.1.1](https://github.com/freckle/freckle-app/compare/freckle-app-v1.20.1.1...freckle-app-v1.20.1.2)
411

‎freckle-app/freckle-app.cabal

+5-1
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@ cabal-version: 1.22
55
-- see: https://github.com/sol/hpack
66

77
name: freckle-app
8-
version: 1.20.1.2
8+
version: 1.20.2.0
99
synopsis: Haskell application toolkit used at Freckle
1010
description: Please see README.md
1111
category: Utils
@@ -102,6 +102,7 @@ library
102102
, MonadRandom
103103
, QuickCheck
104104
, aeson
105+
, annotated-exception
105106
, autodocodec
106107
, autodocodec-openapi3
107108
, base <5
@@ -204,6 +205,7 @@ test-suite spec
204205
Freckle.App.Bugsnag.MetaDataSpec
205206
Freckle.App.BugsnagSpec
206207
Freckle.App.CsvSpec
208+
Freckle.App.Test.Hspec.AnnotatedExceptionSpec
207209
Freckle.App.Test.Http.MatchRequestSpec
208210
Freckle.App.Test.Properties.JSONSpec
209211
Freckle.App.Test.Properties.PathPieceSpec
@@ -228,8 +230,10 @@ test-suite spec
228230
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"
229231
build-depends:
230232
Blammo
233+
, HUnit
231234
, QuickCheck
232235
, aeson
236+
, annotated-exception
233237
, async
234238
, base <5
235239
, bugsnag

‎freckle-app/library/Freckle/App/Test/Hspec/AnnotatedException.hs

+89-4
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,18 @@
11
module Freckle.App.Test.Hspec.AnnotatedException
22
( unwrapAnnotatedHUnitFailure
3+
, annotateHUnitFailure
34
) where
45

56
import Freckle.App.Prelude
67

78
import Control.Exception qualified
9+
import Control.Lens (Lens', lens, over)
10+
import Data.Annotation (Annotation, tryAnnotations)
11+
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
12+
import Data.Text qualified as T
813
import Freckle.App.Exception (AnnotatedException (..))
9-
import Test.HUnit.Lang (HUnitFailure)
14+
import GHC.Stack (CallStack, prettyCallStack)
15+
import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))
1016
import Test.Hspec
1117

1218
-- | An hspec hook that lets hspec catch and pretty-print 'HUnitFailure', the
@@ -17,6 +23,85 @@ import Test.Hspec
1723
-- you end up with an @'AnnotatedException' 'HUnitFailure'@, hspec doesn't recognize
1824
-- it as an assertion failure and you get ugly output instead of nice output.
1925
unwrapAnnotatedHUnitFailure :: Spec -> Spec
20-
unwrapAnnotatedHUnitFailure = around_ $
21-
Control.Exception.handle $ \AnnotatedException {exception = e} ->
22-
Control.Exception.throw (e :: HUnitFailure)
26+
unwrapAnnotatedHUnitFailure = around_ $ mapException annotateHUnitFailure
27+
28+
mapException :: (Exception e, Exception e') => (e -> e') -> IO a -> IO a
29+
mapException f = Control.Exception.handle $ Control.Exception.throw . f
30+
31+
annotateHUnitFailure :: AnnotatedException HUnitFailure -> HUnitFailure
32+
annotateHUnitFailure
33+
AnnotatedException {exception, annotations} =
34+
over hUnitFailureReason (annotateFailureReason annotations) exception
35+
36+
hUnitFailureReason :: Lens' HUnitFailure FailureReason
37+
hUnitFailureReason =
38+
lens
39+
(\(HUnitFailure _ x) -> x)
40+
(\(HUnitFailure l _) x -> HUnitFailure l x)
41+
42+
-- | Augment a 'FailureReason' with extra information derived from 'Annotation's
43+
annotateFailureReason :: [Annotation] -> FailureReason -> FailureReason
44+
annotateFailureReason as =
45+
\case
46+
Reason m -> Reason (makeMessage m as)
47+
ExpectedButGot m e g -> ExpectedButGot (makeMessageMaybe m as) e g
48+
49+
-- | Construct a message that consists of an introductory paragraph plus
50+
-- some additional paragraphs based on annotations, separated by blank lines
51+
makeMessage :: String -> [Annotation] -> String
52+
makeMessage m as =
53+
combineParagraphs $ stringParagraph m :| annotationParagraphs as
54+
55+
-- | Like 'makeMessage' but without necessarily having an introductory paragraph present
56+
--
57+
-- If there is neither an introductory paragraph nor any annotations, the result is 'Nothing'.
58+
makeMessageMaybe :: Maybe String -> [Annotation] -> Maybe String
59+
makeMessageMaybe mm as =
60+
fmap combineParagraphs $
61+
nonEmpty $
62+
fmap stringParagraph (toList mm) <> annotationParagraphs as
63+
64+
-- | Text that constitutes a paragraph in a potentially lengthy error message
65+
--
66+
-- Construct with 'stringParagraph' or 'textParagraph', which strip the text of
67+
-- surrounding whitespace.
68+
newtype Paragraph = Paragraph {paragraphText :: Text}
69+
70+
stringParagraph :: String -> Paragraph
71+
stringParagraph = textParagraph . T.pack
72+
73+
textParagraph :: Text -> Paragraph
74+
textParagraph = Paragraph . T.strip
75+
76+
-- | Combine a list of paragraphs into a single string for the final output
77+
combineParagraphs :: Foldable t => t Paragraph -> String
78+
combineParagraphs =
79+
T.unpack . T.intercalate "\n\n" . fmap paragraphText . toList
80+
81+
-- | Render a list of annotations as a list of paragraphs
82+
--
83+
-- The paragraphs, depending on how much information there is to display, are:
84+
--
85+
-- * a summary of any annotations that aren't call stacks, if any
86+
-- * the first call stack, if there are any call stacks
87+
annotationParagraphs :: [Annotation] -> [Paragraph]
88+
annotationParagraphs annotations =
89+
catMaybes
90+
[ otherAnnotationsPart <$> nonEmpty otherAnnotations
91+
, callStackPart <$> listToMaybe callStacks
92+
]
93+
where
94+
(callStacks, otherAnnotations) = tryAnnotations @CallStack annotations
95+
96+
-- | Construct a paragraph consisting of a bullet list of annotations
97+
otherAnnotationsPart :: Foldable t => t Annotation -> Paragraph
98+
otherAnnotationsPart =
99+
textParagraph
100+
. T.intercalate "\n"
101+
. ("Annotations:" :)
102+
. fmap (("\t * " <>) . T.pack . show)
103+
. toList
104+
105+
-- | Construct a paragraph that displays a call stack
106+
callStackPart :: CallStack -> Paragraph
107+
callStackPart = textParagraph . T.pack . prettyCallStack

‎freckle-app/package.yaml

+4-1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: freckle-app
2-
version: 1.20.1.2
2+
version: 1.20.2.0
33
maintainer: Freckle Education
44
category: Utils
55
github: freckle/freckle-app
@@ -80,6 +80,7 @@ library:
8080
- HUnit
8181
- MonadRandom
8282
- QuickCheck
83+
- annotated-exception
8384
- autodocodec
8485
- autodocodec-openapi3
8586
- aeson
@@ -150,7 +151,9 @@ tests:
150151
source-dirs: tests
151152
ghc-options: -threaded -rtsopts "-with-rtsopts=-N"
152153
dependencies:
154+
- annotated-exception
153155
- Blammo
156+
- HUnit
154157
- QuickCheck
155158
- aeson
156159
- async

‎freckle-app/tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs

+153
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,153 @@
1+
module Freckle.App.Test.Hspec.AnnotatedExceptionSpec
2+
( spec
3+
) where
4+
5+
import Freckle.App.Prelude
6+
7+
import Data.Annotation (toAnnotation)
8+
import Data.List (intercalate)
9+
import Freckle.App.Exception (AnnotatedException (..))
10+
import Freckle.App.Test.Hspec.AnnotatedException (annotateHUnitFailure)
11+
import GHC.Exts (fromList)
12+
import GHC.Stack (CallStack, SrcLoc (..))
13+
import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))
14+
import Test.Hspec (Spec, describe, it, shouldBe)
15+
16+
spec :: Spec
17+
spec = do
18+
describe "annotateHUnitFailure" $ do
19+
describe "does nothing if there are no annotations" $ do
20+
it "when the failure is Reason" $
21+
let e = HUnitFailure Nothing (Reason "x")
22+
in annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
23+
24+
it "when the failure is ExpectedButGot with no message" $
25+
let e = HUnitFailure Nothing (ExpectedButGot Nothing "a" "b")
26+
in annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
27+
28+
it "when the failure is ExpectedButGot with a message" $
29+
let e = HUnitFailure Nothing (ExpectedButGot (Just "x") "a" "b")
30+
in annotateHUnitFailure (AnnotatedException [] e) `shouldBe` e
31+
32+
describe "can show an annotation" $ do
33+
it "when the failure is Reason" $
34+
annotateHUnitFailure
35+
AnnotatedException
36+
{ annotations = [toAnnotation @Int 56]
37+
, exception = HUnitFailure Nothing (Reason "x")
38+
}
39+
`shouldBe` HUnitFailure
40+
Nothing
41+
( Reason . intercalate "\n" $
42+
[ "x"
43+
, ""
44+
, "Annotations:"
45+
, "\t * Annotation @Int 56"
46+
]
47+
)
48+
49+
it "when the failure is ExpectedButGot with no message" $ do
50+
annotateHUnitFailure
51+
AnnotatedException
52+
{ annotations = [toAnnotation @Int 56]
53+
, exception = HUnitFailure Nothing (ExpectedButGot Nothing "a" "b")
54+
}
55+
`shouldBe` HUnitFailure
56+
Nothing
57+
( ExpectedButGot
58+
( Just . intercalate "\n" $
59+
[ "Annotations:"
60+
, "\t * Annotation @Int 56"
61+
]
62+
)
63+
"a"
64+
"b"
65+
)
66+
67+
it "when the failure is ExpectedButGot with a message" $
68+
annotateHUnitFailure
69+
AnnotatedException
70+
{ annotations = [toAnnotation @Int 56]
71+
, exception = HUnitFailure Nothing (ExpectedButGot (Just "x") "a" "b")
72+
}
73+
`shouldBe` HUnitFailure
74+
Nothing
75+
( ExpectedButGot
76+
( Just . intercalate "\n" $
77+
[ "x"
78+
, ""
79+
, "Annotations:"
80+
, "\t * Annotation @Int 56"
81+
]
82+
)
83+
"a"
84+
"b"
85+
)
86+
87+
it "can show a stack trace" $
88+
annotateHUnitFailure
89+
AnnotatedException
90+
{ annotations =
91+
[ toAnnotation @CallStack $
92+
fromList
93+
[
94+
( "abc"
95+
, SrcLoc
96+
{ srcLocPackage = "thepackage"
97+
, srcLocModule = "Foo"
98+
, srcLocFile = "src/Foo.hs"
99+
, srcLocStartLine = 7
100+
, srcLocStartCol = 50
101+
, srcLocEndLine = 8
102+
, srcLocEndCol = 23
103+
}
104+
)
105+
]
106+
]
107+
, exception = HUnitFailure Nothing (Reason "x")
108+
}
109+
`shouldBe` HUnitFailure
110+
Nothing
111+
( Reason . intercalate "\n" $
112+
[ "x"
113+
, ""
114+
, "CallStack (from HasCallStack):"
115+
, " abc, called at src/Foo.hs:7:50 in thepackage:Foo"
116+
]
117+
)
118+
119+
it "can show both an annotation and a stack trace" $
120+
annotateHUnitFailure
121+
AnnotatedException
122+
{ annotations =
123+
[ toAnnotation @Text "Visibility is poor"
124+
, toAnnotation @CallStack $
125+
fromList
126+
[
127+
( "abc"
128+
, SrcLoc
129+
{ srcLocPackage = "thepackage"
130+
, srcLocModule = "Foo"
131+
, srcLocFile = "src/Foo.hs"
132+
, srcLocStartLine = 7
133+
, srcLocStartCol = 50
134+
, srcLocEndLine = 8
135+
, srcLocEndCol = 23
136+
}
137+
)
138+
]
139+
]
140+
, exception = HUnitFailure Nothing (Reason "x")
141+
}
142+
`shouldBe` HUnitFailure
143+
Nothing
144+
( Reason . intercalate "\n" $
145+
[ "x"
146+
, ""
147+
, "Annotations:"
148+
, "\t * Annotation @Text \"Visibility is poor\""
149+
, ""
150+
, "CallStack (from HasCallStack):"
151+
, " abc, called at src/Foo.hs:7:50 in thepackage:Foo"
152+
]
153+
)

0 commit comments

Comments
 (0)