From e614916d940943a1f4f7cd77d9957246d164ab1d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 18:47:11 +0200 Subject: Make Haddock test package more generic. --- haddock-test/src/Test/Haddock.hs | 90 ++++++++++++++++----------------- haddock-test/src/Test/Haddock/Config.hs | 50 ++++++++++++------ 2 files changed, 78 insertions(+), 62 deletions(-) (limited to 'haddock-test') diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index a2c6609a..f31ec53f 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -31,21 +31,20 @@ data CheckResult runAndCheck :: Config c -> IO () runAndCheck cfg = do runHaddock cfg - if cfgAccept cfg - then acceptFiles cfg - else checkFiles cfg + checkFiles cfg checkFiles :: Config c -> IO () checkFiles cfg@(Config { .. }) = do putStrLn "Testing output files..." - failed <- liftM catMaybes . forM cfgFiles $ \file -> do - let mdl = takeBaseName file - putStr $ "Checking " ++ mdl ++ "... " - status <- checkModule cfg mdl + files <- getDirectoryContents (cfgOutDir cfg) + failed <- liftM catMaybes . forM files $ \file -> do + putStr $ "Checking \"" ++ file ++ "\"... " + + status <- checkFile cfg file case status of - Fail -> putStrLn "FAIL" >> (return $ Just mdl) + Fail -> putStrLn "FAIL" >> (return $ Just file) Pass -> putStrLn "PASS" >> (return Nothing) NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing) Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing @@ -59,43 +58,38 @@ checkFiles cfg@(Config { .. }) = do exitFailure -acceptFiles :: Config c -> IO () -acceptFiles (Config { cfgFiles = files, cfgDirConfig = dcfg }) = do - - forM_ files $ \file -> do - let mdl = takeBaseName file - putStr $ "Accepting " ++ mdl ++ "... " - copyFile (outFile dcfg mdl) (refFile dcfg mdl) - putStrLn "DONE" - - -maybeDiff :: Config c -> [String] -> IO () +maybeDiff :: Config c -> [FilePath] -> IO () maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure () -maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) mdls = do +maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do putStrLn "Diffing failed cases..." - forM_ mdls $ diffModule cfg diff + forM_ files $ diffFile cfg diff runHaddock :: Config c -> IO () runHaddock (Config { .. }) = do - putStrLn "Running Haddock process..." - haddockStdOut <- openFile cfgHaddockStdOut WriteMode - handle <- runProcess' cfgHaddockPath $ processConfig - { pcArgs = cfgHaddockArgs ++ cfgFiles - , pcEnv = Just $ cfgEnv - , pcStdOut = Just $ haddockStdOut - } - waitForSuccess "Failed to run Haddock on specified test files" handle - -checkModule :: Config c -> String -> IO CheckResult -checkModule cfg mdl = do - hasRef <- doesFileExist $ refFile dcfg mdl + putStrLn "Generating documentation..." + forM_ cfgPackages $ \tpkg -> do + handle <- runProcess' cfgHaddockPath $ processConfig + { pcArgs = concat + [ cfgHaddockArgs + , pure $ "--odir=" ++ outDir cfgDirConfig tpkg + , tpkgFiles tpkg + ] + , pcEnv = Just $ cfgEnv + , pcStdOut = Just $ haddockStdOut + } + waitForSuccess "Failed to run Haddock on specified test files" handle + + +checkFile :: Config c -> FilePath -> IO CheckResult +checkFile cfg file = do + hasRef <- doesFileExist $ refFile dcfg file if hasRef then do - mout <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl) - mref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl) + mout <- ccfgRead ccfg file <$> readFile (outFile dcfg file) + mref <- ccfgRead ccfg file <$> readFile (refFile dcfg file) return $ case (mout, mref) of (Just out, Just ref) | ccfgEqual ccfg out ref -> Pass @@ -107,14 +101,14 @@ checkModule cfg mdl = do dcfg = cfgDirConfig cfg -diffModule :: Config c -> FilePath -> String -> IO () -diffModule cfg diff mdl = do - Just out <- ccfgRead ccfg mdl <$> readFile (outFile dcfg mdl) - Just ref <- ccfgRead ccfg mdl <$> readFile (refFile dcfg mdl) +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) writeFile outFile' $ ccfgDump ccfg out writeFile refFile' $ ccfgDump ccfg ref - putStrLn $ "Diff for module " ++ show mdl ++ ":" + putStrLn $ "Diff for file \"" ++ file ++ "\":" hFlush stdout handle <- runProcess' diff $ processConfig { pcArgs = [outFile', refFile'] @@ -124,13 +118,17 @@ diffModule cfg diff mdl = do where dcfg = cfgDirConfig cfg ccfg = cfgCheckConfig cfg - outFile' = outFile dcfg mdl <.> "dump" - refFile' = outFile dcfg mdl <.> "ref" <.> "dump" + outFile' = outFile dcfg file <.> "dump" + refFile' = outFile dcfg file <.> "ref" <.> "dump" + + +outDir :: DirConfig -> TestPackage -> FilePath +outDir dcfg tpkg = dcfgOutDir dcfg tpkgName tpkg -outFile :: DirConfig -> String -> FilePath -outFile dcfg mdl = dcfgOutDir dcfg mdl <.> "html" +outFile :: DirConfig -> FilePath -> FilePath +outFile dcfg file = dcfgOutDir dcfg file -refFile :: DirConfig -> String -> FilePath -refFile dcfg mdl = dcfgRefDir dcfg mdl <.> "html" +refFile :: DirConfig -> FilePath -> FilePath +refFile dcfg file = dcfgRefDir dcfg file diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 451cd809..15a53829 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -2,7 +2,7 @@ module Test.Haddock.Config - ( CheckConfig(..), DirConfig(..), Config(..) + ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..) , defaultDirConfig , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir , parseArgs, checkOpt, loadConfig @@ -35,6 +35,12 @@ import Test.Haddock.Process import Test.Haddock.Utils +data TestPackage = TestPackage + { tpkgName :: String + , tpkgFiles :: [FilePath] + } + + data CheckConfig c = CheckConfig { ccfgRead :: String -> String -> Maybe c , ccfgDump :: c -> String @@ -63,7 +69,7 @@ defaultDirConfig baseDir = DirConfig data Config c = Config { cfgHaddockPath :: FilePath - , cfgFiles :: [FilePath] + , cfgPackages :: [TestPackage] , cfgHaddockArgs :: [String] , cfgHaddockStdOut :: FilePath , cfgDiffTool :: Maybe FilePath @@ -164,7 +170,7 @@ loadConfig ccfg dcfg flags files = do printVersions cfgEnv cfgHaddockPath - cfgFiles <- processFileArgs dcfg files + cfgPackages <- processFileArgs dcfg files cfgHaddockArgs <- liftM concat . sequence $ [ pure ["--no-warnings"] @@ -230,24 +236,36 @@ defaultDiffTool = isAvailable = liftM isJust . findProgramLocation silent -processFileArgs :: DirConfig -> [String] -> IO [FilePath] +processFileArgs :: DirConfig -> [String] -> IO [TestPackage] processFileArgs dcfg [] = - map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir + processFileArgs dcfg . filter isValidEntry =<< getDirectoryContents srcDir where + isValidEntry entry = entry /= "." && entry /= ".." srcDir = dcfgSrcDir dcfg - toModulePath = modulePath dcfg . takeBaseName -processFileArgs dcfg args = pure $ map (processFileArg dcfg) args +processFileArgs dcfg args = processFileArgs' dcfg args + + +processFileArgs' :: DirConfig -> [String] -> IO [TestPackage] +processFileArgs' dcfg args = do + (mdls, dirs) <- partitionM doesDirectoryExist' args + rootPkg <- pure $ TestPackage + { tpkgName = "" + , tpkgFiles = map (processFileArg dcfg) mdls + } + otherPkgs <- forM dirs $ \dir -> do + files <- getDirectoryContents dir + pure $ TestPackage + { tpkgName = dir + , tpkgFiles = map ((dcfgSrcDir dcfg dir) ) files + } + pure $ rootPkg:otherPkgs + where + doesDirectoryExist' path = doesDirectoryExist (dcfgSrcDir dcfg path) processFileArg :: DirConfig -> String -> FilePath processFileArg dcfg arg | isSourceFile arg = arg - | otherwise = modulePath dcfg arg - - -isSourceFile :: FilePath -> Bool -isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] - - -modulePath :: DirConfig -> String -> FilePath -modulePath dcfg mdl = dcfgSrcDir dcfg mdl <.> "hs" + | otherwise = dcfgSrcDir dcfg arg ".hs" + where + isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] -- cgit v1.2.3