#!/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}