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
|
import System.Cmd
import System.Environment
import System.FilePath
import System.Exit
import System.Directory
import System.Process
import Data.List
import Control.Monad
import Text.Printf
import Text.Regex
import Distribution.Simple.Utils
import Distribution.Simple.Program
import Distribution.Verbosity
import Data.Maybe
packageRoot = "."
haddockPath = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock"
testSuiteRoot = packageRoot </> "tests" </> "html-tests"
testDir = testSuiteRoot </> "tests"
outDir = testSuiteRoot </> "output"
main = do
test
putStrLn "All tests passed!"
test = do
x <- doesFileExist haddockPath
when (not x) $ die "you need to run 'cabal build' successfully first"
contents <- getDirectoryContents testDir
args <- getArgs
let (opts, spec) = span ("-" `isPrefixOf`) args
let mods =
case spec of
x:_ | x /= "all" -> [x ++ ".hs"]
_ -> filter ((==) ".hs" . takeExtension) contents
let mods' = map (testDir </>) mods
putStrLn ""
putStrLn "Haddock version: "
h1 <- runProcess haddockPath ["--version"] Nothing
(Just [("haddock_datadir", packageRoot)]) Nothing Nothing Nothing
waitForProcess h1
putStrLn ""
putStrLn "GHC version: "
h2 <- runProcess haddockPath ["--ghc-version"] Nothing
(Just [("haddock_datadir", packageRoot)]) Nothing Nothing Nothing
waitForProcess h2
putStrLn ""
-- TODO: use Distribution.* to get the packages instead
libdir <- rawSystemStdout normal haddockPath ["--print-ghc-libdir"]
let librariesPath = ".."</>".."</>"share"</>"doc"</>"ghc"</>"html"</>"libraries"
let mkDep name version =
let path = init libdir </> librariesPath </> name ++ "-" ++ version
in "-i " ++ path ++ "," ++ path </> name ++ ".haddock"
let base = mkDep "base" "4.3.1.0"
process = mkDep "process" "1.0.1.5"
ghcprim = mkDep "ghc-prim" "0.2.0.0"
putStrLn "Running tests..."
handle <- runProcess haddockPath
(["-w", "-o", outDir, "-h", "--pretty-html", "--optghc=-fglasgow-exts"
, "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
Nothing (Just [("haddock_datadir", packageRoot)]) Nothing
Nothing Nothing
code <- waitForProcess handle
when (code /= ExitSuccess) $ error "Haddock run failed! Exiting."
check mods (if not (null args) && args !! 0 == "all" then False else True)
check modules strict = do
forM_ modules $ \mod -> do
let outfile = outDir </> dropExtension mod ++ ".html"
let reffile = testDir </> dropExtension mod ++ ".html.ref"
b <- doesFileExist reffile
if b
then do
copyFile reffile (outDir </> takeFileName reffile)
out <- readFile outfile
ref <- readFile reffile
if not $ haddockEq out ref
then do
putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:"
let ref' = stripLinks ref
out' = stripLinks out
let reffile' = outDir </> takeFileName reffile ++ ".nolinks"
outfile' = outDir </> takeFileName outfile ++ ".nolinks"
writeFile reffile' ref'
writeFile outfile' out'
b <- programOnPath "colordiff"
if b
then system $ "colordiff " ++ reffile' ++ " " ++ outfile'
else system $ "diff " ++ reffile' ++ " " ++ outfile'
if strict then exitFailure else return ()
else do
putStrLn $ "Pass: " ++ mod
else do
putStrLn $ "Pass: " ++ mod ++ " (no .ref file)"
haddockEq file1 file2 = stripLinks file1 == stripLinks file2
stripLinks f = subRegex (mkRegexWithOpts "<A HREF=[^>]*>" False False) f "<A HREF=\"\">"
programOnPath p = do
result <- findProgramLocation silent p
return (isJust result)
|
