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

1 files changed, 149 insertions, 0 deletions

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
new file mode 100644
index 00000000..e8a0ac8e
--- /dev/null
+++ b/haddock-test/src/Test/Haddock.hs
@@ -0,0 +1,149 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Test.Haddock
+    ( module Test.Haddock.Config
+    , runAndCheck, runHaddock, checkFiles
+    ) where
+
+
+import Control.Monad
+
+import Data.Maybe
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO
+import System.Process
+
+import Test.Haddock.Config
+import Test.Haddock.Process
+import Test.Haddock.Utils
+
+
+data CheckResult
+    = Fail
+    | Pass
+    | NoRef
+    | Error String
+    | Accepted
+    deriving Eq
+
+
+runAndCheck :: Config c -> IO ()
+runAndCheck cfg = do
+    runHaddock cfg
+    checkFiles cfg
+
+
+checkFiles :: Config c -> IO ()
+checkFiles cfg@(Config { .. }) = do
+    putStrLn "Testing output files..."
+
+    files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
+    failed <- liftM catMaybes . forM files $ \file -> do
+        putStr $ "Checking \"" ++ file ++ "\"... "
+
+        status <- maybeAcceptFile cfg file =<< checkFile cfg file
+        case status of
+            Fail -> putStrLn "FAIL" >> (return $ Just file)
+            Pass -> putStrLn "PASS" >> (return Nothing)
+            NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
+            Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
+            Accepted -> putStrLn "ACCEPTED" >> return Nothing
+
+    if null failed
+        then do
+            putStrLn "All tests passed!"
+            exitSuccess
+        else do
+            maybeDiff cfg failed
+            exitFailure
+  where
+    ignore = filter (not . dcfgCheckIgnore cfgDirConfig)
+
+
+maybeDiff :: Config c -> [FilePath] -> IO ()
+maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
+maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
+    putStrLn "Diffing failed cases..."
+    forM_ files $ diffFile cfg diff
+
+
+runHaddock :: Config c -> IO ()
+runHaddock cfg@(Config { .. }) = do
+    createEmptyDirectory $ cfgOutDir cfg
+
+    putStrLn "Generating documentation..."
+    forM_ cfgPackages $ \tpkg -> do
+        haddockStdOut <- openFile cfgHaddockStdOut WriteMode
+        handle <- runProcess' cfgHaddockPath $ processConfig
+            { pcArgs = concat
+                [ cfgHaddockArgs
+                , pure $ "--odir=" ++ outDir cfgDirConfig tpkg
+                , tpkgFiles tpkg
+                ]
+            , pcEnv = Just $ cfgEnv
+            , pcStdOut = Just $ haddockStdOut
+            }
+        waitForSuccess "Failed to run Haddock on specified test files" handle
+
+
+checkFile :: Config c -> FilePath -> IO CheckResult
+checkFile cfg file = do
+    hasRef <- doesFileExist $ refFile dcfg file
+    if hasRef
+        then do
+            mout <- ccfgRead ccfg file <$> readFile (outFile dcfg file)
+            mref <- ccfgRead ccfg file <$> readFile (refFile dcfg file)
+            return $ case (mout, mref) of
+                (Just out, Just ref)
+                    | ccfgEqual ccfg out ref -> Pass
+                    | otherwise -> Fail
+                _ -> Error "Failed to parse input files"
+        else return NoRef
+  where
+    ccfg = cfgCheckConfig cfg
+    dcfg = cfgDirConfig cfg
+
+
+diffFile :: Config c -> FilePath -> FilePath -> IO ()
+diffFile cfg diff file = do
+    Just out <- ccfgRead ccfg file <$> readFile (outFile dcfg file)
+    Just ref <- ccfgRead ccfg file <$> readFile (refFile dcfg file)
+    writeFile outFile' $ ccfgDump ccfg out
+    writeFile refFile' $ ccfgDump ccfg ref
+
+    putStrLn $ "Diff for file \"" ++ file ++ "\":"
+    hFlush stdout
+    handle <- runProcess' diff $ processConfig
+        { pcArgs = [outFile', refFile']
+        , pcStdOut = Just $ stdout
+        }
+    waitForProcess handle >> return ()
+  where
+    dcfg = cfgDirConfig cfg
+    ccfg = cfgCheckConfig cfg
+    outFile' = outFile dcfg file <.> "dump"
+    refFile' = outFile dcfg file <.> "ref" <.> "dump"
+
+
+maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult
+maybeAcceptFile cfg@(Config { cfgDirConfig = dcfg }) file result
+    | cfgAccept cfg && result `elem` [NoRef, Fail] = do
+        copyFile' (outFile dcfg file) (refFile dcfg file)
+        pure Accepted
+maybeAcceptFile _ _ result = pure result
+
+
+outDir :: DirConfig -> TestPackage -> FilePath
+outDir dcfg tpkg = dcfgOutDir dcfg </> tpkgName tpkg
+
+
+outFile :: DirConfig -> FilePath -> FilePath
+outFile dcfg file = dcfgOutDir dcfg </> file
+
+
+refFile :: DirConfig -> FilePath -> FilePath
+refFile dcfg file = dcfgRefDir dcfg </> file