sydtest-0.22.0.0: src/Test/Syd/Output.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Test.Syd.Output where
import Control.Arrow (second)
import Control.Exception
import Data.List (sortOn)
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.Text.Lazy.Builder as Text
import qualified Data.Text.Lazy.IO as LTIO
import Data.Word
import GHC.Stack
import Myers.Diff
import Safe
import Test.QuickCheck.IO ()
import Test.Syd.OptParse
import Test.Syd.Run
import Test.Syd.SpecDef
import Test.Syd.SpecForest
import Text.Colour
import Text.Printf
printOutputSpecForest :: Settings -> Timed ResultForest -> IO ()
printOutputSpecForest settings results = do
tc <- deriveTerminalCapababilities settings
LTIO.putStr $ LTB.toLazyText $ renderResultReport settings tc results
renderResultReport :: Settings -> TerminalCapabilities -> Timed ResultForest -> Text.Builder
renderResultReport settings tc rf =
mconcat $
map
(\line -> renderChunksBuilder tc line <> "\n")
(outputResultReport settings rf)
outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]]
outputResultReport settings trf =
let rf = timedValue trf
in concat
[ outputTestsHeader,
outputSpecForest settings 0 (resultForestWidth rf) rf,
[ [chunk ""],
[chunk ""]
],
outputFailuresWithHeading settings rf,
[[chunk ""]],
outputStats (computeTestSuiteStats settings <$> trf),
[[chunk ""]],
if settingProfile settings
then outputProfilingInfo trf
else []
]
outputFailuresHeader :: [[Chunk]]
outputFailuresHeader = outputHeader "Failures:"
outputFailuresWithHeading :: Settings -> ResultForest -> [[Chunk]]
outputFailuresWithHeading settings rf =
if anyFailedTests settings rf
then
concat
[ outputFailuresHeader,
outputFailures settings rf
]
else []
outputStats :: Timed TestSuiteStats -> [[Chunk]]
outputStats timed =
let TestSuiteStats {..} = timedValue timed
sumTimeSeconds :: Double
sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000
totalTimeSeconds :: Double
totalTimeSeconds = fromIntegral (timedTime timed) / 1_000_000_000
in map (padding :) $
concat
[ [ [ chunk "Examples: ",
fore green $ chunk (T.pack (show testSuiteStatExamples))
]
| testSuiteStatExamples /= testSuiteStatSuccesses
],
[ [ chunk "Passed: ",
( if testSuiteStatSuccesses <= 0
then fore red
else fore green
)
$ chunk (T.pack (show testSuiteStatSuccesses))
],
[ chunk "Failed: ",
( if testSuiteStatFailures > 0
then fore red
else fore green
)
$ chunk (T.pack (show testSuiteStatFailures))
]
],
[ [ chunk "Flaky: ",
fore red $ chunk (T.pack (show testSuiteStatFlakyTests))
]
| testSuiteStatFlakyTests > 0
],
[ [ chunk "Pending: ",
fore magenta $ chunk (T.pack (show testSuiteStatPending))
]
| testSuiteStatPending > 0
],
[ [ chunk "Sum of test runtimes:",
fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)
],
[ chunk "Test suite took: ",
fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds)
]
]
]
outputProfilingInfo :: Timed ResultForest -> [[Chunk]]
outputProfilingInfo Timed {..} =
map
( \(path, nanos) ->
[ timeChunkFor nanos,
" ",
chunk $ T.intercalate "." path
]
)
( sortOn
snd
( map
(second (timedTime . testDefVal))
(flattenSpecForest timedValue)
)
)
outputTestsHeader :: [[Chunk]]
outputTestsHeader = outputHeader "Tests:"
outputHeader :: Text -> [[Chunk]]
outputHeader t =
[ [fore blue $ chunk t],
[chunk ""]
]
outputSpecForest :: Settings -> Int -> Int -> ResultForest -> [[Chunk]]
outputSpecForest settings level treeWidth = concatMap (outputSpecTree settings level treeWidth)
outputSpecTree :: Settings -> Int -> Int -> ResultTree -> [[Chunk]]
outputSpecTree settings level treeWidth = \case
SpecifyNode t td -> outputSpecifyLines settings level treeWidth t td
PendingNode t mr -> outputPendingLines t mr
DescribeNode t sf -> outputDescribeLine t : map (padding :) (outputSpecForest settings (level + 1) treeWidth sf)
SubForestNode sf -> outputSpecForest settings level treeWidth sf
outputDescribeLine :: Text -> [Chunk]
outputDescribeLine t = [fore yellow $ chunk t]
outputSpecifyLines :: Settings -> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]
outputSpecifyLines settings level treeWidth specifyText (TDef timed _) =
let testRunReport = timedValue timed
executionTime = timedTime timed
status = testRunReportStatus settings testRunReport
TestRunResult {..} = testRunReportReportedRun testRunReport
withStatusColour = fore (statusColour status)
pad = (chunk (T.pack (replicate paddingSize ' ')) :)
timeChunk = timeChunkFor executionTime
in concatMap
(filter (not . null))
[ [ [ withStatusColour $ chunk (statusCheckMark status),
withStatusColour $ chunk specifyText,
spacingChunk level specifyText (chunkText timeChunk) treeWidth,
timeChunk
]
],
map pad $ retriesChunks testRunReport,
[ pad
[ chunk "passed for all of ",
case w of
0 -> fore red $ chunk "0"
_ -> fore green $ chunk (T.pack (printf "%d" w)),
" inputs."
]
| status == TestPassed,
w <- maybeToList testRunResultNumTests
],
map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels,
map pad $ classesChunks testRunResultClasses,
map pad $ tablesChunks testRunResultTables,
[pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase]
]
exampleNrChunk :: Word -> Word -> Chunk
exampleNrChunk total current =
let digits :: Word
digits = max 2 $ succ $ floor $ logBase 10 $ (fromIntegral :: Word -> Double) total
formatStr = "%" <> show digits <> "d"
in chunk $ T.pack $ printf formatStr current
timeChunkFor :: Word64 -> Chunk
timeChunkFor executionTime =
let t = fromIntegral executionTime / 1_000_000 :: Double -- milliseconds
executionTimeText = T.pack (printf "%10.2f ms" t)
withTimingColour =
if
| t < 10 -> fore green
| t < 100 -> fore yellow
| t < 1_000 -> fore orange
| t < 10_000 -> fore red
| otherwise -> fore darkRed
in withTimingColour $ chunk executionTimeText
retriesChunks :: TestRunReport -> [[Chunk]]
retriesChunks testRunReport =
case testRunReportRetries testRunReport of
Nothing -> []
Just retries ->
let flaky = testRunReportWasFlaky testRunReport
mMessage = case testRunReportFlakinessMode testRunReport of
MayBeFlaky mmesg -> mmesg
MayNotBeFlaky -> Nothing
in if flaky
then
concat
[ [["Retries: ", chunk (T.pack (show retries)), fore red " !!! FLAKY !!!"]],
[[fore magenta $ chunk $ T.pack message] | message <- maybeToList mMessage]
]
else [["Retries: ", chunk (T.pack (show retries)), " (does not look flaky)"]]
labelsChunks :: Word -> Maybe (Map [String] Int) -> [[Chunk]]
labelsChunks _ Nothing = []
labelsChunks totalCount (Just labels)
| M.null labels = []
| map fst (M.toList labels) == [[]] = []
| otherwise =
[chunk "Labels"]
: map
( pad
. ( \(ss, i) ->
[ chunk
( T.pack
( printf
"%5.2f%% %s"
(100 * fromIntegral i / fromIntegral totalCount :: Double)
(commaList (map show ss))
)
)
]
)
)
(M.toList labels)
where
pad = (chunk (T.pack (replicate paddingSize ' ')) :)
classesChunks :: Maybe (Map String Int) -> [[Chunk]]
classesChunks Nothing = []
classesChunks (Just classes)
| M.null classes = []
| otherwise =
[chunk "Classes"]
: map
( pad
. ( \(s, i) ->
[ chunk
( T.pack
( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s
)
)
]
)
)
(M.toList classes)
where
pad = (chunk (T.pack (replicate paddingSize ' ')) :)
total = sum $ map snd $ M.toList classes
tablesChunks :: Maybe (Map String (Map String Int)) -> [[Chunk]]
tablesChunks Nothing = []
tablesChunks (Just tables) = concatMap (uncurry goTable) $ M.toList tables
where
goTable :: String -> Map String Int -> [[Chunk]]
goTable tableName percentages =
[chunk " "]
: [chunk (T.pack tableName)]
: map
( pad
. ( \(s, i) ->
[ chunk
( T.pack
( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s
)
)
]
)
)
(M.toList percentages)
where
pad = (chunk (T.pack (replicate paddingSize ' ')) :)
total = sum $ map snd $ M.toList percentages
outputPendingLines :: Text -> Maybe Text -> [[Chunk]]
outputPendingLines specifyText mReason =
filter
(not . null)
[ [fore magenta $ chunk specifyText],
case mReason of
Nothing -> []
Just reason -> [padding, chunk reason]
]
outputFailureLabels :: Maybe (Map [String] Int) -> [[Chunk]]
outputFailureLabels Nothing = []
outputFailureLabels (Just labels)
| labels == M.singleton [] 1 = []
| otherwise = [["Labels: ", chunk (T.pack (commaList (map show (concat $ M.keys labels))))]]
commaList :: [String] -> String
commaList [] = []
commaList [s] = s
commaList (s1 : rest) = s1 ++ ", " ++ commaList rest
outputFailureClasses :: Maybe (Map String Int) -> [[Chunk]]
outputFailureClasses Nothing = []
outputFailureClasses (Just classes)
| M.null classes = []
| otherwise = [["Class: ", chunk (T.pack (commaList (M.keys classes)))]]
outputGoldenCase :: GoldenCase -> [Chunk]
outputGoldenCase = \case
GoldenNotFound -> [fore red $ chunk "Golden output not found"]
GoldenStarted -> [fore cyan $ chunk "Golden output created"]
GoldenReset -> [fore cyan $ chunk "Golden output reset"]
-- The chunk for spacing between the description and the timing
--
-- initial padding | checkmark | description | THIS CHUNK | execution time
spacingChunk :: Int -> Text -> Text -> Int -> Chunk
spacingChunk level descriptionText executionTimeText treeWidth = chunk $ T.pack $ replicate paddingWidth ' '
where
paddingWidth =
let preferredMaxWidth = 80
checkmarkWidth = 2
minimumSpacing = 1
actualDescriptionWidth = T.length descriptionText
actualTimingWidth = T.length executionTimeText
totalNecessaryWidth = treeWidth + checkmarkWidth + minimumSpacing + actualTimingWidth -- All timings are the same width
actualMaxWidth = max totalNecessaryWidth preferredMaxWidth
in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth
outputFailures :: Settings -> ResultForest -> [[Chunk]]
outputFailures settings rf =
let failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf
nbDigitsInFailureCount :: Int
nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double)
padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :)
in map (padding :) $
concatMap (filter (not . null)) $
indexed failures $ \w (ts, TDef timed cs) ->
let testRunReport = timedValue timed
status = testRunReportStatus settings testRunReport
TestRunResult {..} = testRunReportReportedRun testRunReport
in concat
[ [ [ fore cyan $
chunk $
T.pack $
replicate 2 ' '
++ case headMay $ getCallStack cs of
Nothing -> "Unknown location"
Just (_, SrcLoc {..}) ->
concat
[ srcLocFile,
":",
show srcLocStartLine
]
],
map
(fore (statusColour status))
[ chunk $ statusCheckMark status,
chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w),
chunk $ T.intercalate "." ts
]
],
map padFailureDetails $ retriesChunks testRunReport,
map (padFailureDetails . (: []) . chunk . T.pack) $
case (testRunResultNumTests, testRunResultNumShrinks) of
(Nothing, _) -> []
(Just numTests, Nothing) -> [printf "Failed after %d tests" numTests]
(Just numTests, Just 0) -> [printf "Failed after %d tests" numTests]
(Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks],
map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs,
map padFailureDetails $ outputFailureLabels testRunResultLabels,
map padFailureDetails $ outputFailureClasses testRunResultClasses,
map padFailureDetails $ maybe [] outputSomeException testRunResultException,
[padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase],
concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo],
[[chunk ""]]
]
outputSomeException :: SomeException -> [[Chunk]]
outputSomeException outerException =
case fromException outerException :: Maybe Contextual of
Just (Contextual innerException s) -> outputSomeException (SomeException innerException) ++ stringChunks s
Nothing ->
case fromException outerException :: Maybe Assertion of
Just a -> outputAssertion a
Nothing -> stringChunks $ displayException outerException
outputAssertion :: Assertion -> [[Chunk]]
outputAssertion = \case
NotEqualButShouldHaveBeenEqualWithDiff actual expected diffM -> outputEqualityAssertionFailed actual expected diffM
EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected
PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName
PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName
ExpectationFailed s -> stringChunks s
Context a' context -> outputAssertion a' ++ stringChunks context
-- | Split a list of 'Chunk's into lines of [Chunks].
--
-- This is rather complicated because chunks may contain newlines, in which
-- case they need to be split into two chunks on separate lines but with the
-- same colour information.
-- However, separate chunks are not necessarily on separate lines because there
-- may not be a newline inbetween.
splitChunksIntoLines :: [Chunk] -> [[Chunk]]
splitChunksIntoLines =
-- We maintain a list of 'currently traversing lines'.
-- These are already split into newlines and therefore definitely belong on separate lines.
-- We still need to keep the last of the current line though, because it
-- does not end in a newline and should therefore not necessarily belong on
-- a separate line by itself.
go ([] :| []) -- Start with an empty current line.
where
-- CurrentlyTraversingLines -> ChunksToStillSplit -> SplitChunks
go :: NonEmpty [Chunk] -> [Chunk] -> [[Chunk]]
go cls cs = case NE.uncons cls of
(currentLine, mRest) -> case mRest of
-- If there's only one current line, that's the last one of the currently traversing lines.
-- We split the next chunk into lines and append the first line of that to the current line.
Nothing -> case cs of
-- If there is only one current line, and no more chunks, it's the last line.
[] -> [currentLine]
-- If there are chunks left, split the first one into lines.
(c : rest) -> case T.splitOn "\n" (chunkText c) of
-- Should not happen, but would be fine, just skip this chunk
[] -> go cls rest
-- If the chunk had more than one lines
(l : ls) -> case NE.nonEmpty ls of
-- If there was only one line in the chunk, we continue with the
-- same current line onto the rest of the chunks
Nothing -> go ((currentLine <> [c {chunkText = l}]) :| []) rest
-- If there was more than one line in that chunk, that line is now considered finished.
-- We then make all the lines of this new chunk the new current lines, one chunk per line.
Just ne -> (currentLine <> [c {chunkText = l}]) : go (NE.map (\l' -> [c {chunkText = l'}]) ne) rest
-- If there is more than one current line, all but the last one are considered finished.
-- We skip them one by one.
Just ne -> currentLine : go ne cs
outputEqualityAssertionFailed :: String -> String -> Maybe [PolyDiff Text Text] -> [[Chunk]]
outputEqualityAssertionFailed actual expected diffM =
case diffM of
Just diff -> formatDiff actual expected diff
Nothing ->
concat
[ [[chunk "Expected these values to be equal:"]],
[[chunk "Diff computation took too long and was canceled"]],
[[fromString actual]],
[[fromString expected]]
]
formatDiff :: String -> String -> [PolyDiff Text Text] -> [[Chunk]]
formatDiff actual expected diff =
let -- Add a header to a list of lines of chunks
chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]]
chunksLinesWithHeader header = \case
-- If there is only one line, put the header on that line.
[cs] -> [header : cs]
-- If there is more than one line, put the header on a separate line before
cs -> [header] : cs
-- If it's only whitespace, change the background, otherwise change the foreground
foreOrBack :: Colour -> Text -> Chunk
foreOrBack c t =
(if T.null (T.strip t) then back c else fore c)
(chunk t)
actualChunks :: [[Chunk]]
actualChunks = chunksLinesWithHeader (fore blue "Actual: ") $
splitChunksIntoLines $
flip mapMaybe diff $ \case
First t -> Just $ foreOrBack red t
Second _ -> Nothing
Both t _ -> Just $ chunk t
expectedChunks :: [[Chunk]]
expectedChunks = chunksLinesWithHeader (fore blue "Expected: ") $
splitChunksIntoLines $
flip mapMaybe diff $ \case
First _ -> Nothing
Second t -> Just $ foreOrBack green t
Both t _ -> Just $ chunk t
inlineDiffChunks :: [[Chunk]]
inlineDiffChunks =
if length (lines actual) == 1 && length (lines expected) == 1
then []
else chunksLinesWithHeader (fore blue "Inline diff: ") $
splitChunksIntoLines $
flip map diff $ \case
First t -> foreOrBack red t
Second t -> foreOrBack green t
Both t _ -> chunk t
in concat
[ [[chunk "Expected these values to be equal:"]],
actualChunks,
expectedChunks,
inlineDiffChunks
]
outputNotEqualAssertionFailed :: String -> String -> [[Chunk]]
outputNotEqualAssertionFailed actual notExpected =
if actual == notExpected -- String equality
then
[ [chunk "Did not expect equality of the values but both were:"],
[chunk (T.pack actual)]
]
else
[ [chunk "These two values were considered equal but should not have been equal:"],
[fore blue "Actual : ", chunk (T.pack actual)],
[fore blue "Not Expected: ", chunk (T.pack notExpected)]
]
outputPredicateSuccessAssertionFailed :: String -> Maybe String -> [[Chunk]]
outputPredicateSuccessAssertionFailed actual mName =
concat
[ [ [chunk "Predicate failed, but should have succeeded, on this value:"],
[chunk (T.pack actual)]
],
concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]
]
outputPredicateFailAssertionFailed :: String -> Maybe String -> [[Chunk]]
outputPredicateFailAssertionFailed actual mName =
concat
[ [ [chunk "Predicate succeeded, but should have failed, on this value:"],
[chunk (T.pack actual)]
],
concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]
]
mContextChunks :: Maybe String -> [[Chunk]]
mContextChunks = maybe [] stringChunks
stringChunks :: String -> [[Chunk]]
stringChunks s =
let ls = lines s
in map ((: []) . chunk . T.pack) ls
indexed :: [a] -> (Word -> a -> b) -> [b]
indexed ls func = zipWith func [1 ..] ls
statusColour :: TestStatus -> Colour
statusColour = \case
TestPassed -> green
TestFailed -> red
statusCheckMark :: TestStatus -> Text
statusCheckMark = \case
TestPassed -> "\10003 "
TestFailed -> "\10007 "
resultForestWidth :: SpecForest a -> Int
resultForestWidth = goF 0
where
goF :: Int -> SpecForest a -> Int
goF level = maximum . map (goT level)
goT :: Int -> SpecTree a -> Int
goT level = \case
SpecifyNode t _ -> T.length t + level * paddingSize
PendingNode t _ -> T.length t + level * paddingSize
DescribeNode _ sdf -> goF (succ level) sdf
SubForestNode sdf -> goF level sdf
specForestWidth :: SpecDefForest a b c -> Int
specForestWidth = goF 0
where
goF :: Int -> SpecDefForest a b c -> Int
goF level = \case
[] -> 0
ts -> maximum $ map (goT level) ts
goT :: Int -> SpecDefTree a b c -> Int
goT level = \case
DefSpecifyNode t _ _ -> T.length t + level * paddingSize
DefPendingNode t _ -> T.length t + level * paddingSize
DefDescribeNode _ sdf -> goF (succ level) sdf
DefSetupNode _ sdf -> goF level sdf
DefBeforeAllNode _ sdf -> goF level sdf
DefBeforeAllWithNode _ sdf -> goF level sdf
DefWrapNode _ sdf -> goF level sdf
DefAroundAllNode _ sdf -> goF level sdf
DefAroundAllWithNode _ sdf -> goF level sdf
DefAfterAllNode _ sdf -> goF level sdf
DefParallelismNode _ sdf -> goF level sdf
DefTimeoutNode _ sdf -> goF level sdf
DefRetriesNode _ sdf -> goF level sdf
DefRandomisationNode _ sdf -> goF level sdf
DefFlakinessNode _ sdf -> goF level sdf
DefExpectationNode _ sdf -> goF level sdf
padding :: Chunk
padding = chunk $ T.replicate paddingSize " "
paddingSize :: Int
paddingSize = 2
orange :: Colour
orange = colour256 166
darkRed :: Colour
darkRed = colour256 160