From 4a4d9ecf66bcb6561f7b10c07742c4b6688332b8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 12:21:45 +0200
Subject: Refactor HTML test suite boilerplate to external package.

---
 haddock-test/src/Test/Haddock/Config.hs  | 70 ++++++++++++++++++++++++++++++++
 haddock-test/src/Test/Haddock/Process.hs | 49 ++++++++++++++++++++++
 haddock-test/src/Test/Haddock/Utils.hs   |  8 ++++
 haddock-test/src/Test/Haddock/Xhtml.hs   | 49 ++++++++++++++++++++++
 4 files changed, 176 insertions(+)
 create mode 100644 haddock-test/src/Test/Haddock/Config.hs
 create mode 100644 haddock-test/src/Test/Haddock/Process.hs
 create mode 100644 haddock-test/src/Test/Haddock/Utils.hs
 create mode 100644 haddock-test/src/Test/Haddock/Xhtml.hs

(limited to 'haddock-test/src/Test')

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"
+        ]
-- 
cgit v1.2.3


From 1102352d9e830fdf6ecd8abfba50c405114d5ae2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 13:51:23 +0200
Subject: Create utilities for storing directory configuration.

---
 haddock-test/src/Test/Haddock/Config.hs | 22 ++++++++++++++++++++++
 1 file changed, 22 insertions(+)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index bb226fdb..af2a460b 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -8,6 +8,21 @@ import Test.Haddock.Process
 import Test.Haddock.Utils
 
 
+data DirConfig = DirConfig
+    { dcfgSrcDir :: FilePath
+    , dcfgRefDir :: FilePath
+    , dcfgOutDir :: FilePath
+    }
+
+
+defaultDirConfig :: FilePath -> DirConfig
+defaultDirConfig baseDir = DirConfig
+    { dcfgSrcDir = baseDir </> "src"
+    , dcfgRefDir = baseDir </> "ref"
+    , dcfgOutDir = baseDir </> "out"
+    }
+
+
 data Config = Config
     { cfgHaddockPath :: FilePath
     , cfgGhcPath :: FilePath
@@ -16,9 +31,16 @@ data Config = Config
     , cfgHaddockStdOut :: FilePath
     , cfgDiffTool :: Maybe FilePath
     , cfgEnv :: Environment
+    , cfgDirConfig :: DirConfig
     }
 
 
+cfgSrcDir, cfgRefDir, cfgOutDir :: Config -> FilePath
+cfgSrcDir = dcfgSrcDir . cfgDirConfig
+cfgRefDir = dcfgRefDir . cfgDirConfig
+cfgOutDir = dcfgOutDir . cfgDirConfig
+
+
 data Flag
     = FlagHaddockPath FilePath
     | FlagGhcPath FilePath
-- 
cgit v1.2.3


From 6a2c16a0b0790ca0f3a30be8a6e96c7818514ff6 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 14:33:29 +0200
Subject: Move IO-dependent config of HTML test suite to test package.

---
 haddock-test/src/Test/Haddock/Config.hs | 145 +++++++++++++++++++++++++++++++-
 html-test/run.hs                        | 121 +-------------------------
 2 files changed, 145 insertions(+), 121 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index af2a460b..b9444c3e 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -1,8 +1,30 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
 module Test.Haddock.Config where
 
 
+import Control.Applicative
+import Control.Monad
+
+import qualified Data.List as List
+import Data.Maybe
+
+import Distribution.InstalledPackageInfo
+import Distribution.Package
+import Distribution.Simple.Compiler hiding (Flag)
+import Distribution.Simple.GHC
+import Distribution.Simple.PackageIndex
+import Distribution.Simple.Program
+import Distribution.Simple.Utils
+import Distribution.Verbosity
+
 import System.Console.GetOpt
+import System.Directory
+import System.Exit
+import System.Environment
 import System.FilePath
+import System.IO
 
 import Test.Haddock.Process
 import Test.Haddock.Utils
@@ -12,6 +34,7 @@ data DirConfig = DirConfig
     { dcfgSrcDir :: FilePath
     , dcfgRefDir :: FilePath
     , dcfgOutDir :: FilePath
+    , dcfgResDir :: FilePath
     }
 
 
@@ -20,12 +43,14 @@ defaultDirConfig baseDir = DirConfig
     { dcfgSrcDir = baseDir </> "src"
     , dcfgRefDir = baseDir </> "ref"
     , dcfgOutDir = baseDir </> "out"
+    , dcfgResDir = rootDir </> "resources"
     }
+  where
+    rootDir = baseDir </> ".."
 
 
 data Config = Config
     { cfgHaddockPath :: FilePath
-    , cfgGhcPath :: FilePath
     , cfgFiles :: [FilePath]
     , cfgHaddockArgs :: [String]
     , cfgHaddockStdOut :: FilePath
@@ -35,10 +60,11 @@ data Config = Config
     }
 
 
-cfgSrcDir, cfgRefDir, cfgOutDir :: Config -> FilePath
+cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config -> FilePath
 cfgSrcDir = dcfgSrcDir . cfgDirConfig
 cfgRefDir = dcfgRefDir . cfgDirConfig
 cfgOutDir = dcfgOutDir . cfgDirConfig
+cfgResDir = dcfgResDir . cfgDirConfig
 
 
 data Flag
@@ -90,3 +116,118 @@ options =
     , Option ['h'] ["help"] (NoArg FlagHelp)
         "display this help end exit"
     ]
+
+
+checkOpt :: [String] -> IO ([Flag], [String])
+checkOpt args = do
+    let (flags, files, errors) = getOpt Permute options args
+
+    unless (null errors) $ do
+        hPutStr stderr $ concat errors
+        exitFailure
+
+    when (FlagHelp `elem` flags) $ do
+        hPutStrLn stderr $ usageInfo "" options
+        exitSuccess
+
+    return (flags, files)
+
+
+loadConfig :: DirConfig -> [Flag] -> [String] -> IO Config
+loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
+    cfgEnv <- (:) ("haddock_datadir", dcfgResDir) <$> getEnvironment
+
+    systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
+    cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of
+        Just path -> pure path
+        Nothing -> do
+            hPutStrLn stderr $ "Haddock executable not specified"
+            exitFailure
+
+    ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath
+        ["--print-ghc-path"]
+
+    printVersions cfgEnv cfgHaddockPath
+
+    cfgFiles <- processFileArgs cfgDirConfig files
+
+    cfgHaddockArgs <- liftM concat . sequence $
+        [ pure ["--no-warnings"]
+        , pure ["--odir=" ++ dcfgOutDir]
+        , pure ["--pretty-html"]
+        , pure ["--html"]
+        , pure ["--optghc=-w"]
+        , pure $ flagsHaddockOptions flags
+        , baseDependencies ghcPath
+        ]
+
+    let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags)
+
+    cfgDiffTool <- if FlagNoDiff `elem` flags
+        then pure Nothing
+        else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
+
+    return $ Config { .. }
+
+
+printVersions :: Environment -> FilePath -> IO ()
+printVersions env haddockPath = do
+    handleHaddock <- runProcess' haddockPath $ processConfig
+        { pcEnv = Just env
+        , pcArgs = ["--version"]
+        }
+    waitForSuccess "Failed to run `haddock --version`" handleHaddock
+
+    handleGhc <- runProcess' haddockPath $ processConfig
+        { pcEnv = Just env
+        , pcArgs = ["--ghc-version"]
+        }
+    waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc
+
+
+baseDependencies :: FilePath -> IO [String]
+baseDependencies ghcPath = do
+    (_, _, cfg) <- configure normal (Just ghcPath) Nothing
+        defaultProgramConfiguration
+    pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
+    mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"]
+  where
+    getDependency pkgIndex name = case ifaces pkgIndex name of
+        [] -> do
+            hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name
+            exitFailure
+        (ifArg:_) -> pure ifArg
+    ifaces pkgIndex name = do
+        pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name)
+        iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg
+    iface file html = "--read-interface=" ++ html ++ "," ++ file
+
+
+defaultDiffTool :: IO (Maybe FilePath)
+defaultDiffTool =
+    liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
+  where
+    isAvailable = liftM isJust . findProgramLocation silent
+
+
+processFileArgs :: DirConfig -> [String] -> IO [FilePath]
+processFileArgs dcfg [] =
+    map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
+  where
+    srcDir = dcfgSrcDir dcfg
+    toModulePath = modulePath dcfg . takeBaseName
+processFileArgs dcfg args = pure $ map (processFileArg dcfg) args
+
+
+processFileArg :: DirConfig -> String -> FilePath
+processFileArg dcfg arg
+    | isSourceFile arg = arg
+    | otherwise = modulePath dcfg arg
+
+
+isSourceFile :: FilePath -> Bool
+isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
+
+
+modulePath :: DirConfig -> String -> FilePath
+modulePath dcfg mdl = dcfgSrcDir dcfg </> mdl <.> "hs"
diff --git a/html-test/run.hs b/html-test/run.hs
index e96943a0..5a2944f9 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -9,15 +9,6 @@ import Control.Monad
 import Data.Maybe
 import Data.List
 
