Move Haddock runner of HTML test suite to Haddock test package.

3 files changed, 120 insertions, 118 deletions

diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
index aabe12e9..4cf10799 100644
--- a/haddock-test/haddock-test.cabal
+++ b/haddock-test/haddock-test.cabal
@@ -19,6 +19,7 @@ library
   build-depends:    base, directory, process, filepath, Cabal, xml, syb
 
   exposed-modules:
+    Test.Haddock
     Test.Haddock.Config
     Test.Haddock.Process
     Test.Haddock.Xhtml
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
new file mode 100644
index 00000000..6ca57d7b
--- /dev/null
+++ b/haddock-test/src/Test/Haddock.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Test.Haddock
+    ( module Test.Haddock
+    , module Test.Haddock.Config
+    ) 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.Xhtml
+
+import qualified Text.XML.Light as Xml
+
+
+data CheckResult
+    = Fail
+    | Pass
+    | NoRef
+
+
+checkFiles :: Config -> IO ()
+checkFiles cfg@(Config { .. }) = do
+    putStrLn "Testing output files..."
+    failed <- liftM catMaybes . forM cfgFiles $ \file -> do
+        let mdl = takeBaseName file
+        putStr $ "Checking " ++ mdl ++ "... "
+
+        status <- checkModule cfg mdl
+        case status of
+            Fail -> putStrLn "FAIL" >> (return $ Just mdl)
+            Pass -> putStrLn "PASS" >> (return Nothing)
+            NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
+
+    if null failed
+        then do
+            putStrLn "All tests passed!"
+            exitSuccess
+        else do
+            maybeDiff cfg failed
+            exitFailure
+
+
+maybeDiff :: Config -> [String] -> IO ()
+maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
+maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) mdls = do
+    putStrLn "Diffing failed cases..."
+    forM_ mdls $ diffModule cfg diff
+
+
+runHaddock :: Config -> IO ()
+runHaddock (Config { .. }) = do
+    putStrLn "Running Haddock process..."
+
+    haddockStdOut <- openFile cfgHaddockStdOut WriteMode
+    handle <- runProcess' cfgHaddockPath $ processConfig
+        { pcArgs = cfgHaddockArgs ++ cfgFiles
+        , pcEnv = Just $ cfgEnv
+        , pcStdOut = Just $ haddockStdOut
+        }
+    waitForSuccess "Failed to run Haddock on specified test files" handle
+
+
+checkModule :: Config -> String -> IO CheckResult
+checkModule cfg mdl = do
+    hasRef <- doesFileExist $ refFile dcfg mdl
+    if hasRef
+        then do
+            Just outXml <- readXml $ outFile dcfg mdl
+            Just refXml <- readXml $ refFile dcfg mdl
+            return $ if strip outXml == strip refXml
+                then Pass
+                else Fail
+        else return NoRef
+  where
+    dcfg = cfgDirConfig cfg
+
+
+diffModule :: Config -> FilePath -> String -> IO ()
+diffModule cfg diff mdl = do
+    Just outXml <- readXml $ outFile dcfg mdl
+    Just refXml <- readXml $ refFile dcfg mdl
+    let outXml' = strip outXml
+    let refXml' = strip refXml
+    writeFile outFile' $ Xml.ppElement outXml'
+    writeFile refFile' $ Xml.ppElement refXml'
+
+    putStrLn $ "Diff for module " ++ show mdl ++ ":"
+    hFlush stdout
+    handle <- runProcess' diff $ processConfig
+        { pcArgs = [outFile', refFile']
+        , pcStdOut = Just $ stdout
+        }
+    waitForProcess handle >> return ()
+  where
+    dcfg = cfgDirConfig cfg
+    outFile' = outFile dcfg mdl <.> "nolinks"
+    refFile' = outFile dcfg mdl <.> "ref" <.> "nolinks"
+
+
+outFile :: DirConfig -> String -> FilePath
+outFile dcfg mdl = dcfgOutDir dcfg </> mdl <.> "html"
+
+
+refFile :: DirConfig -> String -> FilePath
+refFile dcfg mdl = dcfgRefDir dcfg </> mdl <.> "html"
diff --git a/html-test/run.hs b/html-test/run.hs
index 5a2944f9..48c733d0 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -1,46 +1,14 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
 
 
-import Control.Applicative
-import Control.Monad
-
-import Data.Maybe
-import Data.List
-
-import System.Console.GetOpt
-import System.Directory
 import System.Environment
