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
|
{-# 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 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
runHaddock cfg
checkFiles cfg
checkFiles :: Config c -> IO ()
checkFiles cfg@(Config { .. }) = do
putStrLn "Testing output files..."
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
then do
putStrLn "All tests passed!"
exitSuccess
else do
maybeDiff cfg failed
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
runHaddock :: Config c -> IO ()
runHaddock cfg@(Config { .. }) = do
haddockStdOut <- openFile cfgHaddockStdOut WriteMode
createEmptyDirectory $ cfgOutDir cfg
putStrLn "Generating documentation..."
forM_ cfgPackages $ \tpkg -> do
handle <- runProcess' cfgHaddockPath $ processConfig
{ pcArgs = concat
[ cfgHaddockArgs
, pure $ "--odir=" ++ outDir cfgDirConfig tpkg
, tpkgFiles tpkg
]
, pcEnv = Just $ cfgEnv
, pcStdOut = Just $ haddockStdOut
}
waitForSuccess "Failed to run Haddock on specified test files" handle
checkFile :: Config c -> FilePath -> IO CheckResult
checkFile cfg file = do
hasRef <- doesFileExist $ refFile dcfg file
if hasRef
then do
mout <- ccfgRead ccfg file <$> readFile (outFile dcfg file)
mref <- ccfgRead ccfg file <$> readFile (refFile dcfg 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
diffFile :: Config c -> FilePath -> FilePath -> IO ()
diffFile cfg diff file = do
Just out <- ccfgRead ccfg file <$> readFile (outFile dcfg file)
Just ref <- ccfgRead ccfg file <$> readFile (refFile dcfg 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@(Config { cfgDirConfig = dcfg }) file result
| cfgAccept cfg && result `elem` [NoRef, Fail] = do
copyFile (outFile dcfg file) (refFile dcfg file)
pure Accepted
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
|
