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

5 files changed, 56 insertions, 196 deletions

diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
new file mode 100644
index 00000000..0490be47
--- /dev/null
+++ b/hypsrc-test/Main.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE CPP #-}
+
+
+import Data.Char
+import Data.List
+
+import System.Environment
+import System.FilePath
+
+import Test.Haddock
+import Test.Haddock.Xhtml
+
+
+checkConfig :: CheckConfig Xml
+checkConfig = CheckConfig
+    { ccfgRead = \_ input -> strip <$> parseXml input
+    , ccfgDump = dumpXml
+    , ccfgEqual = (==)
+    }
+  where
+    strip = stripAnchors' . stripLinks' . stripFooter
+    stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href
+    stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name
+
+
+dirConfig :: DirConfig
+dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
+    { dcfgCheckIgnore = checkIgnore
+    }
+
+
+main :: IO ()
+main = do
+    cfg <- parseArgs checkConfig dirConfig =<< getArgs
+    runAndCheck $ cfg
+        { cfgHaddockArgs = cfgHaddockArgs cfg ++
+            [ "--pretty-html"
+            , "--hyperlinked-source"
+            ]
+        }
+
+
+checkIgnore :: FilePath -> Bool
+checkIgnore file
+    | and . map ($ file) $ [isHtmlFile, isSourceFile, isModuleFile] = False
+  where
+    isHtmlFile = (== ".html") . takeExtension
+    isSourceFile = (== "src") . takeDirectory
+    isModuleFile = isUpper . head . takeBaseName
+checkIgnore _ = True
diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs
deleted file mode 100644
index e15fabee..00000000
--- a/hypsrc-test/Utils.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-
-module Utils
-    ( baseDir, rootDir
-    , srcDir, refDir, outDir, refDir', outDir'
-    , haddockPath
-    , stripLocalAnchors, stripLocalLinks, stripLocalReferences
-    ) where
-
-
-import Data.List
-
-import System.FilePath
-
-
-baseDir, rootDir :: FilePath
-baseDir = takeDirectory __FILE__
-rootDir = baseDir </> ".."
-
-srcDir, refDir, outDir, refDir', outDir' :: FilePath
-srcDir = baseDir </> "src"
-refDir = baseDir </> "ref"
-outDir = baseDir </> "out"
-refDir' = refDir </> "src"
-outDir' = outDir </> "src"
-
-haddockPath :: FilePath
-haddockPath = rootDir </> "dist" </> "build" </> "haddock" </> "haddock"
-
-
-replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a]
-replaceBetween _ _ _ [] = []
-replaceBetween pref end val html@(x:xs') = case stripPrefix pref html of
-    Just strip -> pref ++ val ++ (replaceBetween' . dropWhile (/= end)) strip
-    Nothing -> x:(replaceBetween' xs')
-  where
-    replaceBetween' = replaceBetween pref end val
-
-stripLocalAnchors :: String -> String
-stripLocalAnchors = replaceBetween "<a name=\"local-" '\"' "0"
-
-stripLocalLinks :: String -> String
-stripLocalLinks = replaceBetween "<a href=\"#local-" '\"' "0"
-
-stripLocalReferences :: String -> String
-stripLocalReferences = stripLocalLinks . stripLocalAnchors
diff --git a/hypsrc-test/accept.hs b/hypsrc-test/accept.hs
deleted file mode 100755
index 4606b2df..00000000
--- a/hypsrc-test/accept.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-#!/usr/bin/env runhaskell
-{-# LANGUAGE CPP #-}
-
-
-import System.Directory
-import System.FilePath
-import System.Environment
-
-import Utils
-
-
-main :: IO ()
-main = do
-    args <- getArgs
-    files <- filter isHtmlFile <$> getDirectoryContents outDir'
-    let files' = if args == ["--all"] || args == ["-a"]
-        then files
-        else filter ((`elem` args) . takeBaseName) files
-    mapM_ copy files'
-  where
-    isHtmlFile = (== ".html") . takeExtension
-
-
-copy :: FilePath -> IO ()
-copy file = do
-    content <- stripLocalReferences <$> readFile (outDir' </> file)
-    writeFile (refDir' </> file) content
diff --git a/hypsrc-test/run b/hypsrc-test/run
new file mode 100755
index 00000000..3e72be80
--- /dev/null
+++ b/hypsrc-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/hypsrc-test/run.hs b/hypsrc-test/run.hs
deleted file mode 100755
index 853c4f09..00000000
--- a/hypsrc-test/run.hs
+++ /dev/null
@@ -1,122 +0,0 @@
-#!/usr/bin/env runhaskell
-{-# LANGUAGE CPP #-}
-
-
-import Control.Monad
-
-import Data.List
-import Data.Maybe
-
-import System.Directory
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.Process
-
-import Distribution.Verbosity
-import Distribution.Simple.Utils hiding (die)
-
-import Utils
-
-
-main :: IO ()
-main = do
-    haddockAvailable <- doesFileExist haddockPath
-    unless haddockAvailable $ die "Haddock exectuable not available"
-
-    (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs
-    let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args
-    mods' <- map (srcDir </>) <$> case args of
-        [] -> getAllSrcModules
-        _ -> return $ map (++ ".hs") mods
-
-    putHaddockVersion
-    putGhcVersion
-
-    putStrLn "Running tests..."
-    runHaddock $
-        [ "--odir=" ++ outDir
-        , "--no-warnings"
-        , "--hyperlinked-source"
-        , "--pretty-html"
-        ] ++ args' ++ mods'
-
-    forM_ mods' $ check True
-
-
-check :: Bool -> FilePath -> IO ()
-check strict mdl = do
-    hasReference <- doesFileExist refFile
-    if hasReference
-    then do
-        ref <- readFile refFile
-        out <- readFile outFile
-        compareOutput strict mdl ref out
-    else do
-        putStrLn $ "Pass: " ++ mdl ++ " (no reference file)"
-  where
-    refFile = refDir' </> takeBaseName mdl ++ ".html"
-    outFile = outDir' </> takeBaseName mdl ++ ".html"
-
-
-compareOutput :: Bool -> FilePath -> String -> String -> IO ()
-compareOutput strict mdl ref out = do
-    if ref' == out'
-    then putStrLn $ "Pass: " ++ mdl
-    else do
-        putStrLn $ "Fail: " ++ mdl
-        diff mdl ref' out'
-        when strict $ die "Aborting further tests."
-  where
-    ref' = stripLocalReferences ref
-    out' = stripLocalReferences out
-
-
-diff :: FilePath -> String -> String -> IO ()
-diff mdl ref out = do
-    colorDiffPath <- findProgramLocation silent "colordiff"
-    let cmd = fromMaybe "diff" colorDiffPath
-
-    writeFile refFile ref
-    writeFile outFile out
-
-    result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile
-    unless (result == ExitSuccess) $ die "Failed to run `diff` command."
-  where
-    refFile = outDir </> takeBaseName mdl ++ ".ref.nolinks"
-    outFile = outDir </> takeBaseName mdl ++ ".nolinks"
-
-
-
-getAllSrcModules :: IO [FilePath]
-getAllSrcModules =
-    filter isHaskellFile <$> getDirectoryContents srcDir
-  where
-    isHaskellFile = (== ".hs") . takeExtension
-
-
-putHaddockVersion :: IO ()
-putHaddockVersion = do
-    putStrLn "Haddock version:"
-    runHaddock ["--version"]
-    putStrLn ""
-
-
-putGhcVersion :: IO ()
-putGhcVersion = do
-    putStrLn "GHC version:"
-    runHaddock ["--ghc-version"]
-    putStrLn ""
-
-
-runHaddock :: [String] -> IO ()
-runHaddock args = do
-    menv <- Just <$> getEnvironment
-    handle <- runProcess haddockPath args Nothing menv Nothing Nothing Nothing
-    waitForSuccess handle $ "Failed to invoke haddock with " ++ show args
-
-
-waitForSuccess :: ProcessHandle -> String -> IO ()
-waitForSuccess handle msg = do
-    result <- waitForProcess handle
-    unless (result == ExitSuccess) $ die msg