hedgehog-1.5: src/Hedgehog/Internal/Report.hs
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Hedgehog.Internal.Report (
-- * Report
Summary(..)
, Report(..)
, Progress(..)
, Result(..)
, FailureReport(..)
, FailedAnnotation(..)
, Style(..)
, Markup(..)
, Config(..)
, defaultConfig
, Context(..)
, Lines
, PrintPrefixIcons(..)
, renderProgress
, renderResult
, renderResultWith
, renderSummary
, renderDoc
, ppProgress
, ppResult
, ppResultWith
, ppSummary
, fromResult
, mkFailure
) where
import Control.Monad (zipWithM)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Bifunctor (bimap, first, second)
import qualified Data.Char as Char
import Data.Either (partitionEithers)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe, catMaybes)
#if !MIN_VERSION_base(4,11,0)
import qualified Data.Semigroup as Semigroup
#endif
import Data.Traversable (for)
import Hedgehog.Internal.Config
import Hedgehog.Internal.Discovery (Pos(..), Position(..))
import qualified Hedgehog.Internal.Discovery as Discovery
import Hedgehog.Internal.Prelude
import Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..))
import Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..))
import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..))
import Hedgehog.Internal.Property (ShrinkCount(..), PropertyCount(..))
import Hedgehog.Internal.Property (TestCount(..), DiscardCount(..))
import Hedgehog.Internal.Property (coverPercentage, coverageFailures)
import Hedgehog.Internal.Property (labelCovered)
import Hedgehog.Internal.Property (ShrinkPath(..), skipCompress)
import Hedgehog.Internal.Show
import Hedgehog.Internal.Source
import System.Console.ANSI (ColorIntensity(..), Color(..))
import System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..))
import System.Console.ANSI (SGR(..), setSGRCode)
import System.Directory (makeRelativeToCurrentDirectory)
#if mingw32_HOST_OS
import System.IO (hSetEncoding, stdout, stderr, utf8)
#endif
import Text.PrettyPrint.Annotated.WL (Doc, (<#>), (<+>))
import qualified Text.PrettyPrint.Annotated.WL as WL
import Text.Printf (printf)
------------------------------------------------------------------------
-- Data
data FailedAnnotation =
FailedAnnotation {
failedSpan :: !(Maybe Span)
, failedValue :: !String
} deriving (Eq, Show)
data FailureReport =
FailureReport {
failureShrinks :: !ShrinkCount
, failureShrinkPath :: !ShrinkPath
, failureCoverage :: !(Maybe (Coverage CoverCount))
, failureAnnotations :: ![FailedAnnotation]
, failureLocation :: !(Maybe Span)
, failureMessage :: !String
, failureDiff :: !(Maybe Diff)
, failureFootnotes :: ![String]
} deriving (Eq, Show)
-- | The status of a running property test.
--
data Progress =
Running
| Shrinking !FailureReport
deriving (Eq, Show)
-- | The status of a completed property test.
--
-- In the case of a failure it provides the seed used for the test, the
-- number of shrinks, and the execution log.
--
data Result =
Failed !FailureReport
| GaveUp
| OK
deriving (Eq, Show)
-- | A report on a running or completed property test.
--
data Report a =
Report {
reportTests :: !TestCount
, reportDiscards :: !DiscardCount
, reportCoverage :: !(Coverage CoverCount)
, reportSeed :: !Seed
, reportStatus :: !a
} deriving (Show, Functor, Foldable, Traversable)
-- | A summary of all the properties executed.
--
data Summary =
Summary {
summaryWaiting :: !PropertyCount
, summaryRunning :: !PropertyCount
, summaryFailed :: !PropertyCount
, summaryGaveUp :: !PropertyCount
, summaryOK :: !PropertyCount
} deriving (Show)
instance Monoid Summary where
#if !MIN_VERSION_base(4,11,0)
mappend = (Semigroup.<>)
#endif
mempty =
Summary 0 0 0 0 0
instance Semigroup Summary where
Summary x1 x2 x3 x4 x5 <> Summary y1 y2 y3 y4 y5 =
Summary
(x1 + y1)
(x2 + y2)
(x3 + y3)
(x4 + y4)
(x5 + y5)
-- | Construct a summary from a single result.
--
fromResult :: Result -> Summary
fromResult = \case
Failed _ ->
mempty { summaryFailed = 1 }
GaveUp ->
mempty { summaryGaveUp = 1 }
OK ->
mempty { summaryOK = 1 }
summaryCompleted :: Summary -> PropertyCount
summaryCompleted (Summary _ _ x3 x4 x5) =
x3 + x4 + x5
summaryTotal :: Summary -> PropertyCount
summaryTotal (Summary x1 x2 x3 x4 x5) =
x1 + x2 + x3 + x4 + x5
------------------------------------------------------------------------
-- Pretty Printing Helpers
data Line a =
Line {
lineAnnotation :: !a
, lineNumber :: !LineNo
, _lineSource :: !String
} deriving (Eq, Ord, Show, Functor)
data Declaration a =
Declaration {
declarationFile :: !FilePath
, declarationLine :: !LineNo
, _declarationName :: !String
, declarationSource :: !(Map LineNo (Line a))
} deriving (Eq, Ord, Show, Functor)
data Style =
StyleDefault
| StyleAnnotation
| StyleFailure
deriving (Eq, Ord, Show)
data Markup =
WaitingIcon
| WaitingHeader
| RunningIcon
| RunningHeader
| ShrinkingIcon
| ShrinkingHeader
| FailedIcon
| FailedText
| GaveUpIcon
| GaveUpText
| SuccessIcon
| SuccessText
| CoverageIcon
| CoverageText
| CoverageFill
| DeclarationLocation
| StyledLineNo !Style
| StyledBorder !Style
| StyledSource !Style
| AnnotationGutter
| AnnotationValue
| FailureArrows
| FailureGutter
| FailureMessage
| DiffPrefix
| DiffInfix
| DiffSuffix
| DiffSame
| DiffRemoved
| DiffAdded
| ReproduceHeader
| ReproduceGutter
| ReproduceSource
deriving (Eq, Ord, Show)
instance Semigroup Style where
(<>) x y =
case (x, y) of
(StyleFailure, _) ->
StyleFailure
(_, StyleFailure) ->
StyleFailure
(StyleAnnotation, _) ->
StyleAnnotation
(_, StyleAnnotation) ->
StyleAnnotation
(StyleDefault, _) ->
StyleDefault
------------------------------------------------------------------------
takeAnnotation :: Log -> Maybe FailedAnnotation
takeAnnotation = \case
Annotation loc val ->
Just $ FailedAnnotation loc val
_ ->
Nothing
takeFootnote :: Log -> Maybe String
takeFootnote = \case
Footnote x ->
Just x
_ ->
Nothing
mkFailure ::
ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure shrinks shrinkPath mcoverage location message diff logs =
let
inputs =
mapMaybe takeAnnotation logs
footnotes =
mapMaybe takeFootnote logs
in
FailureReport shrinks shrinkPath mcoverage inputs location message diff footnotes
------------------------------------------------------------------------
-- Pretty Printing
ppShow :: Show x => x -> Doc a
ppShow = -- unfortunate naming clash
WL.text . show
markup :: Markup -> Doc Markup -> Doc Markup
markup =
WL.annotate
gutter :: Markup -> Doc Markup -> Doc Markup
gutter m x =
markup m ">" <+> x
icon :: PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
icon p m i x = case p of
DisablePrefixIcons -> x
EnablePrefixIcons -> markup m (WL.char i) <+> x
ppTestCount :: TestCount -> Doc a
ppTestCount = \case
TestCount 1 ->
"1 test"
TestCount n ->
ppShow n <+> "tests"
ppDiscardCount :: DiscardCount -> Doc a
ppDiscardCount = \case
DiscardCount 1 ->
"1 discard"
DiscardCount n ->
ppShow n <+> "discards"
ppShrinkCount :: ShrinkCount -> Doc a
ppShrinkCount = \case
ShrinkCount 1 ->
"1 shrink"
ShrinkCount n ->
ppShow n <+> "shrinks"
-- | Render a compressed 'Skip'.
--
ppSkip :: Skip -> Doc a
ppSkip =
WL.text . skipCompress
-- | Render a compressed 'Skip', such that it can be read back in.
--
ppSkipReadable :: Skip -> Doc a
ppSkipReadable =
WL.text . show . skipCompress
ppRawPropertyCount :: PropertyCount -> Doc a
ppRawPropertyCount (PropertyCount n) =
ppShow n
ppWithDiscardCount :: DiscardCount -> Doc Markup
ppWithDiscardCount = \case
DiscardCount 0 ->
mempty
n ->
" with" <+> ppDiscardCount n
ppShrinkDiscard :: ShrinkCount -> DiscardCount -> Doc Markup
ppShrinkDiscard s d =
case (s, d) of
(0, 0) ->
""
(0, _) ->
" and" <+> ppDiscardCount d
(_, 0) ->
" and" <+> ppShrinkCount s
(_, _) ->
"," <+> ppShrinkCount s <+> "and" <+> ppDiscardCount d
mapSource :: (Map LineNo (Line a) -> Map LineNo (Line a)) -> Declaration a -> Declaration a
mapSource f decl =
decl {
declarationSource =
f (declarationSource decl)
}
-- | The span of non-whitespace characters for the line.
--
-- The result is @[inclusive, exclusive)@.
--
lineSpan :: Line a -> (ColumnNo, ColumnNo)
lineSpan (Line _ _ x0) =
let
(pre, x1) =
span Char.isSpace x0
(_, x2) =
span Char.isSpace (reverse x1)
start =
length pre
end =
start + length x2
in
(fromIntegral start, fromIntegral end)
takeLines :: Span -> Declaration a -> Map LineNo (Line a)
takeLines sloc =
fst . Map.split (spanEndLine sloc + 1) .
snd . Map.split (spanStartLine sloc - 1) .
declarationSource
readDeclaration :: MonadIO m => Span -> m (Maybe (Declaration ()))
readDeclaration sloc =
runMaybeT $ do
path <- liftIO . makeRelativeToCurrentDirectory $ spanFile sloc
(name, Pos (Position _ line0 _) src) <- MaybeT $
Discovery.readDeclaration path (spanEndLine sloc)
let
line =
fromIntegral line0
pure . Declaration path line name .
Map.fromList .
zip [line..] .
zipWith (Line ()) [line..] $
lines src
defaultStyle :: Declaration a -> Declaration (Style, [(Style, Doc Markup)])
defaultStyle =
fmap $ const (StyleDefault, [])
lastLineSpan :: Monad m => Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo)
lastLineSpan sloc decl =
case reverse . Map.elems $ takeLines sloc decl of
[] ->
MaybeT $ pure Nothing
x : _ ->
pure $
lineSpan x
ppFailedInputTypedArgument :: Int -> FailedAnnotation -> Doc Markup
ppFailedInputTypedArgument ix (FailedAnnotation _ val) =
WL.vsep [
WL.text "forAll" <> ppShow ix <+> "="
, WL.indent 2 . WL.vsep . fmap (markup AnnotationValue . WL.text) $ lines val
]
ppFailedInputDeclaration ::
MonadIO m
=> FailedAnnotation
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInputDeclaration (FailedAnnotation msloc val) =
runMaybeT $ do
sloc <- MaybeT $ pure msloc
decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc
startCol <- fromIntegral . fst <$> lastLineSpan sloc decl
let
ppValLine =
WL.indent startCol .
(markup AnnotationGutter (WL.text "│ ") <>) .
markup AnnotationValue .
WL.text
valDocs =
fmap ((StyleAnnotation, ) . ppValLine) $
List.lines val
startLine =
fromIntegral $ spanStartLine sloc
endLine =
fromIntegral $ spanEndLine sloc
styleInput kvs =
foldr (Map.adjust . fmap . first $ const StyleAnnotation) kvs [startLine..endLine]
insertDoc =
Map.adjust (fmap . second $ const valDocs) endLine
pure $
mapSource (styleInput . insertDoc) decl
ppFailedInput ::
MonadIO m
=> Int
-> FailedAnnotation
-> m (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))
ppFailedInput ix input = do
mdecl <- ppFailedInputDeclaration input
case mdecl of
Nothing ->
pure . Left $ ppFailedInputTypedArgument ix input
Just decl ->
pure $ Right decl
ppLineDiff :: LineDiff -> Doc Markup
ppLineDiff = \case
LineSame x ->
markup DiffSame $
" " <> WL.text x
LineRemoved x ->
markup DiffRemoved $
"- " <> WL.text x
LineAdded x ->
markup DiffAdded $
"+ " <> WL.text x
ppDiff :: Diff -> [Doc Markup]
ppDiff (Diff prefix removed infix_ added suffix diff) = [
markup DiffPrefix (WL.text prefix) <>
markup DiffRemoved (WL.text removed) <>
markup DiffInfix (WL.text infix_) <>
markup DiffAdded (WL.text added) <>
markup DiffSuffix (WL.text suffix)
] ++ fmap ppLineDiff (toLineDiff diff)
ppFailureLocation ::
MonadIO m
=> [Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
ppFailureLocation msgs mdiff sloc =
runMaybeT $ do
decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc
(startCol, endCol) <- bimap fromIntegral fromIntegral <$> lastLineSpan sloc decl
let
arrowDoc =
WL.indent startCol $
markup FailureArrows (WL.text (replicate (endCol - startCol) '^'))
ppFailure x =
WL.indent startCol $
markup FailureGutter (WL.text "│ ") <> x
msgDocs =
fmap ((StyleFailure, ) . ppFailure . markup FailureMessage) msgs
diffDocs =
case mdiff of
Nothing ->
[]
Just diff ->
fmap ((StyleFailure, ) . ppFailure) (ppDiff diff)
docs =
[(StyleFailure, arrowDoc)] ++ msgDocs ++ diffDocs
startLine =
spanStartLine sloc
endLine =
spanEndLine sloc
styleFailure kvs =
foldr (Map.adjust . fmap . first $ const StyleFailure) kvs [startLine..endLine]
insertDoc =
Map.adjust (fmap . second $ const docs) endLine
pure $
mapSource (styleFailure . insertDoc) decl
type Annotation = (Style, [(Style, Doc Markup)])
newtype Lines = Lines Int
deriving (Eq, Num)
instance Show Lines where
showsPrec p (Lines n) = showsPrec p n
data Context = FullContext | Context Lines
deriving (Eq, Show)
applyContext :: Context -> Declaration Annotation -> Declaration Annotation
applyContext context decl = case context of
FullContext -> decl
Context n -> decl { declarationSource = limitContextTo n (declarationSource decl) }
limitContextTo :: Lines -> Map LineNo (Line Annotation) -> Map LineNo (Line Annotation)
limitContextTo (Lines context) =
let
skipBoring xs = case span isBoring xs of
(boring, []) -> take context boring
(boring, rest) -> takeEnd context boring <> keepInteresting rest
keepInteresting xs = case break isBoring xs of
(interesting, rest) -> interesting <> take context rest <> skipBoring rest
isBoring = isBoringAnnotation . lineAnnotation . snd
in
Map.fromList . skipBoring . Map.toList
takeEnd :: Int -> [a] -> [a]
takeEnd n = reverse . take n . reverse
isBoringAnnotation :: Annotation -> Bool
isBoringAnnotation = \ case
(StyleDefault, []) -> True
_ -> False
ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
ppDeclaration decl = let source = declarationSource decl in
case Map.maxView source of
Nothing ->
mempty
Just (lastLine, _) ->
let
ppLocation =
WL.indent (digits + 1) $
markup (StyledBorder StyleDefault) "┏━━" <+>
markup DeclarationLocation (WL.text (declarationFile decl)) <+>
markup (StyledBorder StyleDefault) "━━━"
digits =
length . show . unLineNo $ lineNumber lastLine
ppLineNo =
WL.text . printf ("%" <> show digits <> "d") . unLineNo
ppEmptyNo :: Doc a
ppEmptyNo =
WL.text $ replicate digits ' '
ppSource :: Style -> LineNo -> String -> Doc Markup
ppSource style n src =
(if isOmittedLine (pred n) then addVerticalEllipsis else id) $
markup (StyledLineNo style) (ppLineNo n) <+>
markup (StyledBorder style) "┃" <+>
markup (StyledSource style) (WL.text src)
addVerticalEllipsis =
(verticalEllipsis <#>)
verticalEllipsis =
"\x22ee"
isOmittedLine n =
n >= firstLine && Map.notMember n source
firstLine =
fst $ Map.findMin source
ppAnnot (style, doc) =
markup (StyledLineNo style) ppEmptyNo <+>
markup (StyledBorder style) "┃" <+>
doc
ppLines = do
Line (style, xs) n src <- Map.elems source
ppSource style n src : fmap ppAnnot xs
in
WL.vsep (ppLocation : ppLines)
ppReproduce :: Maybe PropertyName -> Seed -> Skip -> Doc Markup
ppReproduce name seed skip =
WL.vsep [
markup ReproduceHeader
"This failure can be reproduced by running:"
, gutter ReproduceGutter . markup ReproduceSource $
"recheckAt" <+>
WL.text (showsPrec 11 seed "") <+>
ppSkipReadable skip <+>
maybe "<property>" (WL.text . unPropertyName) name
]
mergeLine :: Semigroup a => Line a -> Line a -> Line a
mergeLine (Line x no src) (Line y _ _) =
Line (x <> y) no src
mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a
mergeDeclaration (Declaration file line name src0) (Declaration _ _ _ src1) =
Declaration file line name $
Map.unionWith mergeLine src0 src1
mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a]
mergeDeclarations =
Map.elems .
Map.fromListWith mergeDeclaration .
fmap (\d -> ((declarationFile d, declarationLine d), d))
ppTextLines :: String -> [Doc Markup]
ppTextLines =
fmap WL.text . List.lines
ppFailureReport :: MonadIO m => Config -> Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup]
ppFailureReport config name tests discards seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do
let
basic =
-- Move the failure message to the end section if we have
-- no source location or can't find the source file.
let
msgs1 =
msgs0 ++
(if null msg then [] else [msg])
docs =
concatMap ppTextLines msgs1 ++
maybe [] ppDiff mdiff
in
(docs, Nothing)
(msgs1, mlocation) <-
case mlocation0 of
Nothing ->
return basic
Just location0 -> do
mAdvanced <-
ppFailureLocation (fmap WL.text $ List.lines msg) mdiff location0
case mAdvanced of
Just advanced ->
return (concatMap ppTextLines msgs0, Just advanced)
Nothing ->
return basic
coverageLocations <-
case mcoverage of
Nothing ->
pure []
Just coverage ->
for (coverageFailures tests coverage) $ \(MkLabel _ mclocation _ count) ->
case mclocation of
Nothing ->
pure Nothing
Just clocation ->
let
coverageMsg =
WL.cat [
"Failed ("
, WL.annotate CoverageText $
ppCoverPercentage (coverPercentage tests count) <> " coverage"
, ")"
]
in
ppFailureLocation [coverageMsg] Nothing clocation
(args, idecls) <- fmap partitionEithers $ zipWithM ppFailedInput [0..] inputs0
let
decls :: [Declaration (Style, [(Style, Doc Markup)])]
decls =
mergeDeclarations $
catMaybes (mlocation : coverageLocations) <> idecls
with xs f =
if null xs then
[]
else
[f xs]
whenSome f xs =
if null xs then
xs
else
f xs
bottom = case mcoverage of
Nothing | configPrintReproduceMessage config ->
[ppReproduce name seed (SkipToShrink tests discards shrinkPath)]
_ ->
[]
pure .
whenSome (mempty :) .
whenSome (++ [mempty]) .
WL.punctuate WL.line .
fmap (WL.vsep . fmap (indentBy $ configPrintPrefixIcons config)) .
fmap (id :: [Doc Markup] -> [Doc Markup]) .
List.filter (not . null) $
concat [
with args $
WL.punctuate WL.line
, with decls $
WL.punctuate WL.line . fmap (ppDeclaration . applyContext (configContext config))
, with msgs1 $
id
, with bottom $
id
]
indentBy :: PrintPrefixIcons -> Doc a -> Doc a
indentBy = \case
DisablePrefixIcons ->
id
EnablePrefixIcons ->
WL.indent 2
ppName :: Maybe PropertyName -> Doc a
ppName = \case
Nothing ->
"<interactive>" <> WL.space
Just "" ->
mempty
Just (PropertyName name) ->
WL.text name <> WL.space
ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup)
ppProgress name (Report tests discards coverage _ status) =
case status of
Running ->
pure . WL.vsep $ [
icon EnablePrefixIcons RunningIcon '●' . WL.annotate RunningHeader $
ppName name <>
"passed" <+>
ppTestCount tests <>
ppWithDiscardCount discards <+>
"(running)"
] ++
ppCoverage EnablePrefixIcons tests coverage
Shrinking failure ->
pure . icon EnablePrefixIcons ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $
ppName name <>
"failed" <+> ppFailedAtLocation (failureLocation failure) <#>
"after" <+>
ppTestCount tests <>
ppShrinkDiscard (failureShrinks failure) discards <+>
"(shrinking)"
ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResult = ppResultWith defaultConfig
ppResultWith :: MonadIO m => Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
ppResultWith config name (Report tests discards coverage seed result) = do
case result of
Failed failure -> do
pfailure <- ppFailureReport config name tests discards seed failure
pure . WL.vsep $ [
icon (configPrintPrefixIcons config) FailedIcon '✗' . WL.align . WL.annotate FailedText $
ppName name <>
(
if configPrintFailedAtLocation config then
"failed" <+> ppFailedAtLocation (failureLocation failure) <#> "after"
else
"failed after"
) <+>
ppTestCount tests <>
ppShrinkDiscard (failureShrinks failure) discards <>
"." <>
(
if configPrintShrinkPath config then
WL.line <>
"shrink path:" <+>
ppSkip (SkipToShrink tests discards $ failureShrinkPath failure)
else
mempty
)
] ++
ppCoverage (configPrintPrefixIcons config) tests coverage ++
pfailure
GaveUp ->
pure . WL.vsep $ [
icon (configPrintPrefixIcons config) GaveUpIcon '⚐' . WL.annotate GaveUpText $
ppName name <>
"gave up after" <+>
ppDiscardCount discards <>
", passed" <+>
ppTestCount tests <>
"."
] ++
ppCoverage (configPrintPrefixIcons config) tests coverage
OK ->
pure . WL.vsep $ [
icon (configPrintPrefixIcons config) SuccessIcon '✓' . WL.annotate SuccessText $
ppName name <>
"passed" <+>
ppTestCount tests <>
"."
] ++
ppCoverage (configPrintPrefixIcons config) tests coverage
ppFailedAtLocation :: Maybe Span -> Doc Markup
ppFailedAtLocation = \case
Just x ->
"at" <+>
WL.text (spanFile x) <> ":" <>
WL.pretty (unLineNo (spanStartLine x)) <> ":" <>
WL.pretty (unColumnNo (spanStartColumn x))
Nothing ->
mempty
ppCoverage :: PrintPrefixIcons -> TestCount -> Coverage CoverCount -> [Doc Markup]
ppCoverage icons tests x =
if Map.null (coverageLabels x) then
mempty
else
fmap (ppLabel icons tests (coverageWidth tests x)) .
List.sortOn labelLocation $
Map.elems (coverageLabels x)
data ColumnWidth =
ColumnWidth {
widthPercentage :: !Int
, widthMinimum :: !Int
, widthName :: !Int
, _widthNameFail :: !Int
}
instance Semigroup ColumnWidth where
(<>) (ColumnWidth p0 m0 n0 f0) (ColumnWidth p1 m1 n1 f1) =
ColumnWidth
(max p0 p1)
(max m0 m1)
(max n0 n1)
(max f0 f1)
instance Monoid ColumnWidth where
mempty =
ColumnWidth 0 0 0 0
mappend =
(<>)
coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth
coverageWidth tests (Coverage labels) =
foldMap (labelWidth tests) labels
labelWidth :: TestCount -> Label CoverCount -> ColumnWidth
labelWidth tests x =
let
percentage =
length .
renderCoverPercentage .
coverPercentage tests $
labelAnnotation x
minimum_ =
if labelMinimum x == 0 then
0
else
length .
renderCoverPercentage $
labelMinimum x
name =
length .
unLabelName $
labelName x
nameFail =
if labelCovered tests x then
0
else
name
in
ColumnWidth percentage minimum_ name nameFail
ppLeftPad :: Int -> Doc a -> Doc a
ppLeftPad n doc =
let
ndoc =
length (show doc)
pad =
WL.text $
List.replicate (n - ndoc) ' '
in
pad <> doc
ppLabel :: PrintPrefixIcons -> TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup
ppLabel icons tests w x@(MkLabel name _ minimum_ count) =
let
covered =
labelCovered tests x
ltext =
if not covered then
WL.annotate CoverageText
else
id
lborder =
WL.annotate (StyledBorder StyleDefault)
licon = case icons of
DisablePrefixIcons ->
mempty
EnablePrefixIcons ->
if not covered then
WL.annotate CoverageText "⚠ "
else
" "
lname =
WL.fill (widthName w) (ppLabelName name)
wminimum =
ppLeftPad (widthMinimum w) $
ppCoverPercentage minimum_
wcover i =
ppLeftPad (widthPercentage w + length i) $
WL.text i <>
ppCoverPercentage (coverPercentage tests count)
lminimum =
if widthMinimum w == 0 then
mempty
else if not covered then
" ✗ " <> wminimum
else if minimum_ == 0 then
" " <> ppLeftPad (widthMinimum w) ""
else
" ✓ " <> wminimum
lcover =
if widthMinimum w == 0 then
wcover ""
else if not covered then
wcover ""
else if minimum_ == 0 then
wcover ""
else
wcover ""
in
WL.hcat [
licon
, ltext lname
, lborder " "
, ltext lcover
, lborder " "
, ltext $ ppCoverBar (coverPercentage tests count) minimum_
, lborder "" -- "│"
, ltext lminimum
]
ppLabelName :: LabelName -> Doc a
ppLabelName (LabelName name) =
WL.text name
ppCoverPercentage :: CoverPercentage -> Doc Markup
ppCoverPercentage =
WL.text . renderCoverPercentage
ppCoverBar :: CoverPercentage -> CoverPercentage -> Doc Markup
ppCoverBar (CoverPercentage percentage) (CoverPercentage minimum_) =
let
barWidth :: Int
barWidth =
20
coverageRatio :: Double
coverageRatio =
percentage / 100.0
coverageWidth_ :: Int
coverageWidth_ =
floor $
coverageRatio * fromIntegral barWidth
minimumRatio :: Double
minimumRatio =
minimum_ / 100.0
minimumWidth :: Int
minimumWidth =
floor $
minimumRatio * fromIntegral barWidth
index :: [a] -> Int
index xs =
floor $
((coverageRatio * fromIntegral barWidth) - fromIntegral coverageWidth_) *
fromIntegral (length xs)
part xs =
xs !! index xs
fillWidth =
barWidth - coverageWidth_ - 1
fillErrorWidth =
max 0 (minimumWidth - coverageWidth_ - 1)
fillSurplusWidth =
fillWidth - fillErrorWidth
bar :: (Char, [Char]) -> Doc Markup
bar (full, parts) =
WL.hcat [
WL.text $ replicate coverageWidth_ full
, if fillWidth >= 0 then
if index parts == 0 then
if fillErrorWidth > 0 then
WL.annotate FailedText $ WL.text [part parts]
else
WL.annotate CoverageFill $ WL.text [part parts]
else
WL.text [part parts]
else
""
, WL.annotate FailedText . WL.text $
replicate fillErrorWidth (head parts)
, WL.annotate CoverageFill . WL.text $
replicate fillSurplusWidth (head parts)
--
-- Uncomment when debugging:
--
-- , WL.annotate CoverageFill . WL.text $
-- " " ++ show barWidth
-- ++ " " ++ show coverageWidth_
-- ++ " " ++ show minimumWidth
-- ++ " " ++ "/"
-- ++ " " ++ show fillErrorWidth
-- ++ " " ++ "+"
-- ++ " " ++ show fillSurplusWidth
-- ++ " " ++ "="
-- ++ " " ++ show fillWidth
]
in
bar ('█', ['·', '▏', '▎', '▍', '▌', '▋', '▊', '▉'])
-- FIXME Maybe this should be configurable?
-- Alternative histogram bars:
--bar ('⣿', ['·', '⡀', '⡄', '⡆', '⡇', '⣇', '⣧', '⣷'])
--bar ('⣿', ['⢕', '⡀', '⣀', '⣄', '⣤', '⣦', '⣶', '⣷'])
--bar ('⣿', ['⢕', '⡵', '⢗', '⣗', '⣟'])
--bar ('⣿', [' ', '⡵', '⢗', '⣗', '⣟'])
--bar ('█', ['░','▓'])
--bar ('█', ['░'])
renderCoverPercentage :: CoverPercentage -> String
renderCoverPercentage (CoverPercentage percentage) =
printf "%.0f" percentage <> "%"
ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero suffix n =
if n <= 0 then
Nothing
else
Just $ ppRawPropertyCount n <+> suffix
annotateSummary :: Summary -> Doc Markup -> Doc Markup
annotateSummary summary =
if summaryFailed summary > 0 then
icon EnablePrefixIcons FailedIcon '✗' . WL.annotate FailedText
else if summaryGaveUp summary > 0 then
icon EnablePrefixIcons GaveUpIcon '⚐' . WL.annotate GaveUpText
else if summaryWaiting summary > 0 || summaryRunning summary > 0 then
icon EnablePrefixIcons WaitingIcon '○' . WL.annotate WaitingHeader
else
icon EnablePrefixIcons SuccessIcon '✓' . WL.annotate SuccessText
ppSummary :: MonadIO m => Summary -> m (Doc Markup)
ppSummary summary =
let
complete =
summaryCompleted summary == summaryTotal summary
prefix end =
if complete then
mempty
else
ppRawPropertyCount (summaryCompleted summary) <>
"/" <>
ppRawPropertyCount (summaryTotal summary) <+>
"complete" <> end
addPrefix xs =
if null xs then
prefix mempty : []
else
prefix ": " : xs
suffix =
if complete then
"."
else
" (running)"
in
pure .
annotateSummary summary .
(<> suffix) .
WL.hcat .
addPrefix .
WL.punctuate ", " $
catMaybes [
ppWhenNonZero "failed" (summaryFailed summary)
, ppWhenNonZero "gave up" (summaryGaveUp summary)
, if complete then
ppWhenNonZero "succeeded" (summaryOK summary)
else
Nothing
]
renderDoc :: MonadIO m => UseColor -> Doc Markup -> m String
renderDoc color doc = do
let
dull =
SetColor Foreground Dull
vivid =
SetColor Foreground Vivid
bold =
SetConsoleIntensity BoldIntensity
start = \case
WaitingIcon ->
setSGRCode []
WaitingHeader ->
setSGRCode []
RunningIcon ->
setSGRCode []
RunningHeader ->
setSGRCode []
ShrinkingIcon ->
setSGRCode [vivid Red]
ShrinkingHeader ->
setSGRCode [vivid Red]
FailedIcon ->
setSGRCode [vivid Red]
FailedText ->
setSGRCode [vivid Red]
GaveUpIcon ->
setSGRCode [dull Yellow]
GaveUpText ->
setSGRCode [dull Yellow]
SuccessIcon ->
setSGRCode [dull Green]
SuccessText ->
setSGRCode [dull Green]
CoverageIcon ->
setSGRCode [dull Yellow]
CoverageText ->
setSGRCode [dull Yellow]
CoverageFill ->
setSGRCode [vivid Black]
DeclarationLocation ->
setSGRCode []
StyledLineNo StyleDefault ->
setSGRCode []
StyledSource StyleDefault ->
setSGRCode []
StyledBorder StyleDefault ->
setSGRCode []
StyledLineNo StyleAnnotation ->
setSGRCode [dull Magenta]
StyledSource StyleAnnotation ->
setSGRCode []
StyledBorder StyleAnnotation ->
setSGRCode []
AnnotationGutter ->
setSGRCode [dull Magenta]
AnnotationValue ->
setSGRCode [dull Magenta]
StyledLineNo StyleFailure ->
setSGRCode [vivid Red]
StyledSource StyleFailure ->
setSGRCode [vivid Red, bold]
StyledBorder StyleFailure ->
setSGRCode []
FailureArrows ->
setSGRCode [vivid Red]
FailureMessage ->
setSGRCode []
FailureGutter ->
setSGRCode []
DiffPrefix ->
setSGRCode []
DiffInfix ->
setSGRCode []
DiffSuffix ->
setSGRCode []
DiffSame ->
setSGRCode []
DiffRemoved ->
setSGRCode [dull Red]
DiffAdded ->
setSGRCode [dull Green]
ReproduceHeader ->
setSGRCode []
ReproduceGutter ->
setSGRCode []
ReproduceSource ->
setSGRCode []
end _ =
setSGRCode [Reset]
let
display =
case color of
EnableColor ->
WL.displayDecorated start end id
DisableColor ->
WL.display
#if mingw32_HOST_OS
liftIO $ do
hSetEncoding stdout utf8
hSetEncoding stderr utf8
#endif
pure .
display .
WL.renderSmart 100 $
WL.indent 2 doc
renderProgress :: MonadIO m => UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress color name x =
renderDoc color =<< ppProgress name x
renderResult :: MonadIO m => UseColor -> Maybe PropertyName -> Report Result -> m String
renderResult = renderResultWith defaultConfig
data Config =
Config {
configContext :: Context
, configPrintFailedAtLocation :: Bool
, configPrintShrinkPath :: Bool
, configPrintReproduceMessage :: Bool
, configPrintPrefixIcons :: PrintPrefixIcons
} deriving (Eq, Show)
-- | Whether to add icons to the start of important output lines or not.
--
data PrintPrefixIcons =
DisablePrefixIcons
-- ^ Do not add icons to the start of important output lines.
| EnablePrefixIcons
-- ^ Add icons to the start of important output lines.
deriving (Eq, Show)
defaultConfig :: Config
defaultConfig = Config FullContext True True True EnablePrefixIcons
renderResultWith :: MonadIO m => Config -> UseColor -> Maybe PropertyName -> Report Result -> m String
renderResultWith config color name x =
renderDoc color =<< ppResultWith config name x
renderSummary :: MonadIO m => UseColor -> Summary -> m String
renderSummary color x =
renderDoc color =<< ppSummary x