diff options
Diffstat (limited to 'haddock-test/src/Test')
| -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 | 
