test-framework: Behave decently when output is not a tty

1 files changed, 36 insertions, 24 deletions

diff --git a/test-framework/Test/Framework.hs b/test-framework/Test/Framework.hs
index e83d0de..7380df1 100644
--- a/test-framework/Test/Framework.hs
+++ b/test-framework/Test/Framework.hs
@@ -18,7 +18,7 @@ module Test.Framework (
   TestName,
 ) where
 
-import Control.Monad (forM)
+import Control.Monad (forM, when)
 import Control.Monad.Trans.State.Strict
 import Control.Monad.IO.Class
 import Data.List (isInfixOf, intercalate)
@@ -27,7 +27,7 @@ import Data.String (fromString)
 import Data.Time.Clock
 import System.Environment
 import System.Exit
-import System.IO (hFlush, hPutStrLn, stdout, stderr)
+import System.IO (hFlush, hPutStrLn, stdout, stderr, hIsTerminalDevice)
 import Text.Read (readMaybe)
 
 import qualified Hedgehog as H
@@ -158,23 +158,26 @@ runTests options = \tree' ->
     Nothing -> do hPutStrLn stderr "No tests matched the given pattern."
                   return (ExitFailure 1)
     Just tree -> do
-      let M m = let ?maxlen = computeMaxLen tree in go 0 id tree
+      isterm <- hIsTerminalDevice stdout
+      let M m = let ?maxlen = computeMaxLen tree
+                    ?istty = isterm
+                in go 0 id tree
       starttm <- getCurrentTime
       (success, stats) <- runStateT m initStats
       endtm <- getCurrentTime
-      printStats stats (diffUTCTime endtm starttm)
+      let ?istty = isterm in printStats stats (diffUTCTime endtm starttm)
       return (if isJust success then ExitSuccess else ExitFailure 1)
   where
     -- If all tests are successful, returns the number of output lines produced
-    go :: (?maxlen :: Int) => Int -> (String -> String) -> TestTree -> M (Maybe Int)
+    go :: (?maxlen :: Int, ?istty :: Bool) => Int -> (String -> String) -> TestTree -> M (Maybe Int)
     go indent path (Group collapse name trees) = do
-      liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name)
+      liftIO $ putStrLn (replicate (2 * indent) ' ' ++ name) >> hFlush stdout
       starttm <- liftIO getCurrentTime
       mlns <- fmap (fmap sum . sequence) . forM trees $
                 go (indent + 1) (path . (name++) . ('/':))
       endtm <- liftIO getCurrentTime
       case mlns of
-        Just lns | collapse -> do
+        Just lns | collapse, ?istty -> 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) ' ' ++
@@ -189,8 +192,8 @@ runTests options = \tree' ->
       return success
     go indent path (HP name (H.Property config test)) = do
       let thislen = 2*indent + length name
-      liftIO $ putStr (replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ')
-      liftIO $ hFlush stdout
+      let outputPrefix = replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' '
+      when ?istty $ liftIO $ putStr outputPrefix >> hFlush stdout
 
       (config', seed) <- case optsHedgehogReplay options of
                            Just (skip, seed) -> return (config { H.propertySkip = Just skip }, seed)
@@ -200,41 +203,46 @@ runTests options = \tree' ->
       report <- liftIO $ H.checkReport config' 0 seed test (outputProgress (?maxlen + 2))
       endtm <- liftIO getCurrentTime
 
-      liftIO $ printResult report (path name) (diffUTCTime endtm starttm)
+      liftIO $ do
+        when (not ?istty) $ putStr outputPrefix
+        printResult report (path name) (diffUTCTime endtm starttm)
+        hFlush stdout
 
       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
-  str <- H.renderProgress H.EnableColor (Just (fromString "")) report
-  putStr (replace '\n' "  " str ++ "\x1B[" ++ show (indent+1) ++ "G")
-  hFlush stdout
+outputProgress :: (?istty :: Bool) => Int -> H.Report H.Progress -> IO ()
+outputProgress indent report
+  | ?istty = do
+      str <- H.renderProgress H.EnableColor (Just (fromString "")) report
+      putStr (replace '\n' "  " str ++ "\x1B[" ++ show (indent+1) ++ "G")
+      hFlush stdout
+  | otherwise = return ()
 
-printResult :: H.Report H.Result -> String -> NominalDiffTime -> IO ()
+printResult :: (?istty :: Bool) => H.Report H.Result -> String -> NominalDiffTime -> IO ()
 printResult report path timeTaken = do
   str <- H.renderResult H.EnableColor (Just (fromString "")) report
   case H.reportStatus report of
-    H.OK -> putStrLn ("\x1B[K" ++ str ++ prettyDuration False (realToFrac timeTaken))
+    H.OK -> putStrLn (ansi "\x1B[K" ++ str ++ prettyDuration False (realToFrac timeTaken))
     H.Failed failure -> do
       let H.Report { H.reportTests = count, H.reportDiscards = discards } = report
           replayInfo = H.skipCompress (H.SkipToShrink count discards (H.failureShrinkPath failure)) ++
                        " " ++ show (H.reportSeed report)
           suffix = "\n    Flags to reproduce: `-p '" ++ path ++ "' --hedgehog-replay '" ++ replayInfo ++ "'`"
-      putStrLn ("\x1B[K" ++ str ++ suffix)
-    _ -> putStrLn ("\x1B[K" ++ str)
+      putStrLn (ansi "\x1B[K" ++ str ++ suffix)
+    _ -> putStrLn (ansi "\x1B[K" ++ str)
 
-printStats :: Stats -> NominalDiffTime -> IO ()
+printStats :: (?istty :: Bool) => Stats -> NominalDiffTime -> IO ()
 printStats stats timeTaken
   | statsOK stats == statsTotal stats = do
-      putStrLn $ "\x1B[32mAll " ++ show (statsTotal stats) ++
-                 " tests passed." ++ prettyDuration True (realToFrac timeTaken) ++ "\x1B[0m"
+      putStrLn $ ansi "\x1B[32m" ++ "All " ++ show (statsTotal stats) ++
+                 " tests passed." ++ prettyDuration True (realToFrac timeTaken) ++ ansi "\x1B[0m"
   | otherwise =
       let nfailed = statsTotal stats - statsOK stats
-      in putStrLn $ "\x1B[31mFailed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++
-                    " tests." ++ prettyDuration True (realToFrac timeTaken) ++ "\x1B[0m"
+      in putStrLn $ ansi "\x1B[31m" ++ "Failed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++
+                    " tests." ++ prettyDuration True (realToFrac timeTaken) ++ ansi "\x1B[0m"
 
 prettyDuration :: Bool -> Double -> String
 prettyDuration False x | x < 0.5 = ""
@@ -246,3 +254,7 @@ prettyDuration _ x =
 
 replace :: Eq a => a -> [a] -> [a] -> [a]
 replace x ys = concatMap (\y -> if y == x then ys else [y])
+
+ansi :: (?istty :: Bool) => String -> String
+ansi | ?istty = id
+     | otherwise = const ""