Merge pull request #1 from haskell/ghc-head

Ghc head

1 files changed, 122 insertions, 0 deletions

diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs
new file mode 100755
index 00000000..853c4f09
--- /dev/null
+++ b/hypsrc-test/run.hs
@@ -0,0 +1,122 @@
+#!/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