aboutsummaryrefslogtreecommitdiff
path: root/tests/runtests.hs
diff options
context:
space:
mode:
authorDavid Waern <david.waern@gmail.com>2010-05-11 19:14:31 +0000
committerDavid Waern <david.waern@gmail.com>2010-05-11 19:14:31 +0000
commita7cfb1d83c7e0f97a806e1f2c202416e625b2ce2 (patch)
treea4154de09f38ddee5e17bc16bfac323a41d9b7b5 /tests/runtests.hs
parentc7d9f7678de931e580a3fe1bec2fb0e2dead84d3 (diff)
Re-organise the testsuite structure
Diffstat (limited to 'tests/runtests.hs')
-rw-r--r--tests/runtests.hs114
1 files changed, 0 insertions, 114 deletions
diff --git a/tests/runtests.hs b/tests/runtests.hs
deleted file mode 100644
index 99a47828..00000000
--- a/tests/runtests.hs
+++ /dev/null
@@ -1,114 +0,0 @@
-import System.Cmd
-import System.Environment
-import System.FilePath
-import System.Exit
-import System.Directory
-import System.Process
-import Data.List
-import Control.Monad
-import Text.Printf
-import Text.Regex
-import Distribution.Simple.Utils
-import Distribution.Simple.Program
-import Distribution.Verbosity
-import Data.Maybe
-
-
-haddockPath = ".." </> "dist" </> "build" </> "haddock" </> "haddock"
-
-
-main = do
- test
- putStrLn "All tests passed!"
-
-
-test = do
- x <- doesFileExist haddockPath
- when (not x) $ die "you need to run 'cabal build' successfully first"
-
- contents <- getDirectoryContents "tests"
- args <- getArgs
- let (opts, spec) = span ("-" `isPrefixOf`) args
- let mods =
- case spec of
- x:_ | x /= "all" -> [x ++ ".hs"]
- _ -> filter ((==) ".hs" . takeExtension) contents
-
- let outdir = "output"
- let mods' = map ("tests" </>) mods
- putStrLn ""
- putStrLn "Haddock version: "
- h1 <- runProcess haddockPath ["--version"] Nothing
- (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
- waitForProcess h1
- putStrLn ""
- putStrLn "GHC version: "
- h2 <- runProcess haddockPath ["--ghc-version"] Nothing
- (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
- waitForProcess h2
- putStrLn ""
-
- -- TODO: use Distribution.* to get the packages instead
- libdir <- rawSystemStdout normal haddockPath ["--print-ghc-libdir"]
- let librariesPath = ".."</>".."</>"share"</>"doc"</>"ghc"</>"html"</>"libraries"
-
- let mkDep name version =
- let path = init libdir </> librariesPath </> name ++ "-" ++ version
- in "-i " ++ path ++ "," ++ path </> name ++ ".haddock"
-
- let base = mkDep "base" "4.2.0.0"
- process = mkDep "process" "1.0.1.2"
- ghcprim = mkDep "ghc-prim" "0.2.0.0"
-
- putStrLn "Running tests..."
- handle <- runProcess haddockPath
- (["-w", "-o", outdir, "-h", "--optghc=-fglasgow-exts"
- , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
- Nothing (Just [("haddock_datadir", "../.")]) Nothing
- Nothing Nothing
-
- code <- waitForProcess handle
- when (code /= ExitSuccess) $ error "Haddock run failed! Exiting."
- check mods (if not (null args) && args !! 0 == "all" then False else True)
-
-
-check modules strict = do
- forM_ modules $ \mod -> do
- let outfile = "output" </> (dropExtension mod ++ ".html")
- let reffile = "tests" </> dropExtension mod ++ ".html.ref"
- b <- doesFileExist reffile
- if b
- then do
- copyFile reffile ("output" </> takeFileName reffile)
- 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' = "output" </> takeFileName reffile ++ ".nolinks"
- outfile' = "output" </> takeFileName outfile ++ ".nolinks"
- writeFile reffile' ref'
- writeFile outfile' out'
- b <- programOnPath "colordiff"
- if b
- then system $ "colordiff " ++ reffile' ++ " " ++ outfile'
- else system $ "diff " ++ reffile' ++ " " ++ outfile'
- if strict then exitFailure else return ()
- else do
- putStrLn $ "Pass: " ++ mod
- else do
- putStrLn $ "Pass: " ++ mod ++ " (no .ref file)"
-
-
-haddockEq file1 file2 = stripLinks file1 == stripLinks file2
-
-
-stripLinks f = subRegex (mkRegexWithOpts "<A HREF=[^>]*>" False False) f "<A HREF=\"\">"
-
-
-programOnPath p = do
- result <- findProgramLocation silent p
- return (isJust result)
-