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
|
import Control.Monad
import Data.List
import Data.Maybe
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Simple.Compiler
import Distribution.Simple.GHC
import Distribution.Simple.PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Verbosity
import System.Cmd
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.Process
import Text.Printf
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
unless 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: maybe do something more clever here using haddock.cabal
ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"]
(_, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration
pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf
let safeHead xs = case xs of x : _ -> Just x; [] -> Nothing
let mkDep pkgName =
maybe (error "Couldn't find test dependencies") id $ do
let pkgs = lookupPackageName pkgIndex (PackageName pkgName)
(_, pkgs') <- safeHead pkgs
pkg <- safeHead pkgs'
ifacePath <- safeHead (haddockInterfaces pkg)
htmlPath <- safeHead (haddockHTMLs pkg)
return ("-i " ++ htmlPath ++ "," ++ ifacePath)
let base = mkDep "base"
process = mkDep "process"
ghcprim = mkDep "ghc-prim"
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 str =
let prefix = "<a href=\"" in
case stripPrefix prefix str of
Just str' -> prefix ++ stripLinks (dropWhile (/= '"') str')
Nothing ->
case str of
[] -> []
x : xs -> x : stripLinks xs
programOnPath p = do
result <- findProgramLocation silent p
return (isJust result)
|
