From d25a4f1ec834fa69663a50a6963476e8b3576d1a Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Tue, 21 Aug 2018 00:42:52 -0700
Subject: Better test output when Haddock crashes on a test (#902)

In particular: we report the tests that crashed seperately from the tests
that produced incorrect output. In order for tests to pass (and exit 0),
they must not crash and must produce the right output.
---
 haddock-test/src/Test/Haddock.hs         | 44 +++++++++++++++++++++-----------
 haddock-test/src/Test/Haddock/Config.hs  |  4 +--
 haddock-test/src/Test/Haddock/Process.hs | 14 +++++-----
 3 files changed, 38 insertions(+), 24 deletions(-)

(limited to 'haddock-test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 942c0587..25c64cfe 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -34,12 +34,12 @@ data CheckResult
 
 runAndCheck :: Config c -> IO ()
 runAndCheck cfg = do
-    runHaddock cfg
-    checkFiles cfg
+    crashed <- runHaddock cfg
+    checkFiles cfg crashed
 
 
-checkFiles :: Config c -> IO ()
-checkFiles cfg@(Config { .. }) = do
+checkFiles :: Config c -> Bool -> IO ()
+checkFiles cfg@(Config { .. }) somethingCrashed = do
     putStrLn "Testing output files..."
 
     files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
@@ -54,13 +54,14 @@ checkFiles cfg@(Config { .. }) = do
             Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
             Accepted -> putStrLn "ACCEPTED" >> return Nothing
 
-    if null failed
-        then do
-            putStrLn "All tests passed!"
-            exitSuccess
-        else do
-            maybeDiff cfg failed
-            exitFailure
+    if (null failed && not somethingCrashed)
+      then do
+          putStrLn "All tests passed!"
+          exitSuccess
+      else do
+          unless (null failed) $ maybeDiff cfg failed
+          when somethingCrashed $ putStrLn "Some tests crashed."
+          exitFailure
   where
     ignore = filter (not . dcfgCheckIgnore cfgDirConfig)
 
@@ -72,12 +73,14 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
     forM_ files $ diffFile cfg diff
 
 
-runHaddock :: Config c -> IO ()
+-- | Runs Haddock on all of the test packages, and returns whether 'True' if
+-- any of them caused Haddock to crash.
+runHaddock :: Config c -> IO Bool
 runHaddock cfg@(Config { .. }) = do
     createEmptyDirectory $ cfgOutDir cfg
 
     putStrLn "Generating documentation..."
-    forM_ cfgPackages $ \tpkg -> do
+    successes <- forM cfgPackages $ \tpkg -> do
         haddockStdOut <- openFile cfgHaddockStdOut WriteMode
         let pc = processConfig
                     { pcArgs = concat
@@ -87,9 +90,20 @@ runHaddock cfg@(Config { .. }) = do
                         ]
                     , pcEnv = Just $ cfgEnv
                     , pcStdOut = Just $ haddockStdOut
+                    , pcStdErr = Just $ haddockStdOut
                     }
-        handle <- runProcess' cfgHaddockPath pc
-        waitForSuccess "Failed to run Haddock on specified test files" handle
+
+        let msg = "Failed to run Haddock on test package '" ++ tpkgName tpkg ++ "'"
+        succeeded <- waitForSuccess msg stdout =<< runProcess' cfgHaddockPath pc
+        unless succeeded $ removeDirectoryRecursive (outDir cfgDirConfig tpkg)
+
+        pure succeeded
+
+    let somethingFailed = any not successes
+    when somethingFailed $
+      putStrLn ("Haddock output is at '" ++ cfgHaddockStdOut ++ "'. " ++
+                "This file can be set with `--haddock-stdout`.")
+    pure somethingFailed
 
 
 checkFile :: Config c -> FilePath -> IO CheckResult
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 68f6b867..6447361f 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -224,13 +224,13 @@ printVersions env haddockPath = do
         { pcEnv = Just env
         , pcArgs = ["--version"]
         }
-    waitForSuccess "Failed to run `haddock --version`" handleHaddock
+    void $ waitForSuccess "Failed to run `haddock --version`" stderr handleHaddock
 
     handleGhc <- runProcess' haddockPath $ processConfig
         { pcEnv = Just env
         , pcArgs = ["--ghc-version"]
         }
-    waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc
+    void $ waitForSuccess "Failed to run `haddock --ghc-version`" stderr handleGhc
 
 
 baseDependencies :: FilePath -> IO [String]
diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs
index 52bf9533..a6cab9ac 100644
--- a/haddock-test/src/Test/Haddock/Process.hs
+++ b/haddock-test/src/Test/Haddock/Process.hs
@@ -40,10 +40,10 @@ runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle
 runProcess' path (ProcessConfig { .. }) = runProcess
     path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr
 
-
-waitForSuccess :: String -> ProcessHandle -> IO ()
-waitForSuccess msg handle = do
-    result <- waitForProcess handle
-    unless (result == ExitSuccess) $ do
-        hPutStrLn stderr $ msg
-        exitFailure
+-- | Wait for a process to finish running. If it ends up failing, print out the
+-- error message.
+waitForSuccess :: String -> Handle -> ProcessHandle -> IO Bool
+waitForSuccess msg out handle = do
+    succeeded <- fmap (== ExitSuccess) $ waitForProcess handle
+    unless succeeded $ hPutStrLn out msg
+    pure succeeded
-- 
cgit v1.2.3