module Test.Hspec.AnnotatedException
( unwrapAnnotatedHUnitFailure
, annotateHUnitFailure
) where
import Prelude
import Control.Exception (Exception)
import Control.Exception qualified
import Control.Exception.Annotated (AnnotatedException (..))
import Control.Lens (Lens', lens, over)
import Data.Annotation (Annotation, tryAnnotations)
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
import Data.Maybe (catMaybes, listToMaybe)
import Data.Text (Text)
import Data.Text qualified as T
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
-- exception that is thrown when a test assertion fails
--
-- Tests for any code that might throw 'AnnotatedException' (which includes anything
-- that uses freckle-app) 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.
--
-- This hook does not alter whether a spec succeeds or fails; it only changes the
-- type of exception that is thrown when an assertion fails.
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, 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