Refactor HTML test suite boilerplate to external package.

5 files changed, 202 insertions, 0 deletions

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"
+        ]