1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
{-# 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
|
