aboutsummaryrefslogtreecommitdiff
path: root/haddock-test/src/Test
diff options
context:
space:
mode:
authorŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-08-13 17:28:24 +0200
committerŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-08-22 23:40:27 +0200
commit66d7114dc8d310e1dc1105a0805c1c491312b43c (patch)
tree3ef24b83e9c0d480669ca8a0187bf67691293170 /haddock-test/src/Test
parent54fb845b2b322d823fb44f905bd4c4d40225259c (diff)
Make Haddock test package more generic.
Diffstat (limited to 'haddock-test/src/Test')
-rw-r--r--haddock-test/src/Test/Haddock.hs39
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs26
2 files changed, 39 insertions, 26 deletions
diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs
index 6ca57d7b..3c0c8d5f 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 b9444c3e..3b6dfdeb 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 { .. }