-import Distribution.InstalledPackageInfo
-import Distribution.Package
-import Distribution.Simple.Compiler hiding (Flag)
-import Distribution.Simple.GHC
-import Distribution.Simple.PackageIndex
-import Distribution.Simple.Program
-import Distribution.Simple.Utils
-import Distribution.Verbosity
-
 import System.Console.GetOpt
 import System.Directory
 import System.Environment
@@ -54,7 +45,8 @@ data CheckResult
 
 main :: IO ()
 main = do
-    cfg <- uncurry loadConfig =<< checkOpt =<< getArgs
+    let dcfg = defaultDirConfig baseDir
+    cfg <- uncurry (loadConfig dcfg) =<< checkOpt =<< getArgs
     runHaddock cfg
     checkFiles cfg
 
@@ -101,54 +93,6 @@ runHaddock (Config { .. }) = do
     waitForSuccess "Failed to run Haddock on specified test files" handle
 
 
-checkOpt :: [String] -> IO ([Flag], [String])
-checkOpt args = do
-    let (flags, files, errors) = getOpt Permute options args
-
-    unless (null errors) $ do
-        hPutStr stderr $ concat errors
-        exitFailure
-
-    when (FlagHelp `elem` flags) $ do
-        hPutStrLn stderr $ usageInfo "" options
-        exitSuccess
-
-    return (flags, files)
-
-
-loadConfig :: [Flag] -> [String] -> IO Config
-loadConfig flags files = do
-    cfgEnv <- (:) ("haddock_datadir", resDir) <$> getEnvironment
-
-    cfgHaddockPath <- pure $ flip fromMaybe (flagsHaddockPath flags) $
-        rootDir </> "dist" </> "build" </> "haddock" </> "haddock"
-
-    printVersions cfgEnv cfgHaddockPath
-
-    cfgGhcPath <- flip fromMaybe (flagsGhcPath flags) <$>
-         init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"]
-
-    cfgFiles <- processFileArgs files
-
-    cfgHaddockArgs <- liftM concat . sequence $
-        [ pure ["--no-warnings"]
-        , pure ["--odir=" ++ outDir]
-        , pure ["--pretty-html"]
-        , pure ["--html"]
-        , pure ["--optghc=-w"]
-        , pure $ flagsHaddockOptions flags
-        , baseDependencies cfgGhcPath
-        ]
-
-    let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags)
-
-    cfgDiffTool <- if FlagNoDiff `elem` flags
-        then pure Nothing
-        else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
-
-    return $ Config { .. }
-
-
 checkModule :: String -> IO CheckResult
 checkModule mdl = do
     hasRef <- doesFileExist $ refFile mdl
@@ -191,67 +135,6 @@ refFile :: String -> FilePath
 refFile mdl = refDir </> mdl <.> "html"
 
 
-printVersions :: Environment -> FilePath -> IO ()
-printVersions env haddockPath = do
-    handle <- runProcess' haddockPath $ processConfig
-        { pcEnv = Just env
-        , pcArgs = ["--version"]
-        }
-    waitForSuccess "Failed to run `haddock --version`" handle
-
-    handle <- runProcess' haddockPath $ processConfig
-        { pcEnv = Just env
-        , pcArgs = ["--ghc-version"]
-        }
-    waitForSuccess "Failed to run `haddock --ghc-version`" handle
-
-
-baseDependencies :: FilePath -> IO [String]
-baseDependencies ghcPath = do
-    (_, _, cfg) <- configure normal (Just ghcPath) Nothing
-        defaultProgramConfiguration
-    pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
-    mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"]
-  where
-    getDependency pkgIndex name = case ifaces pkgIndex name of
-        [] -> do
-            hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name
-            exitFailure
-        (ifArg:_) -> pure ifArg
-    ifaces pkgIndex name = do
-        pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name)
-        iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg
-    iface file html = "--read-interface=" ++ html ++ "," ++ file
-
-
-defaultDiffTool :: IO (Maybe FilePath)
-defaultDiffTool =
-    liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
-  where
-    isAvailable = liftM isJust . findProgramLocation silent
-
-
-processFileArgs :: [String] -> IO [FilePath]
-processFileArgs [] =
-    map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
-  where
-    toModulePath = modulePath . takeBaseName
-processFileArgs args = pure $ map processFileArg args
-
-
-processFileArg :: String -> FilePath
-processFileArg arg
-    | isSourceFile arg = arg
-    | otherwise = modulePath arg
-
-
-isSourceFile :: FilePath -> Bool
-isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
-
-modulePath :: String -> FilePath
-modulePath mdl = srcDir </> mdl <.> "hs"
-
-
 -- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
 -- These are considered bad and should be replaced as soon as possible.
 
-- 
cgit v1.2.3


From 54fb845b2b322d823fb44f905bd4c4d40225259c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 16:03:19 +0200
Subject: Move Haddock runner of HTML test suite to Haddock test package.

---
 haddock-test/haddock-test.cabal  |   1 +
 haddock-test/src/Test/Haddock.hs | 117 ++++++++++++++++++++++++++++++++++++++
 html-test/run.hs                 | 120 +--------------------------------------
 3 files changed, 120 insertions(+), 118 deletions(-)
 create mode 100644 haddock-test/src/Test/Haddock.hs

(limited to 'haddock-test/src/Test')

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.
 
-- 
cgit v1.2.3


From 66d7114dc8d310e1dc1105a0805c1c491312b43c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 17:28:24 +0200
Subject: Make Haddock test package more generic.

---
 haddock-test/src/Test/Haddock.hs        | 39 +++++++++++++++++----------------
 haddock-test/src/Test/Haddock/Config.hs | 26 ++++++++++++++++------
 html-test/run.hs                        | 18 +++++++++++----
 3 files changed, 53 insertions(+), 30 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 6ca57d7b..3c0c8d5f 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -19,18 +19,16 @@ 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
+    | Error String
 
 
-checkFiles :: Config -> IO ()
+checkFiles :: Config c -> IO ()
 checkFiles cfg@(Config { .. }) = do
     putStrLn "Testing output files..."
     failed <- liftM catMaybes . forM cfgFiles $ \file -> do
@@ -42,6 +40,7 @@ checkFiles cfg@(Config { .. }) = do
             Fail -> putStrLn "FAIL" >> (return $ Just mdl)
             Pass -> putStrLn "PASS" >> (return Nothing)
             NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
+            Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing
 
     if null failed
         then do
@@ -52,14 +51,14 @@ checkFiles cfg@(Config { .. }) = do
             exitFailure
 
 
-maybeDiff :: Config -> [String] -> IO ()
+maybeDiff :: Config c -> [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 c -> IO ()
 runHaddock (Config { .. }) = do
     putStrLn "Running Haddock process..."
 
@@ -72,29 +71,30 @@ runHaddock (Config { .. }) = do
     waitForSuccess "Failed to run Haddock on specified test files" handle
 
 
-checkModule :: Config -> String -> IO CheckResult
+checkModule :: Config c -> 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
+            mout <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl)
+            mref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl)
+            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
 
 
-diffModule :: Config -> FilePath -> String -> IO ()
+diffModule :: Config c -> 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'
+    Just out <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl)
+    Just ref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl)
+    writeFile outFile' $ ccfgDump ccfg out
+    writeFile refFile' $ ccfgDump ccfg ref
 
     putStrLn $ "Diff for module " ++ show mdl ++ ":"
     hFlush stdout
@@ -105,6 +105,7 @@ diffModule cfg diff mdl = do
     waitForProcess handle >> return ()
   where
     dcfg = cfgDirConfig cfg
