From 4a4d9ecf66bcb6561f7b10c07742c4b6688332b8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 12:21:45 +0200 Subject: Refactor HTML test suite boilerplate to external package. --- haddock-test/src/Test/Haddock/Config.hs | 70 +++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 haddock-test/src/Test/Haddock/Config.hs (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs new file mode 100644 index 00000000..bb226fdb --- /dev/null +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -0,0 +1,70 @@ +module Test.Haddock.Config where + + +import System.Console.GetOpt +import System.FilePath + +import Test.Haddock.Process +import Test.Haddock.Utils + + +data Config = Config + { cfgHaddockPath :: FilePath + , cfgGhcPath :: FilePath + , cfgFiles :: [FilePath] + , cfgHaddockArgs :: [String] + , cfgHaddockStdOut :: FilePath + , cfgDiffTool :: Maybe FilePath + , cfgEnv :: Environment + } + + +data Flag + = FlagHaddockPath FilePath + | FlagGhcPath FilePath + | FlagHaddockOptions String + | FlagHaddockStdOut FilePath + | FlagDiffTool FilePath + | FlagNoDiff + | FlagHelp + deriving Eq + + +flagsHaddockPath :: [Flag] -> Maybe FilePath +flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ] + + +flagsGhcPath :: [Flag] -> Maybe FilePath +flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ] + + +flagsHaddockOptions :: [Flag] -> [String] +flagsHaddockOptions flags = concat + [ words opts | FlagHaddockOptions opts <- flags ] + + +flagsHaddockStdOut :: [Flag] -> Maybe FilePath +flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ] + + +flagsDiffTool :: [Flag] -> Maybe FilePath +flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ] + + +options :: [OptDescr Flag] +options = + [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE") + "path to Haddock executable to exectue tests with" + , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE") + "path to GHC executable" + , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS") + "additional options to run Haddock with" + , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE") + "where to redirect Haddock output" + , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH") + "diff tool to use when printing failed cases" + , Option [] ["no-diff"] (NoArg FlagNoDiff) + "do not print diff for failed cases" + , Option ['h'] ["help"] (NoArg FlagHelp) + "display this help end exit" + ] -- cgit v1.2.3 From 1102352d9e830fdf6ecd8abfba50c405114d5ae2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 13:51:23 +0200 Subject: Create utilities for storing directory configuration. --- haddock-test/src/Test/Haddock/Config.hs | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index bb226fdb..af2a460b 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -8,6 +8,21 @@ import Test.Haddock.Process import Test.Haddock.Utils +data DirConfig = DirConfig + { dcfgSrcDir :: FilePath + , dcfgRefDir :: FilePath + , dcfgOutDir :: FilePath + } + + +defaultDirConfig :: FilePath -> DirConfig +defaultDirConfig baseDir = DirConfig + { dcfgSrcDir = baseDir "src" + , dcfgRefDir = baseDir "ref" + , dcfgOutDir = baseDir "out" + } + + data Config = Config { cfgHaddockPath :: FilePath , cfgGhcPath :: FilePath @@ -16,9 +31,16 @@ data Config = Config , cfgHaddockStdOut :: FilePath , cfgDiffTool :: Maybe FilePath , cfgEnv :: Environment + , cfgDirConfig :: DirConfig } +cfgSrcDir, cfgRefDir, cfgOutDir :: Config -> FilePath +cfgSrcDir = dcfgSrcDir . cfgDirConfig +cfgRefDir = dcfgRefDir . cfgDirConfig +cfgOutDir = dcfgOutDir . cfgDirConfig + + data Flag = FlagHaddockPath FilePath | FlagGhcPath FilePath -- cgit v1.2.3 From 6a2c16a0b0790ca0f3a30be8a6e96c7818514ff6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 14:33:29 +0200 Subject: Move IO-dependent config of HTML test suite to test package. --- haddock-test/src/Test/Haddock/Config.hs | 145 +++++++++++++++++++++++++++++++- html-test/run.hs | 121 +------------------------- 2 files changed, 145 insertions(+), 121 deletions(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index af2a460b..b9444c3e 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -1,8 +1,30 @@ +{-# LANGUAGE RecordWildCards #-} + + module Test.Haddock.Config where +import Control.Applicative +import Control.Monad + +import qualified Data.List as List +import Data.Maybe + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.GHC +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Verbosity + import System.Console.GetOpt +import System.Directory +import System.Exit +import System.Environment import System.FilePath +import System.IO import Test.Haddock.Process import Test.Haddock.Utils @@ -12,6 +34,7 @@ data DirConfig = DirConfig { dcfgSrcDir :: FilePath , dcfgRefDir :: FilePath , dcfgOutDir :: FilePath + , dcfgResDir :: FilePath } @@ -20,12 +43,14 @@ defaultDirConfig baseDir = DirConfig { dcfgSrcDir = baseDir "src" , dcfgRefDir = baseDir "ref" , dcfgOutDir = baseDir "out" + , dcfgResDir = rootDir "resources" } + where + rootDir = baseDir ".." data Config = Config { cfgHaddockPath :: FilePath - , cfgGhcPath :: FilePath , cfgFiles :: [FilePath] , cfgHaddockArgs :: [String] , cfgHaddockStdOut :: FilePath @@ -35,10 +60,11 @@ data Config = Config } -cfgSrcDir, cfgRefDir, cfgOutDir :: Config -> FilePath +cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config -> FilePath cfgSrcDir = dcfgSrcDir . cfgDirConfig cfgRefDir = dcfgRefDir . cfgDirConfig cfgOutDir = dcfgOutDir . cfgDirConfig +cfgResDir = dcfgResDir . cfgDirConfig data Flag @@ -90,3 +116,118 @@ options = , Option ['h'] ["help"] (NoArg FlagHelp) "display this help end exit" ] + + +checkOpt :: [String] -> IO ([Flag], [String]) +checkOpt args = do + let (flags, files, errors) = getOpt Permute options args + + unless (null errors) $ do + hPutStr stderr $ concat errors + exitFailure + + when (FlagHelp `elem` flags) $ do + hPutStrLn stderr $ usageInfo "" options + exitSuccess + + return (flags, files) + + +loadConfig :: DirConfig -> [Flag] -> [String] -> IO Config +loadConfig cfgDirConfig@(DirConfig { .. }) flags files = do + cfgEnv <- (:) ("haddock_datadir", dcfgResDir) <$> getEnvironment + + systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment + cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of + Just path -> pure path + Nothing -> do + hPutStrLn stderr $ "Haddock executable not specified" + exitFailure + + ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath + ["--print-ghc-path"] + + printVersions cfgEnv cfgHaddockPath + + cfgFiles <- processFileArgs cfgDirConfig files + + cfgHaddockArgs <- liftM concat . sequence $ + [ pure ["--no-warnings"] + , pure ["--odir=" ++ dcfgOutDir] + , pure ["--pretty-html"] + , pure ["--html"] + , pure ["--optghc=-w"] + , pure $ flagsHaddockOptions flags + , baseDependencies ghcPath + ] + + let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags) + + cfgDiffTool <- if FlagNoDiff `elem` flags + then pure Nothing + else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool + + return $ Config { .. } + + +printVersions :: Environment -> FilePath -> IO () +printVersions env haddockPath = do + handleHaddock <- runProcess' haddockPath $ processConfig + { pcEnv = Just env + , pcArgs = ["--version"] + } + waitForSuccess "Failed to run `haddock --version`" handleHaddock + + handleGhc <- runProcess' haddockPath $ processConfig + { pcEnv = Just env + , pcArgs = ["--ghc-version"] + } + waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc + + +baseDependencies :: FilePath -> IO [String] +baseDependencies ghcPath = do + (_, _, cfg) <- configure normal (Just ghcPath) Nothing + defaultProgramConfiguration + pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg + mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"] + where + getDependency pkgIndex name = case ifaces pkgIndex name of + [] -> do + hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name + exitFailure + (ifArg:_) -> pure ifArg + ifaces pkgIndex name = do + pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name) + iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg + iface file html = "--read-interface=" ++ html ++ "," ++ file + + +defaultDiffTool :: IO (Maybe FilePath) +defaultDiffTool = + liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"] + where + isAvailable = liftM isJust . findProgramLocation silent + + +processFileArgs :: DirConfig -> [String] -> IO [FilePath] +processFileArgs dcfg [] = + map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir + where + srcDir = dcfgSrcDir dcfg + toModulePath = modulePath dcfg . takeBaseName +processFileArgs dcfg args = pure $ map (processFileArg dcfg) args + + +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" diff --git a/html-test/run.hs b/html-test/run.hs index e96943a0..5a2944f9 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -9,15 +9,6 @@ import Control.Monad import Data.Maybe import Data.List -import Distribution.InstalledPackageInfo -import Distribution.Package -import Distribution.Simple.Compiler hiding (Flag) -import Distribution.Simple.GHC -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.Verbosity - import System.Console.GetOpt import System.Directory import System.Environment @@ -54,7 +45,8 @@ data CheckResult main :: IO () main = do - cfg <- uncurry loadConfig =<< checkOpt =<< getArgs + let dcfg = defaultDirConfig baseDir + cfg <- uncurry (loadConfig dcfg) =<< checkOpt =<< getArgs runHaddock cfg checkFiles cfg @@ -101,54 +93,6 @@ runHaddock (Config { .. }) = do waitForSuccess "Failed to run Haddock on specified test files" handle -checkOpt :: [String] -> IO ([Flag], [String]) -checkOpt args = do - let (flags, files, errors) = getOpt Permute options args - - unless (null errors) $ do - hPutStr stderr $ concat errors - exitFailure - - when (FlagHelp `elem` flags) $ do - hPutStrLn stderr $ usageInfo "" options - exitSuccess - - return (flags, files) - - -loadConfig :: [Flag] -> [String] -> IO Config -loadConfig flags files = do - cfgEnv <- (:) ("haddock_datadir", resDir) <$> getEnvironment - - cfgHaddockPath <- pure $ flip fromMaybe (flagsHaddockPath flags) $ - rootDir "dist" "build" "haddock" "haddock" - - printVersions cfgEnv cfgHaddockPath - - cfgGhcPath <- flip fromMaybe (flagsGhcPath flags) <$> - init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"] - - cfgFiles <- processFileArgs files - - cfgHaddockArgs <- liftM concat . sequence $ - [ pure ["--no-warnings"] - , pure ["--odir=" ++ outDir] - , pure ["--pretty-html"] - , pure ["--html"] - , pure ["--optghc=-w"] - , pure $ flagsHaddockOptions flags - , baseDependencies cfgGhcPath - ] - - let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags) - - cfgDiffTool <- if FlagNoDiff `elem` flags - then pure Nothing - else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool - - return $ Config { .. } - - checkModule :: String -> IO CheckResult checkModule mdl = do hasRef <- doesFileExist $ refFile mdl @@ -191,67 +135,6 @@ refFile :: String -> FilePath refFile mdl = refDir mdl <.> "html" -printVersions :: Environment -> FilePath -> IO () -printVersions env haddockPath = do - handle <- runProcess' haddockPath $ processConfig - { pcEnv = Just env - , pcArgs = ["--version"] - } - waitForSuccess "Failed to run `haddock --version`" handle - - handle <- runProcess' haddockPath $ processConfig - { pcEnv = Just env - , pcArgs = ["--ghc-version"] - } - waitForSuccess "Failed to run `haddock --ghc-version`" handle - - -baseDependencies :: FilePath -> IO [String] -baseDependencies ghcPath = do - (_, _, cfg) <- configure normal (Just ghcPath) Nothing - defaultProgramConfiguration - pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg - mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"] - where - getDependency pkgIndex name = case ifaces pkgIndex name of - [] -> do - hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name - exitFailure - (ifArg:_) -> pure ifArg - ifaces pkgIndex name = do - pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name) - iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg - iface file html = "--read-interface=" ++ html ++ "," ++ file - - -defaultDiffTool :: IO (Maybe FilePath) -defaultDiffTool = - liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"] - where - isAvailable = liftM isJust . findProgramLocation silent - - -processFileArgs :: [String] -> IO [FilePath] -processFileArgs [] = - map toModulePath . filter isSourceFile <$> getDirectoryContents srcDir - where - toModulePath = modulePath . takeBaseName -processFileArgs args = pure $ map processFileArg args - - -processFileArg :: String -> FilePath -processFileArg arg - | isSourceFile arg = arg - | otherwise = modulePath arg - - -isSourceFile :: FilePath -> Bool -isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] - -modulePath :: String -> FilePath -modulePath mdl = srcDir mdl <.> "hs" - - -- *** OLD TEST RUNNER UTILITY FUNCTIONS *** -- These are considered bad and should be replaced as soon as possible. -- cgit v1.2.3 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(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') 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 From ad82e40c858e313f8ff06eed058618fa1eaa8c19 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 20:27:59 +0200 Subject: Create convenience wrappers to simplify in test entry points. --- haddock-test/src/Test/Haddock.hs | 4 ++++ haddock-test/src/Test/Haddock/Config.hs | 4 ++++ html-test/run.hs | 5 +---- 3 files changed, 9 insertions(+), 4 deletions(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index 3c0c8d5f..de293eab 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -28,6 +28,10 @@ data CheckResult | Error String +runAndCheck :: Config c -> IO () +runAndCheck cfg = runHaddock cfg >> checkFiles cfg + + checkFiles :: Config c -> IO () checkFiles cfg@(Config { .. }) = do putStrLn "Testing output files..." diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 3b6dfdeb..3068e52b 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -127,6 +127,10 @@ options = ] +parseArgs :: CheckConfig c -> DirConfig -> [String] -> IO (Config c) +parseArgs ccfg dcfg args = uncurry (loadConfig ccfg dcfg) =<< checkOpt args + + checkOpt :: [String] -> IO ([Flag], [String]) checkOpt args = do let (flags, files, errors) = getOpt Permute options args diff --git a/html-test/run.hs b/html-test/run.hs index 22a06ba3..2758bf56 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -23,10 +23,7 @@ dirConfig = defaultDirConfig $ takeDirectory __FILE__ main :: IO () -main = do - cfg <- uncurry (loadConfig checkConfig dirConfig) =<< checkOpt =<< getArgs - runHaddock cfg - checkFiles cfg +main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs -- *** OLD TEST RUNNER UTILITY FUNCTIONS *** -- cgit v1.2.3 From 188b8aae6efa5d3f41687c84399343494f6bf975 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 21:04:26 +0200 Subject: Adjust module visibility and items they export. --- haddock-test/haddock-test.cabal | 2 +- haddock-test/src/Test/Haddock.hs | 4 ++-- haddock-test/src/Test/Haddock/Config.hs | 7 ++++++- 3 files changed, 9 insertions(+), 4 deletions(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index 4cf10799..18c9d28b 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -21,8 +21,8 @@ library exposed-modules: Test.Haddock Test.Haddock.Config - Test.Haddock.Process Test.Haddock.Xhtml other-modules: + Test.Haddock.Process Test.Haddock.Utils diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index de293eab..a6b9ea8a 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -2,8 +2,8 @@ module Test.Haddock - ( module Test.Haddock - , module Test.Haddock.Config + ( module Test.Haddock.Config + , runAndCheck, runHaddock, checkFiles ) where diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 3068e52b..0c9bdb19 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -1,7 +1,12 @@ {-# LANGUAGE RecordWildCards #-} -module Test.Haddock.Config where +module Test.Haddock.Config + ( CheckConfig(..), DirConfig(..), Config(..) + , defaultDirConfig + , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir + , parseArgs, checkOpt, loadConfig + ) where import Control.Applicative -- cgit v1.2.3 From b1c899c2ccb0b7d12aa7f4217dff516d354f2055 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 21:13:35 +0200 Subject: Remove no longer useful test option. --- haddock-test/src/Test/Haddock/Config.hs | 7 ------- 1 file changed, 7 deletions(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 0c9bdb19..4f6bb818 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -83,7 +83,6 @@ cfgResDir = dcfgResDir . cfgDirConfig data Flag = FlagHaddockPath FilePath - | FlagGhcPath FilePath | FlagHaddockOptions String | FlagHaddockStdOut FilePath | FlagDiffTool FilePath @@ -96,10 +95,6 @@ flagsHaddockPath :: [Flag] -> Maybe FilePath flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ] -flagsGhcPath :: [Flag] -> Maybe FilePath -flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ] - - flagsHaddockOptions :: [Flag] -> [String] flagsHaddockOptions flags = concat [ words opts | FlagHaddockOptions opts <- flags ] @@ -117,8 +112,6 @@ options :: [OptDescr Flag] options = [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE") "path to Haddock executable to exectue tests with" - , Option [] ["ghc-path"] (ReqArg FlagGhcPath "FILE") - "path to GHC executable" , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS") "additional options to run Haddock with" , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE") -- cgit v1.2.3 From 5568091a53ee53f742b6fe9f11b3edd1664228b9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 17 Aug 2015 12:54:48 +0200 Subject: Implement output accepting mechanism in test package. --- haddock-test/src/Test/Haddock.hs | 16 +++++++++++++++- haddock-test/src/Test/Haddock/Config.hs | 6 ++++++ 2 files changed, 21 insertions(+), 1 deletion(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index 78204840..a2c6609a 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -29,7 +29,11 @@ data CheckResult runAndCheck :: Config c -> IO () -runAndCheck cfg = runHaddock cfg >> checkFiles cfg +runAndCheck cfg = do + runHaddock cfg + if cfgAccept cfg + then acceptFiles cfg + else checkFiles cfg checkFiles :: Config c -> IO () @@ -55,6 +59,16 @@ 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 { cfgDiffTool = Nothing }) _ = pure () maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) mdls = do diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 4f6bb818..451cd809 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -68,6 +68,7 @@ data Config c = Config , cfgHaddockStdOut :: FilePath , cfgDiffTool :: Maybe FilePath , cfgEnv :: Environment + , cfgAccept :: Bool , cfgCheckConfig :: CheckConfig c , cfgDirConfig :: DirConfig } @@ -87,6 +88,7 @@ data Flag | FlagHaddockStdOut FilePath | FlagDiffTool FilePath | FlagNoDiff + | FlagAccept | FlagHelp deriving Eq @@ -118,6 +120,8 @@ options = "where to redirect Haddock output" , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH") "diff tool to use when printing failed cases" + , Option ['a'] ["accept"] (NoArg FlagAccept) + "accept generated output" , Option [] ["no-diff"] (NoArg FlagNoDiff) "do not print diff for failed cases" , Option ['h'] ["help"] (NoArg FlagHelp) @@ -178,6 +182,8 @@ loadConfig ccfg dcfg flags files = do then pure Nothing else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool + let cfgAccept = FlagAccept `elem` flags + let cfgCheckConfig = ccfg let cfgDirConfig = dcfg -- cgit v1.2.3 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/src/Test/Haddock/Config.hs') 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 From c2a4125e3a5158078d8c172a840f7292dcf3ab28 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 20:32:12 +0200 Subject: Fix path handling in test runner. --- haddock-test/src/Test/Haddock/Config.hs | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 15a53829..1b89e276 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -238,34 +238,29 @@ defaultDiffTool = processFileArgs :: DirConfig -> [String] -> IO [TestPackage] processFileArgs dcfg [] = - processFileArgs dcfg . filter isValidEntry =<< getDirectoryContents srcDir + processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir where - isValidEntry entry = entry /= "." && entry /= ".." + isValidEntry entry + | hasExtension entry = takeExtension entry `elem` [".hs", ".lhs"] + | otherwise = entry /= "." && entry /= ".." srcDir = dcfgSrcDir dcfg processFileArgs dcfg args = processFileArgs' dcfg args processFileArgs' :: DirConfig -> [String] -> IO [TestPackage] processFileArgs' dcfg args = do - (mdls, dirs) <- partitionM doesDirectoryExist' args + (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args rootPkg <- pure $ TestPackage { tpkgName = "" - , tpkgFiles = map (processFileArg dcfg) mdls + , tpkgFiles = map (srcDir ) mdls } otherPkgs <- forM dirs $ \dir -> do - files <- getDirectoryContents dir + files <- getDirectoryContents (srcDir dir) pure $ TestPackage { tpkgName = dir - , tpkgFiles = map ((dcfgSrcDir dcfg dir) ) files + , tpkgFiles = map ((srcDir dir) ) files } pure $ rootPkg:otherPkgs where - doesDirectoryExist' path = doesDirectoryExist (dcfgSrcDir dcfg path) - - -processFileArg :: DirConfig -> String -> FilePath -processFileArg dcfg arg - | isSourceFile arg = arg - | otherwise = dcfgSrcDir dcfg arg ".hs" - where - isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] + doesDirectoryExist' path = doesDirectoryExist (srcDir path) + srcDir = dcfgSrcDir dcfg -- cgit v1.2.3 From bb7d45db2b79f310ab8c2601b47399d5ac69e085 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 20:43:52 +0200 Subject: Make it possible to specify ignored files for test output. --- haddock-test/src/Test/Haddock.hs | 4 +++- haddock-test/src/Test/Haddock/Config.hs | 2 ++ 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index f31ec53f..581b0d10 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -38,7 +38,7 @@ checkFiles :: Config c -> IO () checkFiles cfg@(Config { .. }) = do putStrLn "Testing output files..." - files <- getDirectoryContents (cfgOutDir cfg) + files <- ignore <$> getDirectoryContents (cfgOutDir cfg) failed <- liftM catMaybes . forM files $ \file -> do putStr $ "Checking \"" ++ file ++ "\"... " @@ -56,6 +56,8 @@ checkFiles cfg@(Config { .. }) = do else do maybeDiff cfg failed exitFailure + where + ignore = filter (not . dcfgCheckIgnore cfgDirConfig) maybeDiff :: Config c -> [FilePath] -> IO () diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 1b89e276..256e9a93 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -53,6 +53,7 @@ data DirConfig = DirConfig , dcfgRefDir :: FilePath , dcfgOutDir :: FilePath , dcfgResDir :: FilePath + , dcfgCheckIgnore :: FilePath -> Bool } @@ -62,6 +63,7 @@ defaultDirConfig baseDir = DirConfig , dcfgRefDir = baseDir "ref" , dcfgOutDir = baseDir "out" , dcfgResDir = rootDir "resources" + , dcfgCheckIgnore = const False } where rootDir = baseDir ".." -- cgit v1.2.3 From ebf06f31c1eaf0e9d045f8472548196d47d53431 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 22:30:06 +0200 Subject: Fix bug with test runner invoking Haddock in incorrect mode. --- haddock-test/src/Test/Haddock/Config.hs | 2 -- html-test/Main.hs | 6 +++++- hypsrc-test/Main.hs | 9 ++++++++- 3 files changed, 13 insertions(+), 4 deletions(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 256e9a93..9fca3348 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -177,8 +177,6 @@ loadConfig ccfg dcfg flags files = do cfgHaddockArgs <- liftM concat . sequence $ [ pure ["--no-warnings"] , pure ["--odir=" ++ dcfgOutDir dcfg] - , pure ["--pretty-html"] - , pure ["--html"] , pure ["--optghc=-w"] , pure $ flagsHaddockOptions flags , baseDependencies ghcPath diff --git a/html-test/Main.hs b/html-test/Main.hs index 49e769f5..724d35ec 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -25,7 +25,11 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__) main :: IO () -main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"] + } stripIfRequired :: String -> Xhtml -> Xhtml diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index 7fa4a705..06cf8546 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -30,7 +30,14 @@ dirConfig = (defaultDirConfig $ takeDirectory __FILE__) main :: IO () -main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ + [ "--pretty-html" + , "--hyperlinked-source" + ] + } checkIgnore :: FilePath -> Bool -- cgit v1.2.3 From 48b5858b9b37e4190c475558a6c88dc923ec5c5a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 23:06:00 +0200 Subject: Fix path handling in test module loader. --- haddock-test/src/Test/Haddock/Config.hs | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 9fca3348..f3056061 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -241,8 +241,8 @@ processFileArgs dcfg [] = processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir where isValidEntry entry - | hasExtension entry = takeExtension entry `elem` [".hs", ".lhs"] - | otherwise = entry /= "." && entry /= ".." + | hasExtension entry = isSourceFile entry + | otherwise = isRealDir entry srcDir = dcfgSrcDir dcfg processFileArgs dcfg args = processFileArgs' dcfg args @@ -255,12 +255,24 @@ processFileArgs' dcfg args = do , tpkgFiles = map (srcDir ) mdls } otherPkgs <- forM dirs $ \dir -> do - files <- getDirectoryContents (srcDir dir) + let srcDir' = srcDir dir + files <- filterM (isModule dir) =<< getDirectoryContents srcDir' pure $ TestPackage { tpkgName = dir - , tpkgFiles = map ((srcDir dir) ) files + , tpkgFiles = map (srcDir' ) files } pure $ rootPkg:otherPkgs where doesDirectoryExist' path = doesDirectoryExist (srcDir path) + isModule dir file = (isSourceFile file &&) <$> + doesFileExist (srcDir dir file) + doesFileExist' dir path = doesFileExist (srcDir dir path) srcDir = dcfgSrcDir dcfg + + +isSourceFile :: FilePath -> Bool +isSourceFile file = takeExtension file `elem` [".hs", ".lhs"] + + +isRealDir :: FilePath -> Bool +isRealDir dir = not $ dir `elem` [".", ".."] -- cgit v1.2.3 From d36a1a5fb39529e396203b4da0c396ceedda133b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 23:11:59 +0200 Subject: Make test runner ignore test packages with no modules. --- haddock-test/src/Test/Haddock/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index f3056061..b1fd2098 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -261,7 +261,7 @@ processFileArgs' dcfg args = do { tpkgName = dir , tpkgFiles = map (srcDir' ) files } - pure $ rootPkg:otherPkgs + pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs where doesDirectoryExist' path = doesDirectoryExist (srcDir path) isModule dir file = (isSourceFile file &&) <$> -- cgit v1.2.3 From 1b758285744eb1b7a34bc63a131738c28f0e089a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 19 Aug 2015 13:06:22 +0200 Subject: Fix warning about no longer needed definition. --- haddock-test/src/Test/Haddock/Config.hs | 1 - 1 file changed, 1 deletion(-) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index b1fd2098..fff84921 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -266,7 +266,6 @@ processFileArgs' dcfg args = do doesDirectoryExist' path = doesDirectoryExist (srcDir path) isModule dir file = (isSourceFile file &&) <$> doesFileExist (srcDir dir file) - doesFileExist' dir path = doesFileExist (srcDir dir path) srcDir = dcfgSrcDir dcfg -- cgit v1.2.3 From 1557c08cac99befbd541dcca4d85c20609518f2b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 25 Aug 2015 17:41:59 +0200 Subject: Fix test suite failure when used with Stack. --- haddock-test/src/Test/Haddock/Config.hs | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'haddock-test/src/Test/Haddock/Config.hs') diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index fff84921..8f1f4885 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -213,6 +213,11 @@ printVersions env haddockPath = do baseDependencies :: FilePath -> IO [String] baseDependencies ghcPath = do + -- The 'getInstalledPackages' crashes if used when "GHC_PACKAGE_PATH" is + -- set to some value. I am not sure why is that happening and what are the + -- consequences of unsetting it - but looks like it works (for now). + unsetEnv "GHC_PACKAGE_PATH" + (_, _, cfg) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg -- cgit v1.2.3