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
|
#!/usr/bin/env runhaskell
\begin{code}
{-# LANGUAGE CPP #-}
import Prelude hiding (mod)
import Control.Monad
import Control.Applicative
import Data.List
import Data.Maybe
import Distribution.InstalledPackageInfo
import Distribution.Package (PackageName (..))
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.IO
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.Process (ProcessHandle, runProcess, waitForProcess, system)
packageRoot, dataDir, haddockPath, baseDir, testDir, outDir, refDir :: FilePath
baseDir = takeDirectory __FILE__
testDir = baseDir </> "src"
refDir = baseDir </> "ref"
outDir = baseDir </> "out"
packageRoot = baseDir </> ".."
dataDir = packageRoot </> "resources"
haddockPath = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock"
main :: IO ()
main = do
test
putStrLn "All tests passed!"
test :: IO ()
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
isDir x' = liftM2 (&&) (doesDirectoryExist $ testDir </> x')
(return $ x' /= "." && x' /= "..")
modDirs <- case spec of
y:_ | y /= "all" -> return [y]
_ -> filterM isDir contents
let modDirs' = map (testDir </>) modDirs
-- add haddock_datadir to environment for subprocesses
env <- Just . (:) ("haddock_datadir", dataDir) <$> getEnvironment
putStrLn ""
putStrLn "Haddock version: "
h1 <- runProcess haddockPath ["--version"] Nothing
env Nothing Nothing Nothing
wait h1 "*** Running `haddock --version' failed!"
putStrLn ""
putStrLn "GHC version: "
h2 <- runProcess haddockPath ["--ghc-version"] Nothing
env Nothing Nothing Nothing
wait h2 "*** Running `haddock --ghc-version' failed!"
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 mkDep pkgName =
fromMaybe (error "Couldn't find test dependencies") $ do
let pkgs = lookupPackageName pkgIndex (PackageName pkgName)
(_, pkgs') <- listToMaybe pkgs
pkg <- listToMaybe pkgs'
ifacePath <- listToMaybe (haddockInterfaces pkg)
htmlPath <- listToMaybe (haddockHTMLs pkg)
return ("-i " ++ htmlPath ++ "," ++ ifacePath)
let base = mkDep "base"
process = mkDep "process"
ghcprim = mkDep "ghc-prim"
putStrLn "Running tests..."
forM_ modDirs' $ \modDir -> do
testModules <- getDirectoryContents modDir
let mods = filter ((==) ".hs" . takeExtension) testModules
mods' = map (modDir </>) mods
unless (null mods') $ do
handle <- runProcess haddockPath
(["-w", "-o", outDir </> last (splitPath modDir), "--latex"
, "--optghc=-fglasgow-exts"
, "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
Nothing env Nothing
Nothing Nothing
wait handle "*** Haddock run failed! Exiting."
check modDirs (if not (null args) && args !! 0 == "all" then False else True)
where
wait :: ProcessHandle -> String -> IO ()
wait h msg = do
r <- waitForProcess h
unless (r == ExitSuccess) $ do
hPutStrLn stderr msg
exitFailure
check :: [FilePath] -> Bool -> IO ()
check modDirs strict = do
forM_ modDirs $ \modDir -> do
let oDir = outDir </> modDir
rDir = refDir </> modDir
refDirExists <- doesDirectoryExist rDir
when refDirExists $ do
-- we're not creating sub-directories, I think.
refFiles <- getDirectoryContents rDir >>= filterM doesFileExist
forM_ refFiles $ \rFile -> do
let refFile = rDir </> rFile
outFile = oDir </> rFile
oe <- doesFileExist outFile
if oe
then do
out <- readFile outFile
ref <- readFile refFile
if out /= ref
then do
putStrLn $ "Output for " ++ modDir ++ " has changed! Exiting with diff:"
let reffile' = outDir </> takeFileName refFile ++ ".nolinks"
outfile' = outDir </> takeFileName outFile ++ ".ref.nolinks"
writeFile reffile' ref
writeFile outfile' out
r <- programOnPath "colordiff"
code <- if r
then system $ "colordiff " ++ reffile' ++ " " ++ outfile'
else system $ "diff " ++ reffile' ++ " " ++ outfile'
if strict then exitFailure else return ()
unless (code == ExitSuccess) $ do
hPutStrLn stderr "*** Running diff failed!"
exitFailure
else do
putStrLn $ "Pass: " ++ modDir
else do
putStrLn $ "Pass: " ++ modDir ++ " (no .ref file)"
programOnPath :: FilePath -> IO Bool
programOnPath p = do
result <- findProgramLocation silent p
return (isJust result)
\end{code}
|
