aboutsummaryrefslogtreecommitdiff
path: root/haddock-test/src/Test/Haddock.hs
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2016-02-08 15:40:44 +0100
committerBen Gamari <ben@smart-cactus.org>2016-02-08 15:40:44 +0100
commit228a0d72baa04be161b0fc918266f2edb0c6519b (patch)
tree43246f722a0f28614019243e34dfd83e5ca29217 /haddock-test/src/Test/Haddock.hs
parent8a4c949bfc731ef0dcd83d557da278d162152fb5 (diff)
parenta427f597e081ce37a881e6612efeab7ef0bb0dac (diff)
Merge branch 'fix-up-testsuite'
Diffstat (limited to 'haddock-test/src/Test/Haddock.hs')
-rw-r--r--haddock-test/src/Test/Haddock.hs40
1 files changed, 34 insertions, 6 deletions
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