Refactor HTML test suite boilerplate to external package.

8 files changed, 208 insertions, 142 deletions

diff --git a/.gitignore b/.gitignore
index 3c9798c1..3eb2ed83 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,6 +1,7 @@
 /dist/
 /haddock-api/dist/
 /haddock-library/dist/
+/haddock-test/dist/
 /html-test/out/
 /hypsrc-test/out/
 /latex-test/out/
diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
new file mode 100644
index 00000000..bc0dde6c
--- /dev/null
+++ b/haddock-test/haddock-test.cabal
@@ -0,0 +1,26 @@
+name:                 haddock-test
+version:              0.0.1
+synopsis:             Test utilities for Haddock
+license:              BSD3
+author:               Simon Marlow, David Waern
+maintainer:           Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
+homepage:             http://www.haskell.org/haddock/
+bug-reports:          https://github.com/haskell/haddock/issues
+copyright:            (c) Simon Marlow, David Waern
+category:             Documentation
+build-type:           Simple
+cabal-version:        >= 1.10
+stability:            experimental
+
+library
+  default-language: Haskell2010
+  hs-source-dirs:   src
+  build-depends:    base, directory, process, filepath, Cabal, xml, syb
+
+  exposed-modules:
+    Test.Haddock.Config
+    Test.Haddock.Process
+    Test.Haddock.Xhtml
+
+  other-modules:
+    Test.Haddock.Utils
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
new file mode 100644
index 00000000..bb226fdb
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -0,0 +1,70 @@
+module Test.Haddock.Config where
+
+
+import System.Console.GetOpt
+import System.FilePath
+
+import Test.Haddock.Process
+import Test.Haddock.Utils
+
+
+data Config = Config
+    { cfgHaddockPath :: FilePath
+    , cfgGhcPath :: FilePath
+    , cfgFiles :: [FilePath]
+    , cfgHaddockArgs :: [String]
+    , cfgHaddockStdOut :: FilePath
+    , cfgDiffTool :: Maybe FilePath
+    , cfgEnv :: Environment
+    }
+
+
+data Flag
+    = FlagHaddockPath FilePath
+    | FlagGhcPath FilePath
+    | FlagHaddockOptions String
+    | FlagHaddockStdOut FilePath
+    | FlagDiffTool FilePath
+    | FlagNoDiff
+    | FlagHelp
+    deriving Eq
+
+
+flagsHaddockPath :: [Flag] -> Maybe FilePath
+flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ]
+
+
+flagsGhcPath :: [Flag] -> Maybe FilePath
+flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ]
+
+
+flagsHaddockOptions :: [Flag] -> [String]
+flagsHaddockOptions flags = concat
+    [ words opts | FlagHaddockOptions opts <- flags ]
+
+
+flagsHaddockStdOut :: [Flag] -> Maybe FilePath
+flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ]
+
+
+flagsDiffTool :: [Flag] -> Maybe FilePath
+flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ]
+
+
+options :: [OptDescr Flag]
+options =
+    [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE")
+        "path to Haddock executable to exectue tests with"
+    , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE")
+        "path to GHC executable"
+    , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS")
+        "additional options to run Haddock with"
+    , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE")
+        "where to redirect Haddock output"
+    , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH")
+        "diff tool to use when printing failed cases"
+    , Option [] ["no-diff"] (NoArg FlagNoDiff)
+        "do not print diff for failed cases"
+    , Option ['h'] ["help"] (NoArg FlagHelp)
+        "display this help end exit"
+    ]
diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs
new file mode 100644
index 00000000..97f3ebed
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Process.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Test.Haddock.Process where
+
+
+import Control.Monad
+
+import System.Exit
+import System.FilePath
+import System.IO
+import System.Process
+
+
+type Environment = [(String, String)]
+
+
+data ProcessConfig = ProcessConfig
+    { pcArgs :: [String]
+    , pcWorkDir :: Maybe FilePath
+    , pcEnv :: Maybe Environment
+    , pcStdIn :: Maybe Handle
+    , pcStdOut :: Maybe Handle
+    , pcStdErr :: Maybe Handle
+    }
+
+
+processConfig :: ProcessConfig
+processConfig = ProcessConfig
+    { pcArgs = []
+    , pcWorkDir = Nothing
+    , pcEnv = Nothing
+    , pcStdIn = Nothing
+    , pcStdOut = Nothing
+    , pcStdErr = Nothing
+    }
+
+
+runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle
+runProcess' path (ProcessConfig { .. }) = runProcess
+    path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr
+
+
+waitForSuccess :: String -> ProcessHandle -> IO ()
+waitForSuccess msg handle = do
+    result <- waitForProcess handle
+    unless (result == ExitSuccess) $ do
+        hPutStrLn stderr $ msg
+        exitFailure
diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs
new file mode 100644
index 00000000..1d57107f
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -0,0 +1,8 @@
+module Test.Haddock.Utils where
+
+
+import Data.Maybe
+
+
+mlast :: [a] -> Maybe a
+mlast = listToMaybe . reverse
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
new file mode 100644
index 00000000..35f5910a
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+
+module Test.Haddock.Xhtml where
+
+
+import Control.Monad
+
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+
+import Text.XML.Light
+
+
+deriving instance Eq Content
+deriving instance Eq Element
+deriving instance Eq CData
+
+
+readXml :: FilePath -> IO (Maybe Element)
+readXml = liftM parseXMLDoc . readFile
+
+
+strip :: Element -> Element
+strip = stripFooter . stripLinks
+
+
+stripLinks :: Element -> Element
+stripLinks =
+    everywhere (mkT unlink)
+  where
+    unlink attr@(Attr { attrKey = key })
+        | qName key == "href" = attr { attrVal = "#" }
+        | otherwise = attr
+
+
+stripFooter :: Element -> Element
+stripFooter =
+    everywhere (mkT defoot)
+  where
+    defoot elem
+        | isFooter elem = elem { elContent = [] }
+        | otherwise = elem
+    isFooter elem = any isFooterAttr $ elAttribs elem
+    isFooterAttr (Attr { .. }) = and
+        [ qName attrKey == "id"
+        , attrVal == "footer"
+        ]
diff --git a/haddock.cabal b/haddock.cabal
index 40bf59a6..c0e812a1 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -127,7 +127,7 @@ test-suite html-test
   default-language: Haskell2010
   main-is:          run.hs
   hs-source-dirs:   html-test
