Mon Nov 20 21:00:10 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,master,pr-filter-maps,pr/cabal-desc,travis,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,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/4ca91adcbd26dfa5f102244f8170c5c74f5200db

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

commit 4ca91adcbd26dfa5f102244f8170c5c74f5200db
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Mon Feb 8 14:25:49 2016 +0100

    testsuite: Rework handling of output sanitization
    
    Previously un-cleaned artifacts were kept as reference output, making
    it difficult to tell what has changed and causing spurious changes in
    the version control history. Here we rework this, cleaning the output
    during acceptance. To accomplish this it was necessary to move to strict
    I/O to ensure the reference handle was closed before accept attempts to
    open the reference file.


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

4ca91adcbd26dfa5f102244f8170c5c74f5200db
 haddock-test/haddock-test.cabal         |  2 +-
 haddock-test/src/Test/Haddock.hs        | 40 ++++++++++++++++++++++++++++-----
 haddock-test/src/Test/Haddock/Config.hs |  6 ++++-
 hoogle-test/Main.hs                     |  3 ++-
 html-test/Main.hs                       |  3 ++-
 hypsrc-test/Main.hs                     |  3 ++-
 latex-test/Main.hs                      |  3 ++-
 7 files changed, 48 insertions(+), 12 deletions(-)

diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
index 0394da8..2b75ea8 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, xhtml, syb
+  build-depends:    base, bytestring, directory, process, filepath, Cabal, xml, xhtml, syb
 
   exposed-modules:
     Test.Haddock
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index e8a0ac8..6041c77 100644
--- a/haddock-test/src/Test/Haddock.hs
+++ b/haddock-test/src/Test/Haddock.hs
@@ -16,6 +16,7 @@ import System.Exit
 import System.FilePath
 import System.IO
 import System.Process
+import qualified Data.ByteString.Char8 as BS
 
 import Test.Haddock.Config
 import Test.Haddock.Process
@@ -95,8 +96,8 @@ checkFile cfg file = do
     hasRef <- doesFileExist $ refFile dcfg file
     if hasRef
         then do
-            mout <- ccfgRead ccfg file <$> readFile (outFile dcfg file)
-            mref <- ccfgRead ccfg file <$> readFile (refFile dcfg file)
+            mout <- readOut cfg file
+            mref <- readRef cfg file
             return $ case (mout, mref) of
                 (Just out, Just ref)
                     | ccfgEqual ccfg out ref -> Pass
@@ -107,11 +108,34 @@ checkFile cfg file = do
     ccfg = cfgCheckConfig cfg
     dcfg = cfgDirConfig cfg
 
+-- We use ByteString here to ensure that no lazy I/O is performed.
+-- This way to ensure that the reference file isn't held open in
+-- case after `diffFile` (which is problematic if we need to rewrite
+-- the reference file in `maybeAcceptFile`)
+
+-- | Read the reference artifact for a test
+readRef :: Config c -> FilePath -> IO (Maybe c)
+readRef cfg file =
+    ccfgRead ccfg . BS.unpack
+    <$> BS.readFile (refFile dcfg file)
+  where
+    ccfg = cfgCheckConfig cfg
+    dcfg = cfgDirConfig cfg
+
+-- | Read (and clean) the test output artifact for a test
+readOut :: Config c -> FilePath -> IO (Maybe c)
+readOut cfg file =
+    fmap (ccfgClean ccfg file) . ccfgRead ccfg . BS.unpack
+    <$> BS.readFile (outFile dcfg file)
+  where
+    ccfg = cfgCheckConfig cfg
+    dcfg = cfgDirConfig cfg
+
 
 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)
+    Just out <- readOut cfg file
+    Just ref <- readRef cfg file
     writeFile outFile' $ ccfgDump ccfg out
     writeFile refFile' $ ccfgDump ccfg ref
 
@@ -130,10 +154,14 @@ diffFile cfg diff file = do
 
 
 maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult
-maybeAcceptFile cfg@(Config { cfgDirConfig = dcfg }) file result
+maybeAcceptFile cfg file result
     | cfgAccept cfg && result `elem` [NoRef, Fail] = do
-        copyFile' (outFile dcfg file) (refFile dcfg file)
+        Just out <- readOut cfg file
+        writeFile (refFile dcfg file) $ ccfgDump ccfg out
         pure Accepted
+  where
+    dcfg = cfgDirConfig cfg
+    ccfg = cfgCheckConfig cfg
 maybeAcceptFile _ _ result = pure result
 
 
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index cd87817..dea101d 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -42,7 +42,11 @@ data TestPackage = TestPackage
 
 
 data CheckConfig c = CheckConfig
-    { ccfgRead :: String -> String -> Maybe c
+    { ccfgRead :: String -> Maybe c
+      -- ^ @f contents@ parses file contents @contents@ to
+      -- produce a thing to be compared.
+    , ccfgClean :: String -> c -> c
+      -- ^ @f fname x@ cleans @x@ to such that it can be compared
     , ccfgDump :: c -> String
     , ccfgEqual :: c -> c -> Bool
     }
diff --git a/hoogle-test/Main.hs b/hoogle-test/Main.hs
index c8cda64..59a98fd 100644
--- a/hoogle-test/Main.hs
+++ b/hoogle-test/Main.hs
@@ -9,7 +9,8 @@ import Test.Haddock
 
 checkConfig :: CheckConfig String
 checkConfig = CheckConfig
-    { ccfgRead = \_ input -> Just input
+    { ccfgRead = Just
+    , ccfgClean = \_ -> id
     , ccfgDump = id
     , ccfgEqual = (==)
     }
diff --git a/html-test/Main.hs b/html-test/Main.hs
index 3880fc3..02a86d4 100755
--- a/html-test/Main.hs
+++ b/html-test/Main.hs
@@ -12,7 +12,8 @@ import Test.Haddock.Xhtml
 
 checkConfig :: CheckConfig Xml
 checkConfig = CheckConfig
-    { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input
+    { ccfgRead = parseXml
+    , ccfgClean = stripIfRequired
     , ccfgDump = dumpXml
     , ccfgEqual = (==)
     }
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
index 0490be4..01cc542 100644
--- a/hypsrc-test/Main.hs
+++ b/hypsrc-test/Main.hs
@@ -13,7 +13,8 @@ import Test.Haddock.Xhtml
 
 checkConfig :: CheckConfig Xml
 checkConfig = CheckConfig
-    { ccfgRead = \_ input -> strip <$> parseXml input
+    { ccfgRead = parseXml
+    , ccfgClean = \_ -> strip
     , ccfgDump = dumpXml
     , ccfgEqual = (==)
     }
diff --git a/latex-test/Main.hs b/latex-test/Main.hs
index 2ee01a2..5989410 100755
--- a/latex-test/Main.hs
+++ b/latex-test/Main.hs
@@ -9,7 +9,8 @@ import Test.Haddock
 
 checkConfig :: CheckConfig String
 checkConfig = CheckConfig
-    { ccfgRead = \_ input -> Just input
+    { ccfgRead = Just
+    , ccfgClean = \_ -> id
     , ccfgDump = id
     , ccfgEqual = (==)
     }

