blob: 5b6b6548f2304d4e319fb40c511173d1fe0b253a (
plain) (
blame)
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
|
#!/usr/bin/env runhaskell
{-# LANGUAGE CPP #-}
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import System.IO
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.Process
import Distribution.Verbosity
import Distribution.Simple.Utils hiding (die)
import Utils
baseDir, rootDir :: FilePath
baseDir = takeDirectory __FILE__
rootDir = baseDir </> ".."
srcDir, refDir, outDir, refDir', outDir' :: FilePath
srcDir = baseDir </> "src"
refDir = baseDir </> "ref"
outDir = baseDir </> "out"
refDir' = refDir </> "src"
outDir' = outDir </> "src"
haddockPath :: FilePath
haddockPath = rootDir </> "dist" </> "build" </> "haddock" </> "haddock"
main :: IO ()
main = do
haddockAvailable <- doesFileExist haddockPath
unless haddockAvailable $ die "Haddock exectuable not available"
(args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs
let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args
mods' <- map (srcDir </>) <$> case args of
[] -> getAllSrcModules
_ -> return $ map (++ ".hs") mods
putHaddockVersion
putGhcVersion
putStrLn "Running tests..."
runHaddock $
[ "--odir=" ++ outDir
, "--no-warnings"
, "--hyperlinked-source"
, "--pretty-html"
] ++ args' ++ mods'
forM_ mods' $ check True
check :: Bool -> FilePath -> IO ()
check strict mdl = do
hasReference <- doesFileExist refFile
if hasReference
then do
ref <- readFile refFile
out <- readFile outFile
compareOutput strict mdl ref out
else do
putStrLn $ "Pass: " ++ mdl ++ " (no reference file)"
where
refFile = refDir' </> takeBaseName mdl ++ ".html"
outFile = outDir' </> takeBaseName mdl ++ ".html"
compareOutput :: Bool -> FilePath -> String -> String -> IO ()
compareOutput strict mdl ref out = do
if ref' == out'
then putStrLn $ "Pass: " ++ mdl
else do
putStrLn $ "Fail: " ++ mdl
diff mdl ref' out'
when strict $ die "Aborting further tests."
where
ref' = stripLocalReferences ref
out' = stripLocalReferences out
diff :: FilePath -> String -> String -> IO ()
diff mdl ref out = do
colorDiffPath <- findProgramLocation silent "colordiff"
let cmd = fromMaybe "diff" colorDiffPath
writeFile refFile ref
writeFile outFile out
result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile
unless (result == ExitSuccess) $ die "Failed to run `diff` command."
where
refFile = outDir </> takeFileName mdl </> ".ref.nolinks"
outFile = outDir </> takeFileName mdl </> ".nolinks"
getAllSrcModules :: IO [FilePath]
getAllSrcModules =
filter isValid <$> getDirectoryContents srcDir
where
isValid = (== ".hs") . takeExtension
putHaddockVersion :: IO ()
putHaddockVersion = do
putStrLn "Haddock version:"
runHaddock ["--version"]
putStrLn ""
putGhcVersion :: IO ()
putGhcVersion = do
putStrLn "GHC version:"
runHaddock ["--ghc-version"]
putStrLn ""
runHaddock :: [String] -> IO ()
runHaddock args = do
env <- Just <$> getEnvironment
handle <- runProcess haddockPath args Nothing env Nothing Nothing Nothing
waitForSuccess handle $ "Failed to invoke haddock with " ++ show args
waitForSuccess :: ProcessHandle -> String -> IO ()
waitForSuccess handle msg = do
result <- waitForProcess handle
unless (result == ExitSuccess) $ die msg
|