-  build-depends:    base, directory, process, filepath, Cabal, xml, syb
+  build-depends:    base, directory, process, filepath, Cabal, xml, syb, haddock-test
 
 test-suite hypsrc-test
   type:             exitcode-stdio-1.0
diff --git a/html-test/run.hs b/html-test/run.hs
index f57d547a..e96943a0 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -1,4 +1,3 @@
-#!/usr/bin/env runhaskell
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -7,8 +6,6 @@
 import Control.Applicative
 import Control.Monad
 
-import Data.Generics.Aliases
-import Data.Generics.Schemes
 import Data.Maybe
 import Data.List
 
@@ -31,6 +28,10 @@ import System.Process
 
 import qualified Text.XML.Light as Xml
 
+import Test.Haddock.Process
+import Test.Haddock.Config
+import Test.Haddock.Xhtml
+
 
 baseDir, rootDir :: FilePath
 baseDir = takeDirectory __FILE__
@@ -45,17 +46,6 @@ resDir :: FilePath
 resDir = rootDir </> "resources"
 
 
-data Config = Config
-    { cfgHaddockPath :: FilePath
-    , cfgGhcPath :: FilePath
-    , cfgFiles :: [FilePath]
-    , cfgHaddockArgs :: [String]
-    , cfgHaddockStdOut :: FilePath
-    , cfgDiffTool :: Maybe FilePath
-    , cfgEnv :: Environment
-    }
-
-
 data CheckResult
     = Fail
     | Pass
