freckle-exception 0.0.0.2 → 0.0.1.0
raw patch · 6 files changed
+357/−2 lines, 6 filesdep +HUnitdep +freckle-exceptiondep +hspecPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, freckle-exception, hspec, prettyprinter, text
API changes (from Hackage documentation)
+ Freckle.App.Test.Hspec.AnnotatedException: annotateHUnitFailure :: AnnotatedException HUnitFailure -> HUnitFailure
+ Freckle.App.Test.Hspec.AnnotatedException: unwrapAnnotatedHUnitFailure :: Spec -> Spec
Files
- CHANGELOG.md +5/−0
- freckle-exception.cabal +40/−1
- library/Freckle/App/Test/Hspec/AnnotatedException.hs +100/−0
- package.yaml +17/−1
- tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs +194/−0
- tests/Spec.hs +1/−0
CHANGELOG.md view
@@ -1,5 +1,10 @@ ## [_Unreleased_](https://github.com/freckle/freckle-exception/compare/freckle-exception-v0.0.0.2...main) +## [v0.0.1.0](https://github.com/freckle/freckle-exception/compare/v0.0.0.2...v0.0.1.0)++* Add `Hspec.AnnotatedException` module for rendering test failure exceptions+ with annotations+ ## [v0.0.0.2](https://github.com/freckle/freckle-exception/compare/v0.0.0.1...v0.0.0.2) Metadata change only; moved source repository.
freckle-exception.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: freckle-exception-version: 0.0.0.2+version: 0.0.1.0 license: MIT license-file: LICENSE maintainer: Freckle Education@@ -25,6 +25,7 @@ Freckle.App.Exception.MonadThrow Freckle.App.Exception.MonadUnliftIO Freckle.App.Exception.Types+ Freckle.App.Test.Hspec.AnnotatedException hs-source-dirs: library other-modules: Paths_freckle_exception@@ -43,12 +44,50 @@ -Wno-safe -Wno-unsafe build-depends:+ HUnit >=1.6.2.0, aeson >=2.0.3.0, annotated-exception >=0.2.0.4, base >=4.16.4.0 && <5, exceptions >=0.10.4,+ hspec >=2.10.0, monad-logger-aeson >=0.4.0.4,+ prettyprinter >=1.7.1,+ text >=1.2.5.0, unliftio >=0.2.25.0++ if impl(ghc >=9.8)+ ghc-options:+ -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: tests+ other-modules:+ Freckle.App.Test.Hspec.AnnotatedExceptionSpec+ Paths_freckle_exception++ default-language: GHC2021+ default-extensions:+ DataKinds DeriveAnyClass DerivingVia DerivingStrategies GADTs+ LambdaCase NoImplicitPrelude NoMonomorphismRestriction+ OverloadedStrings TypeFamilies++ 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:+ HUnit >=1.6.2.0,+ annotated-exception >=0.2.0.4,+ base >=4.16.4.0 && <5,+ freckle-exception,+ hspec >=2.10.0,+ text >=1.2.5.0 if impl(ghc >=9.8) ghc-options:
+ library/Freckle/App/Test/Hspec/AnnotatedException.hs view
@@ -0,0 +1,100 @@+module Freckle.App.Test.Hspec.AnnotatedException+ ( unwrapAnnotatedHUnitFailure+ , annotateHUnitFailure+ ) where++import Prelude++import Control.Exception (Exception)+import Control.Exception qualified+import Data.Annotation (Annotation, tryAnnotations)+import Data.Foldable (toList)+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)+import Data.Maybe (catMaybes, listToMaybe)+import Data.Text qualified as T+import Freckle.App.Exception (AnnotatedException (..))+import GHC.Stack (CallStack, prettyCallStack)+import Prettyprinter+import Prettyprinter.Render.String+import Prettyprinter.Util (reflow)+import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))+import Test.Hspec++-- | An hspec hook that catches and pretty-prints 'HUnitFailure', the exception+-- that is thrown when a test assertion fails+--+-- Tests for any code that might throw 'AnnotatedException' (which includes+-- anything that uses @freckle-exception@) should add this hook to their test+-- suite. Without it, if 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_ $ 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 = HUnitFailure l x, annotations} =+ HUnitFailure l $ annotateFailureReason annotations 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 $ pretty 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 pretty (toList mm)+ <> annotationParagraphs as++-- | Combine a list of paragraphs into a single string for the final output+combineParagraphs :: Foldable t => t (Doc ann) -> String+combineParagraphs =+ renderString+ . layoutSmart defaultLayoutOptions+ . vsep+ . punctuate hardline+ . 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] -> [Doc ann]+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 -> Doc ann+otherAnnotationsPart =+ vsep+ . ("Annotations:" :)+ . fmap (indent 2 . ("*" <+>) . align . reflow . T.pack . show)+ . toList++-- | Construct a paragraph that displays a call stack+callStackPart :: CallStack -> Doc ann+callStackPart = pretty . prettyCallStack
package.yaml view
@@ -1,5 +1,5 @@ name: freckle-exception-version: 0.0.0.2+version: 0.0.1.0 maintainer: Freckle Education category: Exceptions github: freckle/freckle-exception@@ -54,8 +54,24 @@ library: source-dirs: library dependencies:+ - HUnit - aeson - annotated-exception - exceptions+ - hspec - monad-logger-aeson+ - prettyprinter+ - text - unliftio++tests:+ spec:+ main: Spec.hs+ source-dirs: tests+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N"+ dependencies:+ - HUnit+ - annotated-exception+ - freckle-exception+ - hspec+ - text
+ tests/Freckle/App/Test/Hspec/AnnotatedExceptionSpec.hs view
@@ -0,0 +1,194 @@+module Freckle.App.Test.Hspec.AnnotatedExceptionSpec+ ( spec+ ) where++import Prelude++import Data.Annotation (toAnnotation)+import Data.List (intercalate)+import Data.Text (Text)+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:"+ , " * 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:"+ , " * 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:"+ , " * 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:"+ , " * Annotation @Text \"Visibility is poor\""+ , ""+ , "CallStack (from HasCallStack):"+ , " abc, called at src/Foo.hs:7:50 in thepackage:Foo"+ ]+ )++ it "wraps long annotations into neat lists"+ $ annotateHUnitFailure+ AnnotatedException+ { annotations =+ [ toAnnotation @Text+ "Visibility is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability is poor. Visability 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:"+ , " * Annotation @Text \"Visibility is poor. Visability is poor. Visability is"+ , " poor. Visability is poor. Visability is poor. Visability is poor. Visability"+ , " is poor. Visability is poor. Visability is poor. Visability is poor."+ , " Visability is poor\""+ , ""+ , "CallStack (from HasCallStack):"+ , " abc, called at src/Foo.hs:7:50 in thepackage:Foo"+ ]+ )
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-missing-export-lists #-}