From 958d64d77572c47d249965d7146ac17a23de806d Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Mon, 15 Oct 2012 10:34:28 +0200
Subject: Move HTML tests to directory /html-test/

---
 tests/html-tests/runtests.hs | 152 -------------------------------------------
 1 file changed, 152 deletions(-)
 delete mode 100644 tests/html-tests/runtests.hs

(limited to 'tests/html-tests/runtests.hs')

diff --git a/tests/html-tests/runtests.hs b/tests/html-tests/runtests.hs
deleted file mode 100644
index 759f7495..00000000
--- a/tests/html-tests/runtests.hs
+++ /dev/null
@@ -1,152 +0,0 @@
-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, testSuiteRoot, testDir, outDir :: FilePath
-packageRoot   = "."
-dataDir       = packageRoot </> "resources"
-haddockPath   = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock"
-testSuiteRoot = packageRoot </> "tests" </> "html-tests"
-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"
-
-  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 = testDir </> dropExtension mod ++ ".html.ref"
-    b <- doesFileExist reffile
-    if b
-      then do
-        copyFile reffile (outDir </> 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' = outDir </> takeFileName reffile ++ ".nolinks"
-                outfile' = outDir </> takeFileName outfile ++ ".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 = "<a href=\"" in
-  case stripPrefix prefix str of
-    Just str' -> 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)
-- 
cgit v1.2.3