diff options
| -rw-r--r-- | src/Main.hs | 12 | ||||
| -rw-r--r-- | src/Output.hs | 13 | ||||
| -rw-r--r-- | src/Run.hs | 62 |
3 files changed, 54 insertions, 33 deletions
diff --git a/src/Main.hs b/src/Main.hs index 8c50bce..88fa4ba 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,6 +8,7 @@ import Data.Maybe import Data.Text (Text) import Data.Text qualified as T +import Text.Printf import Text.Read (readMaybe) import System.Console.GetOpt @@ -218,20 +219,23 @@ main = do Report {..} <- runTests out topts lmGlobalDefs tests when (optReport opts) $ flip runReaderT out $ do - outLineF OutputGlobalSummary Nothing $ "Total: " <> plainText (T.pack (show reportTotalCount)) + outLineF OutputGlobalSummary Nothing $ "Total tests: " <> plainText (T.pack (show reportTotalCount)) + let ( mins, secs ) = (floor reportTotalTime :: Integer) `quotRem` 60 + csecs = floor (reportTotalTime * 100) `rem` 100 :: Integer + outLineF OutputGlobalSummary Nothing $ "Total time: " <> plainText (T.pack $ printf "%d:%02d.%02d" mins secs csecs) outLineF OutputGlobalSummary Nothing $ mconcat - [ "Passed: " + [ "Passed tests: " , withStyle (if (reportPassedCount > 0) then setForegroundColor Green noStyle else noStyle) $ plainText $ T.pack $ show reportPassedCount ] outLineF OutputGlobalSummary Nothing $ mconcat - [ "Failed: " + [ "Failed tests: " , withStyle (if (reportFailedCount > 0) then setForegroundColor Red noStyle else noStyle) $ plainText (T.pack (show reportFailedCount)) ] when (reportFailedCount > 0) $ do outLine OutputGlobalSummary Nothing "" - outLineF OutputGlobalSummary Nothing $ withStyle (setForegroundColor BrightRed noStyle) $ "Failing tests:" + outLineF OutputGlobalSummary Nothing $ withStyle (setForegroundColor BrightRed noStyle) $ "Failed tests:" forM_ reportFailedList $ \tname -> do outLineF OutputGlobalSummary Nothing $ withStyle (setForegroundColor Red noStyle) $ diff --git a/src/Output.hs b/src/Output.hs index b28ad5c..962a594 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -3,6 +3,7 @@ module Output ( MonadOutput(..), startOutput, resetOutputTime, + getElapsedTime, outLine, outLineF, outPromptGetLine, @@ -14,6 +15,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader +import Data.Scientific import Data.Text (Text) import Data.Text qualified as T import Data.Text.Lazy qualified as TL @@ -89,6 +91,12 @@ resetOutputTime :: Output -> IO () resetOutputTime Output {..} = do modifyMVar_ outStartedAt . const $ getTime Monotonic +getElapsedTime :: Output -> IO Scientific +getElapsedTime Output {..} = do + stime <- readMVar outStartedAt + (/ 1000000000) . fromIntegral . toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic + + outColor :: OutputType -> Text outColor = \case OutputGlobalInfo -> "0" @@ -185,13 +193,12 @@ outLineF otype prompt line = ioWithOutput $ \out -> OutputStyleTest -> testOutput out where normalOutput out = do - stime <- readMVar (outStartedAt out) - nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic + secs <- getElapsedTime out withMVar (outState out) $ \st -> do forM_ (normalOutputLines otype $ renderLine out line) $ \line' -> do outPrint st $ TL.fromChunks $ concat [ if includeTestTime otype - then [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ] + then [ T.pack $ printf "[% 2d.%03d] " (floor secs :: Integer) (floor (secs * 1000) `rem` 1000 :: Integer) ] else [] , if outUseColor (outConfig out) then [ T.pack "\ESC[", outColor otype, T.pack "m" ] @@ -1,6 +1,6 @@ module Run ( module Run.Monad, - Report(..), + Report(..), SingleTestReport(..), TestName, textTestName, runTests, runTest, @@ -67,19 +67,14 @@ data Report = Report , reportSkippedCount :: Int , reportFailedCount :: Int , reportFailedList :: [ TestName ] + , reportTotalTime :: Scientific + , reportTests :: [ SingleTestReport ] } -reportPassed :: Report -> Report -reportPassed r = r - { reportTotalCount = reportTotalCount r + 1 - , reportPassedCount = reportPassedCount r + 1 - } - -reportFailed :: TestName -> Report -> Report -reportFailed tname r = r - { reportTotalCount = reportTotalCount r + 1 - , reportFailedCount = reportFailedCount r + 1 - , reportFailedList = tname : reportFailedList r +data SingleTestReport = SingleTestReport + { reportTestName :: TestName + , reportTestFailed :: Maybe Failed + , reportTime :: Scientific } runTests :: Output -> TestOptions -> GlobalDefs -> [ Test ] -> IO Report @@ -87,21 +82,34 @@ runTests out opts gdefs tests = do go $ concat $ replicate (optRepeat opts) tests where go (t : ts) = do - runTest out opts gdefs t >>= \case - True -> reportPassed <$> go ts - False -> reportFailed (testName t) <$> if - | optKeepGoing opts -> go ts - | otherwise -> go [] + single <- runTest out opts gdefs t + let failed = isJust (reportTestFailed single) + r <- if + | failed && not (optKeepGoing opts) + -> go [] + | otherwise + -> go ts + return Report + { reportTotalCount = 1 + reportTotalCount r + , reportPassedCount = (if failed then 0 else 1) + reportPassedCount r + , reportSkippedCount = reportSkippedCount r + , reportFailedCount = (if failed then 1 else 0) + reportFailedCount r + , reportFailedList = (if failed then (reportTestName single :) else id) $ reportFailedList r + , reportTotalTime = reportTime single + reportTotalTime r + , reportTests = single : reportTests r + } go [] = return Report { reportTotalCount = 0 , reportPassedCount = 0 , reportSkippedCount = 0 , reportFailedCount = 0 , reportFailedList = [] + , reportTotalTime = 0 + , reportTests = [] } -runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO Bool +runTest :: Output -> TestOptions -> GlobalDefs -> Test -> IO SingleTestReport runTest out opts gdefs test = do let testDir = optTestDir opts </> T.unpack (textTestName $ testName test) when (optForce opts) $ removeDirectoryRecursive testDir `catchIOError` \e -> @@ -159,12 +167,12 @@ runTest out opts gdefs test = do Stopped sig -> err $ T.pack $ "child stopped with signal " ++ show sig oldHandler <- installHandler processStatusChanged (CatchInfo sigHandler) Nothing - resetOutputTime out - testRunResult <- newEmptyMVar - flip runReaderT out $ do void $ outLine OutputGlobalInfo Nothing $ "Starting test ‘" <> textTestName (testName test) <> "’" + resetOutputTime out + testRunResult <- newEmptyMVar + void $ forkOS $ do isolateFilesystem testDir >>= \case True -> do @@ -178,6 +186,7 @@ runTest out opts gdefs test = do putMVar testRunResult ( Left Failed, [] ) ( res, [] ) <- takeMVar testRunResult + reportTime <- getElapsedTime out void $ installHandler processStatusChanged oldHandler Nothing @@ -186,17 +195,18 @@ runTest out opts gdefs test = do [] <- readMVar procVar failed <- atomically $ readTVar (teFailed tenv) - fres <- case ( res, failed ) of + reportTestFailed <- case ( res, failed ) of ( Right (), Nothing ) -> do when (not $ optKeep opts) $ removeDirectoryRecursive testDir - return True + return Nothing _ -> do flip runReaderT out $ do void $ outLine OutputGlobalError Nothing $ "Test ‘" <> textTestName (testName test) <> "’ failed." - return False + return $ either Just (const Nothing) res `mplus` failed - (optHookTestResult opts) (testName test) fres - return fres + (optHookTestResult opts) (testName test) (isNothing reportTestFailed) + let reportTestName = testName test + return SingleTestReport {..} data LoadedModules = LoadedModules |