diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # Changelog +## [0.23.0.0] - 2026-01-26 + +### Added + +* Terse output format +* AI-executor detection + +### Changed + +* Simplified outputting code. + +This is technically a breaking change, but if you are not using the sydtest +output code directly, it should not break anything for you. + ## [0.22.0.0] - 2025-09-28 ### Changed diff --git a/src/Test/Syd/OptParse.hs b/src/Test/Syd/OptParse.hs --- a/src/Test/Syd/OptParse.hs +++ b/src/Test/Syd/OptParse.hs @@ -5,13 +5,19 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.OptParse where import Autodocodec import Control.Applicative +import Control.Concurrent (getNumCapabilities) +import Control.Monad +import Control.Monad.IO.Class +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text (Text) +import qualified Data.Text.IO as TIO import GHC.Generics (Generic) import OptEnvConf import Path @@ -22,7 +28,6 @@ #ifdef mingw32_HOST_OS import System.Console.ANSI (hSupportsANSIColor) -import System.IO (stdout) #else import Text.Colour.Capabilities.FromEnv #endif @@ -50,8 +55,8 @@ settingGoldenStart :: !Bool, -- | Whether to overwrite golden tests instead of having them fail settingGoldenReset :: !Bool, - -- | Whether to use colour in the output, 'Nothing' means "detect" - settingColour :: !(Maybe Bool), + -- | Whether to use colour in the output + settingTerminalCapabilities :: !TerminalCapabilities, -- | The filters to use to select which tests to run settingFilters :: ![Text], -- | Whether to stop upon the first test failure @@ -71,18 +76,43 @@ -- | How to report progress settingReportProgress :: !ReportProgress, -- | Profiling mode - settingProfile :: !Bool + settingProfile :: !Bool, + -- | Output format + settingOutputFormat :: !OutputFormat } deriving (Show, Eq, Generic) +-- | Output format for test results +data OutputFormat + = -- | Pretty output with colors, unicode symbols, and detailed formatting + OutputFormatPretty + | -- | Terse output optimized for machine/AI consumption + OutputFormatTerse + deriving (Show, Eq, Generic, Enum, Bounded) + +instance HasCodec OutputFormat where + codec = + stringConstCodec $ + (OutputFormatPretty, "pretty") + :| [(OutputFormatTerse, "terse")] + instance HasParser Settings where settingsParser = subEnv_ "sydtest" $ withConfigurableYamlConfig (runIO $ resolveFile' ".sydtest.yaml") $ - checkMapEither combine settingsParser + checkMapIO combine settingsParser where + combine :: Flags -> IO (Either String Settings) combine Flags {..} = do - let d func = func defaultSettings + let d :: forall a. (Settings -> a) -> a + d func = func defaultSettings + terminalCapabilities <- case flagColour of + Just False -> pure WithoutColours + Just True -> pure With8BitColours + Nothing -> case flagAiExecutor of + Just True -> pure WithoutColours + _ -> detectTerminalCapabilities + let threads = fromMaybe ( if flagDebug @@ -90,61 +120,90 @@ else d settingThreads ) flagThreads - progress <- case flagReportProgress of + case threads of + ByCapabilities -> do + i <- getNumCapabilities + + when (i == 1) $ do + let outputLine :: [Chunk] -> IO () + outputLine lineChunks = liftIO $ do + putChunksLocaleWith terminalCapabilities lineChunks + TIO.putStrLn "" + mapM_ + ( outputLine + . (: []) + . fore red + ) + [ chunk "WARNING: Only one CPU core detected, make sure to compile your test suite with these ghc options:", + chunk " -threaded -rtsopts -with-rtsopts=-N", + chunk " (This is important for correctness as well as speed, as a parallel test suite can find thread safety problems.)" + ] + _ -> pure () + errOrProgress <- case flagReportProgress of Nothing -> pure $ - if threads == Synchronous - then - if flagDebug - then ReportProgress - else d settingReportProgress - else d settingReportProgress + Right $ + if threads == Synchronous + then + if flagDebug + then ReportProgress + else d settingReportProgress + else d settingReportProgress + Just ReportNoProgress -> pure $ Right ReportNoProgress Just ReportProgress -> if threads /= Synchronous - then Left "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner." - else pure ReportProgress - Just ReportNoProgress -> pure ReportNoProgress - pure - Settings - { settingSeed = flagSeed, - settingRandomiseExecutionOrder = - fromMaybe - ( if flagDebug - then False - else d settingRandomiseExecutionOrder - ) - flagRandomiseExecutionOrder, - settingThreads = threads, - settingMaxSuccess = flagMaxSuccess, - settingMaxSize = flagMaxSize, - settingMaxDiscard = flagMaxDiscard, - settingMaxShrinks = flagMaxShrinks, - settingGoldenStart = flagGoldenStart, - settingGoldenReset = flagGoldenReset, - settingColour = flagColour, - settingFilters = flagFilters, - settingFailFast = - fromMaybe - ( if flagDebug - then True - else d settingFailFast - ) - flagFailFast, - settingIterations = flagIterations, - settingTimeout = flagTimeout, - settingRetries = - fromMaybe - ( if flagDebug - then 0 - else d settingRetries - ) - flagRetries, - settingFailOnFlaky = flagFailOnFlaky, - settingSkipPassed = flagSkipPassed, - settingReportFile = flagReportFile, - settingReportProgress = progress, - settingProfile = flagProfile - } + then pure $ Left "Reporting progress in asynchronous runners is not supported. You can use --synchronous or --debug to use a synchronous runner." + else pure $ Right ReportProgress + forM errOrProgress $ \progress -> do + pure $ + Settings + { settingSeed = flagSeed, + settingRandomiseExecutionOrder = + fromMaybe + ( if flagDebug + then False + else d settingRandomiseExecutionOrder + ) + flagRandomiseExecutionOrder, + settingThreads = threads, + settingMaxSuccess = flagMaxSuccess, + settingMaxSize = flagMaxSize, + settingMaxDiscard = flagMaxDiscard, + settingMaxShrinks = flagMaxShrinks, + settingGoldenStart = flagGoldenStart, + settingGoldenReset = flagGoldenReset, + settingTerminalCapabilities = terminalCapabilities, + settingFilters = flagFilters, + settingFailFast = + fromMaybe + ( if flagDebug + then True + else d settingFailFast + ) + flagFailFast, + settingIterations = flagIterations, + settingTimeout = flagTimeout, + settingRetries = + fromMaybe + ( if flagDebug + then 0 + else d settingRetries + ) + flagRetries, + settingFailOnFlaky = flagFailOnFlaky, + settingSkipPassed = flagSkipPassed, + settingReportFile = flagReportFile, + settingReportProgress = progress, + settingProfile = flagProfile, + settingOutputFormat = + fromMaybe + ( case flagAiExecutor of + Nothing -> OutputFormatPretty + Just False -> OutputFormatPretty + Just True -> OutputFormatTerse + ) + flagOutputFormat + } defaultSettings :: Settings defaultSettings = @@ -159,7 +218,7 @@ settingMaxShrinks = d testRunSettingMaxShrinks, settingGoldenStart = d testRunSettingGoldenStart, settingGoldenReset = d testRunSettingGoldenReset, - settingColour = Nothing, + settingTerminalCapabilities = With8BitColours, settingFilters = mempty, settingFailFast = False, settingIterations = OneIteration, @@ -169,7 +228,8 @@ settingSkipPassed = False, settingReportProgress = ReportNoProgress, settingReportFile = Nothing, - settingProfile = False + settingProfile = False, + settingOutputFormat = OutputFormatPretty } -- 60 seconds @@ -179,12 +239,6 @@ defaultRetries :: Word defaultRetries = 3 -deriveTerminalCapababilities :: Settings -> IO TerminalCapabilities -deriveTerminalCapababilities settings = case settingColour settings of - Just False -> pure WithoutColours - Just True -> pure With8BitColours - Nothing -> detectTerminalCapabilities - #ifdef mingw32_HOST_OS detectTerminalCapabilities :: IO TerminalCapabilities detectTerminalCapabilities = do @@ -196,6 +250,7 @@ detectTerminalCapabilities :: IO TerminalCapabilities detectTerminalCapabilities = getTerminalCapabilitiesFromEnv #endif + -- We use an intermediate 'Flags' type so that default values can change based -- on parse settings. For example, the default value for 'flagThreads' depends -- on the value of 'flagDebug'. @@ -220,7 +275,9 @@ flagReportFile :: !(Maybe (Path Abs File)), flagReportProgress :: !(Maybe ReportProgress), flagDebug :: !Bool, - flagProfile :: !Bool + flagProfile :: !Bool, + flagAiExecutor :: !(Maybe Bool), + flagOutputFormat :: !(Maybe OutputFormat) } deriving (Show, Eq, Generic) @@ -358,6 +415,42 @@ name "profile", value $ settingProfile defaultSettings ] + flagAiExecutor <- + optional $ + choice + [ setting + [ help "Indicate that an AI is executing tests, sets defaults to 'no colours' and 'terse output'", + switch True, + long "ai-executor" + ], + setting + [ help "Turn off ai mode. This lets AIs opt out of ai-executor mode", + switch False, + long "no-ai-executor" + ], + setting + [ help "Activate AI executor mode based on env vars", + reader exists, + -- Feel free to add env vars here. + env "CLAUDECODE", + metavar "ANY" + ] + ] + + flagOutputFormat <- + optional $ + choice + [ setting + [ help "Use terse output (compact, no colors, failures only)", + switch OutputFormatTerse, + long "terse" + ], + setting + [ help "Use pretty output (colors, unicode, detailed formatting)", + switch OutputFormatPretty, + long "pretty" + ] + ] pure Flags {..} data Timeout diff --git a/src/Test/Syd/Output.hs b/src/Test/Syd/Output.hs --- a/src/Test/Syd/Output.hs +++ b/src/Test/Syd/Output.hs @@ -1,625 +1,29 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} +module Test.Syd.Output + ( -- * Main dispatch function + printOutputSpecForest, -module Test.Syd.Output where + -- * Re-exports + module Test.Syd.Output.Common, + module Test.Syd.Output.Pretty, + module Test.Syd.Output.Terse, + ) +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.Output.Common +import Test.Syd.Output.Pretty +import Test.Syd.Output.Terse +import Test.Syd.Run (Timed) 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 +printOutputSpecForest settings results = + LTIO.putStr $ + LTB.toLazyText $ + let renderer = + case settingOutputFormat settings of + OutputFormatTerse -> renderTerseSummary + OutputFormatPretty -> renderPrettyReport + in renderer settings results diff --git a/src/Test/Syd/Output/Common.hs b/src/Test/Syd/Output/Common.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Output/Common.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE RecordWildCards #-} +-- {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Syd.Output.Common where + +import Control.Exception +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable (cast) +import Data.Word +import Myers.Diff +import Test.Syd.Run +import Test.Syd.SpecDef +import Test.Syd.SpecForest +import Text.Colour +import Text.Printf + +padding :: Chunk +padding = chunk $ T.replicate paddingSize " " + +paddingSize :: Int +paddingSize = 2 + +orange :: Colour +orange = colour256 166 + +darkRed :: Colour +darkRed = colour256 160 + +statusColour :: TestStatus -> Colour +statusColour = \case + TestPassed -> green + TestFailed -> red + +statusCheckMark :: TestStatus -> Text +statusCheckMark = \case + TestPassed -> "\10003 " + TestFailed -> "\10007 " + +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 + +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 + +commaList :: [String] -> String +commaList [] = [] +commaList [s] = s +commaList (s1 : rest) = s1 ++ ", " ++ commaList rest + +mContextChunks :: Maybe String -> [[Chunk]] +mContextChunks = maybe [] stringChunks + +outputSomeException :: SomeException -> [[Chunk]] +outputSomeException outerException = + case fromException outerException :: Maybe Contextual of + Just (Contextual innerException s) -> + -- Check if innerException is already a SomeException to avoid double-wrapping + let innerSE = case cast innerException of + Just se -> se :: SomeException + Nothing -> SomeException innerException + in outputSomeException innerSE ++ 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] + ] + +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 diff --git a/src/Test/Syd/Output/Pretty.hs b/src/Test/Syd/Output/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Output/Pretty.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Test.Syd.Output.Pretty where + +import Control.Arrow (second) +import Data.List (sortOn) +import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as Text +import GHC.Stack +import Safe +import Test.Syd.OptParse +import Test.Syd.Output.Common +import Test.Syd.Run +import Test.Syd.SpecDef +import Test.Syd.SpecForest +import Text.Colour +import Text.Printf + +renderPrettyReport :: Settings -> Timed ResultForest -> Text.Builder +renderPrettyReport settings rf = + mconcat $ + map + (\line -> renderChunksBuilder (settingTerminalCapabilities settings) 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 ""] + ], + outputPrettySummary settings trf + ] + +outputPrettySummary :: Settings -> Timed ResultForest -> [[Chunk]] +outputPrettySummary settings trf = + let rf = timedValue trf + in concat + [ 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 + +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))))]] + +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 ""]] + ] diff --git a/src/Test/Syd/Output/Terse.hs b/src/Test/Syd/Output/Terse.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Output/Terse.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Test.Syd.Output.Terse where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as Text +import GHC.Stack +import Safe +import Test.Syd.OptParse +import Test.Syd.Output.Common +import Test.Syd.Run +import Test.Syd.SpecDef +import Test.Syd.SpecForest +import Text.Colour +import Text.Printf + +-- | Render a terse report +renderTerseSummary :: Settings -> Timed ResultForest -> Text.Builder +renderTerseSummary settings trf = + mconcat $ + map + (\line -> renderChunksBuilder (settingTerminalCapabilities settings) line <> "\n") + (outputTerseSummary settings trf) + +-- | Output the terse report as chunks. +outputTerseSummary :: Settings -> Timed ResultForest -> [[Chunk]] +outputTerseSummary settings trf = + let rf = timedValue trf + failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf + stats = computeTestSuiteStats settings rf + totalTimeSeconds = fromIntegral (timedTime trf) / 1_000_000_000 :: Double + in concat + [ concatMap (outputTerseFailure settings) failures, + [outputTerseStats stats totalTimeSeconds] + ] + +-- | Output a single failure in terse format. +outputTerseFailure :: Settings -> ([Text], TDef (Timed TestRunReport)) -> [[Chunk]] +outputTerseFailure _settings (ts, TDef timed cs) = + let testRunReport = timedValue timed + TestRunResult {..} = testRunReportReportedRun testRunReport + location = case headMay $ getCallStack cs of + Nothing -> "Unknown location" + Just (_, SrcLoc {..}) -> concat [srcLocFile, ":", show srcLocStartLine] + testPath = T.intercalate "." ts + in concat + [ [ [ chunk "FAIL ", + chunk (T.pack location), + chunk " ", + chunk testPath + ] + ], + map + (\l -> if null l then l else padding : l) + (maybe [] outputSomeException testRunResultException), + [[chunk ""]] + ] + +-- | Output the summary line in terse format. +-- +-- Format: Summary: X failed, Y passed, Z pending (Ns) +outputTerseStats :: TestSuiteStats -> Double -> [Chunk] +outputTerseStats TestSuiteStats {..} totalTimeSeconds = + concat $ + concat + [ [[padding]], + [ [ 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 + ], + [ [ fore yellow $ chunk $ T.pack (printf " (%0.2f s)" totalTimeSeconds) + ] + ] + ] diff --git a/src/Test/Syd/Run.hs b/src/Test/Syd/Run.hs --- a/src/Test/Syd/Run.hs +++ b/src/Test/Syd/Run.hs @@ -533,34 +533,34 @@ instance HasParser SeedSetting where settingsParser = - choice - [ setting - [ help "Use a random seed for pseudo-randomness", - switch RandomSeed, - long "random-seed" - ], - RandomSeed - <$ setting + withDefault (testRunSettingSeed defaultTestRunSettings) $ + choice + [ setting [ help "Use a random seed for pseudo-randomness", - OptEnvConf.reader exists, - env "RANDOM_SEED", - metavar "ANY" + switch RandomSeed, + long "random-seed" ], - FixedSeed - <$> setting + RandomSeed + <$ setting + [ help "Use a random seed for pseudo-randomness", + OptEnvConf.reader exists, + env "RANDOM_SEED", + metavar "ANY" + ], + FixedSeed + <$> setting + [ help "Seed for pseudo-randomness", + OptEnvConf.reader auto, + option, + long "seed", + env "SEED", + metavar "INT" + ], + setting [ help "Seed for pseudo-randomness", - OptEnvConf.reader auto, - option, - long "seed", - env "SEED", - metavar "INT" - ], - setting - [ help "Seed for pseudo-randomness", - conf "seed" - ], - pure $ testRunSettingSeed defaultTestRunSettings - ] + conf "seed" + ] + ] data TestRunResult = TestRunResult { testRunResultStatus :: !TestStatus, diff --git a/src/Test/Syd/Runner.hs b/src/Test/Syd/Runner.hs --- a/src/Test/Syd/Runner.hs +++ b/src/Test/Syd/Runner.hs @@ -14,9 +14,6 @@ where import Control.Concurrent (getNumCapabilities) -import Control.Monad -import Control.Monad.IO.Class -import qualified Data.Text.IO as TIO import System.Environment import System.Mem (performGC) import System.Random (mkStdGen, setStdGen) @@ -27,7 +24,6 @@ import Test.Syd.Runner.Asynchronous import Test.Syd.Runner.Synchronous import Test.Syd.SpecDef -import Text.Colour import Text.Printf -- | Set the command line argument of the underlying action to empty. @@ -66,41 +62,25 @@ sydTestOnce :: Settings -> TestDefM '[] () r -> IO (Timed ResultForest) sydTestOnce settings spec = do specForest <- execTestDefM settings spec - tc <- deriveTerminalCapababilities settings withNullArgs $ do setPseudorandomness (settingSeed settings) case settingThreads settings of Synchronous -> runSpecForestInterleavedWithOutputSynchronously settings specForest ByCapabilities -> do i <- fromIntegral <$> getNumCapabilities - - when (i == 1) $ do - let outputLine :: [Chunk] -> IO () - outputLine lineChunks = liftIO $ do - putChunksLocaleWith tc lineChunks - TIO.putStrLn "" - mapM_ - ( outputLine - . (: []) - . fore red - ) - [ chunk "WARNING: Only one CPU core detected, make sure to compile your test suite with these ghc options:", - chunk " -threaded -rtsopts -with-rtsopts=-N", - chunk " (This is important for correctness as well as speed, as a parallel test suite can find thread safety problems.)" - ] runSpecForestInterleavedWithOutputAsynchronously settings i specForest Asynchronous i -> runSpecForestInterleavedWithOutputAsynchronously settings i specForest sydTestIterations :: Maybe Word -> Settings -> TestDefM '[] () r -> IO (Timed ResultForest) -sydTestIterations totalIterations settings spec = +sydTestIterations totalIterations settings spec = do withNullArgs $ do nbCapabilities <- fromIntegral <$> getNumCapabilities let runOnce settings_ = do setPseudorandomness (settingSeed settings_) specForest <- execTestDefM settings_ spec - r <- timeItT 0 $ case settingThreads settings_ of + r <- case settingThreads settings_ of Synchronous -> runSpecForestSynchronously settings_ specForest ByCapabilities -> runSpecForestAsynchronously settings_ nbCapabilities specForest Asynchronous i -> runSpecForestAsynchronously settings_ i specForest diff --git a/src/Test/Syd/Runner/Asynchronous.hs b/src/Test/Syd/Runner/Asynchronous.hs --- a/src/Test/Syd/Runner/Asynchronous.hs +++ b/src/Test/Syd/Runner/Asynchronous.hs @@ -35,7 +35,7 @@ import Test.Syd.SpecForest import Text.Colour -runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO ResultForest +runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestAsynchronously settings nbThreads testForest = do handleForest <- makeHandleForest testForest failFastVar <- newEmptyMVar @@ -50,8 +50,22 @@ failFastVar <- newEmptyMVar suiteBegin <- getMonotonicTimeNSec let runRunner = runner settings nbThreads failFastVar handleForest - runPrinter = liftIO $ printer settings failFastVar suiteBegin handleForest + runPrinter = case settingOutputFormat settings of + OutputFormatPretty -> liftIO $ printer settings failFastVar suiteBegin handleForest + OutputFormatTerse -> liftIO $ waiter failFastVar handleForest ((), resultForest) <- concurrently runRunner runPrinter + + let outputLine :: [Chunk] -> IO () + outputLine lineChunks = liftIO $ do + putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks + TIO.putStrLn "" + outputLines :: [[Chunk]] -> IO () + outputLines = mapM_ outputLine + + outputLines $ case settingOutputFormat settings of + OutputFormatPretty -> outputPrettySummary settings resultForest + OutputFormatTerse -> outputTerseSummary settings resultForest + pure resultForest type HandleForest a b = SpecDefForest a b (MVar (Timed TestRunReport)) @@ -328,11 +342,9 @@ printer :: Settings -> MVar () -> Word64 -> HandleForest '[] () -> IO (Timed ResultForest) printer settings failFastVar suiteBegin handleForest = do - tc <- deriveTerminalCapababilities settings - let outputLine :: [Chunk] -> IO () outputLine lineChunks = liftIO $ do - putChunksLocaleWith tc lineChunks + putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks TIO.putStrLn "" treeWidth :: Int @@ -394,9 +406,6 @@ DefExpectationNode _ sdf -> fmap SubForestNode <$> goForest sdf mapM_ outputLine outputTestsHeader resultForest <- fromMaybe [] <$> runReaderT (goForest handleForest) 0 - outputLine [chunk " "] - mapM_ outputLine $ outputFailuresWithHeading settings resultForest - outputLine [chunk " "] suiteEnd <- getMonotonicTimeNSec let timedResult = Timed @@ -405,13 +414,7 @@ timedBegin = suiteBegin, timedEnd = suiteEnd } - mapM_ outputLine $ outputStats (computeTestSuiteStats settings <$> timedResult) - outputLine [chunk " "] - when (settingProfile settings) $ do - mapM_ outputLine (outputProfilingInfo timedResult) - outputLine [chunk " "] - pure timedResult addLevel :: P a -> P a @@ -419,8 +422,8 @@ type P = ReaderT Int IO -waiter :: MVar () -> HandleForest '[] () -> IO ResultForest -waiter failFastVar handleForest = do +waiter :: MVar () -> HandleForest '[] () -> IO (Timed ResultForest) +waiter failFastVar handleForest = timeItT 0 $ do let goForest :: HandleForest a b -> IO (Maybe ResultForest) goForest hts = do rts <- catMaybes <$> mapM goTree hts diff --git a/src/Test/Syd/Runner/Synchronous/Interleaved.hs b/src/Test/Syd/Runner/Synchronous/Interleaved.hs --- a/src/Test/Syd/Runner/Synchronous/Interleaved.hs +++ b/src/Test/Syd/Runner/Synchronous/Interleaved.hs @@ -26,10 +26,9 @@ runSpecForestInterleavedWithOutputSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestInterleavedWithOutputSynchronously settings testForest = do - tc <- deriveTerminalCapababilities settings let outputLine :: [Chunk] -> IO () outputLine lineChunks = liftIO $ do - putChunksLocaleWith tc lineChunks + putChunksLocaleWith (settingTerminalCapabilities settings) lineChunks TIO.putStrLn "" treeWidth :: Int @@ -44,7 +43,9 @@ liftIO $ outputLine $ pad level line outputLinesR :: [[Chunk]] -> R a () - outputLinesR = mapM_ outputLineR + outputLinesR cs = case settingOutputFormat settings of + OutputFormatPretty -> mapM_ outputLineR cs + OutputFormatTerse -> return () let goForest :: TestForest a () -> R a (Next ResultForest) goForest [] = pure (Continue []) diff --git a/src/Test/Syd/Runner/Synchronous/Separate.hs b/src/Test/Syd/Runner/Synchronous/Separate.hs --- a/src/Test/Syd/Runner/Synchronous/Separate.hs +++ b/src/Test/Syd/Runner/Synchronous/Separate.hs @@ -17,18 +17,19 @@ import Test.Syd.SpecDef import Test.Syd.SpecForest -runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO ResultForest +runSpecForestSynchronously :: Settings -> TestForest '[] () -> IO (Timed ResultForest) runSpecForestSynchronously settings testForest = - extractNext - <$> runReaderT - (goForest testForest) - Env - { eTimeout = settingTimeout settings, - eRetries = settingRetries settings, - eFlakinessMode = MayNotBeFlaky, - eExpectationMode = ExpectPassing, - eExternalResources = HNil - } + timeItT 0 $ + extractNext + <$> runReaderT + (goForest testForest) + Env + { eTimeout = settingTimeout settings, + eRetries = settingRetries settings, + eFlakinessMode = MayNotBeFlaky, + eExpectationMode = ExpectPassing, + eExternalResources = HNil + } where goForest :: forall a. TestForest a () -> R a (Next ResultForest) goForest [] = pure (Continue []) diff --git a/sydtest.cabal b/sydtest.cabal --- a/sydtest.cabal +++ b/sydtest.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest -version: 0.22.0.0 +version: 0.23.0.0 synopsis: A modern testing framework for Haskell with good defaults and advanced testing features. description: A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category: Testing @@ -42,6 +42,9 @@ Test.Syd.Modify Test.Syd.OptParse Test.Syd.Output + Test.Syd.Output.Common + Test.Syd.Output.Pretty + Test.Syd.Output.Terse Test.Syd.Path Test.Syd.ReRun Test.Syd.Run