Mon Nov 20 20:53:56 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13
Link       : http://git.haskell.org/haddock.git/commitdiff/66d7114dc8d310e1dc1105a0805c1c491312b43c

>---------------------------------------------------------------

commit 66d7114dc8d310e1dc1105a0805c1c491312b43c
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Thu Aug 13 17:28:24 2015 +0200

    Make Haddock test package more generic.


>---------------------------------------------------------------

66d7114dc8d310e1dc1105a0805c1c491312b43c
 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(-)

diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 6ca57d7..3c0c8d5 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 b9444c3..3b6dfde 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 48c733d..22a06ba 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
 

