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/Config.hs  |  4 ++--
 haddock-test/src/Test/Haddock/Process.hs | 14 +++++++-------
 2 files changed, 9 insertions(+), 9 deletions(-)

(limited to 'haddock-test/src/Test/Haddock')

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