diff options
| -rw-r--r-- | haddock-test/src/Test/Haddock.hs | 44 | ||||
| -rw-r--r-- | haddock-test/src/Test/Haddock/Config.hs | 4 | ||||
| -rw-r--r-- | haddock-test/src/Test/Haddock/Process.hs | 14 |
3 files changed, 38 insertions, 24 deletions
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 |