diff options
Diffstat (limited to 'test-framework/Test')
| -rw-r--r-- | test-framework/Test/Framework.hs | 61 |
1 files changed, 40 insertions, 21 deletions
diff --git a/test-framework/Test/Framework.hs b/test-framework/Test/Framework.hs index 0eee830..9622686 100644 --- a/test-framework/Test/Framework.hs +++ b/test-framework/Test/Framework.hs @@ -5,6 +5,7 @@ module Test.Framework ( TestTree, testGroup, + testGroupCollapse, testProperty, withResource, withResource', @@ -15,9 +16,10 @@ module Test.Framework ( TestName, ) where -import Control.Monad (forM_) +import Control.Monad (forM) import Control.Monad.Trans.State.Strict import Control.Monad.IO.Class +import Data.Maybe (isJust) import Data.String (fromString) import Data.Time.Clock import System.Exit @@ -32,14 +34,17 @@ import qualified Hedgehog.Internal.Seed as H.Seed data TestTree - = Group String [TestTree] + = Group Bool String [TestTree] | forall a. Resource (IO a) (a -> IO ()) (a -> TestTree) | HP String H.Property type TestName = String testGroup :: String -> [TestTree] -> TestTree -testGroup = Group +testGroup = Group False + +testGroupCollapse :: String -> [TestTree] -> TestTree +testGroupCollapse = Group True -- | The @a -> TestTree@ function must use the @a@ only inside properties: when -- not actually running properties, it will be passed 'undefined'. @@ -57,8 +62,8 @@ computeMaxLen :: TestTree -> Int computeMaxLen = go 0 where go :: Int -> TestTree -> Int - -- go indent (Group name trees) = maximum (2*indent + length name : map (go (indent+1)) trees) - go indent (Group _ trees) = maximum (0 : map (go (indent+1)) trees) + go indent (Group True name trees) = maximum (2*indent + length name : map (go (indent+1)) trees) + go indent (Group False _ trees) = maximum (0 : map (go (indent+1)) trees) go indent (Resource _ _ fun) = go indent (fun undefined) go indent (HP name _) = 2 * indent + length name @@ -83,21 +88,32 @@ runTests :: TestTree -> IO ExitCode runTests = \tree -> do let M m = let ?maxlen = computeMaxLen tree in go 0 tree starttm <- getCurrentTime - stats <- execStateT m initStats + (success, stats) <- runStateT m initStats endtm <- getCurrentTime printStats stats (diffUTCTime endtm starttm) - return (if statsOK stats == statsTotal stats - then ExitSuccess else ExitFailure 1) + return (if isJust success then ExitSuccess else ExitFailure 1) where - go :: (?maxlen :: Int) => Int -> TestTree -> M () - go indent (Group name trees) = do + -- If all tests are successful, returns the number of output lines produced + go :: (?maxlen :: Int) => Int -> TestTree -> M (Maybe Int) + go indent (Group collapse name trees) = do liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name) - forM_ trees $ go (indent + 1) + starttm <- liftIO getCurrentTime + mlns <- fmap (fmap sum . sequence) . forM trees $ go (indent + 1) + endtm <- liftIO getCurrentTime + case mlns of + Just lns | collapse -> do + let thislen = 2*indent + length name + liftIO $ putStrLn $ concat (replicate (lns+1) "\x1B[A\x1B[2K") ++ "\x1B[G" ++ + replicate (2 * indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ' ++ + "\x1B[32mOK\x1B[0m" ++ + prettyDuration False (realToFrac (diffUTCTime endtm starttm)) + return (Just 1) + _ -> return mlns go indent (Resource make cleanup fun) = do value <- liftIO make - go indent (fun value) + success <- go indent (fun value) liftIO $ cleanup value - return () + return success go indent (HP name (H.Property config test)) = do let thislen = 2*indent + length name liftIO $ putStr (replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ') @@ -111,8 +127,10 @@ runTests = \tree -> do liftIO $ printResult report (diffUTCTime endtm starttm) - modifyStats $ \stats -> stats { statsOK = fromEnum (H.reportStatus report == H.OK) + statsOK stats + let ok = H.reportStatus report == H.OK + modifyStats $ \stats -> stats { statsOK = fromEnum ok + statsOK stats , statsTotal = 1 + statsTotal stats } + return (if ok then Just 1 else Nothing) outputProgress :: Int -> H.Report H.Progress -> IO () outputProgress indent report = do @@ -123,26 +141,27 @@ outputProgress indent report = do printResult :: H.Report H.Result -> NominalDiffTime -> IO () printResult report timeTaken = do str <- H.renderResult H.EnableColor (Just (fromString "")) report - if timeTaken >= 0.5 && H.reportStatus report == H.OK - then putStrLn ("\x1B[K" ++ str ++ " (" ++ prettySeconds (realToFrac timeTaken) ++ ")") + if H.reportStatus report == H.OK + then putStrLn ("\x1B[K" ++ str ++ prettyDuration False (realToFrac timeTaken)) else putStrLn ("\x1B[K" ++ str) printStats :: Stats -> NominalDiffTime -> IO () printStats stats timeTaken | statsOK stats == statsTotal stats = do putStrLn $ "\x1B[32mAll " ++ show (statsTotal stats) ++ - " tests passed. (" ++ prettySeconds (realToFrac timeTaken) ++ ")\x1B[0m" + " tests passed." ++ prettyDuration True (realToFrac timeTaken) ++ "\x1B[0m" | otherwise = let nfailed = statsTotal stats - statsOK stats in putStrLn $ "\x1B[31mFailed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++ - " tests. (" ++ prettySeconds (realToFrac timeTaken) ++ ")\x1B[0m" + " tests." ++ prettyDuration True (realToFrac timeTaken) ++ "\x1B[0m" -prettySeconds :: Double -> String -prettySeconds x = +prettyDuration :: Bool -> Double -> String +prettyDuration False x | x < 0.5 = "" +prettyDuration _ x = let str = show (round (x * 100) :: Int) str' = replicate (3 - length str) '0' ++ str (pre, post) = splitAt (length str' - 2) str' - in pre ++ "." ++ post ++ "s" + in " (" ++ pre ++ "." ++ post ++ "s)" replace :: Eq a => a -> [a] -> [a] -> [a] replace x ys = concatMap (\y -> if y == x then ys else [y]) |