From 66d7114dc8d310e1dc1105a0805c1c491312b43c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 17:28:24 +0200 Subject: Make Haddock test package more generic. --- haddock-test/src/Test/Haddock.hs | 39 +++++++++++++++++---------------- haddock-test/src/Test/Haddock/Config.hs | 26 ++++++++++++++++------ html-test/run.hs | 18 +++++++++++---- 3 files changed, 53 insertions(+), 30 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 { .. } diff --git a/html-test/run.hs b/html-test/run.hs index 48c733d0..22a06ba3 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -5,16 +5,26 @@ import System.Environment import System.FilePath import Test.Haddock +import Test.Haddock.Xhtml +import qualified Text.XML.Light as Xml -baseDir :: FilePath -baseDir = takeDirectory __FILE__ + +checkConfig :: CheckConfig Xml.Element +checkConfig = CheckConfig + { ccfgRead = \_ input -> strip <$> Xml.parseXMLDoc input + , ccfgDump = Xml.ppElement + , ccfgEqual = (==) + } + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ main :: IO () main = do - let dcfg = defaultDirConfig baseDir - cfg <- uncurry (loadConfig dcfg) =<< checkOpt =<< getArgs + cfg <- uncurry (loadConfig checkConfig dirConfig) =<< checkOpt =<< getArgs runHaddock cfg checkFiles cfg -- cgit v1.2.3