freckle-app 1.20.1.2 → 1.20.2.0
raw patch · 5 files changed
+259/−7 lines, 5 filesdep +annotated-exception
Dependencies added: annotated-exception
Files
- CHANGELOG.md +8/−1
- freckle-app.cabal +5/−1
- library/Freckle/App/Test/Hspec/AnnotatedException.hs +89/−4
- package.yaml +4/−1
- tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs +153/−0
CHANGELOG.md view
@@ -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)
freckle-app.cabal view
@@ -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,
library/Freckle/App/Test/Hspec/AnnotatedException.hs view
@@ -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
package.yaml view
@@ -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
+ tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs view
@@ -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"+ ]+ )