Tue Nov 28 11:37:12 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/T14529,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,wip/ttg6-unrevert-2017-11-22
Link       : http://git.haskell.org/haddock.git/commitdiff/a2d23f2b34f9341c7c812cb7ce59c41fbd9de130

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

commit a2d23f2b34f9341c7c812cb7ce59c41fbd9de130
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Tue Aug 4 18:25:32 2015 +0200

    Refactor architecture of test runner output checking functions.


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

a2d23f2b34f9341c7c812cb7ce59c41fbd9de130
 html-test/run.hs | 52 +++++++++++++++++++++++++++++++++-------------------
 1 file changed, 33 insertions(+), 19 deletions(-)

diff --git a/html-test/run.hs b/html-test/run.hs
index b9e1cc5..52fae69 100755
--- a/html-test/run.hs
+++ b/html-test/run.hs
@@ -59,22 +59,28 @@ main :: IO ()
 main = do
     cfg <- uncurry loadConfig =<< checkOpt =<< getArgs
     runHaddock cfg
-    checkOutput cfg
+    checkFiles cfg
 
 
-checkOutput :: Config -> IO ()
-checkOutput (Config { .. }) = do
-    putStrLn "Diffing output files..."
-    failFiles <- forM cfgFiles $ \file -> do
-        putStr $ "Checking " ++ takeBaseName file ++ "... "
+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 <- checkFile file
+        status <- checkModule mdl
         case status of
-            Fail -> putStrLn "FAIL" >> (return $ Just file)
+            Fail -> putStrLn "FAIL" >> (return $ Just mdl)
             Pass -> putStrLn "PASS" >> (return Nothing)
             NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing)
 
-    return () -- TODO: Print diff for failed cases.
+    when (null failed) $ do
+        putStrLn "All tests passed!"
+        exitSuccess
+
+    putStrLn "Diffing failed cases..."
+    forM_ failed checkModule
 
 
 runHaddock :: Config -> IO ()
@@ -134,21 +140,29 @@ loadConfig flags files = do
     return $ Config { .. }
 
 
-checkFile :: FilePath -> IO CheckResult
-checkFile file = do
-    hasRef <- doesFileExist refFile
+checkModule :: String -> IO CheckResult
+checkModule mdl = do
+    hasRef <- doesFileExist $ refFile mdl
     if hasRef
     then do
-        out <- readFile outFile
-        ref <- readFile refFile
-        return $ if haddockEq (outFile, out) (refFile, ref)
+        out <- readFile $ outFile mdl
+        ref <- readFile $ refFile mdl
+        return $ if haddockEq (outFile mdl, out) (refFile mdl, ref)
             then Pass
             else Fail
     else return NoRef
-  where
-    outFile = outDir </> mdl <.> "html"
-    refFile = refDir </> mdl <.> "html"
-    mdl = takeBaseName $ file
+
+
+diffModule :: String -> IO ()
+diffModule mdl = return ()
+
+
+outFile :: String -> FilePath
+outFile mdl = outDir </> mdl <.> "html"
+
+
+refFile :: String -> FilePath
+refFile mdl = refDir </> mdl <.> "html"
 
 
 printVersions :: Environment -> FilePath -> IO ()