+    ccfg = cfgCheckConfig cfg
     outFile' = outFile dcfg mdl <.> "nolinks"
     refFile' = outFile dcfg mdl <.> "ref" <.> "nolinks"
 
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index b9444c3e..3b6dfdeb 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -30,6 +30,13 @@ import Test.Haddock.Process
 import Test.Haddock.Utils
 
 
+data CheckConfig c = CheckConfig
+    { ccfgRead :: String -> String -> Maybe c
+    , ccfgDump :: c -> String
+    , ccfgEqual :: c -> c -> Bool
+    }
+
+
 data DirConfig = DirConfig
     { dcfgSrcDir :: FilePath
     , dcfgRefDir :: FilePath
@@ -49,24 +56,26 @@ defaultDirConfig baseDir = DirConfig
     rootDir = baseDir </> ".."
 
 
-data Config = Config
+data Config c = Config
     { cfgHaddockPath :: FilePath
     , cfgFiles :: [FilePath]
     , cfgHaddockArgs :: [String]
     , cfgHaddockStdOut :: FilePath
     , cfgDiffTool :: Maybe FilePath
     , cfgEnv :: Environment
+    , cfgCheckConfig :: CheckConfig c
     , cfgDirConfig :: DirConfig
     }
 
 
-cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config -> FilePath
+cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config c -> FilePath
 cfgSrcDir = dcfgSrcDir . cfgDirConfig
 cfgRefDir = dcfgRefDir . cfgDirConfig
 cfgOutDir = dcfgOutDir . cfgDirConfig
 cfgResDir = dcfgResDir . cfgDirConfig
 
 
+
 data Flag
     = FlagHaddockPath FilePath
     | FlagGhcPath FilePath
@@ -133,9 +142,9 @@ checkOpt args = do
     return (flags, files)
 
 
-loadConfig :: DirConfig -> [Flag] -> [String] -> IO Config
-loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
-    cfgEnv <- (:) ("haddock_datadir", dcfgResDir) <$> getEnvironment
+loadConfig :: CheckConfig c -> DirConfig -> [Flag] -> [String] -> IO (Config c)
+loadConfig ccfg dcfg flags files = do
+    cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment
 
     systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
     cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of
@@ -149,11 +158,11 @@ loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
 
     printVersions cfgEnv cfgHaddockPath
 
-    cfgFiles <- processFileArgs cfgDirConfig files
+    cfgFiles <- processFileArgs dcfg files
 
     cfgHaddockArgs <- liftM concat . sequence $
         [ pure ["--no-warnings"]
-        , pure ["--odir=" ++ dcfgOutDir]
+        , pure ["--odir=" ++ dcfgOutDir dcfg]
         , pure ["--pretty-html"]
         , pure ["--html"]
         , pure ["--optghc=-w"]
@@ -167,6 +176,9 @@ loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do
         then pure Nothing
         else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
 
+    let cfgCheckConfig = ccfg
+    let cfgDirConfig = dcfg
+
     return $ Config { .. }
 
 
diff --git a/html-test/run.hs b/html-test/run.hs
index 48c733d0..22a06ba3 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -5,16 +5,26 @@ import System.Environment
 import System.FilePath
 
 import Test.Haddock
+import Test.Haddock.Xhtml
 
+import qualified Text.XML.Light as Xml
 
-baseDir :: FilePath
-baseDir = takeDirectory __FILE__
+
+checkConfig :: CheckConfig Xml.Element
+checkConfig = CheckConfig
+    { ccfgRead = \_ input -> strip <$> Xml.parseXMLDoc input
+    , ccfgDump = Xml.ppElement
+    , ccfgEqual = (==)
+    }
+
+
+dirConfig :: DirConfig
+dirConfig = defaultDirConfig $ takeDirectory __FILE__
 
 
 main :: IO ()
 main = do
-    let dcfg = defaultDirConfig baseDir
-    cfg <- uncurry (loadConfig dcfg) =<< checkOpt =<< getArgs
+    cfg <- uncurry (loadConfig checkConfig dirConfig) =<< checkOpt =<< getArgs
     runHaddock cfg
     checkFiles cfg
 
-- 
cgit v1.2.3


From ad82e40c858e313f8ff06eed058618fa1eaa8c19 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 20:27:59 +0200
Subject: Create convenience wrappers to simplify in test entry points.

---
 haddock-test/src/Test/Haddock.hs        | 4 ++++
 haddock-test/src/Test/Haddock/Config.hs | 4 ++++
 html-test/run.hs                        | 5 +----
 3 files changed, 9 insertions(+), 4 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 3c0c8d5f..de293eab 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -28,6 +28,10 @@ data CheckResult
     | Error String
 
 
+runAndCheck :: Config c -> IO ()
+runAndCheck cfg = runHaddock cfg >> checkFiles cfg
+
+
 checkFiles :: Config c -> IO ()
 checkFiles cfg@(Config { .. }) = do
     putStrLn "Testing output files..."
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 3b6dfdeb..3068e52b 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -127,6 +127,10 @@ options =
     ]
 
 
+parseArgs :: CheckConfig c -> DirConfig -> [String] -> IO (Config c)
+parseArgs ccfg dcfg args = uncurry (loadConfig ccfg dcfg) =<< checkOpt args
+
+
 checkOpt :: [String] -> IO ([Flag], [String])
 checkOpt args = do
     let (flags, files, errors) = getOpt Permute options args
diff --git a/html-test/run.hs b/html-test/run.hs
index 22a06ba3..2758bf56 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -23,10 +23,7 @@ dirConfig = defaultDirConfig $ takeDirectory __FILE__
 
 
 main :: IO ()
-main = do
-    cfg <- uncurry (loadConfig checkConfig dirConfig) =<< checkOpt =<< getArgs
-    runHaddock cfg
-    checkFiles cfg
+main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs
 
 
 -- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
-- 
cgit v1.2.3


From 188b8aae6efa5d3f41687c84399343494f6bf975 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 21:04:26 +0200
Subject: Adjust module visibility and items they export.

---
 haddock-test/haddock-test.cabal         | 2 +-
 haddock-test/src/Test/Haddock.hs        | 4 ++--
 haddock-test/src/Test/Haddock/Config.hs | 7 ++++++-
 3 files changed, 9 insertions(+), 4 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
index 4cf10799..18c9d28b 100644
--- a/haddock-test/haddock-test.cabal
+++ b/haddock-test/haddock-test.cabal
@@ -21,8 +21,8 @@ library
   exposed-modules:
     Test.Haddock
     Test.Haddock.Config
-    Test.Haddock.Process
     Test.Haddock.Xhtml
 
   other-modules:
+    Test.Haddock.Process
     Test.Haddock.Utils
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index de293eab..a6b9ea8a 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -2,8 +2,8 @@
 
 
 module Test.Haddock
-    ( module Test.Haddock
-    , module Test.Haddock.Config
+    ( module Test.Haddock.Config
+    , runAndCheck, runHaddock, checkFiles
     ) where
 
 
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 3068e52b..0c9bdb19 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -1,7 +1,12 @@
 {-# LANGUAGE RecordWildCards #-}
 
 
-module Test.Haddock.Config where
+module Test.Haddock.Config
+    ( CheckConfig(..), DirConfig(..), Config(..)
+    , defaultDirConfig
+    , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir
+    , parseArgs, checkOpt, loadConfig
+    ) where
 
 
 import Control.Applicative
-- 
cgit v1.2.3


From b1c899c2ccb0b7d12aa7f4217dff516d354f2055 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 21:13:35 +0200
Subject: Remove no longer useful test option.

---
 haddock-test/src/Test/Haddock/Config.hs | 7 -------
 1 file changed, 7 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 0c9bdb19..4f6bb818 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -83,7 +83,6 @@ cfgResDir = dcfgResDir . cfgDirConfig
 
 data Flag
     = FlagHaddockPath FilePath
-    | FlagGhcPath FilePath
     | FlagHaddockOptions String
     | FlagHaddockStdOut FilePath
     | FlagDiffTool FilePath
@@ -96,10 +95,6 @@ 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 ]
@@ -117,8 +112,6 @@ 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")
-- 
cgit v1.2.3


From 869ee23cc7ec1bd2fa9299323b74d71fe6023ef2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 13 Aug 2015 21:21:02 +0200
Subject: Change extension of test files used for diffing.

---
 haddock-test/src/Test/Haddock.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index a6b9ea8a..78204840 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -110,8 +110,8 @@ diffModule cfg diff mdl = do
   where
     dcfg = cfgDirConfig cfg
     ccfg = cfgCheckConfig cfg
-    outFile' = outFile dcfg mdl <.> "nolinks"
-    refFile' = outFile dcfg mdl <.> "ref" <.> "nolinks"
+    outFile' = outFile dcfg mdl <.> "dump"
+    refFile' = outFile dcfg mdl <.> "ref" <.> "dump"
 
 
 outFile :: DirConfig -> String -> FilePath
-- 
cgit v1.2.3


From 5934c411a8ebe0ba1a317f7c95babfbd63106254 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 14 Aug 2015 00:34:10 +0200
Subject: Refactor and simplify XHTML helper module of test package.

---
 haddock-test/src/Test/Haddock/Xhtml.hs | 40 ++++++++++++++++++++--------------
 html-test/run.hs                       | 17 +++++++++------
 2 files changed, 34 insertions(+), 23 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index 35f5910a..b6941496 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -2,47 +2,55 @@
 {-# LANGUAGE StandaloneDeriving #-}
 
 
-module Test.Haddock.Xhtml where
+module Test.Haddock.Xhtml
+    ( Xhtml(..)
+    , parseXhtml, dumpXhtml
+    , stripLinks, stripFooter
+    ) where
 
 
-import Control.Monad
-
 import Data.Generics.Aliases
 import Data.Generics.Schemes
 
 import Text.XML.Light
 
 
-deriving instance Eq Content
+newtype Xhtml = Xhtml
+    { xhtmlElement :: Element
+    } deriving Eq
+
+
+-- TODO: Find a way to avoid warning about orphan instances.
 deriving instance Eq Element
+deriving instance Eq Content
 deriving instance Eq CData
 
 
-readXml :: FilePath -> IO (Maybe Element)
-readXml = liftM parseXMLDoc . readFile
+parseXhtml :: String -> Maybe Xhtml
+parseXhtml = fmap Xhtml . parseXMLDoc
 
 
-strip :: Element -> Element
-strip = stripFooter . stripLinks
+dumpXhtml :: Xhtml -> String
+dumpXhtml = ppElement . xhtmlElement
 
 
-stripLinks :: Element -> Element
+stripLinks :: Xhtml -> Xhtml
 stripLinks =
-    everywhere (mkT unlink)
+    Xhtml . everywhere (mkT unlink) . xhtmlElement
   where
     unlink attr@(Attr { attrKey = key })
         | qName key == "href" = attr { attrVal = "#" }
         | otherwise = attr
 
 
-stripFooter :: Element -> Element
+stripFooter :: Xhtml -> Xhtml
 stripFooter =
-    everywhere (mkT defoot)
+    Xhtml . everywhere (mkT defoot) . xhtmlElement
   where
-    defoot elem
-        | isFooter elem = elem { elContent = [] }
-        | otherwise = elem
-    isFooter elem = any isFooterAttr $ elAttribs elem
+    defoot el
+        | isFooter el = el { elContent = [] }
+        | otherwise = el
+    isFooter el = any isFooterAttr $ elAttribs el
     isFooterAttr (Attr { .. }) = and
         [ qName attrKey == "id"
         , attrVal == "footer"
diff --git a/html-test/run.hs b/html-test/run.hs
index 2758bf56..ab007f57 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -7,13 +7,11 @@ import System.FilePath
 import Test.Haddock
 import Test.Haddock.Xhtml
 
-import qualified Text.XML.Light as Xml
 
-
-checkConfig :: CheckConfig Xml.Element
+checkConfig :: CheckConfig Xhtml
 checkConfig = CheckConfig
-    { ccfgRead = \_ input -> strip <$> Xml.parseXMLDoc input
-    , ccfgDump = Xml.ppElement
+    { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input
+    , ccfgDump = dumpXhtml
     , ccfgEqual = (==)
     }
 
@@ -26,8 +24,13 @@ main :: IO ()
 main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs
 
 
--- *** OLD TEST RUNNER UTILITY FUNCTIONS ***
--- These are considered bad and should be replaced as soon as possible.
+stripIfRequired :: String -> Xhtml -> Xhtml
+stripIfRequired mdl =
+    stripLinks' . stripFooter
+  where
+    stripLinks'
+        | mdl `elem` preserveLinksModules = id
+        | otherwise = stripFooter
 
 
 -- | List of modules in which we don't 'stripLinks'
-- 
cgit v1.2.3


From 1cb714e35337a6b17d7fc37f086914f43f7f2da3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 14 Aug 2015 20:41:41 +0200
Subject: Implement utility functions for conditional link stripping.

---
 haddock-test/src/Test/Haddock/Xhtml.hs | 27 ++++++++++++++++++++++-----
 1 file changed, 22 insertions(+), 5 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index b6941496..d8c26249 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -5,7 +5,7 @@
 module Test.Haddock.Xhtml
     ( Xhtml(..)
     , parseXhtml, dumpXhtml
-    , stripLinks, stripFooter
+    , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
     ) where
 
 
@@ -35,14 +35,31 @@ dumpXhtml = ppElement . xhtmlElement
 
 
 stripLinks :: Xhtml -> Xhtml
-stripLinks =
-    Xhtml . everywhere (mkT unlink) . xhtmlElement
+stripLinks = stripLinksWhen (const True)
+
+
+stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml
+stripLinksWhen p =
+    processAnchors unlink
+  where
+    unlink attr@(Attr { attrKey = key, attrVal = val })
+        | qName key == "href" && p val = attr { attrVal = "#" }
+        | otherwise = attr
+
+
+stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml
+stripAnchorsWhen p =
+    processAnchors unname
   where
-    unlink attr@(Attr { attrKey = key })
-        | qName key == "href" = attr { attrVal = "#" }
+    unname attr@(Attr { attrKey = key, attrVal = val })
+        | qName key == "name" && p val = attr { attrVal = "" }
         | otherwise = attr
 
 
+processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml
+processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement
+
+
 stripFooter :: Xhtml -> Xhtml
 stripFooter =
     Xhtml . everywhere (mkT defoot) . xhtmlElement
-- 
cgit v1.2.3


From 5568091a53ee53f742b6fe9f11b3edd1664228b9 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 17 Aug 2015 12:54:48 +0200
Subject: Implement output accepting mechanism in test package.

---
 haddock-test/src/Test/Haddock.hs        | 16 +++++++++++++++-
 haddock-test/src/Test/Haddock/Config.hs |  6 ++++++
 2 files changed, 21 insertions(+), 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 78204840..a2c6609a 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -29,7 +29,11 @@ data CheckResult
 
 
 runAndCheck :: Config c -> IO ()
-runAndCheck cfg = runHaddock cfg >> checkFiles cfg
+runAndCheck cfg = do
+    runHaddock cfg
+    if cfgAccept cfg
+        then acceptFiles cfg
+        else checkFiles cfg
 
 
 checkFiles :: Config c -> IO ()
@@ -55,6 +59,16 @@ checkFiles cfg@(Config { .. }) = do
             exitFailure
 
 
+acceptFiles :: Config c -> IO ()
+acceptFiles (Config { cfgFiles = files, cfgDirConfig = dcfg }) = do
+
+    forM_ files $ \file -> do
+        let mdl = takeBaseName file
+        putStr $ "Accepting " ++ mdl ++ "... "
+        copyFile (outFile dcfg mdl) (refFile dcfg mdl)
+        putStrLn "DONE"
+
+
 maybeDiff :: Config c -> [String] -> IO ()
 maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
 maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) mdls = do
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 4f6bb818..451cd809 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -68,6 +68,7 @@ data Config c = Config
     , cfgHaddockStdOut :: FilePath
     , cfgDiffTool :: Maybe FilePath
     , cfgEnv :: Environment
+    , cfgAccept :: Bool
     , cfgCheckConfig :: CheckConfig c
     , cfgDirConfig :: DirConfig
     }
@@ -87,6 +88,7 @@ data Flag
     | FlagHaddockStdOut FilePath
     | FlagDiffTool FilePath
     | FlagNoDiff
+    | FlagAccept
     | FlagHelp
     deriving Eq
 
@@ -118,6 +120,8 @@ options =
         "where to redirect Haddock output"
     , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH")
         "diff tool to use when printing failed cases"
+    , Option ['a'] ["accept"] (NoArg FlagAccept)
+        "accept generated output"
     , Option [] ["no-diff"] (NoArg FlagNoDiff)
         "do not print diff for failed cases"
     , Option ['h'] ["help"] (NoArg FlagHelp)
@@ -178,6 +182,8 @@ loadConfig ccfg dcfg flags files = do
         then pure Nothing
         else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
 
+    let cfgAccept = FlagAccept `elem` flags
+
     let cfgCheckConfig = ccfg
     let cfgDirConfig = dcfg
 
-- 
cgit v1.2.3


From 163da5a4b6268de54594e18f69f06799df637305 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 18:06:59 +0200
Subject: Create utility function for recursive obtaining directory contents.

---
 haddock-test/src/Test/Haddock/Utils.hs | 25 +++++++++++++++++++++++++
 1 file changed, 25 insertions(+)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs
index 1d57107f..4640fe97 100644
--- a/haddock-test/src/Test/Haddock/Utils.hs
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -1,8 +1,33 @@
 module Test.Haddock.Utils where
 
 
+import Control.Monad
+
 import Data.Maybe
 
+import System.Directory
+import System.FilePath
+
 
 mlast :: [a] -> Maybe a
 mlast = listToMaybe . reverse
+
+
+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
+partitionM _ [] = pure ([], [])
+partitionM p (x:xs) = do
+    (ss, fs) <- partitionM p xs
+    b <- p x
+    pure $ if b then (x:ss, fs) else (ss, x:fs)
+
+
+getDirectoryTree :: FilePath -> IO [FilePath]
+getDirectoryTree path = do
+    (dirs, files) <- partitionM isDirectory =<< contents
+    subfiles <- fmap concat . forM dirs $ \dir ->
+        map (dir </>) <$> getDirectoryTree (path </> dir)
+    pure $ files ++ subfiles
+  where
+    contents = filter realEntry <$> getDirectoryContents path
+    isDirectory entry = doesDirectoryExist $ path </> entry
+    realEntry entry = not $ entry == "." || entry == ".."
-- 
cgit v1.2.3


From e614916d940943a1f4f7cd77d9957246d164ab1d Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 18:47:11 +0200
Subject: Make Haddock test package more generic.

---
 haddock-test/src/Test/Haddock.hs        | 90 ++++++++++++++++-----------------
 haddock-test/src/Test/Haddock/Config.hs | 50 ++++++++++++------
 2 files changed, 78 insertions(+), 62 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index a2c6609a..f31ec53f 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -31,21 +31,20 @@ data CheckResult
 runAndCheck :: Config c -> IO ()
 runAndCheck cfg = do
     runHaddock cfg
-    if cfgAccept cfg
-        then acceptFiles cfg
-        else checkFiles cfg
+    checkFiles cfg
 
 
 checkFiles :: Config c -> 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
+    files <- getDirectoryContents (cfgOutDir cfg)
+    failed <- liftM catMaybes . forM files $ \file -> do
+        putStr $ "Checking \"" ++ file ++ "\"... "
+
+        status <- checkFile cfg file
         case status of
-            Fail -> putStrLn "FAIL" >> (return $ Just mdl)
+            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
@@ -59,43 +58,38 @@ checkFiles cfg@(Config { .. }) = do
             exitFailure
 
 
-acceptFiles :: Config c -> IO ()
-acceptFiles (Config { cfgFiles = files, cfgDirConfig = dcfg }) = do
-
-    forM_ files $ \file -> do
-        let mdl = takeBaseName file
-        putStr $ "Accepting " ++ mdl ++ "... "
-        copyFile (outFile dcfg mdl) (refFile dcfg mdl)
-        putStrLn "DONE"
-
-
-maybeDiff :: Config c -> [String] -> IO ()
+maybeDiff :: Config c -> [FilePath] -> IO ()
 maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure ()
-maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) mdls = do
+maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
     putStrLn "Diffing failed cases..."
-    forM_ mdls $ diffModule cfg diff
+    forM_ files $ diffFile cfg diff
 
 
 runHaddock :: Config c -> 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 c -> String -> IO CheckResult
-checkModule cfg mdl = do
-    hasRef <- doesFileExist $ refFile dcfg mdl
+    putStrLn "Generating documentation..."
+    forM_ cfgPackages $ \tpkg -> do
+        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 mdl <$> readFile (outFile dcfg mdl)
-            mref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl)
+            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
@@ -107,14 +101,14 @@ checkModule cfg mdl = do
     dcfg = cfgDirConfig cfg
 
 
-diffModule :: Config c -> FilePath -> String -> IO ()
-diffModule cfg diff mdl = do
-    Just out <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl)
-    Just ref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl)
+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 module " ++ show mdl ++ ":"
+    putStrLn $ "Diff for file \"" ++ file ++ "\":"
     hFlush stdout
     handle <- runProcess' diff $ processConfig
         { pcArgs = [outFile', refFile']
@@ -124,13 +118,17 @@ diffModule cfg diff mdl = do
   where
     dcfg = cfgDirConfig cfg
     ccfg = cfgCheckConfig cfg
-    outFile' = outFile dcfg mdl <.> "dump"
-    refFile' = outFile dcfg mdl <.> "ref" <.> "dump"
+    outFile' = outFile dcfg file <.> "dump"
+    refFile' = outFile dcfg file <.> "ref" <.> "dump"
+
+
+outDir :: DirConfig -> TestPackage -> FilePath
+outDir dcfg tpkg = dcfgOutDir dcfg </> tpkgName tpkg
 
 
-outFile :: DirConfig -> String -> FilePath
-outFile dcfg mdl = dcfgOutDir dcfg </> mdl <.> "html"
+outFile :: DirConfig -> FilePath -> FilePath
+outFile dcfg file = dcfgOutDir dcfg </> file
 
 
-refFile :: DirConfig -> String -> FilePath
-refFile dcfg mdl = dcfgRefDir dcfg </> mdl <.> "html"
+refFile :: DirConfig -> FilePath -> FilePath
+refFile dcfg file = dcfgRefDir dcfg </> file
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 451cd809..15a53829 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -2,7 +2,7 @@
 
 
 module Test.Haddock.Config
-    ( CheckConfig(..), DirConfig(..), Config(..)
+    ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..)
     , defaultDirConfig
     , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir
     , parseArgs, checkOpt, loadConfig
@@ -35,6 +35,12 @@ import Test.Haddock.Process
 import Test.Haddock.Utils
 
 
+data TestPackage = TestPackage
+    { tpkgName :: String
+    , tpkgFiles :: [FilePath]
+    }
+
+
 data CheckConfig c = CheckConfig
     { ccfgRead :: String -> String -> Maybe c
     , ccfgDump :: c -> String
@@ -63,7 +69,7 @@ defaultDirConfig baseDir = DirConfig
 
 data Config c = Config
     { cfgHaddockPath :: FilePath
-    , cfgFiles :: [FilePath]
+    , cfgPackages :: [TestPackage]
     , cfgHaddockArgs :: [String]
     , cfgHaddockStdOut :: FilePath
     , cfgDiffTool :: Maybe FilePath
@@ -164,7 +170,7 @@ loadConfig ccfg dcfg flags files = do
 
     printVersions cfgEnv cfgHaddockPath
 
-    cfgFiles <- processFileArgs dcfg files
+    cfgPackages <- processFileArgs dcfg files
 
     cfgHaddockArgs <- liftM concat . sequence $
         [ pure ["--no-warnings"]
@@ -230,24 +236,36 @@ defaultDiffTool =
     isAvailable = liftM isJust . findProgramLocation silent
 
 
-processFileArgs :: DirConfig -> [String] -> IO [FilePath]
+processFileArgs :: DirConfig -> [String] -> IO [TestPackage]
 processFileArgs dcfg [] =
-    map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir
+    processFileArgs dcfg . filter isValidEntry =<< getDirectoryContents srcDir
   where
+    isValidEntry entry = entry /= "." && entry /= ".."
     srcDir = dcfgSrcDir dcfg
-    toModulePath = modulePath dcfg . takeBaseName
-processFileArgs dcfg args = pure $ map (processFileArg dcfg) args
+processFileArgs dcfg args = processFileArgs' dcfg args
+
+
+processFileArgs' :: DirConfig -> [String] -> IO [TestPackage]
+processFileArgs' dcfg args = do
+    (mdls, dirs) <- partitionM doesDirectoryExist' args
+    rootPkg <- pure $ TestPackage
+        { tpkgName = ""
+        , tpkgFiles = map (processFileArg dcfg) mdls
+        }
+    otherPkgs <- forM dirs $ \dir -> do
+        files <- getDirectoryContents dir
+        pure $ TestPackage
+            { tpkgName = dir
+            , tpkgFiles = map ((dcfgSrcDir dcfg </> dir) </>) files
+            }
+    pure $ rootPkg:otherPkgs
+  where
+    doesDirectoryExist' path = doesDirectoryExist (dcfgSrcDir dcfg </> path)
 
 
 processFileArg :: DirConfig -> String -> FilePath
 processFileArg dcfg arg
     | isSourceFile arg = arg
-    | otherwise = modulePath dcfg arg
-
-
-isSourceFile :: FilePath -> Bool
-isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
-
-
-modulePath :: DirConfig -> String -> FilePath
-modulePath dcfg mdl = dcfgSrcDir dcfg </> mdl <.> "hs"
+    | otherwise = dcfgSrcDir dcfg </> arg </> ".hs"
+  where
+    isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
-- 
cgit v1.2.3


From c2a4125e3a5158078d8c172a840f7292dcf3ab28 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 20:32:12 +0200
Subject: Fix path handling in test runner.

---
 haddock-test/src/Test/Haddock/Config.hs | 25 ++++++++++---------------
 1 file changed, 10 insertions(+), 15 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 15a53829..1b89e276 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -238,34 +238,29 @@ defaultDiffTool =
 
 processFileArgs :: DirConfig -> [String] -> IO [TestPackage]
 processFileArgs dcfg [] =
-    processFileArgs dcfg . filter isValidEntry =<< getDirectoryContents srcDir
+    processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
   where
-    isValidEntry entry = entry /= "." && entry /= ".."
+    isValidEntry entry
+        | hasExtension entry = takeExtension entry `elem` [".hs", ".lhs"]
+        | otherwise = entry /= "." && entry /= ".."
     srcDir = dcfgSrcDir dcfg
 processFileArgs dcfg args = processFileArgs' dcfg args
 
 
 processFileArgs' :: DirConfig -> [String] -> IO [TestPackage]
 processFileArgs' dcfg args = do
-    (mdls, dirs) <- partitionM doesDirectoryExist' args
+    (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args
     rootPkg <- pure $ TestPackage
         { tpkgName = ""
-        , tpkgFiles = map (processFileArg dcfg) mdls
+        , tpkgFiles = map (srcDir </>) mdls
         }
     otherPkgs <- forM dirs $ \dir -> do
-        files <- getDirectoryContents dir
+        files <- getDirectoryContents (srcDir </> dir)
         pure $ TestPackage
             { tpkgName = dir
-            , tpkgFiles = map ((dcfgSrcDir dcfg </> dir) </>) files
+            , tpkgFiles = map ((srcDir </> dir) </>) files
             }
     pure $ rootPkg:otherPkgs
   where
-    doesDirectoryExist' path = doesDirectoryExist (dcfgSrcDir dcfg </> path)
-
-
-processFileArg :: DirConfig -> String -> FilePath
-processFileArg dcfg arg
-    | isSourceFile arg = arg
-    | otherwise = dcfgSrcDir dcfg </> arg </> ".hs"
-  where
-    isSourceFile path = takeExtension path `elem` [".hs", ".lhs"]
+    doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
+    srcDir = dcfgSrcDir dcfg
-- 
cgit v1.2.3


From bb7d45db2b79f310ab8c2601b47399d5ac69e085 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 20:43:52 +0200
Subject: Make it possible to specify ignored files for test output.

---
 haddock-test/src/Test/Haddock.hs        | 4 +++-
 haddock-test/src/Test/Haddock/Config.hs | 2 ++
 2 files changed, 5 insertions(+), 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index f31ec53f..581b0d10 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -38,7 +38,7 @@ checkFiles :: Config c -> IO ()
 checkFiles cfg@(Config { .. }) = do
     putStrLn "Testing output files..."
 
-    files <- getDirectoryContents (cfgOutDir cfg)
+    files <- ignore <$> getDirectoryContents (cfgOutDir cfg)
     failed <- liftM catMaybes . forM files $ \file -> do
         putStr $ "Checking \"" ++ file ++ "\"... "
 
@@ -56,6 +56,8 @@ checkFiles cfg@(Config { .. }) = do
         else do
             maybeDiff cfg failed
             exitFailure
+  where
+    ignore = filter (not . dcfgCheckIgnore cfgDirConfig)
 
 
 maybeDiff :: Config c -> [FilePath] -> IO ()
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 1b89e276..256e9a93 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -53,6 +53,7 @@ data DirConfig = DirConfig
     , dcfgRefDir :: FilePath
     , dcfgOutDir :: FilePath
     , dcfgResDir :: FilePath
+    , dcfgCheckIgnore :: FilePath -> Bool
     }
 
 
@@ -62,6 +63,7 @@ defaultDirConfig baseDir = DirConfig
     , dcfgRefDir = baseDir </> "ref"
     , dcfgOutDir = baseDir </> "out"
     , dcfgResDir = rootDir </> "resources"
+    , dcfgCheckIgnore = const False
     }
   where
     rootDir = baseDir </> ".."
-- 
cgit v1.2.3


From eff66b0bbf6f7ccc8f24ab21131be59b137fea47 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 21:55:15 +0200
Subject: Fix bug with not all test output files being checked.

---
 haddock-test/src/Test/Haddock.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 581b0d10..ab6ce775 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -19,6 +19,7 @@ import System.Process
 
 import Test.Haddock.Config
 import Test.Haddock.Process
+import Test.Haddock.Utils
 
 
 data CheckResult
@@ -38,7 +39,7 @@ checkFiles :: Config c -> IO ()
 checkFiles cfg@(Config { .. }) = do
     putStrLn "Testing output files..."
 
-    files <- ignore <$> getDirectoryContents (cfgOutDir cfg)
+    files <- ignore <$> getDirectoryTree (cfgOutDir cfg)
     failed <- liftM catMaybes . forM files $ \file -> do
         putStr $ "Checking \"" ++ file ++ "\"... "
 
-- 
cgit v1.2.3


From ebf06f31c1eaf0e9d045f8472548196d47d53431 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 22:30:06 +0200
Subject: Fix bug with test runner invoking Haddock in incorrect mode.

---
 haddock-test/src/Test/Haddock/Config.hs | 2 --
 html-test/Main.hs                       | 6 +++++-
 hypsrc-test/Main.hs                     | 9 ++++++++-
 3 files changed, 13 insertions(+), 4 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 256e9a93..9fca3348 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -177,8 +177,6 @@ loadConfig ccfg dcfg flags files = do
     cfgHaddockArgs <- liftM concat . sequence $
         [ pure ["--no-warnings"]
         , pure ["--odir=" ++ dcfgOutDir dcfg]
-        , pure ["--pretty-html"]
-        , pure ["--html"]
         , pure ["--optghc=-w"]
         , pure $ flagsHaddockOptions flags
         , baseDependencies ghcPath
diff --git a/html-test/Main.hs b/html-test/Main.hs
index 49e769f5..724d35ec 100755
--- a/html-test/Main.hs
+++ b/html-test/Main.hs
@@ -25,7 +25,11 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
 
 
 main :: IO ()
-main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs
+main = do
+    cfg <- parseArgs checkConfig dirConfig =<< getArgs
+    runAndCheck $ cfg
+        { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"]
+        }
 
 
 stripIfRequired :: String -> Xhtml -> Xhtml
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
index 7fa4a705..06cf8546 100644
--- a/hypsrc-test/Main.hs
+++ b/hypsrc-test/Main.hs
@@ -30,7 +30,14 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__)
 
 
 main :: IO ()
-main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs
+main = do
+    cfg <- parseArgs checkConfig dirConfig =<< getArgs
+    runAndCheck $ cfg
+        { cfgHaddockArgs = cfgHaddockArgs cfg ++
+            [ "--pretty-html"
+            , "--hyperlinked-source"
+            ]
+        }
 
 
 checkIgnore :: FilePath -> Bool
-- 
cgit v1.2.3


From 48b5858b9b37e4190c475558a6c88dc923ec5c5a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 23:06:00 +0200
Subject: Fix path handling in test module loader.

---
 haddock-test/src/Test/Haddock/Config.hs | 20 ++++++++++++++++----
 1 file changed, 16 insertions(+), 4 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index 9fca3348..f3056061 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -241,8 +241,8 @@ processFileArgs dcfg [] =
     processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
   where
     isValidEntry entry
-        | hasExtension entry = takeExtension entry `elem` [".hs", ".lhs"]
-        | otherwise = entry /= "." && entry /= ".."
+        | hasExtension entry = isSourceFile entry
+        | otherwise = isRealDir entry
     srcDir = dcfgSrcDir dcfg
 processFileArgs dcfg args = processFileArgs' dcfg args
 
@@ -255,12 +255,24 @@ processFileArgs' dcfg args = do
         , tpkgFiles = map (srcDir </>) mdls
         }
     otherPkgs <- forM dirs $ \dir -> do
-        files <- getDirectoryContents (srcDir </> dir)
+        let srcDir' = srcDir </> dir
+        files <- filterM (isModule dir) =<< getDirectoryContents srcDir'
         pure $ TestPackage
             { tpkgName = dir
-            , tpkgFiles = map ((srcDir </> dir) </>) files
+            , tpkgFiles = map (srcDir' </>) files
             }
     pure $ rootPkg:otherPkgs
   where
     doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
+    isModule dir file = (isSourceFile file &&) <$>
+        doesFileExist (srcDir </> dir </> file)
+    doesFileExist' dir path = doesFileExist (srcDir </> dir </> path)
     srcDir = dcfgSrcDir dcfg
+
+
+isSourceFile :: FilePath -> Bool
+isSourceFile file = takeExtension file `elem` [".hs", ".lhs"]
+
+
+isRealDir :: FilePath -> Bool
+isRealDir dir = not $ dir `elem` [".", ".."]
-- 
cgit v1.2.3


From d36a1a5fb39529e396203b4da0c396ceedda133b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 23:11:59 +0200
Subject: Make test runner ignore test packages with no modules.

---
 haddock-test/src/Test/Haddock/Config.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index f3056061..b1fd2098 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -261,7 +261,7 @@ processFileArgs' dcfg args = do
             { tpkgName = dir
             , tpkgFiles = map (srcDir' </>) files
             }
-    pure $ rootPkg:otherPkgs
+    pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs
   where
     doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
     isModule dir file = (isSourceFile file &&) <$>
-- 
cgit v1.2.3


From 863d33c4d125e13f87193802f6d4faed38da24db Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 18 Aug 2015 23:42:25 +0200
Subject: Fix bug with unnecessary checking old test output.

---
 haddock-test/src/Test/Haddock.hs       |  4 +++-
 haddock-test/src/Test/Haddock/Utils.hs | 10 ++++++++++
 2 files changed, 13 insertions(+), 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index ab6ce775..18ae38ca 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -69,9 +69,11 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
 
 
 runHaddock :: Config c -> IO ()
-runHaddock (Config { .. }) = do
+runHaddock cfg@(Config { .. }) = do
     haddockStdOut <- openFile cfgHaddockStdOut WriteMode
 
+    createEmptyDirectory $ cfgOutDir cfg
+
     putStrLn "Generating documentation..."
     forM_ cfgPackages $ \tpkg -> do
         handle <- runProcess' cfgHaddockPath $ processConfig
diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs
index 4640fe97..4f97fa72 100644
--- a/haddock-test/src/Test/Haddock/Utils.hs
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -21,6 +21,10 @@ partitionM p (x:xs) = do
     pure $ if b then (x:ss, fs) else (ss, x:fs)
 
 
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM mb action = mb >>= \b -> when b action
+
+
 getDirectoryTree :: FilePath -> IO [FilePath]
 getDirectoryTree path = do
     (dirs, files) <- partitionM isDirectory =<< contents
@@ -31,3 +35,9 @@ getDirectoryTree path = do
     contents = filter realEntry <$> getDirectoryContents path
     isDirectory entry = doesDirectoryExist $ path </> entry
     realEntry entry = not $ entry == "." || entry == ".."
+
+
+createEmptyDirectory :: FilePath -> IO ()
+createEmptyDirectory path = do
+    whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
+    createDirectory path
-- 
cgit v1.2.3


From cf22686d11bf9923926f3380793e64d2ff4141fc Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 19 Aug 2015 13:04:54 +0200
Subject: Re-implement test acceptance functionality.

---
 haddock-test/src/Test/Haddock.hs | 13 ++++++++++++-
 1 file changed, 12 insertions(+), 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 18ae38ca..41e15978 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -27,6 +27,8 @@ data CheckResult
     | Pass
     | NoRef
     | Error String
+    | Accepted
+    deriving Eq
 
 
 runAndCheck :: Config c -> IO ()
@@ -43,12 +45,13 @@ checkFiles cfg@(Config { .. }) = do
     failed <- liftM catMaybes . forM files $ \file -> do
         putStr $ "Checking \"" ++ file ++ "\"... "
 
-        status <- checkFile cfg 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
@@ -127,6 +130,14 @@ diffFile cfg diff file = do
     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
 
-- 
cgit v1.2.3


From 1b758285744eb1b7a34bc63a131738c28f0e089a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 19 Aug 2015 13:06:22 +0200
Subject: Fix warning about no longer needed definition.

---
 haddock-test/src/Test/Haddock/Config.hs | 1 -
 1 file changed, 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index b1fd2098..fff84921 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -266,7 +266,6 @@ processFileArgs' dcfg args = do
     doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
     isModule dir file = (isSourceFile file &&) <$>
         doesFileExist (srcDir </> dir </> file)
-    doesFileExist' dir path = doesFileExist (srcDir </> dir </> path)
     srcDir = dcfgSrcDir dcfg
 
 
-- 
cgit v1.2.3


From 7d0317a9210ddbb4f00976318910018fa9abea99 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 19 Aug 2015 16:37:43 +0200
Subject: Fix bug with test runner failing when run on multiple test packages.

---
 haddock-test/src/Test/Haddock.hs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 41e15978..87c16739 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -73,12 +73,11 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do
 
 runHaddock :: Config c -> IO ()
 runHaddock cfg@(Config { .. }) = do
-    haddockStdOut <- openFile cfgHaddockStdOut WriteMode
-
     createEmptyDirectory $ cfgOutDir cfg
 
     putStrLn "Generating documentation..."
     forM_ cfgPackages $ \tpkg -> do
+        haddockStdOut <- openFile cfgHaddockStdOut WriteMode
         handle <- runProcess' cfgHaddockPath $ processConfig
             { pcArgs = concat
                 [ cfgHaddockArgs
-- 
cgit v1.2.3


From 391225eea26bb2484cbf49d0ca5964ab3176b974 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 21 Aug 2015 19:32:37 +0200
Subject: Create helper function for conversion between XML and XHTML.

---
 haddock-test/haddock-test.cabal        |  2 +-
 haddock-test/src/Test/Haddock/Xhtml.hs | 19 +++++++++++++++++++
 2 files changed, 20 insertions(+), 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
index 18c9d28b..0394da8f 100644
--- a/haddock-test/haddock-test.cabal
+++ b/haddock-test/haddock-test.cabal
@@ -16,7 +16,7 @@ library
   default-language: Haskell2010
   ghc-options: -Wall
   hs-source-dirs:   src
-  build-depends:    base, directory, process, filepath, Cabal, xml, syb
+  build-depends:    base, directory, process, filepath, Cabal, xml, xhtml, syb
 
   exposed-modules:
     Test.Haddock
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index d8c26249..21fda36d 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -13,6 +13,7 @@ import Data.Generics.Aliases
 import Data.Generics.Schemes
 
 import Text.XML.Light
+import Text.XHtml
 
 
 newtype Xhtml = Xhtml
@@ -72,3 +73,21 @@ stripFooter =
         [ qName attrKey == "id"
         , attrVal == "footer"
         ]
+
+
+xmlElementToXhtml :: Element -> Html
+xmlElementToXhtml (Element { .. }) =
+    tag (qName elName) contents ! attrs
+  where
+    contents = mconcat $ map xmlContentToXhtml elContent
+    attrs = map xmlAttrToXhtml elAttribs
+
+
+xmlContentToXhtml :: Content -> Html
+xmlContentToXhtml (Elem el) = xmlElementToXhtml el
+xmlContentToXhtml (Text text) = toHtml $ cdData text
+xmlContentToXhtml (CRef cref) = noHtml
+
+
+xmlAttrToXhtml :: Attr -> HtmlAttr
+xmlAttrToXhtml (Attr { .. }) = strAttr (qName attrKey) attrVal
-- 
cgit v1.2.3


From 2555cc37c9e9c0eeb9f7fbddb9599bb6fae3e982 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 21 Aug 2015 19:51:24 +0200
Subject: Refactor existing code to use XHTML printer instead of XML one.

---
 haddock-test/src/Test/Haddock/Xhtml.hs | 41 +++++++++++++++++-----------------
 html-test/Main.hs                      |  8 +++----
 hypsrc-test/Main.hs                    |  6 ++---
 3 files changed, 28 insertions(+), 27 deletions(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
index 21fda36d..69361f7c 100644
--- a/haddock-test/src/Test/Haddock/Xhtml.hs
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -3,8 +3,8 @@
 
 
 module Test.Haddock.Xhtml
-    ( Xhtml(..)
-    , parseXhtml, dumpXhtml
+    ( Xml(..)
+    , parseXml, dumpXml
     , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
     ) where
 
@@ -13,11 +13,12 @@ import Data.Generics.Aliases
 import Data.Generics.Schemes
 
 import Text.XML.Light
-import Text.XHtml
+import Text.XHtml (Html, HtmlAttr, (!))
+import qualified Text.XHtml as Xhtml
 
 
-newtype Xhtml = Xhtml
-    { xhtmlElement :: Element
+newtype Xml = Xml
+    { xmlElement :: Element
     } deriving Eq
 
 
@@ -27,19 +28,19 @@ deriving instance Eq Content
 deriving instance Eq CData
 
 
-parseXhtml :: String -> Maybe Xhtml
-parseXhtml = fmap Xhtml . parseXMLDoc
+parseXml :: String -> Maybe Xml
+parseXml = fmap Xml . parseXMLDoc
 
 
-dumpXhtml :: Xhtml -> String
-dumpXhtml = ppElement . xhtmlElement
+dumpXml :: Xml -> String
+dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement
 
 
-stripLinks :: Xhtml -> Xhtml
+stripLinks :: Xml -> Xml
 stripLinks = stripLinksWhen (const True)
 
 
-stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml
+stripLinksWhen :: (String -> Bool) -> Xml -> Xml
 stripLinksWhen p =
     processAnchors unlink
   where
@@ -48,7 +49,7 @@ stripLinksWhen p =
         | otherwise = attr
 
 
-stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml
+stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml
 stripAnchorsWhen p =
     processAnchors unname
   where
@@ -57,13 +58,13 @@ stripAnchorsWhen p =
         | otherwise = attr
 
 
-processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml
-processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement
+processAnchors :: (Attr -> Attr) -> Xml -> Xml
+processAnchors f = Xml . everywhere (mkT f) . xmlElement
 
 
-stripFooter :: Xhtml -> Xhtml
+stripFooter :: Xml -> Xml
 stripFooter =
-    Xhtml . everywhere (mkT defoot) . xhtmlElement
+    Xml . everywhere (mkT defoot) . xmlElement
   where
     defoot el
         | isFooter el = el { elContent = [] }
@@ -77,7 +78,7 @@ stripFooter =
 
 xmlElementToXhtml :: Element -> Html
 xmlElementToXhtml (Element { .. }) =
-    tag (qName elName) contents ! attrs
+    Xhtml.tag (qName elName) contents ! attrs
   where
     contents = mconcat $ map xmlContentToXhtml elContent
     attrs = map xmlAttrToXhtml elAttribs
@@ -85,9 +86,9 @@ xmlElementToXhtml (Element { .. }) =
 
 xmlContentToXhtml :: Content -> Html
 xmlContentToXhtml (Elem el) = xmlElementToXhtml el
-xmlContentToXhtml (Text text) = toHtml $ cdData text
-xmlContentToXhtml (CRef cref) = noHtml
+xmlContentToXhtml (Text text) = Xhtml.toHtml $ cdData text
+xmlContentToXhtml (CRef _) = Xhtml.noHtml
 
 
 xmlAttrToXhtml :: Attr -> HtmlAttr
-xmlAttrToXhtml (Attr { .. }) = strAttr (qName attrKey) attrVal
+xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal
diff --git a/html-test/Main.hs b/html-test/Main.hs
index 724d35ec..3880fc3c 100755
--- a/html-test/Main.hs
+++ b/html-test/Main.hs
@@ -10,10 +10,10 @@ import Test.Haddock
 import Test.Haddock.Xhtml
 
 
-checkConfig :: CheckConfig Xhtml
+checkConfig :: CheckConfig Xml
 checkConfig = CheckConfig
-    { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input
-    , ccfgDump = dumpXhtml
+    { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input
+    , ccfgDump = dumpXml
     , ccfgEqual = (==)
     }
 
@@ -32,7 +32,7 @@ main = do
         }
 
 
-stripIfRequired :: String -> Xhtml -> Xhtml
+stripIfRequired :: String -> Xml -> Xml
 stripIfRequired mdl =
     stripLinks' . stripFooter
   where
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
index 06cf8546..0490be47 100644
--- a/hypsrc-test/Main.hs
+++ b/hypsrc-test/Main.hs
@@ -11,10 +11,10 @@ import Test.Haddock
 import Test.Haddock.Xhtml
 
 
-checkConfig :: CheckConfig Xhtml
+checkConfig :: CheckConfig Xml
 checkConfig = CheckConfig
-    { ccfgRead = \_ input -> strip <$> parseXhtml input
-    , ccfgDump = dumpXhtml
+    { ccfgRead = \_ input -> strip <$> parseXml input
+    , ccfgDump = dumpXml
     , ccfgEqual = (==)
     }
   where
-- 
cgit v1.2.3


From 27d5cba94e827e10c9f5b02b162f6b13cd8cbea1 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 22 Aug 2015 23:43:16 +0200
Subject: Remove redundant import statement.

---
 haddock-test/src/Test/Haddock/Process.hs | 1 -
 1 file changed, 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs
index 97f3ebed..ae720f6f 100644
--- a/haddock-test/src/Test/Haddock/Process.hs
+++ b/haddock-test/src/Test/Haddock/Process.hs
@@ -7,7 +7,6 @@ module Test.Haddock.Process where
 import Control.Monad
 
 import System.Exit
-import System.FilePath
 import System.IO
 import System.Process
 
-- 
cgit v1.2.3


From 136c48c5fe074ac8a2755c4705d555de24e22a3a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 24 Aug 2015 23:09:20 +0200
Subject: Fix bug with accepting to non-existing directory.

---
 haddock-test/src/Test/Haddock.hs       | 2 +-
 haddock-test/src/Test/Haddock/Utils.hs | 7 +++++++
 2 files changed, 8 insertions(+), 1 deletion(-)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 87c16739..e8a0ac8e 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -132,7 +132,7 @@ diffFile cfg diff file = do
 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)
+        copyFile' (outFile dcfg file) (refFile dcfg file)
         pure Accepted
 maybeAcceptFile _ _ result = pure result
 
diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs
index 4f97fa72..a947fea1 100644
--- a/haddock-test/src/Test/Haddock/Utils.hs
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -41,3 +41,10 @@ createEmptyDirectory :: FilePath -> IO ()
 createEmptyDirectory path = do
     whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
     createDirectory path
+
+
+-- | Just like 'copyFile' but output directory path is not required to exist.
+copyFile' :: FilePath -> FilePath -> IO ()
+copyFile' old new = do
+    createDirectoryIfMissing True $ takeDirectory new
+    copyFile old new
-- 
cgit v1.2.3


From 1557c08cac99befbd541dcca4d85c20609518f2b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Tue, 25 Aug 2015 17:41:59 +0200
Subject: Fix test suite failure when used with Stack.

---
 haddock-test/src/Test/Haddock/Config.hs | 5 +++++
 1 file changed, 5 insertions(+)

(limited to 'haddock-test/src/Test')

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index fff84921..8f1f4885 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -213,6 +213,11 @@ printVersions env haddockPath = do
 
 baseDependencies :: FilePath -> IO [String]
 baseDependencies ghcPath = do
+    -- The 'getInstalledPackages' crashes if used when "GHC_PACKAGE_PATH" is
+    -- set to some value. I am not sure why is that happening and what are the
+    -- consequences of unsetting it - but looks like it works (for now).
+    unsetEnv "GHC_PACKAGE_PATH"
+
     (_, _, cfg) <- configure normal (Just ghcPath) Nothing
         defaultProgramConfiguration
     pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
-- 
cgit v1.2.3