@@ -262,133 +252,6 @@ modulePath :: String -> FilePath
 modulePath mdl = srcDir </> mdl <.> "hs"
 
 
-deriving instance Eq Xml.Content
-deriving instance Eq Xml.Element
-deriving instance Eq Xml.CData
-
-
-readXml :: FilePath -> IO (Maybe Xml.Element)
-readXml = liftM Xml.parseXMLDoc . readFile
-
-
-strip :: Xml.Element -> Xml.Element
-strip = stripFooter . stripLinks
-
-
-stripLinks :: Xml.Element -> Xml.Element
-stripLinks =
-    everywhere (mkT unlink)
-  where
-    unlink attr@(Xml.Attr { attrKey = key })
-        | Xml.qName key == "href" = attr { Xml.attrVal = "#" }
-        | otherwise = attr
-
-
-stripFooter :: Xml.Element -> Xml.Element
-stripFooter =
-    everywhere (mkT defoot)
-  where
-    defoot elem
-        | isFooter elem = elem { Xml.elContent = [] }
-        | otherwise = elem
-    isFooter elem = any isFooterAttr $ Xml.elAttribs elem
-    isFooterAttr (Xml.Attr { .. }) = and
-        [ Xml.qName attrKey == "id"
-        , attrVal == "footer"
-        ]
-
-
-data Flag
-    = FlagHaddockPath FilePath
-    | FlagGhcPath FilePath
-    | FlagHaddockOptions String
-    | FlagHaddockStdOut FilePath
-    | FlagDiffTool FilePath
-    | FlagNoDiff
-    | FlagHelp
-    deriving Eq
-
-
-options :: [OptDescr Flag]
-options =
-    [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE")
-        "path to Haddock executable to exectue tests with"
-    , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE")
-        "path to GHC executable"
-    , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS")
-        "additional options to run Haddock with"
-    , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE")
-        "where to redirect Haddock output"
-    , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH")
-        "diff tool to use when printing failed cases"
-    , Option [] ["no-diff"] (NoArg FlagNoDiff)
-        "do not print diff for failed cases"
-    , Option ['h'] ["help"] (NoArg FlagHelp)
-        "display this help end exit"
-    ]
-
-
-flagsHaddockPath :: [Flag] -> Maybe FilePath
-flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ]
-
-
-flagsGhcPath :: [Flag] -> Maybe FilePath
-flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ]
-
-
-flagsHaddockOptions :: [Flag] -> [String]
-flagsHaddockOptions flags = concat
-    [ words opts | FlagHaddockOptions opts <- flags ]
-
-
-flagsHaddockStdOut :: [Flag] -> Maybe FilePath
-flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ]
-
-
-flagsDiffTool :: [Flag] -> Maybe FilePath
-flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ]
-
-
-type Environment = [(String, String)]
-
-data ProcessConfig = ProcessConfig
-    { pcArgs :: [String]
-    , pcWorkDir :: Maybe FilePath
-    , pcEnv :: Maybe Environment
-    , pcStdIn :: Maybe Handle
-    , pcStdOut :: Maybe Handle
-    , pcStdErr :: Maybe Handle
-    }
-
-
-processConfig :: ProcessConfig
-processConfig = ProcessConfig
-    { pcArgs = []
-    , pcWorkDir = Nothing
-    , pcEnv = Nothing
-    , pcStdIn = Nothing
-    , pcStdOut = Nothing
-    , pcStdErr = Nothing
-    }
-
-
-runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle
-runProcess' path (ProcessConfig { .. }) = runProcess
-    path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr
-
-
-waitForSuccess :: String -> ProcessHandle -> IO ()
-waitForSuccess msg handle = do
-    result <- waitForProcess handle
-    unless (result == ExitSuccess) $ do
-        hPutStrLn stderr $ msg
-        exitFailure
-
-
-mlast :: [a] -> Maybe a
-mlast = listToMaybe . reverse
-
-
 -- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
 -- These are considered bad and should be replaced as soon as possible.