test-framework: Even more compact output with testGroupCollapse

2 files changed, 41 insertions, 22 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])
diff --git a/test/Main.hs b/test/Main.hs
index 1ad7f75..52bdbd0 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -209,7 +209,7 @@ adTestGen name expr envGenerator =
   in
   withCompiled env expr $ \primalfun ->
   withCompiled env (simplifyFix expr) $ \primalSfun ->
-  testGroup name
+  testGroupCollapse name
     [testProperty "compile primal" $ property $ do
        input <- forAllWith (showEnv env) envGenerator