blob: 1019e815e2d3051dad01283971511f351bf84057 (
plain) (
tree)
|
|
{-# LANGUAGE RecordWildCards #-}
module Test.Haddock
( module Test.Haddock.Config
, runAndCheck, runHaddock, checkFiles
) where
import Control.Monad
import Data.Maybe
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Process
import qualified Data.ByteString.Char8 as BS
import Test.Haddock.Config
import Test.Haddock.Process
import Test.Haddock.Utils
data CheckResult
= Fail
| Pass
| NoRef
| Error String
| Accepted
deriving Eq
runAndCheck :: Config c -> IO ()
runAndCheck cfg = do
crashed <- runHaddock cfg
checkFiles cfg crashed
checkFiles :: Config c -> Bool -> IO ()
checkFiles cfg@(Config { .. }) somethingCrashed = do
putStrLn "Testing output files..."
createDirectoryIfMissing True (cfgOutDir cfg)
files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
failed <- liftM catMaybes . forM files $ \file -> do
putStr $ "Checking \"" ++ file ++ "\"... "
status <- maybeAcceptFile cfg file =<< checkFile cfg file
case status of
Fail -> putStrLn "FAIL" >> (return $ Just file)
Pass -> putStrLn "PASS" >> (return Nothing)
NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
Accepted -> putStrLn "ACCEPTED" >> return Nothing
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)
maybeDiff :: Config c -> [FilePath] -> IO ()
maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
putStrLn "Diffing failed cases..."
forM_ files $ diffFile cfg diff
-- | 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..."
successes <- forM cfgPackages $ \tpkg -> do
haddockStdOut <- openFile cfgHaddockStdOut WriteMode
let pc = processConfig
{ pcArgs = concat
[ cfgHaddockArgs
, pure $ "--odir=" ++ outDir cfgDirConfig tpkg
, tpkgFiles tpkg
]
, pcEnv = Just $ cfgEnv
, pcStdOut = Just $ haddockStdOut
, pcStdErr = Just $ haddockStdOut
}
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
checkFile cfg file = do
hasRef <- doesFileExist $ refFile dcfg file
if hasRef
then do
mout <- readOut cfg file
mref <- readRef cfg file
return $ case (mout, mref) of
(Just out, Just ref)
| ccfgEqual ccfg out ref -> Pass
| otherwise -> Fail
_ -> Error "Failed to parse input files"
else return NoRef
where
ccfg = cfgCheckConfig cfg
dcfg = cfgDirConfig cfg
-- We use ByteString here to ensure that no lazy I/O is performed.
-- This way to ensure that the reference file isn't held open in
-- case after `diffFile` (which is problematic if we need to rewrite
-- the reference file in `maybeAcceptFile`)
-- | Read the reference artifact for a test
readRef :: Config c -> FilePath -> IO (Maybe c)
readRef cfg file =
ccfgRead ccfg . BS.unpack
<$> BS.readFile (refFile dcfg file)
where
ccfg = cfgCheckConfig cfg
dcfg = cfgDirConfig cfg
-- | Read (and clean) the test output artifact for a test
readOut :: Config c -> FilePath -> IO (Maybe c)
readOut cfg file =
fmap (ccfgClean ccfg file) . ccfgRead ccfg . BS.unpack
<$> BS.readFile (outFile dcfg file)
where
ccfg = cfgCheckConfig cfg
dcfg = cfgDirConfig cfg
diffFile :: Config c -> FilePath -> FilePath -> IO ()
diffFile cfg diff file = do
Just out <- readOut cfg file
Just ref <- readRef cfg file
writeFile outFile' $ ccfgDump ccfg out
writeFile refFile' $ ccfgDump ccfg ref
putStrLn $ "Diff for file \"" ++ file ++ "\":"
hFlush stdout
handle <- runProcess' diff $ processConfig
{ pcArgs = [outFile', refFile']
, pcStdOut = Just $ stdout
}
waitForProcess handle >> return ()
where
dcfg = cfgDirConfig cfg
ccfg = cfgCheckConfig cfg
outFile' = outFile dcfg file <.> "dump"
refFile' = outFile dcfg file <.> "ref" <.> "dump"
maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult
maybeAcceptFile cfg file result
| cfgAccept cfg && result `elem` [NoRef, Fail] = do
Just out <- readOut cfg file
let ref = refFile dcfg file
createDirectoryIfMissing True (takeDirectory ref)
writeFile ref $ ccfgDump ccfg out
pure Accepted
where
dcfg = cfgDirConfig cfg
ccfg = cfgCheckConfig cfg
maybeAcceptFile _ _ result = pure result
outDir :: DirConfig -> TestPackage -> FilePath
outDir dcfg tpkg = dcfgOutDir dcfg </> tpkgName tpkg
outFile :: DirConfig -> FilePath -> FilePath
outFile dcfg file = dcfgOutDir dcfg </> file
refFile :: DirConfig -> FilePath -> FilePath
refFile dcfg file = dcfgRefDir dcfg </> file
|