-import System.Exit
 import System.FilePath
-import System.IO
-import System.Process
 
-import qualified Text.XML.Light as Xml
+import Test.Haddock
 
-import Test.Haddock.Process
-import Test.Haddock.Config
-import Test.Haddock.Xhtml
 
-
-baseDir, rootDir :: FilePath
+baseDir :: FilePath
 baseDir = takeDirectory __FILE__
-rootDir = baseDir </> ".."
-
-srcDir, refDir, outDir :: FilePath
-srcDir = baseDir </> "src"
-refDir = baseDir </> "ref"
-outDir = baseDir </> "out"
-
-resDir :: FilePath
-resDir = rootDir </> "resources"
-
-
-data CheckResult
-    = Fail
-    | Pass
-    | NoRef
 
 
 main :: IO ()
@@ -51,90 +19,6 @@ main = do
     checkFiles cfg
 
 
-checkFiles :: Config -> IO ()
-checkFiles (Config { .. }) = do
-    putStrLn "Testing output files..."
-    failed <- liftM catMaybes . forM cfgFiles $ \file -> do
-        let mdl = takeBaseName file
-        putStr $ "Checking " ++ mdl ++ "... "
-
-        status <- checkModule mdl
-        case status of
-            Fail -> putStrLn "FAIL" >> (return $ Just mdl)
-            Pass -> putStrLn "PASS" >> (return Nothing)
-            NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
-
-    if null failed
-        then do
-            putStrLn "All tests passed!"
-            exitSuccess
-        else do
-            maybeDiff cfgDiffTool failed
-            exitFailure
-
-
-maybeDiff :: Maybe FilePath -> [String] -> IO ()
-maybeDiff Nothing _ = pure ()
-maybeDiff (Just diff) mdls = do
-    putStrLn "Diffing failed cases..."
-    forM_ mdls $ diffModule diff
-
-
-runHaddock :: Config -> IO ()
-runHaddock (Config { .. }) = do
-    putStrLn "Running Haddock process..."
-
-    haddockStdOut <- openFile cfgHaddockStdOut WriteMode
-    handle <- runProcess' cfgHaddockPath $ processConfig
-        { pcArgs = cfgHaddockArgs ++ cfgFiles
-        , pcEnv = Just $ cfgEnv
-        , pcStdOut = Just $ haddockStdOut
-        }
-    waitForSuccess "Failed to run Haddock on specified test files" handle
-
-
-checkModule :: String -> IO CheckResult
-checkModule mdl = do
-    hasRef <- doesFileExist $ refFile mdl
-    if hasRef
-        then do
-            Just outXml <- readXml $ outFile mdl
-            Just refXml <- readXml $ refFile mdl
-            return $ if strip outXml == strip refXml
-                then Pass
-                else Fail
-        else return NoRef
-
-
-diffModule :: FilePath -> String -> IO ()
-diffModule diff mdl = do
-    Just outXml <- readXml $ outFile mdl
-    Just refXml <- readXml $ refFile mdl
-    let outXml' = strip outXml
-    let refXml' = strip refXml
-    writeFile outFile' $ Xml.ppElement outXml'
-    writeFile refFile' $ Xml.ppElement refXml'
-
-    putStrLn $ "Diff for module " ++ show mdl ++ ":"
-    hFlush stdout
-    handle <- runProcess' diff $ processConfig
-        { pcArgs = [outFile', refFile']
-        , pcStdOut = Just $ stdout
-        }
-    waitForProcess handle >> return ()
-  where
-    outFile' = outFile mdl <.> "nolinks"
-    refFile' = outFile mdl <.> "ref" <.> "nolinks"
-
-
-outFile :: String -> FilePath
-outFile mdl = outDir </> mdl <.> "html"
-
-
-refFile :: String -> FilePath
-refFile mdl = refDir </> mdl <.> "html"
-
-
 -- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
 -- These are considered bad and should be replaced as soon as possible.