Repository : ssh://darcs.haskell.org//srv/darcs/haddock On branch : ghc-7.6
http://hackage.haskell.org/trac/ghc/changeset/175406f50e0755d6b8a295c243419ae1f59226dd >--------------------------------------------------------------- commit 175406f50e0755d6b8a295c243419ae1f59226dd Author: Simon Hengel <s...@typeful.net> Date: Sun Oct 7 17:46:08 2012 +0200 runtests.hs: Fix some warnings >--------------------------------------------------------------- tests/html-tests/runtests.hs | 23 +++++++++++++++-------- 1 files changed, 15 insertions(+), 8 deletions(-) diff --git a/tests/html-tests/runtests.hs b/tests/html-tests/runtests.hs index fc9477c..9d5d050 100644 --- a/tests/html-tests/runtests.hs +++ b/tests/html-tests/runtests.hs @@ -1,8 +1,9 @@ +import Prelude hiding (mod) import Control.Monad import Data.List import Data.Maybe import Distribution.InstalledPackageInfo -import Distribution.Package +import Distribution.Package (PackageName (..)) import Distribution.Simple.Compiler import Distribution.Simple.GHC import Distribution.Simple.PackageIndex @@ -14,10 +15,10 @@ import System.Directory import System.Environment import System.Exit import System.FilePath -import System.Process -import Text.Printf +import System.Process (runProcess, waitForProcess) +packageRoot, haddockPath, testSuiteRoot, testDir, outDir :: FilePath packageRoot = "." haddockPath = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock" testSuiteRoot = packageRoot </> "tests" </> "html-tests" @@ -25,11 +26,13 @@ testDir = testSuiteRoot </> "tests" outDir = testSuiteRoot </> "output" +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" @@ -39,7 +42,7 @@ test = do let (opts, spec) = span ("-" `isPrefixOf`) args let mods = case spec of - x:_ | x /= "all" -> [x ++ ".hs"] + y:_ | y /= "all" -> [y ++ ".hs"] _ -> filter ((==) ".hs" . takeExtension) contents let mods' = map (testDir </>) mods @@ -63,7 +66,6 @@ test = do ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"] (_, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf - let safeHead xs = case xs of x : _ -> Just x; [] -> Nothing let mkDep pkgName = maybe (error "Couldn't find test dependencies") id $ do let pkgs = lookupPackageName pkgIndex (PackageName pkgName) @@ -87,8 +89,11 @@ test = do code <- waitForProcess handle when (code /= ExitSuccess) $ error "Haddock run failed! Exiting." check mods (if not (null args) && args !! 0 == "all" then False else True) + where + safeHead xs = case xs of x : _ -> Just x; [] -> Nothing +check :: [FilePath] -> Bool -> IO () check modules strict = do forM_ modules $ \mod -> do let outfile = outDir </> dropExtension mod ++ ".html" @@ -108,8 +113,8 @@ check modules strict = do outfile' = outDir </> takeFileName outfile ++ ".nolinks" writeFile reffile' ref' writeFile outfile' out' - b <- programOnPath "colordiff" - if b + r <- programOnPath "colordiff" + if r then system $ "colordiff " ++ reffile' ++ " " ++ outfile' else system $ "diff " ++ reffile' ++ " " ++ outfile' if strict then exitFailure else return () @@ -119,8 +124,10 @@ check modules strict = 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 = "<a href=\"" in case stripPrefix prefix str of @@ -130,7 +137,7 @@ stripLinks str = [] -> [] x : xs -> x : stripLinks xs +programOnPath :: FilePath -> IO Bool programOnPath p = do result <- findProgramLocation silent p return (isJust result) - _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
