Merge remote-tracking branch 'mrhania/testing-framework-improvements' into ghc-head

5 files changed, 34 insertions, 210 deletions

diff --git a/latex-test/Main.hs b/latex-test/Main.hs
new file mode 100755
index 00000000..2ee01a26
--- /dev/null
+++ b/latex-test/Main.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE CPP #-}
+
+
+import System.Environment
+import System.FilePath
+
+import Test.Haddock
+
+
+checkConfig :: CheckConfig String
+checkConfig = CheckConfig
+    { ccfgRead = \_ input -> Just input
+    , ccfgDump = id
+    , ccfgEqual = (==)
+    }
+
+
+dirConfig :: DirConfig
+dirConfig = defaultDirConfig $ takeDirectory __FILE__
+
+
+main :: IO ()
+main = do
+    cfg <- parseArgs checkConfig dirConfig =<< getArgs
+    runAndCheck $ cfg
+        { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--latex"]
+        }
diff --git a/latex-test/accept.lhs b/latex-test/accept.lhs
deleted file mode 100755
index 4d0b0127..00000000
--- a/latex-test/accept.lhs
+++ /dev/null
@@ -1,46 +0,0 @@
-#!/usr/bin/env runhaskell
-\begin{code}
-{-# LANGUAGE CPP #-}
-import System.Environment
-import System.FilePath
-import System.Directory
-import Data.List
-import Control.Applicative
-import Control.Monad
-
-baseDir :: FilePath
-baseDir = takeDirectory __FILE__
-
-main :: IO ()
-main = do
-  contents <- filter (not . ignore) <$> getDirectoryContents (baseDir </> "out")
-  args <- getArgs
-  mapM_ copyDir $ if not (null args)
-                  then filter ((`elem` args) . takeBaseName) contents
-                  else contents
-  where
-    ignore =
-      foldr (liftA2 (||)) (const False) [
-        (== ".")
-      , (== "..")
-      , isPrefixOf "index"
-      , isPrefixOf "doc-index"
-      ]
-
--- | Copy a directory to ref, one level deep.
-copyDir :: FilePath -> IO ()
-copyDir dir = do
-  let old = baseDir </> "out" </> dir
-      new = baseDir </> "ref" </> dir
-  alreadyExists <- doesDirectoryExist new
-  unless alreadyExists $ do
-    putStrLn (old ++ " -> " ++ new)
-    createDirectoryIfMissing True new
-    files <- getDirectoryContents old >>= filterM (liftM not . doesDirectoryExist)
-    let files' = filter (\x -> x /= "." && x /= "..") files
-    mapM_ (\f -> copyFile' (old </> f) (new </> f)) files'
-      where
-        copyFile' o n = do
-          putStrLn $ o ++ " -> " ++ n
-          copyFile o n
-\end{code}
diff --git a/latex-test/ref/Simple/Simple.tex b/latex-test/ref/Simple/Simple.tex
index 89e849f8..5ba4712c 100644
--- a/latex-test/ref/Simple/Simple.tex
+++ b/latex-test/ref/Simple/Simple.tex
@@ -11,7 +11,6 @@ module Simple (
 \item[\begin{tabular}{@{}l}
 foo\ ::\ t
 \end{tabular}]\haddockbegindoc
-This is foo.
-\par
+This is foo.\par
 
 \end{haddockdesc}
\ No newline at end of file
diff --git a/latex-test/run b/latex-test/run
new file mode 100755
index 00000000..3e72be80
--- /dev/null
+++ b/latex-test/run
@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+export HADDOCK_PATH=$(which haddock)
+LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/"
+MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs"
+runhaskell -i:"$LIB_PATH" $MAIN_PATH $@
diff --git a/latex-test/run.lhs b/latex-test/run.lhs
deleted file mode 100755
index d3e39e90..00000000
--- a/latex-test/run.lhs
+++ /dev/null
@@ -1,162 +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 hiding (dataDir)
-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, refDir :: 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
-      isDir x' = liftM2 (&&) (doesDirectoryExist $ testDir </> x')
-                             (return $ x' /= "." && x' /= "..")
-  modDirs <- case spec of
-    y:_ | y /= "all" -> return [y]
-    _ -> filterM isDir contents
-
-  let modDirs' = map (testDir </>) modDirs
-
-  -- 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..."
-
-  forM_ modDirs' $ \modDir -> do
-    testModules <- getDirectoryContents modDir
-
-    let mods = filter ((==) ".hs" . takeExtension) testModules
-        mods' = map (modDir </>) mods
-
-    unless (null mods') $ do
-      handle <- runProcess haddockPath
-                (["-w", "-o", outDir </> last (splitPath modDir), "--latex"
-                 , "--optghc=-fglasgow-exts"
-                 , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
-                Nothing env Nothing
-                Nothing Nothing
-
-      wait handle "*** Haddock run failed! Exiting."
-
-  check modDirs (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 modDirs strict = do
-  forM_ modDirs $ \modDir -> do
-    let oDir = outDir </> modDir
-        rDir = refDir </> modDir
-
-    refDirExists <- doesDirectoryExist rDir
-    when refDirExists $ do
-      -- we're not creating sub-directories, I think.
-      refFiles <- getDirectoryContents rDir >>= filterM doesFileExist
-
-      forM_ refFiles $ \rFile -> do
-        let refFile = rDir </> rFile
-            outFile = oDir </> rFile
-        oe <- doesFileExist outFile
-        if oe
-          then do
-            out <- readFile outFile
-            ref <- readFile refFile
-
-            if out /= ref
-               then do
-                 putStrLn $ "Output for " ++ modDir ++ " has changed! Exiting with diff:"
-
-                 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: " ++ modDir
-           else do
-             putStrLn $ "Pass: " ++ modDir ++ " (no .ref file)"
-
-programOnPath :: FilePath -> IO Bool
-programOnPath p = do
-  result <- findProgramLocation silent p
-  return (isJust result)
-\end{code}