From a4fb9cb0a44101d858d69281a3ee0aa0dbf7ddda Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Mon, 15 Oct 2012 20:29:43 +0200 Subject: Rename html-test/runtests.lhs to html-test/run.lhs --- haddock.cabal | 4 +- html-test/run.lhs | 156 +++++++++++++++++++++++++++++++++++++++++++++++++ html-test/runtests.lhs | 156 ------------------------------------------------- 3 files changed, 158 insertions(+), 158 deletions(-) create mode 100755 html-test/run.lhs delete mode 100755 html-test/runtests.lhs diff --git a/haddock.cabal b/haddock.cabal index 78a6ed73..99bf5e4a 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -31,7 +31,7 @@ extra-source-files: src/haddock.sh -- The test files shouldn't have to go here, but the source files for -- the test-suite stanzas don't get picked up by `cabal sdist`. - tests/html-test/runtests.lhs + tests/html-test/run.lhs data-dir: resources data-files: html/frames.html @@ -186,7 +186,7 @@ library test-suite html-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: runtests.lhs + main-is: run.lhs hs-source-dirs: html-test build-depends: base, directory, process, filepath, Cabal diff --git a/html-test/run.lhs b/html-test/run.lhs new file mode 100755 index 00000000..c8671a76 --- /dev/null +++ b/html-test/run.lhs @@ -0,0 +1,156 @@ +#!/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.Cmd +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.Process (ProcessHandle, runProcess, waitForProcess) + + +packageRoot, dataDir, haddockPath, baseDir, testDir, outDir :: FilePath +baseDir = takeDirectory __FILE__ +testDir = baseDir "tests" +refDir = baseDir "ref" +outDir = baseDir "output" +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 + 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", 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=-fglasgow-exts" + , "--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 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 ++ ".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)" + + +haddockEq :: String -> String -> Bool +haddockEq file1 file2 = stripLinks file1 == stripLinks file2 + +stripLinks :: String -> String +stripLinks str = + let prefix = " prefix ++ stripLinks (dropWhile (/= '"') str') + Nothing -> + case str of + [] -> [] + x : xs -> x : stripLinks xs + +programOnPath :: FilePath -> IO Bool +programOnPath p = do + result <- findProgramLocation silent p + return (isJust result) +\end{code} diff --git a/html-test/runtests.lhs b/html-test/runtests.lhs deleted file mode 100755 index c8671a76..00000000 --- a/html-test/runtests.lhs +++ /dev/null @@ -1,156 +0,0 @@ -#!/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.Cmd -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process (ProcessHandle, runProcess, waitForProcess) - - -packageRoot, dataDir, haddockPath, baseDir, testDir, outDir :: FilePath -baseDir = takeDirectory __FILE__ -testDir = baseDir "tests" -refDir = baseDir "ref" -outDir = baseDir "output" -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 - 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", 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=-fglasgow-exts" - , "--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 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 ++ ".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)" - - -haddockEq :: String -> String -> Bool -haddockEq file1 file2 = stripLinks file1 == stripLinks file2 - -stripLinks :: String -> String -stripLinks str = - let prefix = " prefix ++ stripLinks (dropWhile (/= '"') str') - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs - -programOnPath :: FilePath -> IO Bool -programOnPath p = do - result <- findProgramLocation silent p - return (isJust result) -\end{code} -- cgit v1.2.3