#!/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 :: 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 $ System.Exit.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
y:_ | y /= "all" -> [y ++ ".hs"]
_ -> filter ((==) ".hs" . takeExtension) contents
let mods' = map (testDir </>) mods
-- add haddock_datadir to environment for subprocesses
env <- Just . (:) ("haddock_datadir", Main.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..."
handle <- runProcess haddockPath
(["-w", "-o", outDir, "-h", "--pretty-html"
, "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
Nothing env Nothing
Nothing Nothing
wait handle "*** Haddock run failed! Exiting."
check mods (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 modules strict = do
forM_ modules $ \mod -> do
let outfile = outDir </> dropExtension mod ++ ".html"
let reffile = refDir </> dropExtension mod ++ ".html"
b <- doesFileExist reffile
if b
then do
out <- readFile outfile
ref <- readFile reffile
if not $ haddockEq (outfile, out) (reffile, ref)
then do
putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:"
let ref' = maybeStripLinks outfile ref
out' = maybeStripLinks reffile out
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: " ++ mod
else do
putStrLn $ "Pass: " ++ mod ++ " (no .ref file)"
-- | List of modules in which we don't 'stripLinks'
preserveLinksModules :: [String]
preserveLinksModules = map (++ ".html") ["Bug253"]
-- | A rather nasty way to drop the Haddock version string from the
-- end of the generated HTML files so that we don't have to change
-- every single test every time we change versions. We rely on the the
-- last paragraph of the document to be the version. We end up with
-- malformed HTML but we don't care as we never look at it ourselves.
dropVersion :: String -> String
dropVersion = reverse . dropTillP . reverse
where
dropTillP [] = []
dropTillP ('p':'<':xs) = xs
dropTillP (_:xs) = dropTillP xs
haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool
haddockEq (fn1, file1) (fn2, file2) =
maybeStripLinks fn1 (dropVersion file1)
== maybeStripLinks fn2 (dropVersion file2)
maybeStripLinks :: String -- ^ Module we're considering for stripping
-> String -> String
maybeStripLinks m = if any (`isSuffixOf` m) preserveLinksModules
then id
else stripLinks
stripLinks :: String -> String
stripLinks str =
let prefix = "<a href=\"" in
case stripPrefix prefix str of
Just str' -> case dropWhile (/= '>') (dropWhile (/= '"') str') of
[] -> []
x:xs -> stripLinks (stripHrefEnd xs)
Nothing ->
case str of
[] -> []
x : xs -> x : stripLinks xs
stripHrefEnd :: String -> String
stripHrefEnd s =
let pref = "</a" in
case stripPrefix pref s of
Just str' -> case dropWhile (/= '>') str' of
[] -> []
x:xs -> xs
Nothing ->
case s of
[] -> []
x : xs -> x : stripHrefEnd xs
programOnPath :: FilePath -> IO Bool
programOnPath p = do
result <- findProgramLocation silent p
return (isJust result)
\end{code}