aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2016-02-08 14:25:49 +0100
committerBen Gamari <ben@smart-cactus.org>2016-02-08 14:54:56 +0100
commit4ca91adcbd26dfa5f102244f8170c5c74f5200db (patch)
treec46673b85fba14b889940bd9b4e09cc9dd9490e0
parent25b8d00a149098d9b7842600dbb93f40836b4546 (diff)
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.
-rw-r--r--haddock-test/haddock-test.cabal2
-rw-r--r--haddock-test/src/Test/Haddock.hs40
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs6
-rw-r--r--hoogle-test/Main.hs3
-rwxr-xr-xhtml-test/Main.hs3
-rw-r--r--hypsrc-test/Main.hs3
-rwxr-xr-xlatex-test/Main.hs3
7 files changed, 48 insertions, 12 deletions
diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
index 0394da8f..2b75ea81 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 e8a0ac8e..6041c77c 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 cd878178..dea101d8 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 c8cda640..59a98fd0 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 3880fc3c..02a86d43 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 0490be47..01cc5429 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 2ee01a26..5989410b 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 = (==)
}