From 0a7c9cc09882f4d0bd3a3c1b64d0ae8f2d7a2317 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 1 Aug 2015 16:45:23 +0200 Subject: Create script file for new HTML test runner. --- html-test/run.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100755 html-test/run.hs diff --git a/html-test/run.hs b/html-test/run.hs new file mode 100755 index 00000000..71d78f73 --- /dev/null +++ b/html-test/run.hs @@ -0,0 +1,28 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE CPP #-} + + +import System.Environment +import System.FilePath + + +baseDir, rootDir :: FilePath +baseDir = takeDirectory __FILE__ +rootDir = baseDir ".." + +srcDir, refDir, outDir :: FilePath +srcDir = baseDir "src" +refDir = baseDir "ref" +outDir = baseDir "out" + + +main :: IO () +main = do + files <- map processArg <$> getArgs + putStrLn $ "Files to test: " ++ show files + + +processArg :: String -> FilePath +processArg arg + | takeExtension arg `elem` [".hs", ".lhs"] = arg + | otherwise = srcDir arg <.> "hs" -- cgit v1.2.3 From a2949cdb2be4b8e5c8290736d2916009f9526c3d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 1 Aug 2015 17:03:33 +0200 Subject: Set default behaviour if no arguments given. --- html-test/run.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 71d78f73..99ca1ec1 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} +import System.Directory import System.Environment import System.FilePath @@ -18,11 +19,20 @@ outDir = baseDir "out" main :: IO () main = do - files <- map processArg <$> getArgs + files <- processArgs =<< getArgs putStrLn $ "Files to test: " ++ show files +processArgs :: [String] -> IO [FilePath] +processArgs [] = filter isSourceFile <$> getDirectoryContents srcDir +processArgs args = pure $ map processArg args + + processArg :: String -> FilePath processArg arg - | takeExtension arg `elem` [".hs", ".lhs"] = arg + | isSourceFile arg = arg | otherwise = srcDir arg <.> "hs" + + +isSourceFile :: FilePath -> Bool +isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] -- cgit v1.2.3 From ee55e4775739a7c42f19223435ef6ea2ad0bcff0 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 1 Aug 2015 18:10:15 +0200 Subject: Add support for providing optional arguments for test runner. --- html-test/run.hs | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 62 insertions(+), 7 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 99ca1ec1..be31aeea 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -1,9 +1,16 @@ #!/usr/bin/env runhaskell {-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +import Control.Monad + +import Data.Maybe + +import System.Console.GetOpt import System.Directory import System.Environment +import System.Exit import System.FilePath @@ -17,22 +24,70 @@ refDir = baseDir "ref" outDir = baseDir "out" +data Config = Config + { cfgHaddockPath :: FilePath + , cfgFiles :: [FilePath] + } + + main :: IO () main = do - files <- processArgs =<< getArgs - putStrLn $ "Files to test: " ++ show files + Config { .. } <- parseArgs =<< getArgs + putStrLn $ "Files to test: " ++ show cfgFiles + + +parseArgs :: [String] -> IO Config +parseArgs args = do + let (flags, files, errors) = getOpt Permute options args + + when (not $ null errors) $ do + mapM_ putStrLn errors + exitFailure + + when (FlagHelp `elem` flags) $ do + putStrLn $ usageInfo "" options + exitSuccess + + cfgFiles <- processFileArgs files + let cfgHaddockPath = haddockPath flags + return $ Config { .. } -processArgs :: [String] -> IO [FilePath] -processArgs [] = filter isSourceFile <$> getDirectoryContents srcDir -processArgs args = pure $ map processArg args +processFileArgs :: [String] -> IO [FilePath] +processFileArgs [] = filter isSourceFile <$> getDirectoryContents srcDir +processFileArgs args = pure $ map processFileArg args -processArg :: String -> FilePath -processArg arg +processFileArg :: String -> FilePath +processFileArg arg | isSourceFile arg = arg | otherwise = srcDir arg <.> "hs" isSourceFile :: FilePath -> Bool isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] + + +data Flag + = FlagHaddockPath FilePath + | FlagHelp + deriving Eq + + +options :: [OptDescr Flag] +options = + [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE") + "path to Haddock executable to exectue tests with" + , Option ['h'] ["help"] (NoArg FlagHelp) + "display this help end exit" + ] + + +haddockPath :: [Flag] -> FilePath +haddockPath flags = case mlast [ path | FlagHaddockPath path <- flags ] of + Just path -> path + Nothing -> rootDir "dist" "build" "haddock" "haddock" + + +mlast :: [a] -> Maybe a +mlast = listToMaybe . reverse -- cgit v1.2.3 From d5d2030ee343ed5a27db338dea48f801e040db9f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 1 Aug 2015 18:20:44 +0200 Subject: Improve output of test runner error messages. --- html-test/run.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index be31aeea..a3887df6 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -12,6 +12,7 @@ import System.Directory import System.Environment import System.Exit import System.FilePath +import System.IO baseDir, rootDir :: FilePath @@ -41,11 +42,11 @@ parseArgs args = do let (flags, files, errors) = getOpt Permute options args when (not $ null errors) $ do - mapM_ putStrLn errors + hPutStr stderr $ concat errors exitFailure when (FlagHelp `elem` flags) $ do - putStrLn $ usageInfo "" options + hPutStrLn stderr $ usageInfo "" options exitSuccess cfgFiles <- processFileArgs files -- cgit v1.2.3 From 1377659f2fc98db024e436ffc4c59b5e8be31c7a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 1 Aug 2015 18:57:05 +0200 Subject: Add support for executing Haddock process in test runner. --- html-test/run.hs | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/html-test/run.hs b/html-test/run.hs index a3887df6..91e692a1 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -13,6 +13,7 @@ import System.Environment import System.Exit import System.FilePath import System.IO +import System.Process baseDir, rootDir :: FilePath @@ -24,6 +25,9 @@ srcDir = baseDir "src" refDir = baseDir "ref" outDir = baseDir "out" +resDir :: FilePath +resDir = rootDir "resources" + data Config = Config { cfgHaddockPath :: FilePath @@ -34,6 +38,21 @@ data Config = Config main :: IO () main = do Config { .. } <- parseArgs =<< getArgs + + env <- Just . (:) ("haddock_datadir", resDir) <$> getEnvironment + + handle <- runProcess' cfgHaddockPath $ processConfig + { pcEnv = env + , pcArgs = ["--version"] + } + waitForSuccess "Failed to run `haddock --version`" handle + + handle <- runProcess' cfgHaddockPath $ processConfig + { pcEnv = env + , pcArgs = ["--ghc-version"] + } + waitForSuccess "Failed to run `haddock --ghc-version`" handle + putStrLn $ "Files to test: " ++ show cfgFiles @@ -92,3 +111,37 @@ haddockPath flags = case mlast [ path | FlagHaddockPath path <- flags ] of mlast :: [a] -> Maybe a mlast = listToMaybe . reverse + + +data ProcessConfig = ProcessConfig + { pcArgs :: [String] + , pcWorkDir :: Maybe FilePath + , pcEnv :: Maybe [(String, String)] + , pcStdIn :: Maybe Handle + , pcStdOut :: Maybe Handle + , pcStdErr :: Maybe Handle + } + + +processConfig :: ProcessConfig +processConfig = ProcessConfig + { pcArgs = [] + , pcWorkDir = Nothing + , pcEnv = Nothing + , pcStdIn = Nothing + , pcStdOut = Nothing + , pcStdErr = Nothing + } + + +runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle +runProcess' path (ProcessConfig { .. }) = runProcess + path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr + + +waitForSuccess :: String -> ProcessHandle -> IO () +waitForSuccess msg handle = do + result <- waitForProcess handle + unless (result == ExitSuccess) $ do + hPutStrLn stderr $ msg + exitFailure -- cgit v1.2.3 From a380904e39ea57e3907c0297b41eb546680b0d3a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 3 Aug 2015 20:34:12 +0200 Subject: Add GHC path to test runner configuration. --- html-test/run.hs | 68 +++++++++++++++++++++++++++++++++----------------------- 1 file changed, 40 insertions(+), 28 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 91e692a1..61e00781 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -7,6 +7,9 @@ import Control.Monad import Data.Maybe +import Distribution.Simple.Utils +import Distribution.Verbosity + import System.Console.GetOpt import System.Directory import System.Environment @@ -31,33 +34,19 @@ resDir = rootDir "resources" data Config = Config { cfgHaddockPath :: FilePath + , cfgGhcPath :: FilePath , cfgFiles :: [FilePath] } main :: IO () main = do - Config { .. } <- parseArgs =<< getArgs + Config { .. } <- loadConfig =<< getArgs + return () - env <- Just . (:) ("haddock_datadir", resDir) <$> getEnvironment - handle <- runProcess' cfgHaddockPath $ processConfig - { pcEnv = env - , pcArgs = ["--version"] - } - waitForSuccess "Failed to run `haddock --version`" handle - - handle <- runProcess' cfgHaddockPath $ processConfig - { pcEnv = env - , pcArgs = ["--ghc-version"] - } - waitForSuccess "Failed to run `haddock --ghc-version`" handle - - putStrLn $ "Files to test: " ++ show cfgFiles - - -parseArgs :: [String] -> IO Config -parseArgs args = do +loadConfig :: [String] -> IO Config +loadConfig args = do let (flags, files, errors) = getOpt Permute options args when (not $ null errors) $ do @@ -68,11 +57,35 @@ parseArgs args = do hPutStrLn stderr $ usageInfo "" options exitSuccess + env <- Just . (:) ("haddock_datadir", resDir) <$> getEnvironment + + let cfgHaddockPath = flagsHaddockPath flags + + printVersions env cfgHaddockPath + cfgFiles <- processFileArgs files - let cfgHaddockPath = haddockPath flags + cfgGhcPath <- init <$> rawSystemStdout normal cfgHaddockPath + ["--print-ghc-path"] + putStrLn $ "Files to test: " ++ show cfgFiles return $ Config { .. } + +printVersions :: Maybe [(String, String)] -> FilePath -> IO () +printVersions env haddockPath = do + handle <- runProcess' haddockPath $ processConfig + { pcEnv = env + , pcArgs = ["--version"] + } + waitForSuccess "Failed to run `haddock --version`" handle + + handle <- runProcess' haddockPath $ processConfig + { pcEnv = env + , pcArgs = ["--ghc-version"] + } + waitForSuccess "Failed to run `haddock --ghc-version`" handle + + processFileArgs :: [String] -> IO [FilePath] processFileArgs [] = filter isSourceFile <$> getDirectoryContents srcDir processFileArgs args = pure $ map processFileArg args @@ -103,14 +116,13 @@ options = ] -haddockPath :: [Flag] -> FilePath -haddockPath flags = case mlast [ path | FlagHaddockPath path <- flags ] of - Just path -> path - Nothing -> rootDir "dist" "build" "haddock" "haddock" - - -mlast :: [a] -> Maybe a -mlast = listToMaybe . reverse +flagsHaddockPath :: [Flag] -> FilePath +flagsHaddockPath flags = + case mlast [ path | FlagHaddockPath path <- flags ] of + Just path -> path + Nothing -> rootDir "dist" "build" "haddock" "haddock" + where + mlast = listToMaybe . reverse data ProcessConfig = ProcessConfig -- cgit v1.2.3 From c162d63f71839a02acb8017d7f15915d9cf7023d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 3 Aug 2015 20:59:34 +0200 Subject: Make GHC path a test runner command-line argument. --- html-test/run.hs | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 61e00781..829b5704 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -59,15 +59,16 @@ loadConfig args = do env <- Just . (:) ("haddock_datadir", resDir) <$> getEnvironment - let cfgHaddockPath = flagsHaddockPath flags + cfgHaddockPath <- pure $ flip fromMaybe (flagsHaddockPath flags) $ + rootDir "dist" "build" "haddock" "haddock" printVersions env cfgHaddockPath + cfgGhcPath <- flip fromMaybe (flagsGhcPath flags) <$> + init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"] + cfgFiles <- processFileArgs files - cfgGhcPath <- init <$> rawSystemStdout normal cfgHaddockPath - ["--print-ghc-path"] - putStrLn $ "Files to test: " ++ show cfgFiles return $ Config { .. } @@ -103,6 +104,7 @@ isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] data Flag = FlagHaddockPath FilePath + | FlagGhcPath FilePath | FlagHelp deriving Eq @@ -111,18 +113,19 @@ 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 ['h'] ["help"] (NoArg FlagHelp) "display this help end exit" ] -flagsHaddockPath :: [Flag] -> FilePath -flagsHaddockPath flags = - case mlast [ path | FlagHaddockPath path <- flags ] of - Just path -> path - Nothing -> rootDir "dist" "build" "haddock" "haddock" - where - mlast = listToMaybe . reverse +flagsHaddockPath :: [Flag] -> Maybe FilePath +flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ] + + +flagsGhcPath :: [Flag] -> Maybe FilePath +flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ] data ProcessConfig = ProcessConfig @@ -157,3 +160,7 @@ waitForSuccess msg handle = do unless (result == ExitSuccess) $ do hPutStrLn stderr $ msg exitFailure + + +mlast :: [a] -> Maybe a +mlast = listToMaybe . reverse -- cgit v1.2.3 From da76b1b4ea86ad8b27f722ad803be40b512c9e00 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 14:09:20 +0200 Subject: Extend test runner configuration with Haddock arguments. --- html-test/run.hs | 48 +++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 45 insertions(+), 3 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 829b5704..3a421be7 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -7,6 +7,12 @@ import Control.Monad 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 @@ -36,13 +42,14 @@ data Config = Config { cfgHaddockPath :: FilePath , cfgGhcPath :: FilePath , cfgFiles :: [FilePath] - } + , cfgHaddockArgs :: [String] + } deriving Show main :: IO () main = do - Config { .. } <- loadConfig =<< getArgs - return () + cfg <- loadConfig =<< getArgs + putStrLn $ show cfg loadConfig :: [String] -> IO Config @@ -69,6 +76,15 @@ loadConfig args = do cfgFiles <- processFileArgs files + cfgHaddockArgs <- liftM concat . sequence $ + [ pure ["--no-warnings"] + , pure ["--odir=" ++ outDir] + , pure ["--pretty-html"] + , pure ["--optghc=--w"] + , pure $ flagsHaddockOptions flags + , baseDependencies cfgGhcPath + ] + return $ Config { .. } @@ -87,6 +103,24 @@ printVersions env haddockPath = do 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 + + processFileArgs :: [String] -> IO [FilePath] processFileArgs [] = filter isSourceFile <$> getDirectoryContents srcDir processFileArgs args = pure $ map processFileArg args @@ -105,6 +139,7 @@ isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] data Flag = FlagHaddockPath FilePath | FlagGhcPath FilePath + | FlagHaddockOptions String | FlagHelp deriving Eq @@ -115,6 +150,8 @@ options = "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 ['h'] ["help"] (NoArg FlagHelp) "display this help end exit" ] @@ -128,6 +165,11 @@ flagsGhcPath :: [Flag] -> Maybe FilePath flagsGhcPath flags = mlast [ path | FlagGhcPath path <- flags ] +flagsHaddockOptions :: [Flag] -> [String] +flagsHaddockOptions flags = concat + [ words opts | FlagHaddockOptions opts <- flags ] + + data ProcessConfig = ProcessConfig { pcArgs :: [String] , pcWorkDir :: Maybe FilePath -- cgit v1.2.3 From 17be133c363d161cff0a0e21968784afd2f7058a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 14:21:22 +0200 Subject: Refactor test runner and create stub functions. --- html-test/run.hs | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 3a421be7..a9fe8bb7 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -48,15 +48,25 @@ data Config = Config main :: IO () main = do - cfg <- loadConfig =<< getArgs + cfg <- uncurry loadConfig =<< checkOpt =<< getArgs putStrLn $ show cfg + runHaddock cfg + checkOutput cfg -loadConfig :: [String] -> IO Config -loadConfig args = do +checkOutput :: Config -> IO () +checkOutput _ = return () -- TODO. + + +runHaddock :: Config -> IO () +runHaddock _ = return () -- TODO. + + +checkOpt :: [String] -> IO ([Flag], [String]) +checkOpt args = do let (flags, files, errors) = getOpt Permute options args - when (not $ null errors) $ do + unless (null errors) $ do hPutStr stderr $ concat errors exitFailure @@ -64,6 +74,11 @@ loadConfig args = do hPutStrLn stderr $ usageInfo "" options exitSuccess + return (flags, files) + + +loadConfig :: [Flag] -> [String] -> IO Config +loadConfig flags files = do env <- Just . (:) ("haddock_datadir", resDir) <$> getEnvironment cfgHaddockPath <- pure $ flip fromMaybe (flagsHaddockPath flags) $ -- cgit v1.2.3 From 076e04cd4c049ddfad6feed242e2c1024d5db101 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 14:41:06 +0200 Subject: Make test runner actually run Haddock executable. --- html-test/run.hs | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index a9fe8bb7..62e8bc23 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -43,13 +43,13 @@ data Config = Config , cfgGhcPath :: FilePath , cfgFiles :: [FilePath] , cfgHaddockArgs :: [String] - } deriving Show + , cfgEnv :: Environment + } main :: IO () main = do cfg <- uncurry loadConfig =<< checkOpt =<< getArgs - putStrLn $ show cfg runHaddock cfg checkOutput cfg @@ -59,7 +59,12 @@ checkOutput _ = return () -- TODO. runHaddock :: Config -> IO () -runHaddock _ = return () -- TODO. +runHaddock (Config { .. }) = do + handle <- runProcess' cfgHaddockPath $ processConfig + { pcArgs = cfgHaddockArgs + , pcEnv = Just $ cfgEnv + } + waitForSuccess "Failed to run Haddock on specified test files" handle checkOpt :: [String] -> IO ([Flag], [String]) @@ -79,12 +84,12 @@ checkOpt args = do loadConfig :: [Flag] -> [String] -> IO Config loadConfig flags files = do - env <- Just . (:) ("haddock_datadir", resDir) <$> getEnvironment + cfgEnv <- (:) ("haddock_datadir", resDir) <$> getEnvironment cfgHaddockPath <- pure $ flip fromMaybe (flagsHaddockPath flags) $ rootDir "dist" "build" "haddock" "haddock" - printVersions env cfgHaddockPath + printVersions cfgEnv cfgHaddockPath cfgGhcPath <- flip fromMaybe (flagsGhcPath flags) <$> init <$> rawSystemStdout normal cfgHaddockPath ["--print-ghc-path"] @@ -95,7 +100,7 @@ loadConfig flags files = do [ pure ["--no-warnings"] , pure ["--odir=" ++ outDir] , pure ["--pretty-html"] - , pure ["--optghc=--w"] + , pure ["--optghc=-w"] , pure $ flagsHaddockOptions flags , baseDependencies cfgGhcPath ] @@ -103,16 +108,16 @@ loadConfig flags files = do return $ Config { .. } -printVersions :: Maybe [(String, String)] -> FilePath -> IO () +printVersions :: Environment -> FilePath -> IO () printVersions env haddockPath = do handle <- runProcess' haddockPath $ processConfig - { pcEnv = env + { pcEnv = Just env , pcArgs = ["--version"] } waitForSuccess "Failed to run `haddock --version`" handle handle <- runProcess' haddockPath $ processConfig - { pcEnv = env + { pcEnv = Just env , pcArgs = ["--ghc-version"] } waitForSuccess "Failed to run `haddock --ghc-version`" handle @@ -185,10 +190,12 @@ flagsHaddockOptions flags = concat [ words opts | FlagHaddockOptions opts <- flags ] +type Environment = [(String, String)] + data ProcessConfig = ProcessConfig { pcArgs :: [String] , pcWorkDir :: Maybe FilePath - , pcEnv :: Maybe [(String, String)] + , pcEnv :: Maybe Environment , pcStdIn :: Maybe Handle , pcStdOut :: Maybe Handle , pcStdErr :: Maybe Handle -- cgit v1.2.3 From c96ac677097f3500ca923a5b3a32818f8f75a5be Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 14:44:01 +0200 Subject: Fix bug with test runner not producing any output files. --- html-test/run.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/html-test/run.hs b/html-test/run.hs index 62e8bc23..5678a877 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -61,7 +61,7 @@ checkOutput _ = return () -- TODO. runHaddock :: Config -> IO () runHaddock (Config { .. }) = do handle <- runProcess' cfgHaddockPath $ processConfig - { pcArgs = cfgHaddockArgs + { pcArgs = cfgHaddockArgs ++ cfgFiles , pcEnv = Just $ cfgEnv } waitForSuccess "Failed to run Haddock on specified test files" handle @@ -100,6 +100,7 @@ loadConfig flags files = do [ pure ["--no-warnings"] , pure ["--odir=" ++ outDir] , pure ["--pretty-html"] + , pure ["--html"] , pure ["--optghc=-w"] , pure $ flagsHaddockOptions flags , baseDependencies cfgGhcPath -- cgit v1.2.3 From cf8f24440d50de82dff9277bc9376cbdcc75e91b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 16:49:47 +0200 Subject: Setup skeleton of framework for running tests. --- html-test/run.hs | 44 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 43 insertions(+), 1 deletion(-) diff --git a/html-test/run.hs b/html-test/run.hs index 5678a877..b3ca4786 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -47,6 +47,12 @@ data Config = Config } +data CheckResult + = Fail + | Pass + | NoRef + + main :: IO () main = do cfg <- uncurry loadConfig =<< checkOpt =<< getArgs @@ -55,14 +61,29 @@ main = do checkOutput :: Config -> IO () -checkOutput _ = return () -- TODO. +checkOutput (Config { .. }) = do + putStrLn "Diffing output files..." + failFiles <- forM cfgFiles $ \file -> do + putStr $ "Checking " ++ takeBaseName file ++ "... " + + status <- checkFile file + case status of + Fail -> putStrLn "FAIL" >> (return $ Just file) + Pass -> putStrLn "PASS" >> (return Nothing) + NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing) + + return () -- TODO: Print diff for failed cases. runHaddock :: Config -> IO () runHaddock (Config { .. }) = do + putStrLn "Running Haddock process..." + + devNull <- openFile "/dev/null" WriteMode handle <- runProcess' cfgHaddockPath $ processConfig { pcArgs = cfgHaddockArgs ++ cfgFiles , pcEnv = Just $ cfgEnv + , pcStdOut = Just $ devNull } waitForSuccess "Failed to run Haddock on specified test files" handle @@ -109,6 +130,23 @@ loadConfig flags files = do return $ Config { .. } +checkFile :: FilePath -> IO CheckResult +checkFile file = do + hasRef <- doesFileExist refFile + if hasRef + then do + out <- readFile outFile + ref <- readFile refFile + return $ if haddockEq out ref + then Pass + else Fail + else return NoRef + where + outFile = outDir mdl <.> "html" + refFile = refDir mdl <.> "html" + mdl = takeBaseName $ file + + printVersions :: Environment -> FilePath -> IO () printVersions env haddockPath = do handle <- runProcess' haddockPath $ processConfig @@ -229,3 +267,7 @@ waitForSuccess msg handle = do mlast :: [a] -> Maybe a mlast = listToMaybe . reverse + + +haddockEq :: String -> String -> Bool +haddockEq _ _ = True -- TODO. -- cgit v1.2.3 From 11d74d7f84b7683501cbd0e88b62c98016c3a66d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 17:00:52 +0200 Subject: Fix bug with modules not being found in global search mode. --- html-test/run.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index b3ca4786..da414171 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -181,19 +181,25 @@ baseDependencies ghcPath = do processFileArgs :: [String] -> IO [FilePath] -processFileArgs [] = filter isSourceFile <$> getDirectoryContents srcDir +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 = srcDir arg <.> "hs" + | otherwise = modulePath arg isSourceFile :: FilePath -> Bool isSourceFile path = takeExtension path `elem` [".hs", ".lhs"] +modulePath :: String -> FilePath +modulePath mdl = srcDir mdl <.> "hs" + data Flag = FlagHaddockPath FilePath -- cgit v1.2.3 From 110599220155087d3c02a8a9a2f2d4834c666e47 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 17:07:58 +0200 Subject: Make Haddock standard output redirection be more configurable. --- html-test/run.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index da414171..ace3c6a0 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -43,6 +43,7 @@ data Config = Config , cfgGhcPath :: FilePath , cfgFiles :: [FilePath] , cfgHaddockArgs :: [String] + , cfgHaddockStdOut :: FilePath , cfgEnv :: Environment } @@ -79,11 +80,11 @@ runHaddock :: Config -> IO () runHaddock (Config { .. }) = do putStrLn "Running Haddock process..." - devNull <- openFile "/dev/null" WriteMode + haddockStdOut <- openFile cfgHaddockStdOut WriteMode handle <- runProcess' cfgHaddockPath $ processConfig { pcArgs = cfgHaddockArgs ++ cfgFiles , pcEnv = Just $ cfgEnv - , pcStdOut = Just $ devNull + , pcStdOut = Just $ haddockStdOut } waitForSuccess "Failed to run Haddock on specified test files" handle @@ -127,6 +128,8 @@ loadConfig flags files = do , baseDependencies cfgGhcPath ] + let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags) + return $ Config { .. } @@ -205,6 +208,7 @@ data Flag = FlagHaddockPath FilePath | FlagGhcPath FilePath | FlagHaddockOptions String + | FlagHaddockStdOut FilePath | FlagHelp deriving Eq @@ -217,6 +221,8 @@ options = "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 ['h'] ["help"] (NoArg FlagHelp) "display this help end exit" ] @@ -235,6 +241,10 @@ flagsHaddockOptions flags = concat [ words opts | FlagHaddockOptions opts <- flags ] +flagsHaddockStdOut :: [Flag] -> Maybe FilePath +flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ] + + type Environment = [(String, String)] data ProcessConfig = ProcessConfig -- cgit v1.2.3 From 5cf07eb5041a7947400713f9f1105cc1ebfc6eb6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 18:06:19 +0200 Subject: Incorporate old, ugly functions for comparing output files. --- html-test/run.hs | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 61 insertions(+), 3 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index ace3c6a0..b9e1cc56 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -6,6 +6,7 @@ import Control.Monad import Data.Maybe +import Data.List import Distribution.InstalledPackageInfo import Distribution.Package @@ -140,7 +141,7 @@ checkFile file = do then do out <- readFile outFile ref <- readFile refFile - return $ if haddockEq out ref + return $ if haddockEq (outFile, out) (refFile, ref) then Pass else Fail else return NoRef @@ -285,5 +286,62 @@ mlast :: [a] -> Maybe a mlast = listToMaybe . reverse -haddockEq :: String -> String -> Bool -haddockEq _ _ = True -- TODO. +-- *** OLD TEST RUNNER UTILITY FUNCTIONS *** +-- These are considered bad and should be replaced as soon as possible. + + +-- | List of modules in which we don't 'stripLinks' +preserveLinksModules :: [String] +preserveLinksModules = ["Bug253"] + + +-- | A rather nasty way to drop the Haddock version string from the +-- end of the generated HTML files so that we don't have to change +-- every single test every time we change versions. We rely on the the +-- last paragraph of the document to be the version. We end up with +-- malformed HTML but we don't care as we never look at it ourselves. +dropVersion :: String -> String +dropVersion = reverse . dropTillP . reverse + where + dropTillP [] = [] + dropTillP ('p':'<':xs) = xs + dropTillP (_:xs) = dropTillP xs + + +haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool +haddockEq (fn1, file1) (fn2, file2) = + maybeStripLinks fn1 (dropVersion file1) + == maybeStripLinks fn2 (dropVersion file2) + + +maybeStripLinks :: FilePath -- ^ Module we're considering for stripping + -> String -> String +maybeStripLinks file + | takeBaseName file `elem` preserveLinksModules = id + | otherwise = stripLinks + + +stripLinks :: String -> String +stripLinks str = + let prefix = " case dropWhile (/= '>') (dropWhile (/= '"') str') of + [] -> [] + x:xs -> stripLinks (stripHrefEnd xs) + Nothing -> + case str of + [] -> [] + x : xs -> x : stripLinks xs + + +stripHrefEnd :: String -> String +stripHrefEnd s = + let pref = " case dropWhile (/= '>') str' of + [] -> [] + x:xs -> xs + Nothing -> + case s of + [] -> [] + x : xs -> x : stripHrefEnd xs -- cgit v1.2.3 From a2d23f2b34f9341c7c812cb7ce59c41fbd9de130 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 18:25:32 +0200 Subject: Refactor architecture of test runner output checking functions. --- html-test/run.hs | 52 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 19 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index b9e1cc56..52fae690 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -59,22 +59,28 @@ main :: IO () main = do cfg <- uncurry loadConfig =<< checkOpt =<< getArgs runHaddock cfg - checkOutput cfg + checkFiles cfg -checkOutput :: Config -> IO () -checkOutput (Config { .. }) = do - putStrLn "Diffing output files..." - failFiles <- forM cfgFiles $ \file -> do - putStr $ "Checking " ++ takeBaseName file ++ "... " +checkFiles :: Config -> IO () +checkFiles (Config { .. }) = do + putStrLn "Testing output files..." + failed <- liftM catMaybes . forM cfgFiles $ \file -> do + let mdl = takeBaseName file + putStr $ "Checking " ++ mdl ++ "... " - status <- checkFile file + status <- checkModule mdl case status of - Fail -> putStrLn "FAIL" >> (return $ Just file) + Fail -> putStrLn "FAIL" >> (return $ Just mdl) Pass -> putStrLn "PASS" >> (return Nothing) NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing) - return () -- TODO: Print diff for failed cases. + when (null failed) $ do + putStrLn "All tests passed!" + exitSuccess + + putStrLn "Diffing failed cases..." + forM_ failed checkModule runHaddock :: Config -> IO () @@ -134,21 +140,29 @@ loadConfig flags files = do return $ Config { .. } -checkFile :: FilePath -> IO CheckResult -checkFile file = do - hasRef <- doesFileExist refFile +checkModule :: String -> IO CheckResult +checkModule mdl = do + hasRef <- doesFileExist $ refFile mdl if hasRef then do - out <- readFile outFile - ref <- readFile refFile - return $ if haddockEq (outFile, out) (refFile, ref) + out <- readFile $ outFile mdl + ref <- readFile $ refFile mdl + return $ if haddockEq (outFile mdl, out) (refFile mdl, ref) then Pass else Fail else return NoRef - where - outFile = outDir mdl <.> "html" - refFile = refDir mdl <.> "html" - mdl = takeBaseName $ file + + +diffModule :: String -> IO () +diffModule mdl = return () + + +outFile :: String -> FilePath +outFile mdl = outDir mdl <.> "html" + + +refFile :: String -> FilePath +refFile mdl = refDir mdl <.> "html" printVersions :: Environment -> FilePath -> IO () -- cgit v1.2.3 From 18333ed77a6134c01c000d82efd5e05a8d502428 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 18:52:46 +0200 Subject: Implement actual diffing mechanism. --- html-test/run.hs | 31 ++++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 52fae690..039ff676 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -75,12 +75,14 @@ checkFiles (Config { .. }) = do Pass -> putStrLn "PASS" >> (return Nothing) NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing) - when (null failed) $ do - putStrLn "All tests passed!" - exitSuccess - - putStrLn "Diffing failed cases..." - forM_ failed checkModule + if null failed + then do + putStrLn "All tests passed!" + exitSuccess + else do + putStrLn "Diffing failed cases..." + forM_ failed diffModule + exitFailure runHaddock :: Config -> IO () @@ -154,7 +156,22 @@ checkModule mdl = do diffModule :: String -> IO () -diffModule mdl = return () +diffModule mdl = do + out <- readFile $ outFile mdl + ref <- readFile $ refFile mdl + let out' = stripLinks . dropVersion $ out + let ref' = stripLinks . dropVersion $ ref + writeFile outFile' out' + writeFile refFile' ref' + + putStrLn $ "Diff for module " ++ show mdl ++ ":" + handle <- runProcess' "diff" $ processConfig + { pcArgs = [outFile', refFile'] + } + waitForProcess handle >> return () + where + outFile' = outFile mdl <.> "nolinks" + refFile' = outFile mdl <.> "ref" <.> "nolinks" outFile :: String -> FilePath -- cgit v1.2.3 From 9048548dc9dbdf129b16e4c9ac22ca1343261378 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 18:53:47 +0200 Subject: Improve code style to match popular guidelines. --- html-test/run.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 039ff676..d1a134f8 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -146,13 +146,13 @@ checkModule :: String -> IO CheckResult checkModule mdl = do hasRef <- doesFileExist $ refFile mdl if hasRef - then do - out <- readFile $ outFile mdl - ref <- readFile $ refFile mdl - return $ if haddockEq (outFile mdl, out) (refFile mdl, ref) - then Pass - else Fail - else return NoRef + then do + out <- readFile $ outFile mdl + ref <- readFile $ refFile mdl + return $ if haddockEq (outFile mdl, out) (refFile mdl, ref) + then Pass + else Fail + else return NoRef diffModule :: String -> IO () -- cgit v1.2.3 From 4ca12fff14afffc61d80ca0edd2106bd5d3d738e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 4 Aug 2015 19:18:08 +0200 Subject: Make it possible to choose alternative diff tool. --- html-test/run.hs | 34 +++++++++++++++++++++++++++++----- 1 file changed, 29 insertions(+), 5 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index d1a134f8..ee2d0829 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} +import Control.Applicative import Control.Monad import Data.Maybe @@ -45,6 +46,7 @@ data Config = Config , cfgFiles :: [FilePath] , cfgHaddockArgs :: [String] , cfgHaddockStdOut :: FilePath + , cfgDiffTool :: Maybe FilePath , cfgEnv :: Environment } @@ -80,11 +82,17 @@ checkFiles (Config { .. }) = do putStrLn "All tests passed!" exitSuccess else do - putStrLn "Diffing failed cases..." - forM_ failed diffModule + maybeDiff cfgDiffTool failed exitFailure +maybeDiff :: Maybe FilePath -> [String] -> IO () +maybeDiff Nothing _ = pure () +maybeDiff (Just diff) mdls = do + putStrLn "Diffing failed cases..." + forM_ mdls $ diffModule diff + + runHaddock :: Config -> IO () runHaddock (Config { .. }) = do putStrLn "Running Haddock process..." @@ -139,6 +147,8 @@ loadConfig flags files = do let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags) + cfgDiffTool <- (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool + return $ Config { .. } @@ -155,8 +165,8 @@ checkModule mdl = do else return NoRef -diffModule :: String -> IO () -diffModule mdl = do +diffModule :: FilePath -> String -> IO () +diffModule diff mdl = do out <- readFile $ outFile mdl ref <- readFile $ refFile mdl let out' = stripLinks . dropVersion $ out @@ -165,7 +175,7 @@ diffModule mdl = do writeFile refFile' ref' putStrLn $ "Diff for module " ++ show mdl ++ ":" - handle <- runProcess' "diff" $ processConfig + handle <- runProcess' diff $ processConfig { pcArgs = [outFile', refFile'] } waitForProcess handle >> return () @@ -215,6 +225,13 @@ baseDependencies ghcPath = do 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 @@ -241,6 +258,7 @@ data Flag | FlagGhcPath FilePath | FlagHaddockOptions String | FlagHaddockStdOut FilePath + | FlagDiffTool FilePath | FlagHelp deriving Eq @@ -255,6 +273,8 @@ options = "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 ['h'] ["help"] (NoArg FlagHelp) "display this help end exit" ] @@ -277,6 +297,10 @@ flagsHaddockStdOut :: [Flag] -> Maybe FilePath flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ] +flagsDiffTool :: [Flag] -> Maybe FilePath +flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ] + + type Environment = [(String, String)] data ProcessConfig = ProcessConfig -- cgit v1.2.3 From 503e92e8e0d452c9eef30171f76f8f425912beef Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 5 Aug 2015 17:30:10 +0200 Subject: Create stub methods for processing test output as XML documents. --- html-test/run.hs | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index ee2d0829..87d53bab 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -1,6 +1,7 @@ #!/usr/bin/env runhaskell {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} import Control.Applicative @@ -26,6 +27,8 @@ import System.FilePath import System.IO import System.Process +import qualified Text.XML.Light as Xml + baseDir, rootDir :: FilePath baseDir = takeDirectory __FILE__ @@ -157,12 +160,14 @@ checkModule mdl = do hasRef <- doesFileExist $ refFile mdl if hasRef then do - out <- readFile $ outFile mdl - ref <- readFile $ refFile mdl - return $ if haddockEq (outFile mdl, out) (refFile mdl, ref) + Just outXml <- readXml $ outFile mdl + Just refXml <- readXml $ refFile mdl + return $ if strip outXml == strip refXml then Pass else Fail else return NoRef + where + readXml = liftM Xml.parseXMLDoc . readFile diffModule :: FilePath -> String -> IO () @@ -253,6 +258,15 @@ modulePath :: String -> FilePath modulePath mdl = srcDir mdl <.> "hs" +deriving instance Eq Xml.Content +deriving instance Eq Xml.Element +deriving instance Eq Xml.CData + + +strip :: Xml.Element -> Xml.Element +strip = id -- TODO. + + data Flag = FlagHaddockPath FilePath | FlagGhcPath FilePath -- cgit v1.2.3 From b816a40ecb60ee04ab63558cd17373907e9bf4c4 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 5 Aug 2015 17:42:20 +0200 Subject: Implement link-stripping logic as simple SYB transformation. --- html-test/run.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/html-test/run.hs b/html-test/run.hs index 87d53bab..f416f07c 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -7,6 +7,8 @@ import Control.Applicative import Control.Monad +import Data.Generics.Aliases +import Data.Generics.Schemes import Data.Maybe import Data.List @@ -264,7 +266,12 @@ deriving instance Eq Xml.CData strip :: Xml.Element -> Xml.Element -strip = id -- TODO. +strip = + everywhere (mkT unlink) + where + unlink attr@(Xml.Attr { attrKey = key }) + | Xml.qName key == "href" = attr { Xml.attrVal = "" } + | otherwise = attr data Flag -- cgit v1.2.3 From 8af6bdb677b6fc91752a5276e8f7a7c17f5881e7 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 5 Aug 2015 17:58:08 +0200 Subject: Incorporate link stripping to output diffing mechanism. --- html-test/run.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index f416f07c..06f20ee6 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -168,18 +168,16 @@ checkModule mdl = do then Pass else Fail else return NoRef - where - readXml = liftM Xml.parseXMLDoc . readFile diffModule :: FilePath -> String -> IO () diffModule diff mdl = do - out <- readFile $ outFile mdl - ref <- readFile $ refFile mdl - let out' = stripLinks . dropVersion $ out - let ref' = stripLinks . dropVersion $ ref - writeFile outFile' out' - writeFile refFile' ref' + Just outXml <- readXml $ outFile mdl + Just refXml <- readXml $ refFile mdl + let outXml' = strip outXml + let refXml' = strip refXml + writeFile outFile' $ Xml.ppElement outXml' + writeFile refFile' $ Xml.ppElement refXml' putStrLn $ "Diff for module " ++ show mdl ++ ":" handle <- runProcess' diff $ processConfig @@ -265,12 +263,16 @@ deriving instance Eq Xml.Element deriving instance Eq Xml.CData +readXml :: FilePath -> IO (Maybe Xml.Element) +readXml = liftM Xml.parseXMLDoc . readFile + + strip :: Xml.Element -> Xml.Element strip = everywhere (mkT unlink) where unlink attr@(Xml.Attr { attrKey = key }) - | Xml.qName key == "href" = attr { Xml.attrVal = "" } + | Xml.qName key == "href" = attr { Xml.attrVal = "#" } | otherwise = attr -- cgit v1.2.3 From 6f86719bbda5339f0986dea5c26aa895e9d3069b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 5 Aug 2015 18:24:56 +0200 Subject: Implement footer-stripping logic. --- html-test/run.hs | 72 +++++++++++++++----------------------------------------- 1 file changed, 19 insertions(+), 53 deletions(-) diff --git a/html-test/run.hs b/html-test/run.hs index 06f20ee6..afd60a13 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -268,7 +268,11 @@ readXml = liftM Xml.parseXMLDoc . readFile strip :: Xml.Element -> Xml.Element -strip = +strip = stripFooter . stripLinks + + +stripLinks :: Xml.Element -> Xml.Element +stripLinks = everywhere (mkT unlink) where unlink attr@(Xml.Attr { attrKey = key }) @@ -276,6 +280,20 @@ strip = | otherwise = attr +stripFooter :: Xml.Element -> Xml.Element +stripFooter = + everywhere (mkT defoot) + where + defoot elem + | isFooter elem = elem { Xml.elContent = [] } + | otherwise = elem + isFooter elem = any isFooterAttr $ Xml.elAttribs elem + isFooterAttr (Xml.Attr { .. }) = and + [ Xml.qName attrKey == "id" + , attrVal == "footer" + ] + + data Flag = FlagHaddockPath FilePath | FlagGhcPath FilePath @@ -371,55 +389,3 @@ mlast = listToMaybe . reverse -- | List of modules in which we don't 'stripLinks' preserveLinksModules :: [String] preserveLinksModules = ["Bug253"] - - --- | A rather nasty way to drop the Haddock version string from the --- end of the generated HTML files so that we don't have to change --- every single test every time we change versions. We rely on the the --- last paragraph of the document to be the version. We end up with --- malformed HTML but we don't care as we never look at it ourselves. -dropVersion :: String -> String -dropVersion = reverse . dropTillP . reverse - where - dropTillP [] = [] - dropTillP ('p':'<':xs) = xs - dropTillP (_:xs) = dropTillP xs - - -haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool -haddockEq (fn1, file1) (fn2, file2) = - maybeStripLinks fn1 (dropVersion file1) - == maybeStripLinks fn2 (dropVersion file2) - - -maybeStripLinks :: FilePath -- ^ Module we're considering for stripping - -> String -> String -maybeStripLinks file - | takeBaseName file `elem` preserveLinksModules = id - | otherwise = stripLinks - - -stripLinks :: String -> String -stripLinks str = - let prefix = " case dropWhile (/= '>') (dropWhile (/= '"') str') of - [] -> [] - x:xs -> stripLinks (stripHrefEnd xs) - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs - - -stripHrefEnd :: String -> String -stripHrefEnd s = - let pref = " case dropWhile (/= '>') str' of - [] -> [] - x:xs -> xs - Nothing -> - case s of - [] -> [] - x : xs -> x : stripHrefEnd xs -- cgit v1.2.3 From 0c28e3fc12a905eac5ffbcd124aedc0fb41de271 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 5 Aug 2015 19:20:25 +0200 Subject: Add missing dependencies in Cabal configuration file. --- haddock.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock.cabal b/haddock.cabal index 71b78347..40bf59a6 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -125,9 +125,9 @@ executable haddock test-suite html-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: run.lhs + main-is: run.hs hs-source-dirs: html-test - build-depends: base, directory, process, filepath, Cabal + build-depends: base, directory, process, filepath, Cabal, xml, syb test-suite hypsrc-test type: exitcode-stdio-1.0 -- cgit v1.2.3 From 16eb78529ebd0cf438aed500edec2eef6612cbcb Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 6 Aug 2015 18:58:46 +0200 Subject: Fix issue with output being printed in incorrect order. --- html-test/run.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/html-test/run.hs b/html-test/run.hs index afd60a13..4103ad04 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -180,8 +180,10 @@ diffModule diff mdl = do writeFile refFile' $ Xml.ppElement refXml' putStrLn $ "Diff for module " ++ show mdl ++ ":" + hFlush stdout handle <- runProcess' diff $ processConfig { pcArgs = [outFile', refFile'] + , pcStdOut = Just $ stdout } waitForProcess handle >> return () where -- cgit v1.2.3 From 7196607a71a1ab1ef9e40f8eab2f27888c7290c2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 6 Aug 2015 19:13:18 +0200 Subject: Make it possible to run tests without generating diff. --- html-test/run.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/html-test/run.hs b/html-test/run.hs index 4103ad04..f57d547a 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -152,7 +152,9 @@ loadConfig flags files = do let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags) - cfgDiffTool <- (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool + cfgDiffTool <- if FlagNoDiff `elem` flags + then pure Nothing + else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool return $ Config { .. } @@ -302,6 +304,7 @@ data Flag | FlagHaddockOptions String | FlagHaddockStdOut FilePath | FlagDiffTool FilePath + | FlagNoDiff | FlagHelp deriving Eq @@ -318,6 +321,8 @@ options = "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 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. --- .gitignore | 1 + haddock-test/haddock-test.cabal | 26 ++++++ haddock-test/src/Test/Haddock/Config.hs | 70 +++++++++++++++ haddock-test/src/Test/Haddock/Process.hs | 49 +++++++++++ haddock-test/src/Test/Haddock/Utils.hs | 8 ++ haddock-test/src/Test/Haddock/Xhtml.hs | 49 +++++++++++ haddock.cabal | 2 +- html-test/run.hs | 145 +------------------------------ 8 files changed, 208 insertions(+), 142 deletions(-) create mode 100644 haddock-test/haddock-test.cabal create mode 100644 haddock-test/src/Test/Haddock/Config.hs create mode 100644 haddock-test/src/Test/Haddock/Process.hs create mode 100644 haddock-test/src/Test/Haddock/Utils.hs create mode 100644 haddock-test/src/Test/Haddock/Xhtml.hs diff --git a/.gitignore b/.gitignore index 3c9798c1..3eb2ed83 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ /dist/ /haddock-api/dist/ /haddock-library/dist/ +/haddock-test/dist/ /html-test/out/ /hypsrc-test/out/ /latex-test/out/ diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal new file mode 100644 index 00000000..bc0dde6c --- /dev/null +++ b/haddock-test/haddock-test.cabal @@ -0,0 +1,26 @@ +name: haddock-test +version: 0.0.1 +synopsis: Test utilities for Haddock +license: BSD3 +author: Simon Marlow, David Waern +maintainer: Simon Hengel , Mateusz Kowalczyk +homepage: http://www.haskell.org/haddock/ +bug-reports: https://github.com/haskell/haddock/issues +copyright: (c) Simon Marlow, David Waern +category: Documentation +build-type: Simple +cabal-version: >= 1.10 +stability: experimental + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base, directory, process, filepath, Cabal, xml, syb + + exposed-modules: + Test.Haddock.Config + Test.Haddock.Process + Test.Haddock.Xhtml + + other-modules: + Test.Haddock.Utils 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" + ] diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs new file mode 100644 index 00000000..97f3ebed --- /dev/null +++ b/haddock-test/src/Test/Haddock/Process.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock.Process where + + +import Control.Monad + +import System.Exit +import System.FilePath +import System.IO +import System.Process + + +type Environment = [(String, String)] + + +data ProcessConfig = ProcessConfig + { pcArgs :: [String] + , pcWorkDir :: Maybe FilePath + , pcEnv :: Maybe Environment + , pcStdIn :: Maybe Handle + , pcStdOut :: Maybe Handle + , pcStdErr :: Maybe Handle + } + + +processConfig :: ProcessConfig +processConfig = ProcessConfig + { pcArgs = [] + , pcWorkDir = Nothing + , pcEnv = Nothing + , pcStdIn = Nothing + , pcStdOut = Nothing + , pcStdErr = Nothing + } + + +runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle +runProcess' path (ProcessConfig { .. }) = runProcess + path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr + + +waitForSuccess :: String -> ProcessHandle -> IO () +waitForSuccess msg handle = do + result <- waitForProcess handle + unless (result == ExitSuccess) $ do + hPutStrLn stderr $ msg + exitFailure diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs new file mode 100644 index 00000000..1d57107f --- /dev/null +++ b/haddock-test/src/Test/Haddock/Utils.hs @@ -0,0 +1,8 @@ +module Test.Haddock.Utils where + + +import Data.Maybe + + +mlast :: [a] -> Maybe a +mlast = listToMaybe . reverse diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs new file mode 100644 index 00000000..35f5910a --- /dev/null +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + + +module Test.Haddock.Xhtml where + + +import Control.Monad + +import Data.Generics.Aliases +import Data.Generics.Schemes + +import Text.XML.Light + + +deriving instance Eq Content +deriving instance Eq Element +deriving instance Eq CData + + +readXml :: FilePath -> IO (Maybe Element) +readXml = liftM parseXMLDoc . readFile + + +strip :: Element -> Element +strip = stripFooter . stripLinks + + +stripLinks :: Element -> Element +stripLinks = + everywhere (mkT unlink) + where + unlink attr@(Attr { attrKey = key }) + | qName key == "href" = attr { attrVal = "#" } + | otherwise = attr + + +stripFooter :: Element -> Element +stripFooter = + everywhere (mkT defoot) + where + defoot elem + | isFooter elem = elem { elContent = [] } + | otherwise = elem + isFooter elem = any isFooterAttr $ elAttribs elem + isFooterAttr (Attr { .. }) = and + [ qName attrKey == "id" + , attrVal == "footer" + ] diff --git a/haddock.cabal b/haddock.cabal index 40bf59a6..c0e812a1 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -127,7 +127,7 @@ test-suite html-test default-language: Haskell2010 main-is: run.hs hs-source-dirs: html-test - build-depends: base, directory, process, filepath, Cabal, xml, syb + build-depends: base, directory, process, filepath, Cabal, xml, syb, haddock-test test-suite hypsrc-test type: exitcode-stdio-1.0 diff --git a/html-test/run.hs b/html-test/run.hs index f57d547a..e96943a0 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -1,4 +1,3 @@ -#!/usr/bin/env runhaskell {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -7,8 +6,6 @@ import Control.Applicative import Control.Monad -import Data.Generics.Aliases -import Data.Generics.Schemes import Data.Maybe import Data.List @@ -31,6 +28,10 @@ import System.Process import qualified Text.XML.Light as Xml +import Test.Haddock.Process +import Test.Haddock.Config +import Test.Haddock.Xhtml + baseDir, rootDir :: FilePath baseDir = takeDirectory __FILE__ @@ -45,17 +46,6 @@ resDir :: FilePath resDir = rootDir "resources" -data Config = Config - { cfgHaddockPath :: FilePath - , cfgGhcPath :: FilePath - , cfgFiles :: [FilePath] - , cfgHaddockArgs :: [String] - , cfgHaddockStdOut :: FilePath - , cfgDiffTool :: Maybe FilePath - , cfgEnv :: Environment - } - - data CheckResult = Fail | Pass @@ -262,133 +252,6 @@ modulePath :: String -> FilePath modulePath mdl = srcDir mdl <.> "hs" -deriving instance Eq Xml.Content -deriving instance Eq Xml.Element -deriving instance Eq Xml.CData - - -readXml :: FilePath -> IO (Maybe Xml.Element) -readXml = liftM Xml.parseXMLDoc . readFile - - -strip :: Xml.Element -> Xml.Element -strip = stripFooter . stripLinks - - -stripLinks :: Xml.Element -> Xml.Element -stripLinks = - everywhere (mkT unlink) - where - unlink attr@(Xml.Attr { attrKey = key }) - | Xml.qName key == "href" = attr { Xml.attrVal = "#" } - | otherwise = attr - - -stripFooter :: Xml.Element -> Xml.Element -stripFooter = - everywhere (mkT defoot) - where - defoot elem - | isFooter elem = elem { Xml.elContent = [] } - | otherwise = elem - isFooter elem = any isFooterAttr $ Xml.elAttribs elem - isFooterAttr (Xml.Attr { .. }) = and - [ Xml.qName attrKey == "id" - , attrVal == "footer" - ] - - -data Flag - = FlagHaddockPath FilePath - | FlagGhcPath FilePath - | FlagHaddockOptions String - | FlagHaddockStdOut FilePath - | FlagDiffTool FilePath - | FlagNoDiff - | FlagHelp - deriving Eq - - -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" - ] - - -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 ] - - -type Environment = [(String, String)] - -data ProcessConfig = ProcessConfig - { pcArgs :: [String] - , pcWorkDir :: Maybe FilePath - , pcEnv :: Maybe Environment - , pcStdIn :: Maybe Handle - , pcStdOut :: Maybe Handle - , pcStdErr :: Maybe Handle - } - - -processConfig :: ProcessConfig -processConfig = ProcessConfig - { pcArgs = [] - , pcWorkDir = Nothing - , pcEnv = Nothing - , pcStdIn = Nothing - , pcStdOut = Nothing - , pcStdErr = Nothing - } - - -runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle -runProcess' path (ProcessConfig { .. }) = runProcess - path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr - - -waitForSuccess :: String -> ProcessHandle -> IO () -waitForSuccess msg handle = do - result <- waitForProcess handle - unless (result == ExitSuccess) $ do - hPutStrLn stderr $ msg - exitFailure - - -mlast :: [a] -> Maybe a -mlast = listToMaybe . reverse - - -- *** OLD TEST RUNNER UTILITY FUNCTIONS *** -- These are considered bad and should be replaced as soon as possible. -- 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(+) 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(-) 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 fa04b4138311db1026755e3d75fdd4abaa81c427 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 14:34:05 +0200 Subject: Enable all compiler warnings in Haddock test package configuration. --- haddock-test/haddock-test.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index bc0dde6c..aabe12e9 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -14,6 +14,7 @@ stability: experimental library default-language: Haskell2010 + ghc-options: -Wall hs-source-dirs: src build-depends: base, directory, process, filepath, Cabal, xml, syb -- cgit v1.2.3 From 54fb845b2b322d823fb44f905bd4c4d40225259c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 16:03:19 +0200 Subject: Move Haddock runner of HTML test suite to Haddock test package. --- haddock-test/haddock-test.cabal | 1 + haddock-test/src/Test/Haddock.hs | 117 ++++++++++++++++++++++++++++++++++++++ html-test/run.hs | 120 +-------------------------------------- 3 files changed, 120 insertions(+), 118 deletions(-) create mode 100644 haddock-test/src/Test/Haddock.hs diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index aabe12e9..4cf10799 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -19,6 +19,7 @@ library build-depends: base, directory, process, filepath, Cabal, xml, syb exposed-modules: + Test.Haddock Test.Haddock.Config Test.Haddock.Process Test.Haddock.Xhtml diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs new file mode 100644 index 00000000..6ca57d7b --- /dev/null +++ b/haddock-test/src/Test/Haddock.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock + ( module Test.Haddock + , module Test.Haddock.Config + ) where + + +import Control.Monad + +import Data.Maybe + +import System.Directory +import System.Exit +import System.FilePath +import System.IO +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 + + +checkFiles :: Config -> 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 + case status of + Fail -> putStrLn "FAIL" >> (return $ Just mdl) + Pass -> putStrLn "PASS" >> (return Nothing) + NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing) + + if null failed + then do + putStrLn "All tests passed!" + exitSuccess + else do + maybeDiff cfg failed + exitFailure + + +maybeDiff :: Config -> [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 { .. }) = 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 -> 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 + else return NoRef + where + dcfg = cfgDirConfig cfg + + +diffModule :: Config -> 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' + + putStrLn $ "Diff for module " ++ show mdl ++ ":" + hFlush stdout + handle <- runProcess' diff $ processConfig + { pcArgs = [outFile', refFile'] + , pcStdOut = Just $ stdout + } + waitForProcess handle >> return () + where + dcfg = cfgDirConfig cfg + outFile' = outFile dcfg mdl <.> "nolinks" + refFile' = outFile dcfg mdl <.> "ref" <.> "nolinks" + + +outFile :: DirConfig -> String -> FilePath +outFile dcfg mdl = dcfgOutDir dcfg mdl <.> "html" + + +refFile :: DirConfig -> String -> FilePath +refFile dcfg mdl = dcfgRefDir dcfg mdl <.> "html" diff --git a/html-test/run.hs b/html-test/run.hs index 5a2944f9..48c733d0 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -1,46 +1,14 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -import Control.Applicative -import Control.Monad - -import Data.Maybe -import Data.List - -import System.Console.GetOpt -import System.Directory import System.Environment -import System.Exit import System.FilePath -import System.IO -import System.Process -import qualified Text.XML.Light as Xml +import Test.Haddock -import Test.Haddock.Process -import Test.Haddock.Config -import Test.Haddock.Xhtml - -baseDir, rootDir :: FilePath +baseDir :: FilePath baseDir = takeDirectory __FILE__ -rootDir = baseDir ".." - -srcDir, refDir, outDir :: FilePath -srcDir = baseDir "src" -refDir = baseDir "ref" -outDir = baseDir "out" - -resDir :: FilePath -resDir = rootDir "resources" - - -data CheckResult - = Fail - | Pass - | NoRef main :: IO () @@ -51,90 +19,6 @@ main = do checkFiles cfg -checkFiles :: Config -> IO () -checkFiles (Config { .. }) = do - putStrLn "Testing output files..." - failed <- liftM catMaybes . forM cfgFiles $ \file -> do - let mdl = takeBaseName file - putStr $ "Checking " ++ mdl ++ "... " - - status <- checkModule mdl - case status of - Fail -> putStrLn "FAIL" >> (return $ Just mdl) - Pass -> putStrLn "PASS" >> (return Nothing) - NoRef -> putStrLn "PASS [no .ref]" >> (return Nothing) - - if null failed - then do - putStrLn "All tests passed!" - exitSuccess - else do - maybeDiff cfgDiffTool failed - exitFailure - - -maybeDiff :: Maybe FilePath -> [String] -> IO () -maybeDiff Nothing _ = pure () -maybeDiff (Just diff) mdls = do - putStrLn "Diffing failed cases..." - forM_ mdls $ diffModule diff - - -runHaddock :: Config -> 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 :: String -> IO CheckResult -checkModule mdl = do - hasRef <- doesFileExist $ refFile mdl - if hasRef - then do - Just outXml <- readXml $ outFile mdl - Just refXml <- readXml $ refFile mdl - return $ if strip outXml == strip refXml - then Pass - else Fail - else return NoRef - - -diffModule :: FilePath -> String -> IO () -diffModule diff mdl = do - Just outXml <- readXml $ outFile mdl - Just refXml <- readXml $ refFile mdl - let outXml' = strip outXml - let refXml' = strip refXml - writeFile outFile' $ Xml.ppElement outXml' - writeFile refFile' $ Xml.ppElement refXml' - - putStrLn $ "Diff for module " ++ show mdl ++ ":" - hFlush stdout - handle <- runProcess' diff $ processConfig - { pcArgs = [outFile', refFile'] - , pcStdOut = Just $ stdout - } - waitForProcess handle >> return () - where - outFile' = outFile mdl <.> "nolinks" - refFile' = outFile mdl <.> "ref" <.> "nolinks" - - -outFile :: String -> FilePath -outFile mdl = outDir mdl <.> "html" - - -refFile :: String -> FilePath -refFile mdl = refDir mdl <.> "html" - - -- *** 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(-) 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(-) 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(-) 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(-) 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 869ee23cc7ec1bd2fa9299323b74d71fe6023ef2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 13 Aug 2015 21:21:02 +0200 Subject: Change extension of test files used for diffing. --- haddock-test/src/Test/Haddock.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index a6b9ea8a..78204840 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -110,8 +110,8 @@ diffModule cfg diff mdl = do where dcfg = cfgDirConfig cfg ccfg = cfgCheckConfig cfg - outFile' = outFile dcfg mdl <.> "nolinks" - refFile' = outFile dcfg mdl <.> "ref" <.> "nolinks" + outFile' = outFile dcfg mdl <.> "dump" + refFile' = outFile dcfg mdl <.> "ref" <.> "dump" outFile :: DirConfig -> String -> FilePath -- cgit v1.2.3 From 5934c411a8ebe0ba1a317f7c95babfbd63106254 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 14 Aug 2015 00:34:10 +0200 Subject: Refactor and simplify XHTML helper module of test package. --- haddock-test/src/Test/Haddock/Xhtml.hs | 40 ++++++++++++++++++++-------------- html-test/run.hs | 17 +++++++++------ 2 files changed, 34 insertions(+), 23 deletions(-) diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index 35f5910a..b6941496 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -2,47 +2,55 @@ {-# LANGUAGE StandaloneDeriving #-} -module Test.Haddock.Xhtml where +module Test.Haddock.Xhtml + ( Xhtml(..) + , parseXhtml, dumpXhtml + , stripLinks, stripFooter + ) where -import Control.Monad - import Data.Generics.Aliases import Data.Generics.Schemes import Text.XML.Light -deriving instance Eq Content +newtype Xhtml = Xhtml + { xhtmlElement :: Element + } deriving Eq + + +-- TODO: Find a way to avoid warning about orphan instances. deriving instance Eq Element +deriving instance Eq Content deriving instance Eq CData -readXml :: FilePath -> IO (Maybe Element) -readXml = liftM parseXMLDoc . readFile +parseXhtml :: String -> Maybe Xhtml +parseXhtml = fmap Xhtml . parseXMLDoc -strip :: Element -> Element -strip = stripFooter . stripLinks +dumpXhtml :: Xhtml -> String +dumpXhtml = ppElement . xhtmlElement -stripLinks :: Element -> Element +stripLinks :: Xhtml -> Xhtml stripLinks = - everywhere (mkT unlink) + Xhtml . everywhere (mkT unlink) . xhtmlElement where unlink attr@(Attr { attrKey = key }) | qName key == "href" = attr { attrVal = "#" } | otherwise = attr -stripFooter :: Element -> Element +stripFooter :: Xhtml -> Xhtml stripFooter = - everywhere (mkT defoot) + Xhtml . everywhere (mkT defoot) . xhtmlElement where - defoot elem - | isFooter elem = elem { elContent = [] } - | otherwise = elem - isFooter elem = any isFooterAttr $ elAttribs elem + defoot el + | isFooter el = el { elContent = [] } + | otherwise = el + isFooter el = any isFooterAttr $ elAttribs el isFooterAttr (Attr { .. }) = and [ qName attrKey == "id" , attrVal == "footer" diff --git a/html-test/run.hs b/html-test/run.hs index 2758bf56..ab007f57 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -7,13 +7,11 @@ import System.FilePath import Test.Haddock import Test.Haddock.Xhtml -import qualified Text.XML.Light as Xml - -checkConfig :: CheckConfig Xml.Element +checkConfig :: CheckConfig Xhtml checkConfig = CheckConfig - { ccfgRead = \_ input -> strip <$> Xml.parseXMLDoc input - , ccfgDump = Xml.ppElement + { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input + , ccfgDump = dumpXhtml , ccfgEqual = (==) } @@ -26,8 +24,13 @@ main :: IO () main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs --- *** OLD TEST RUNNER UTILITY FUNCTIONS *** --- These are considered bad and should be replaced as soon as possible. +stripIfRequired :: String -> Xhtml -> Xhtml +stripIfRequired mdl = + stripLinks' . stripFooter + where + stripLinks' + | mdl `elem` preserveLinksModules = id + | otherwise = stripFooter -- | List of modules in which we don't 'stripLinks' -- cgit v1.2.3 From 20867f75e92931e2131a1badfa6b9606b970eb12 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 14 Aug 2015 19:16:12 +0200 Subject: Fix typo in link stripper of HTML test suite runner. --- html-test/run.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/html-test/run.hs b/html-test/run.hs index ab007f57..8d1b40a8 100755 --- a/html-test/run.hs +++ b/html-test/run.hs @@ -30,7 +30,7 @@ stripIfRequired mdl = where stripLinks' | mdl `elem` preserveLinksModules = id - | otherwise = stripFooter + | otherwise = stripLinks -- | List of modules in which we don't 'stripLinks' -- cgit v1.2.3 From 554db03b637a76a01f2907d3115ef0dc290234c5 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 14 Aug 2015 20:05:37 +0200 Subject: Create convenience script for running specific HTML tests. --- haddock.cabal | 4 ++-- html-test/Main.hs | 38 ++++++++++++++++++++++++++++++++++++++ html-test/run | 5 +++++ html-test/run.hs | 38 -------------------------------------- 4 files changed, 45 insertions(+), 40 deletions(-) create mode 100755 html-test/Main.hs create mode 100755 html-test/run delete mode 100755 html-test/run.hs diff --git a/haddock.cabal b/haddock.cabal index c0e812a1..019f235e 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -125,9 +125,9 @@ executable haddock test-suite html-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: run.hs + main-is: Main.hs hs-source-dirs: html-test - build-depends: base, directory, process, filepath, Cabal, xml, syb, haddock-test + build-depends: base, filepath, haddock-test test-suite hypsrc-test type: exitcode-stdio-1.0 diff --git a/html-test/Main.hs b/html-test/Main.hs new file mode 100755 index 00000000..8d1b40a8 --- /dev/null +++ b/html-test/Main.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} + + +import System.Environment +import System.FilePath + +import Test.Haddock +import Test.Haddock.Xhtml + + +checkConfig :: CheckConfig Xhtml +checkConfig = CheckConfig + { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input + , ccfgDump = dumpXhtml + , ccfgEqual = (==) + } + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ + + +main :: IO () +main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs + + +stripIfRequired :: String -> Xhtml -> Xhtml +stripIfRequired mdl = + stripLinks' . stripFooter + where + stripLinks' + | mdl `elem` preserveLinksModules = id + | otherwise = stripLinks + + +-- | List of modules in which we don't 'stripLinks' +preserveLinksModules :: [String] +preserveLinksModules = ["Bug253"] diff --git a/html-test/run b/html-test/run new file mode 100755 index 00000000..5e17ad0f --- /dev/null +++ b/html-test/run @@ -0,0 +1,5 @@ +#!/bin/bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +runhaskell -i:"$LIB_PATH" "Main.hs" $@ diff --git a/html-test/run.hs b/html-test/run.hs deleted file mode 100755 index 8d1b40a8..00000000 --- a/html-test/run.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE CPP #-} - - -import System.Environment -import System.FilePath - -import Test.Haddock -import Test.Haddock.Xhtml - - -checkConfig :: CheckConfig Xhtml -checkConfig = CheckConfig - { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input - , ccfgDump = dumpXhtml - , ccfgEqual = (==) - } - - -dirConfig :: DirConfig -dirConfig = defaultDirConfig $ takeDirectory __FILE__ - - -main :: IO () -main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs - - -stripIfRequired :: String -> Xhtml -> Xhtml -stripIfRequired mdl = - stripLinks' . stripFooter - where - stripLinks' - | mdl `elem` preserveLinksModules = id - | otherwise = stripLinks - - --- | List of modules in which we don't 'stripLinks' -preserveLinksModules :: [String] -preserveLinksModules = ["Bug253"] -- cgit v1.2.3 From 1cb714e35337a6b17d7fc37f086914f43f7f2da3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 14 Aug 2015 20:41:41 +0200 Subject: Implement utility functions for conditional link stripping. --- haddock-test/src/Test/Haddock/Xhtml.hs | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index b6941496..d8c26249 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -5,7 +5,7 @@ module Test.Haddock.Xhtml ( Xhtml(..) , parseXhtml, dumpXhtml - , stripLinks, stripFooter + , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter ) where @@ -35,14 +35,31 @@ dumpXhtml = ppElement . xhtmlElement stripLinks :: Xhtml -> Xhtml -stripLinks = - Xhtml . everywhere (mkT unlink) . xhtmlElement +stripLinks = stripLinksWhen (const True) + + +stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripLinksWhen p = + processAnchors unlink + where + unlink attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "href" && p val = attr { attrVal = "#" } + | otherwise = attr + + +stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripAnchorsWhen p = + processAnchors unname where - unlink attr@(Attr { attrKey = key }) - | qName key == "href" = attr { attrVal = "#" } + unname attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "name" && p val = attr { attrVal = "" } | otherwise = attr +processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml +processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement + + stripFooter :: Xhtml -> Xhtml stripFooter = Xhtml . everywhere (mkT defoot) . xhtmlElement -- cgit v1.2.3 From c2d2c481da18310053396bb0d2a9d070335eb865 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 14 Aug 2015 20:53:34 +0200 Subject: Adapt `hypsrc-test` module to work with new testing framework. --- haddock.cabal | 4 ++-- hypsrc-test/Main.hs | 30 ++++++++++++++++++++++++++++++ 2 files changed, 32 insertions(+), 2 deletions(-) create mode 100644 hypsrc-test/Main.hs diff --git a/haddock.cabal b/haddock.cabal index 019f235e..fde2ad4e 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -132,9 +132,9 @@ test-suite html-test test-suite hypsrc-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: run.hs + main-is: Main.hs hs-source-dirs: hypsrc-test - build-depends: base, directory, process, filepath, Cabal + build-depends: base, filepath, haddock-test ghc-options: -Wall -fwarn-tabs test-suite latex-test diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs new file mode 100644 index 00000000..b1b48ca4 --- /dev/null +++ b/hypsrc-test/Main.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} + + +import Data.List + +import System.Environment +import System.FilePath + +import Test.Haddock +import Test.Haddock.Xhtml + + +checkConfig :: CheckConfig Xhtml +checkConfig = CheckConfig + { ccfgRead = \_ input -> strip <$> parseXhtml input + , ccfgDump = dumpXhtml + , ccfgEqual = (==) + } + where + strip = stripAnchors' . stripLinks' . stripFooter + stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href + stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ + + +main :: IO () +main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs -- 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(-) 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 163da5a4b6268de54594e18f69f06799df637305 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 18:06:59 +0200 Subject: Create utility function for recursive obtaining directory contents. --- haddock-test/src/Test/Haddock/Utils.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs index 1d57107f..4640fe97 100644 --- a/haddock-test/src/Test/Haddock/Utils.hs +++ b/haddock-test/src/Test/Haddock/Utils.hs @@ -1,8 +1,33 @@ module Test.Haddock.Utils where +import Control.Monad + import Data.Maybe +import System.Directory +import System.FilePath + mlast :: [a] -> Maybe a mlast = listToMaybe . reverse + + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM p (x:xs) = do + (ss, fs) <- partitionM p xs + b <- p x + pure $ if b then (x:ss, fs) else (ss, x:fs) + + +getDirectoryTree :: FilePath -> IO [FilePath] +getDirectoryTree path = do + (dirs, files) <- partitionM isDirectory =<< contents + subfiles <- fmap concat . forM dirs $ \dir -> + map (dir ) <$> getDirectoryTree (path dir) + pure $ files ++ subfiles + where + contents = filter realEntry <$> getDirectoryContents path + isDirectory entry = doesDirectoryExist $ path entry + realEntry entry = not $ entry == "." || entry == ".." -- 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(-) 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(-) 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(-) 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 8efa6cbc72bbdad8dceb06896f8c1e7a90ab6c6a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 21:07:06 +0200 Subject: Adapt HTML test runner to use new ignoring functionality. --- html-test/Main.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/html-test/Main.hs b/html-test/Main.hs index 8d1b40a8..49e769f5 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} +import Data.Char + import System.Environment import System.FilePath @@ -17,7 +19,9 @@ checkConfig = CheckConfig dirConfig :: DirConfig -dirConfig = defaultDirConfig $ takeDirectory __FILE__ +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = checkIgnore + } main :: IO () @@ -36,3 +40,8 @@ stripIfRequired mdl = -- | List of modules in which we don't 'stripLinks' preserveLinksModules :: [String] preserveLinksModules = ["Bug253"] + + +checkIgnore :: FilePath -> Bool +checkIgnore file@(c:_) | takeExtension file == ".html" && isUpper c = False +checkIgnore _ = True -- cgit v1.2.3 From eff66b0bbf6f7ccc8f24ab21131be59b137fea47 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 21:55:15 +0200 Subject: Fix bug with not all test output files being checked. --- haddock-test/src/Test/Haddock.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index 581b0d10..ab6ce775 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -19,6 +19,7 @@ import System.Process import Test.Haddock.Config import Test.Haddock.Process +import Test.Haddock.Utils data CheckResult @@ -38,7 +39,7 @@ checkFiles :: Config c -> IO () checkFiles cfg@(Config { .. }) = do putStrLn "Testing output files..." - files <- ignore <$> getDirectoryContents (cfgOutDir cfg) + files <- ignore <$> getDirectoryTree (cfgOutDir cfg) failed <- liftM catMaybes . forM files $ \file -> do putStr $ "Checking \"" ++ file ++ "\"... " -- cgit v1.2.3 From 9ff514d4da431955db26cf4e64b68a8e219161b9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 21:57:54 +0200 Subject: Specify ignored files for hyperlinker source test runner. --- hypsrc-test/Main.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index b1b48ca4..7fa4a705 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} +import Data.Char import Data.List import System.Environment @@ -23,8 +24,20 @@ checkConfig = CheckConfig dirConfig :: DirConfig -dirConfig = defaultDirConfig $ takeDirectory __FILE__ +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = checkIgnore + } main :: IO () main = runAndCheck =<< parseArgs checkConfig dirConfig =<< getArgs + + +checkIgnore :: FilePath -> Bool +checkIgnore file + | and . map ($ file) $ [isHtmlFile, isSourceFile, isModuleFile] = False + where + isHtmlFile = (== ".html") . takeExtension + isSourceFile = (== "src") . takeDirectory + isModuleFile = isUpper . head . takeBaseName +checkIgnore _ = True -- cgit v1.2.3 From f7337b12cc3c198a3827c31cbc2854501f360595 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 21:58:37 +0200 Subject: Copy test runner script for hyperlinked source case. --- hypsrc-test/run | 5 +++++ 1 file changed, 5 insertions(+) create mode 100755 hypsrc-test/run diff --git a/hypsrc-test/run b/hypsrc-test/run new file mode 100755 index 00000000..5e17ad0f --- /dev/null +++ b/hypsrc-test/run @@ -0,0 +1,5 @@ +#!/bin/bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +runhaskell -i:"$LIB_PATH" "Main.hs" $@ -- 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(-) 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(-) 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(-) 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 8e05e0b78eabbaf59c7d2c90d1f839fd58c5fe09 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 23:19:39 +0200 Subject: Create test runner entry points for LaTeX test suite. --- latex-test/Main.hs | 27 +++++++++++++++++++++++++++ latex-test/run | 5 +++++ 2 files changed, 32 insertions(+) create mode 100755 latex-test/Main.hs create mode 100755 latex-test/run diff --git a/latex-test/Main.hs b/latex-test/Main.hs new file mode 100755 index 00000000..2ee01a26 --- /dev/null +++ b/latex-test/Main.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + + +import System.Environment +import System.FilePath + +import Test.Haddock + + +checkConfig :: CheckConfig String +checkConfig = CheckConfig + { ccfgRead = \_ input -> Just input + , ccfgDump = id + , ccfgEqual = (==) + } + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ + + +main :: IO () +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--latex"] + } diff --git a/latex-test/run b/latex-test/run new file mode 100755 index 00000000..5e17ad0f --- /dev/null +++ b/latex-test/run @@ -0,0 +1,5 @@ +#!/bin/bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +runhaskell -i:"$LIB_PATH" "Main.hs" $@ -- cgit v1.2.3 From 863d33c4d125e13f87193802f6d4faed38da24db Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 18 Aug 2015 23:42:25 +0200 Subject: Fix bug with unnecessary checking old test output. --- haddock-test/src/Test/Haddock.hs | 4 +++- haddock-test/src/Test/Haddock/Utils.hs | 10 ++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index ab6ce775..18ae38ca 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -69,9 +69,11 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do runHaddock :: Config c -> IO () -runHaddock (Config { .. }) = do +runHaddock cfg@(Config { .. }) = do haddockStdOut <- openFile cfgHaddockStdOut WriteMode + createEmptyDirectory $ cfgOutDir cfg + putStrLn "Generating documentation..." forM_ cfgPackages $ \tpkg -> do handle <- runProcess' cfgHaddockPath $ processConfig diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs index 4640fe97..4f97fa72 100644 --- a/haddock-test/src/Test/Haddock/Utils.hs +++ b/haddock-test/src/Test/Haddock/Utils.hs @@ -21,6 +21,10 @@ partitionM p (x:xs) = do pure $ if b then (x:ss, fs) else (ss, x:fs) +whenM :: Monad m => m Bool -> m () -> m () +whenM mb action = mb >>= \b -> when b action + + getDirectoryTree :: FilePath -> IO [FilePath] getDirectoryTree path = do (dirs, files) <- partitionM isDirectory =<< contents @@ -31,3 +35,9 @@ getDirectoryTree path = do contents = filter realEntry <$> getDirectoryContents path isDirectory entry = doesDirectoryExist $ path entry realEntry entry = not $ entry == "." || entry == ".." + + +createEmptyDirectory :: FilePath -> IO () +createEmptyDirectory path = do + whenM (doesDirectoryExist path) $ removeDirectoryRecursive path + createDirectory path -- cgit v1.2.3 From cf22686d11bf9923926f3380793e64d2ff4141fc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 19 Aug 2015 13:04:54 +0200 Subject: Re-implement test acceptance functionality. --- haddock-test/src/Test/Haddock.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index 18ae38ca..41e15978 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -27,6 +27,8 @@ data CheckResult | Pass | NoRef | Error String + | Accepted + deriving Eq runAndCheck :: Config c -> IO () @@ -43,12 +45,13 @@ checkFiles cfg@(Config { .. }) = do failed <- liftM catMaybes . forM files $ \file -> do putStr $ "Checking \"" ++ file ++ "\"... " - status <- checkFile cfg file + status <- maybeAcceptFile cfg file =<< checkFile cfg file case status of 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 + Accepted -> putStrLn "ACCEPTED" >> return Nothing if null failed then do @@ -127,6 +130,14 @@ diffFile cfg diff file = do refFile' = outFile dcfg file <.> "ref" <.> "dump" +maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult +maybeAcceptFile cfg@(Config { cfgDirConfig = dcfg }) file result + | cfgAccept cfg && result `elem` [NoRef, Fail] = do + copyFile (outFile dcfg file) (refFile dcfg file) + pure Accepted +maybeAcceptFile _ _ result = pure result + + outDir :: DirConfig -> TestPackage -> FilePath outDir dcfg tpkg = dcfgOutDir dcfg tpkgName tpkg -- 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(-) 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 5bc022f12e3f35c609a047ca96fe4e8117763b0b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 19 Aug 2015 13:51:36 +0200 Subject: Adapt Cabal configuration to execute LaTeX suite with new runner. --- haddock.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock.cabal b/haddock.cabal index fde2ad4e..ea214869 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -140,9 +140,9 @@ test-suite hypsrc-test test-suite latex-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: run.lhs + main-is: Main.hs hs-source-dirs: latex-test - build-depends: base, directory, process, filepath, Cabal + build-depends: base, filepath, haddock-test source-repository head type: git -- cgit v1.2.3 From acf526f68d0ecb3ddf4ddd6efcee7774cd8ffa54 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 19 Aug 2015 14:43:39 +0200 Subject: Setup test suite for Hoogle backend. --- haddock.cabal | 7 +++++++ hoogle-test/Main.hs | 27 +++++++++++++++++++++++++++ hoogle-test/run | 5 +++++ 3 files changed, 39 insertions(+) create mode 100644 hoogle-test/Main.hs create mode 100755 hoogle-test/run diff --git a/haddock.cabal b/haddock.cabal index ea214869..aba0c394 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -144,6 +144,13 @@ test-suite latex-test hs-source-dirs: latex-test build-depends: base, filepath, haddock-test +test-suite hoogle-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: hoogle-test + build-depends: base, filepath, haddock-test + source-repository head type: git location: https://github.com/haskell/haddock.git diff --git a/hoogle-test/Main.hs b/hoogle-test/Main.hs new file mode 100644 index 00000000..9da20c36 --- /dev/null +++ b/hoogle-test/Main.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + + +import System.Environment +import System.FilePath + +import Test.Haddock + + +checkConfig :: CheckConfig String +checkConfig = CheckConfig + { ccfgRead = \_ input -> Just input + , ccfgDump = id + , ccfgEqual = (==) + } + + +dirConfig :: DirConfig +dirConfig = defaultDirConfig $ takeDirectory __FILE__ + + +main :: IO () +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--hoogle"] + } diff --git a/hoogle-test/run b/hoogle-test/run new file mode 100755 index 00000000..5e17ad0f --- /dev/null +++ b/hoogle-test/run @@ -0,0 +1,5 @@ +#!/bin/bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +runhaskell -i:"$LIB_PATH" "Main.hs" $@ -- cgit v1.2.3 From ac67d1f057ce0aafcca3f72a965444d10010d5a3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 19 Aug 2015 16:11:27 +0200 Subject: Make Hoogle backend create output directory if needed. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f6ad9808..945488d0 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -30,6 +30,8 @@ import Data.Char import Data.List import Data.Maybe import Data.Version + +import System.Directory import System.FilePath import System.IO @@ -48,6 +50,7 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] + createDirectoryIfMissing True odir h <- openFile (odir filename) WriteMode hSetEncoding h utf8 hPutStr h (unlines contents) -- cgit v1.2.3 From 109ebe47a7141b477844ba52291785969f01514c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 19 Aug 2015 16:13:55 +0200 Subject: Add appropriate .gitignore entry and configure Hoogle test suite. --- .gitignore | 1 + hoogle-test/Main.hs | 6 +++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 3eb2ed83..2bbb0885 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ /html-test/out/ /hypsrc-test/out/ /latex-test/out/ +/hoogle-test/out/ /doc/haddock /doc/haddock.ps diff --git a/hoogle-test/Main.hs b/hoogle-test/Main.hs index 9da20c36..c8cda640 100644 --- a/hoogle-test/Main.hs +++ b/hoogle-test/Main.hs @@ -23,5 +23,9 @@ main :: IO () main = do cfg <- parseArgs checkConfig dirConfig =<< getArgs runAndCheck $ cfg - { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--hoogle"] + { cfgHaddockArgs = cfgHaddockArgs cfg ++ + [ "--package-name=test" + , "--package-version=0.0.0" + , "--hoogle" + ] } -- cgit v1.2.3 From 7d0317a9210ddbb4f00976318910018fa9abea99 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 19 Aug 2015 16:37:43 +0200 Subject: Fix bug with test runner failing when run on multiple test packages. --- haddock-test/src/Test/Haddock.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index 41e15978..87c16739 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -73,12 +73,11 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do runHaddock :: Config c -> IO () runHaddock cfg@(Config { .. }) = do - haddockStdOut <- openFile cfgHaddockStdOut WriteMode - createEmptyDirectory $ cfgOutDir cfg putStrLn "Generating documentation..." forM_ cfgPackages $ \tpkg -> do + haddockStdOut <- openFile cfgHaddockStdOut WriteMode handle <- runProcess' cfgHaddockPath $ processConfig { pcArgs = concat [ cfgHaddockArgs -- cgit v1.2.3 From 3378ef409170ae1f319c934876d2b9e1a14bb9a8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 19 Aug 2015 17:07:25 +0200 Subject: Create simple test cases for Hoogle backend. --- hoogle-test/src/assoc-types/AssocTypes.hs | 23 +++++++++++++++++++++++ hoogle-test/src/classes/Classes.hs | 16 ++++++++++++++++ hoogle-test/src/fixity/Fixity.hs | 12 ++++++++++++ hoogle-test/src/modules/Bar.hs | 12 ++++++++++++ hoogle-test/src/modules/Foo.hs | 9 +++++++++ 5 files changed, 72 insertions(+) create mode 100644 hoogle-test/src/assoc-types/AssocTypes.hs create mode 100644 hoogle-test/src/classes/Classes.hs create mode 100644 hoogle-test/src/fixity/Fixity.hs create mode 100644 hoogle-test/src/modules/Bar.hs create mode 100644 hoogle-test/src/modules/Foo.hs diff --git a/hoogle-test/src/assoc-types/AssocTypes.hs b/hoogle-test/src/assoc-types/AssocTypes.hs new file mode 100644 index 00000000..a9bdc6d8 --- /dev/null +++ b/hoogle-test/src/assoc-types/AssocTypes.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeFamilies #-} + + +module AssocTypes where + + +class Foo a where + + type Bar a b + type Baz a + + type Baz a = [(a, a)] + + bar :: Bar a a + bar = undefined + + +instance Foo [a] where + + type Bar [a] Int = [(a, Bool)] + type Bar [a] Bool = [(Int, a)] + + type Baz [a] = (a, a, a) diff --git a/hoogle-test/src/classes/Classes.hs b/hoogle-test/src/classes/Classes.hs new file mode 100644 index 00000000..23f68499 --- /dev/null +++ b/hoogle-test/src/classes/Classes.hs @@ -0,0 +1,16 @@ +module Classes where + + +class Foo f where + + bar :: f a -> f b -> f (a, b) + baz :: f () + + baz = undefined + + +class Quux q where + + (+++), (///) :: q -> q -> q + (***), logBase :: q -> q -> q + foo, quux :: q -> q -> q diff --git a/hoogle-test/src/fixity/Fixity.hs b/hoogle-test/src/fixity/Fixity.hs new file mode 100644 index 00000000..3af38117 --- /dev/null +++ b/hoogle-test/src/fixity/Fixity.hs @@ -0,0 +1,12 @@ +module Fixity where + + +(+++), (***), (///) :: a -> a -> a +(+++) = undefined +(***) = undefined +(///) = undefined + + +infix 6 +++ +infixl 7 *** +infixr 8 /// diff --git a/hoogle-test/src/modules/Bar.hs b/hoogle-test/src/modules/Bar.hs new file mode 100644 index 00000000..156a835f --- /dev/null +++ b/hoogle-test/src/modules/Bar.hs @@ -0,0 +1,12 @@ +module Bar where + + +import Foo + + +bar :: Int -> Int +bar x = foo' x x + + +bar' :: Int -> Int -> Int +bar' x y = foo' (bar (foo x)) (bar (foo y)) diff --git a/hoogle-test/src/modules/Foo.hs b/hoogle-test/src/modules/Foo.hs new file mode 100644 index 00000000..6581fe4c --- /dev/null +++ b/hoogle-test/src/modules/Foo.hs @@ -0,0 +1,9 @@ +module Foo where + + +foo :: Int -> Int +foo = (* 2) + + +foo' :: Int -> Int -> Int +foo' x y = foo x + foo y -- cgit v1.2.3 From 391225eea26bb2484cbf49d0ca5964ab3176b974 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 21 Aug 2015 19:32:37 +0200 Subject: Create helper function for conversion between XML and XHTML. --- haddock-test/haddock-test.cabal | 2 +- haddock-test/src/Test/Haddock/Xhtml.hs | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index 18c9d28b..0394da8f 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -16,7 +16,7 @@ library default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src - build-depends: base, directory, process, filepath, Cabal, xml, syb + build-depends: base, directory, process, filepath, Cabal, xml, xhtml, syb exposed-modules: Test.Haddock diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index d8c26249..21fda36d 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -13,6 +13,7 @@ import Data.Generics.Aliases import Data.Generics.Schemes import Text.XML.Light +import Text.XHtml newtype Xhtml = Xhtml @@ -72,3 +73,21 @@ stripFooter = [ qName attrKey == "id" , attrVal == "footer" ] + + +xmlElementToXhtml :: Element -> Html +xmlElementToXhtml (Element { .. }) = + tag (qName elName) contents ! attrs + where + contents = mconcat $ map xmlContentToXhtml elContent + attrs = map xmlAttrToXhtml elAttribs + + +xmlContentToXhtml :: Content -> Html +xmlContentToXhtml (Elem el) = xmlElementToXhtml el +xmlContentToXhtml (Text text) = toHtml $ cdData text +xmlContentToXhtml (CRef cref) = noHtml + + +xmlAttrToXhtml :: Attr -> HtmlAttr +xmlAttrToXhtml (Attr { .. }) = strAttr (qName attrKey) attrVal -- cgit v1.2.3 From 2555cc37c9e9c0eeb9f7fbddb9599bb6fae3e982 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 21 Aug 2015 19:51:24 +0200 Subject: Refactor existing code to use XHTML printer instead of XML one. --- haddock-test/src/Test/Haddock/Xhtml.hs | 41 +++++++++++++++++----------------- html-test/Main.hs | 8 +++---- hypsrc-test/Main.hs | 6 ++--- 3 files changed, 28 insertions(+), 27 deletions(-) diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index 21fda36d..69361f7c 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -3,8 +3,8 @@ module Test.Haddock.Xhtml - ( Xhtml(..) - , parseXhtml, dumpXhtml + ( Xml(..) + , parseXml, dumpXml , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter ) where @@ -13,11 +13,12 @@ import Data.Generics.Aliases import Data.Generics.Schemes import Text.XML.Light -import Text.XHtml +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Xhtml -newtype Xhtml = Xhtml - { xhtmlElement :: Element +newtype Xml = Xml + { xmlElement :: Element } deriving Eq @@ -27,19 +28,19 @@ deriving instance Eq Content deriving instance Eq CData -parseXhtml :: String -> Maybe Xhtml -parseXhtml = fmap Xhtml . parseXMLDoc +parseXml :: String -> Maybe Xml +parseXml = fmap Xml . parseXMLDoc -dumpXhtml :: Xhtml -> String -dumpXhtml = ppElement . xhtmlElement +dumpXml :: Xml -> String +dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement -stripLinks :: Xhtml -> Xhtml +stripLinks :: Xml -> Xml stripLinks = stripLinksWhen (const True) -stripLinksWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripLinksWhen :: (String -> Bool) -> Xml -> Xml stripLinksWhen p = processAnchors unlink where @@ -48,7 +49,7 @@ stripLinksWhen p = | otherwise = attr -stripAnchorsWhen :: (String -> Bool) -> Xhtml -> Xhtml +stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml stripAnchorsWhen p = processAnchors unname where @@ -57,13 +58,13 @@ stripAnchorsWhen p = | otherwise = attr -processAnchors :: (Attr -> Attr) -> Xhtml -> Xhtml -processAnchors f = Xhtml . everywhere (mkT f) . xhtmlElement +processAnchors :: (Attr -> Attr) -> Xml -> Xml +processAnchors f = Xml . everywhere (mkT f) . xmlElement -stripFooter :: Xhtml -> Xhtml +stripFooter :: Xml -> Xml stripFooter = - Xhtml . everywhere (mkT defoot) . xhtmlElement + Xml . everywhere (mkT defoot) . xmlElement where defoot el | isFooter el = el { elContent = [] } @@ -77,7 +78,7 @@ stripFooter = xmlElementToXhtml :: Element -> Html xmlElementToXhtml (Element { .. }) = - tag (qName elName) contents ! attrs + Xhtml.tag (qName elName) contents ! attrs where contents = mconcat $ map xmlContentToXhtml elContent attrs = map xmlAttrToXhtml elAttribs @@ -85,9 +86,9 @@ xmlElementToXhtml (Element { .. }) = xmlContentToXhtml :: Content -> Html xmlContentToXhtml (Elem el) = xmlElementToXhtml el -xmlContentToXhtml (Text text) = toHtml $ cdData text -xmlContentToXhtml (CRef cref) = noHtml +xmlContentToXhtml (Text text) = Xhtml.toHtml $ cdData text +xmlContentToXhtml (CRef _) = Xhtml.noHtml xmlAttrToXhtml :: Attr -> HtmlAttr -xmlAttrToXhtml (Attr { .. }) = strAttr (qName attrKey) attrVal +xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal diff --git a/html-test/Main.hs b/html-test/Main.hs index 724d35ec..3880fc3c 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -10,10 +10,10 @@ import Test.Haddock import Test.Haddock.Xhtml -checkConfig :: CheckConfig Xhtml +checkConfig :: CheckConfig Xml checkConfig = CheckConfig - { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXhtml input - , ccfgDump = dumpXhtml + { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input + , ccfgDump = dumpXml , ccfgEqual = (==) } @@ -32,7 +32,7 @@ main = do } -stripIfRequired :: String -> Xhtml -> Xhtml +stripIfRequired :: String -> Xml -> Xml stripIfRequired mdl = stripLinks' . stripFooter where diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index 06cf8546..0490be47 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -11,10 +11,10 @@ import Test.Haddock import Test.Haddock.Xhtml -checkConfig :: CheckConfig Xhtml +checkConfig :: CheckConfig Xml checkConfig = CheckConfig - { ccfgRead = \_ input -> strip <$> parseXhtml input - , ccfgDump = dumpXhtml + { ccfgRead = \_ input -> strip <$> parseXml input + , ccfgDump = dumpXml , ccfgEqual = (==) } where -- cgit v1.2.3 From f2b7e4d0b7be232841e86edabf5152f242976105 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 22 Aug 2015 23:28:19 +0200 Subject: Improve portability of test runner scripts. --- hoogle-test/run | 5 +++-- html-test/run | 5 +++-- hypsrc-test/run | 5 +++-- latex-test/run | 5 +++-- 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/hoogle-test/run b/hoogle-test/run index 5e17ad0f..3e72be80 100755 --- a/hoogle-test/run +++ b/hoogle-test/run @@ -1,5 +1,6 @@ -#!/bin/bash +#!/usr/bin/env bash export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" -runhaskell -i:"$LIB_PATH" "Main.hs" $@ +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/html-test/run b/html-test/run index 5e17ad0f..3e72be80 100755 --- a/html-test/run +++ b/html-test/run @@ -1,5 +1,6 @@ -#!/bin/bash +#!/usr/bin/env bash export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" -runhaskell -i:"$LIB_PATH" "Main.hs" $@ +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/hypsrc-test/run b/hypsrc-test/run index 5e17ad0f..3e72be80 100755 --- a/hypsrc-test/run +++ b/hypsrc-test/run @@ -1,5 +1,6 @@ -#!/bin/bash +#!/usr/bin/env bash export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" -runhaskell -i:"$LIB_PATH" "Main.hs" $@ +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/latex-test/run b/latex-test/run index 5e17ad0f..3e72be80 100755 --- a/latex-test/run +++ b/latex-test/run @@ -1,5 +1,6 @@ -#!/bin/bash +#!/usr/bin/env bash export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" -runhaskell -i:"$LIB_PATH" "Main.hs" $@ +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ -- cgit v1.2.3 From 27d5cba94e827e10c9f5b02b162f6b13cd8cbea1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 22 Aug 2015 23:43:16 +0200 Subject: Remove redundant import statement. --- haddock-test/src/Test/Haddock/Process.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs index 97f3ebed..ae720f6f 100644 --- a/haddock-test/src/Test/Haddock/Process.hs +++ b/haddock-test/src/Test/Haddock/Process.hs @@ -7,7 +7,6 @@ module Test.Haddock.Process where import Control.Monad import System.Exit -import System.FilePath import System.IO import System.Process -- cgit v1.2.3 From 136c48c5fe074ac8a2755c4705d555de24e22a3a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 24 Aug 2015 23:09:20 +0200 Subject: Fix bug with accepting to non-existing directory. --- haddock-test/src/Test/Haddock.hs | 2 +- haddock-test/src/Test/Haddock/Utils.hs | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index 87c16739..e8a0ac8e 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -132,7 +132,7 @@ diffFile cfg diff file = do maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult maybeAcceptFile cfg@(Config { cfgDirConfig = dcfg }) file result | cfgAccept cfg && result `elem` [NoRef, Fail] = do - copyFile (outFile dcfg file) (refFile dcfg file) + copyFile' (outFile dcfg file) (refFile dcfg file) pure Accepted maybeAcceptFile _ _ result = pure result diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs index 4f97fa72..a947fea1 100644 --- a/haddock-test/src/Test/Haddock/Utils.hs +++ b/haddock-test/src/Test/Haddock/Utils.hs @@ -41,3 +41,10 @@ createEmptyDirectory :: FilePath -> IO () createEmptyDirectory path = do whenM (doesDirectoryExist path) $ removeDirectoryRecursive path createDirectory path + + +-- | Just like 'copyFile' but output directory path is not required to exist. +copyFile' :: FilePath -> FilePath -> IO () +copyFile' old new = do + createDirectoryIfMissing True $ takeDirectory new + copyFile old new -- cgit v1.2.3 From 5b427d2a86f09832ba4e86a314abc821e4715aae Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 24 Aug 2015 23:09:47 +0200 Subject: Accept output for Hoogle and LaTeX backends. --- hoogle-test/ref/assoc-types/test.txt | 14 ++++++++++++++ hoogle-test/ref/classes/test.txt | 17 +++++++++++++++++ hoogle-test/ref/fixity/test.txt | 13 +++++++++++++ hoogle-test/ref/modules/test.txt | 13 +++++++++++++ latex-test/ref/Simple/Simple.tex | 3 +-- 5 files changed, 58 insertions(+), 2 deletions(-) create mode 100644 hoogle-test/ref/assoc-types/test.txt create mode 100644 hoogle-test/ref/classes/test.txt create mode 100644 hoogle-test/ref/fixity/test.txt create mode 100644 hoogle-test/ref/modules/test.txt diff --git a/hoogle-test/ref/assoc-types/test.txt b/hoogle-test/ref/assoc-types/test.txt new file mode 100644 index 00000000..ba1a145a --- /dev/null +++ b/hoogle-test/ref/assoc-types/test.txt @@ -0,0 +1,14 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module AssocTypes +class Foo a where { + type family Bar a b; + type family Baz a; + type Baz a = [(a, a)]; +} +bar :: Foo a => Bar a a +instance AssocTypes.Foo [a] diff --git a/hoogle-test/ref/classes/test.txt b/hoogle-test/ref/classes/test.txt new file mode 100644 index 00000000..69f224eb --- /dev/null +++ b/hoogle-test/ref/classes/test.txt @@ -0,0 +1,17 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Classes +class Foo f +bar :: Foo f => f a -> f b -> f (a, b) +baz :: Foo f => f () +class Quux q +(+++) :: Quux q => q -> q -> q +(///) :: Quux q => q -> q -> q +(***) :: Quux q => q -> q -> q +logBase :: Quux q => q -> q -> q +foo :: Quux q => q -> q -> q +quux :: Quux q => q -> q -> q diff --git a/hoogle-test/ref/fixity/test.txt b/hoogle-test/ref/fixity/test.txt new file mode 100644 index 00000000..6f609539 --- /dev/null +++ b/hoogle-test/ref/fixity/test.txt @@ -0,0 +1,13 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Fixity +(+++) :: a -> a -> a +infix 6 +++ +(***) :: a -> a -> a +infixl 7 *** +(///) :: a -> a -> a +infixr 8 /// diff --git a/hoogle-test/ref/modules/test.txt b/hoogle-test/ref/modules/test.txt new file mode 100644 index 00000000..6705b790 --- /dev/null +++ b/hoogle-test/ref/modules/test.txt @@ -0,0 +1,13 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Foo +foo :: Int -> Int +foo' :: Int -> Int -> Int + +module Bar +bar :: Int -> Int +bar' :: Int -> Int -> Int diff --git a/latex-test/ref/Simple/Simple.tex b/latex-test/ref/Simple/Simple.tex index 89e849f8..5ba4712c 100644 --- a/latex-test/ref/Simple/Simple.tex +++ b/latex-test/ref/Simple/Simple.tex @@ -11,7 +11,6 @@ module Simple ( \item[\begin{tabular}{@{}l} foo\ ::\ t \end{tabular}]\haddockbegindoc -This is foo. -\par +This is foo.\par \end{haddockdesc} \ No newline at end of file -- cgit v1.2.3 From 3c88a8a3336b26939738d481a60233821b926adb Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 24 Aug 2015 23:14:18 +0200 Subject: Get rid of obsolete testing utilities. --- html-test/README.markdown | 27 ------- html-test/accept.lhs | 49 ------------ html-test/run.lhs | 191 ---------------------------------------------- hypsrc-test/Utils.hs | 47 ------------ hypsrc-test/accept.hs | 27 ------- hypsrc-test/run.hs | 122 ----------------------------- latex-test/accept.lhs | 46 ----------- latex-test/run.lhs | 162 --------------------------------------- 8 files changed, 671 deletions(-) delete mode 100644 html-test/README.markdown delete mode 100755 html-test/accept.lhs delete mode 100755 html-test/run.lhs delete mode 100644 hypsrc-test/Utils.hs delete mode 100755 hypsrc-test/accept.hs delete mode 100755 hypsrc-test/run.hs delete mode 100755 latex-test/accept.lhs delete mode 100755 latex-test/run.lhs diff --git a/html-test/README.markdown b/html-test/README.markdown deleted file mode 100644 index 717bac5c..00000000 --- a/html-test/README.markdown +++ /dev/null @@ -1,27 +0,0 @@ -This is a testsuite for Haddock that uses the concept of "golden files". That -is, it compares output files against a set of reference files. - -To add a new test: - - 1. Create a module in the `html-test/src` directory. - - 2. Run `cabal test`. You should now have `html-test/out/.html`. - The test passes since there is no reference file to compare with. - - 3. To make a reference file from the output file, run - - html-test/accept.lhs - -Tips and tricks: - -To "accept" all output files (copy them to reference files), run - - runhaskell accept.lhs - -You can run all tests despite failing tests, like so - - cabal test --test-option=all - -You can pass extra options to haddock like so - - cabal test --test-options='all --title="All Tests"' diff --git a/html-test/accept.lhs b/html-test/accept.lhs deleted file mode 100755 index f6dfc4cd..00000000 --- a/html-test/accept.lhs +++ /dev/null @@ -1,49 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import System.Cmd -import System.Environment -import System.FilePath -import System.Directory -import Data.List -import Control.Applicative - -baseDir = takeDirectory __FILE__ - -main :: IO () -main = do - contents <- filter (not . ignore) <$> getDirectoryContents (baseDir "out") - args <- getArgs - if not $ null args then - mapM_ copy [ baseDir "out" file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] - else - mapM_ copy [ baseDir "out" file | file <- contents] - where - ignore = - foldr (liftA2 (||)) (const False) [ - (== ".") - , (== "..") - , (isPrefixOf "index") - , (isPrefixOf "doc-index") - ] - -copy :: FilePath -> IO () -copy file = do - let new = baseDir "ref" takeFileName file - if ".html" `isSuffixOf` file then do - putStrLn (file ++ " -> " ++ new) - stripLinks <$> readFile file >>= writeFile new - else do - -- copy css, images, etc. - copyFile file new - -stripLinks :: String -> String -stripLinks str = - let prefix = " prefix ++ stripLinks (dropWhile (/= '"') str') - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs -\end{code} diff --git a/html-test/run.lhs b/html-test/run.lhs deleted file mode 100755 index 1f19b723..00000000 --- a/html-test/run.lhs +++ /dev/null @@ -1,191 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import Prelude hiding (mod) -import Control.Monad -import Control.Applicative -import Data.List -import Data.Maybe -import Distribution.InstalledPackageInfo -import Distribution.Package (PackageName (..)) -import Distribution.Simple.Compiler -import Distribution.Simple.GHC -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.Verbosity -import System.IO -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process (ProcessHandle, runProcess, waitForProcess, system) - -packageRoot, dataDir, haddockPath, baseDir, testDir, outDir :: FilePath -baseDir = takeDirectory __FILE__ -testDir = baseDir "src" -refDir = baseDir "ref" -outDir = baseDir "out" -packageRoot = baseDir ".." -dataDir = packageRoot "resources" -haddockPath = packageRoot "dist" "build" "haddock" "haddock" - - -main :: IO () -main = do - test - putStrLn "All tests passed!" - - -test :: IO () -test = do - x <- doesFileExist haddockPath - unless x $ System.Exit.die "you need to run 'cabal build' successfully first" - - contents <- getDirectoryContents testDir - args <- getArgs - let (opts, spec) = span ("-" `isPrefixOf`) args - let mods = - case spec of - y:_ | y /= "all" -> [y ++ ".hs"] - _ -> filter ((==) ".hs" . takeExtension) contents - - let mods' = map (testDir ) mods - - -- add haddock_datadir to environment for subprocesses - env <- Just . (:) ("haddock_datadir", Main.dataDir) <$> getEnvironment - - putStrLn "" - putStrLn "Haddock version: " - h1 <- runProcess haddockPath ["--version"] Nothing - env Nothing Nothing Nothing - wait h1 "*** Running `haddock --version' failed!" - putStrLn "" - putStrLn "GHC version: " - h2 <- runProcess haddockPath ["--ghc-version"] Nothing - env Nothing Nothing Nothing - wait h2 "*** Running `haddock --ghc-version' failed!" - putStrLn "" - - -- TODO: maybe do something more clever here using haddock.cabal - ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"] - (_, _, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration - pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf - let mkDep pkgName = - fromMaybe (error "Couldn't find test dependencies") $ do - let pkgs = lookupPackageName pkgIndex (PackageName pkgName) - (_, pkgs') <- listToMaybe pkgs - pkg <- listToMaybe pkgs' - ifacePath <- listToMaybe (haddockInterfaces pkg) - htmlPath <- listToMaybe (haddockHTMLs pkg) - return ("-i " ++ htmlPath ++ "," ++ ifacePath) - - let base = mkDep "base" - process = mkDep "process" - ghcprim = mkDep "ghc-prim" - - putStrLn "Running tests..." - handle <- runProcess haddockPath - (["-w", "-o", outDir, "-h", "--pretty-html" - , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods') - Nothing env Nothing - Nothing Nothing - - wait handle "*** Haddock run failed! Exiting." - check mods (if not (null args) && args !! 0 == "all" then False else True) - where - wait :: ProcessHandle -> String -> IO () - wait h msg = do - r <- waitForProcess h - unless (r == ExitSuccess) $ do - hPutStrLn stderr msg - exitFailure - -check :: [FilePath] -> Bool -> IO () -check modules strict = do - forM_ modules $ \mod -> do - let outfile = outDir dropExtension mod ++ ".html" - let reffile = refDir dropExtension mod ++ ".html" - b <- doesFileExist reffile - if b - then do - out <- readFile outfile - ref <- readFile reffile - if not $ haddockEq (outfile, out) (reffile, ref) - then do - putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:" - let ref' = maybeStripLinks outfile ref - out' = maybeStripLinks reffile out - let reffile' = outDir takeFileName reffile ++ ".nolinks" - outfile' = outDir takeFileName outfile ++ ".ref.nolinks" - writeFile reffile' ref' - writeFile outfile' out' - r <- programOnPath "colordiff" - code <- if r - then system $ "colordiff " ++ reffile' ++ " " ++ outfile' - else system $ "diff " ++ reffile' ++ " " ++ outfile' - if strict then exitFailure else return () - unless (code == ExitSuccess) $ do - hPutStrLn stderr "*** Running diff failed!" - exitFailure - else do - putStrLn $ "Pass: " ++ mod - else do - putStrLn $ "Pass: " ++ mod ++ " (no .ref file)" - --- | List of modules in which we don't 'stripLinks' -preserveLinksModules :: [String] -preserveLinksModules = map (++ ".html") ["Bug253"] - --- | A rather nasty way to drop the Haddock version string from the --- end of the generated HTML files so that we don't have to change --- every single test every time we change versions. We rely on the the --- last paragraph of the document to be the version. We end up with --- malformed HTML but we don't care as we never look at it ourselves. -dropVersion :: String -> String -dropVersion = reverse . dropTillP . reverse - where - dropTillP [] = [] - dropTillP ('p':'<':xs) = xs - dropTillP (_:xs) = dropTillP xs - -haddockEq :: (FilePath, String) -> (FilePath, String) -> Bool -haddockEq (fn1, file1) (fn2, file2) = - maybeStripLinks fn1 (dropVersion file1) - == maybeStripLinks fn2 (dropVersion file2) - -maybeStripLinks :: String -- ^ Module we're considering for stripping - -> String -> String -maybeStripLinks m = if any (`isSuffixOf` m) preserveLinksModules - then id - else stripLinks - -stripLinks :: String -> String -stripLinks str = - let prefix = " case dropWhile (/= '>') (dropWhile (/= '"') str') of - [] -> [] - x:xs -> stripLinks (stripHrefEnd xs) - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs - -stripHrefEnd :: String -> String -stripHrefEnd s = - let pref = " case dropWhile (/= '>') str' of - [] -> [] - x:xs -> xs - Nothing -> - case s of - [] -> [] - x : xs -> x : stripHrefEnd xs - -programOnPath :: FilePath -> IO Bool -programOnPath p = do - result <- findProgramLocation silent p - return (isJust result) -\end{code} diff --git a/hypsrc-test/Utils.hs b/hypsrc-test/Utils.hs deleted file mode 100644 index e15fabee..00000000 --- a/hypsrc-test/Utils.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE CPP #-} - - -module Utils - ( baseDir, rootDir - , srcDir, refDir, outDir, refDir', outDir' - , haddockPath - , stripLocalAnchors, stripLocalLinks, stripLocalReferences - ) where - - -import Data.List - -import System.FilePath - - -baseDir, rootDir :: FilePath -baseDir = takeDirectory __FILE__ -rootDir = baseDir ".." - -srcDir, refDir, outDir, refDir', outDir' :: FilePath -srcDir = baseDir "src" -refDir = baseDir "ref" -outDir = baseDir "out" -refDir' = refDir "src" -outDir' = outDir "src" - -haddockPath :: FilePath -haddockPath = rootDir "dist" "build" "haddock" "haddock" - - -replaceBetween :: Eq a => [a] -> a -> [a] -> [a] -> [a] -replaceBetween _ _ _ [] = [] -replaceBetween pref end val html@(x:xs') = case stripPrefix pref html of - Just strip -> pref ++ val ++ (replaceBetween' . dropWhile (/= end)) strip - Nothing -> x:(replaceBetween' xs') - where - replaceBetween' = replaceBetween pref end val - -stripLocalAnchors :: String -> String -stripLocalAnchors = replaceBetween " String -stripLocalLinks = replaceBetween " String -stripLocalReferences = stripLocalLinks . stripLocalAnchors diff --git a/hypsrc-test/accept.hs b/hypsrc-test/accept.hs deleted file mode 100755 index 4606b2df..00000000 --- a/hypsrc-test/accept.hs +++ /dev/null @@ -1,27 +0,0 @@ -#!/usr/bin/env runhaskell -{-# LANGUAGE CPP #-} - - -import System.Directory -import System.FilePath -import System.Environment - -import Utils - - -main :: IO () -main = do - args <- getArgs - files <- filter isHtmlFile <$> getDirectoryContents outDir' - let files' = if args == ["--all"] || args == ["-a"] - then files - else filter ((`elem` args) . takeBaseName) files - mapM_ copy files' - where - isHtmlFile = (== ".html") . takeExtension - - -copy :: FilePath -> IO () -copy file = do - content <- stripLocalReferences <$> readFile (outDir' file) - writeFile (refDir' file) content diff --git a/hypsrc-test/run.hs b/hypsrc-test/run.hs deleted file mode 100755 index 853c4f09..00000000 --- a/hypsrc-test/run.hs +++ /dev/null @@ -1,122 +0,0 @@ -#!/usr/bin/env runhaskell -{-# LANGUAGE CPP #-} - - -import Control.Monad - -import Data.List -import Data.Maybe - -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process - -import Distribution.Verbosity -import Distribution.Simple.Utils hiding (die) - -import Utils - - -main :: IO () -main = do - haddockAvailable <- doesFileExist haddockPath - unless haddockAvailable $ die "Haddock exectuable not available" - - (args, mods) <- partition ("-" `isPrefixOf`) <$> getArgs - let args' = filter (\arg -> not $ arg == "--all" || arg == "-a") args - mods' <- map (srcDir ) <$> case args of - [] -> getAllSrcModules - _ -> return $ map (++ ".hs") mods - - putHaddockVersion - putGhcVersion - - putStrLn "Running tests..." - runHaddock $ - [ "--odir=" ++ outDir - , "--no-warnings" - , "--hyperlinked-source" - , "--pretty-html" - ] ++ args' ++ mods' - - forM_ mods' $ check True - - -check :: Bool -> FilePath -> IO () -check strict mdl = do - hasReference <- doesFileExist refFile - if hasReference - then do - ref <- readFile refFile - out <- readFile outFile - compareOutput strict mdl ref out - else do - putStrLn $ "Pass: " ++ mdl ++ " (no reference file)" - where - refFile = refDir' takeBaseName mdl ++ ".html" - outFile = outDir' takeBaseName mdl ++ ".html" - - -compareOutput :: Bool -> FilePath -> String -> String -> IO () -compareOutput strict mdl ref out = do - if ref' == out' - then putStrLn $ "Pass: " ++ mdl - else do - putStrLn $ "Fail: " ++ mdl - diff mdl ref' out' - when strict $ die "Aborting further tests." - where - ref' = stripLocalReferences ref - out' = stripLocalReferences out - - -diff :: FilePath -> String -> String -> IO () -diff mdl ref out = do - colorDiffPath <- findProgramLocation silent "colordiff" - let cmd = fromMaybe "diff" colorDiffPath - - writeFile refFile ref - writeFile outFile out - - result <- system $ cmd ++ " " ++ refFile ++ " " ++ outFile - unless (result == ExitSuccess) $ die "Failed to run `diff` command." - where - refFile = outDir takeBaseName mdl ++ ".ref.nolinks" - outFile = outDir takeBaseName mdl ++ ".nolinks" - - - -getAllSrcModules :: IO [FilePath] -getAllSrcModules = - filter isHaskellFile <$> getDirectoryContents srcDir - where - isHaskellFile = (== ".hs") . takeExtension - - -putHaddockVersion :: IO () -putHaddockVersion = do - putStrLn "Haddock version:" - runHaddock ["--version"] - putStrLn "" - - -putGhcVersion :: IO () -putGhcVersion = do - putStrLn "GHC version:" - runHaddock ["--ghc-version"] - putStrLn "" - - -runHaddock :: [String] -> IO () -runHaddock args = do - menv <- Just <$> getEnvironment - handle <- runProcess haddockPath args Nothing menv Nothing Nothing Nothing - waitForSuccess handle $ "Failed to invoke haddock with " ++ show args - - -waitForSuccess :: ProcessHandle -> String -> IO () -waitForSuccess handle msg = do - result <- waitForProcess handle - unless (result == ExitSuccess) $ die msg diff --git a/latex-test/accept.lhs b/latex-test/accept.lhs deleted file mode 100755 index 4d0b0127..00000000 --- a/latex-test/accept.lhs +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import System.Environment -import System.FilePath -import System.Directory -import Data.List -import Control.Applicative -import Control.Monad - -baseDir :: FilePath -baseDir = takeDirectory __FILE__ - -main :: IO () -main = do - contents <- filter (not . ignore) <$> getDirectoryContents (baseDir "out") - args <- getArgs - mapM_ copyDir $ if not (null args) - then filter ((`elem` args) . takeBaseName) contents - else contents - where - ignore = - foldr (liftA2 (||)) (const False) [ - (== ".") - , (== "..") - , isPrefixOf "index" - , isPrefixOf "doc-index" - ] - --- | Copy a directory to ref, one level deep. -copyDir :: FilePath -> IO () -copyDir dir = do - let old = baseDir "out" dir - new = baseDir "ref" dir - alreadyExists <- doesDirectoryExist new - unless alreadyExists $ do - putStrLn (old ++ " -> " ++ new) - createDirectoryIfMissing True new - files <- getDirectoryContents old >>= filterM (liftM not . doesDirectoryExist) - let files' = filter (\x -> x /= "." && x /= "..") files - mapM_ (\f -> copyFile' (old f) (new f)) files' - where - copyFile' o n = do - putStrLn $ o ++ " -> " ++ n - copyFile o n -\end{code} diff --git a/latex-test/run.lhs b/latex-test/run.lhs deleted file mode 100755 index d3e39e90..00000000 --- a/latex-test/run.lhs +++ /dev/null @@ -1,162 +0,0 @@ -#!/usr/bin/env runhaskell -\begin{code} -{-# LANGUAGE CPP #-} -import Prelude hiding (mod) -import Control.Monad -import Control.Applicative -import Data.List -import Data.Maybe -import Distribution.InstalledPackageInfo hiding (dataDir) -import Distribution.Package (PackageName (..)) -import Distribution.Simple.Compiler -import Distribution.Simple.GHC -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.Verbosity -import System.IO -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process (ProcessHandle, runProcess, waitForProcess, system) - - -packageRoot, dataDir, haddockPath, baseDir, testDir, outDir, refDir :: FilePath -baseDir = takeDirectory __FILE__ -testDir = baseDir "src" -refDir = baseDir "ref" -outDir = baseDir "out" -packageRoot = baseDir ".." -dataDir = packageRoot "resources" -haddockPath = packageRoot "dist" "build" "haddock" "haddock" - - -main :: IO () -main = do - test - putStrLn "All tests passed!" - - -test :: IO () -test = do - x <- doesFileExist haddockPath - unless x $ System.Exit.die "you need to run 'cabal build' successfully first" - - contents <- getDirectoryContents testDir - - args <- getArgs - let (opts, spec) = span ("-" `isPrefixOf`) args - isDir x' = liftM2 (&&) (doesDirectoryExist $ testDir x') - (return $ x' /= "." && x' /= "..") - modDirs <- case spec of - y:_ | y /= "all" -> return [y] - _ -> filterM isDir contents - - let modDirs' = map (testDir ) modDirs - - -- add haddock_datadir to environment for subprocesses - env <- Just . (:) ("haddock_datadir", dataDir) <$> getEnvironment - - putStrLn "" - putStrLn "Haddock version: " - h1 <- runProcess haddockPath ["--version"] Nothing - env Nothing Nothing Nothing - wait h1 "*** Running `haddock --version' failed!" - putStrLn "" - putStrLn "GHC version: " - h2 <- runProcess haddockPath ["--ghc-version"] Nothing - env Nothing Nothing Nothing - wait h2 "*** Running `haddock --ghc-version' failed!" - putStrLn "" - - -- TODO: maybe do something more clever here using haddock.cabal - ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"] - (_, _, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration - pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf - let mkDep pkgName = - fromMaybe (error "Couldn't find test dependencies") $ do - let pkgs = lookupPackageName pkgIndex (PackageName pkgName) - (_, pkgs') <- listToMaybe pkgs - pkg <- listToMaybe pkgs' - ifacePath <- listToMaybe (haddockInterfaces pkg) - htmlPath <- listToMaybe (haddockHTMLs pkg) - return ("-i " ++ htmlPath ++ "," ++ ifacePath) - - let base = mkDep "base" - process = mkDep "process" - ghcprim = mkDep "ghc-prim" - - putStrLn "Running tests..." - - forM_ modDirs' $ \modDir -> do - testModules <- getDirectoryContents modDir - - let mods = filter ((==) ".hs" . takeExtension) testModules - mods' = map (modDir ) mods - - unless (null mods') $ do - handle <- runProcess haddockPath - (["-w", "-o", outDir last (splitPath modDir), "--latex" - , "--optghc=-fglasgow-exts" - , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods') - Nothing env Nothing - Nothing Nothing - - wait handle "*** Haddock run failed! Exiting." - - check modDirs (if not (null args) && args !! 0 == "all" then False else True) - where - wait :: ProcessHandle -> String -> IO () - wait h msg = do - r <- waitForProcess h - unless (r == ExitSuccess) $ do - hPutStrLn stderr msg - exitFailure - -check :: [FilePath] -> Bool -> IO () -check modDirs strict = do - forM_ modDirs $ \modDir -> do - let oDir = outDir modDir - rDir = refDir modDir - - refDirExists <- doesDirectoryExist rDir - when refDirExists $ do - -- we're not creating sub-directories, I think. - refFiles <- getDirectoryContents rDir >>= filterM doesFileExist - - forM_ refFiles $ \rFile -> do - let refFile = rDir rFile - outFile = oDir rFile - oe <- doesFileExist outFile - if oe - then do - out <- readFile outFile - ref <- readFile refFile - - if out /= ref - then do - putStrLn $ "Output for " ++ modDir ++ " has changed! Exiting with diff:" - - let reffile' = outDir takeFileName refFile ++ ".nolinks" - outfile' = outDir takeFileName outFile ++ ".ref.nolinks" - writeFile reffile' ref - writeFile outfile' out - r <- programOnPath "colordiff" - code <- if r - then system $ "colordiff " ++ reffile' ++ " " ++ outfile' - else system $ "diff " ++ reffile' ++ " " ++ outfile' - if strict then exitFailure else return () - unless (code == ExitSuccess) $ do - hPutStrLn stderr "*** Running diff failed!" - exitFailure - else do - putStrLn $ "Pass: " ++ modDir - else do - putStrLn $ "Pass: " ++ modDir ++ " (no .ref file)" - -programOnPath :: FilePath -> IO Bool -programOnPath p = do - result <- findProgramLocation silent p - return (isJust result) -\end{code} -- cgit v1.2.3 From 0b5a59a94f7d03df5d833c93ffd75b3f8d5bd5ba Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 24 Aug 2015 23:18:50 +0200 Subject: Update sandbox setup guide to work with Haddock test package. --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 31015e91..08b960de 100644 --- a/README.md +++ b/README.md @@ -57,6 +57,7 @@ example setup using cabal sandboxes. cabal sandbox init cabal sandbox add-source haddock-library cabal sandbox add-source haddock-api + cabal sandbox add-source haddock-test # adjust -j to the number of cores you want to use cabal install -j4 --dependencies-only --enable-tests cabal configure --enable-tests -- cgit v1.2.3 From 0f2b8a81aa01fd7f008e92c8963135ef14dc545d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 24 Aug 2015 23:51:30 +0200 Subject: Make Travis aware of Haddock test package. --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index c16b1709..cb76774c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,6 +22,7 @@ before_install: - cabal install - cd .. - (cd haddock-api/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal test && cabal install) + - (cd haddock-test/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal install) script: - cabal configure --enable-tests && cabal build && cabal test -- 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(+) 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 From f8764c73ecc8b226aaa00672f48eb7c0fc7b5cb1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 25 Aug 2015 18:01:29 +0200 Subject: Add sample Stack setup to the hacking guide. --- README.md | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 08b960de..367b70e8 100644 --- a/README.md +++ b/README.md @@ -48,12 +48,20 @@ Please create issues when you have any problems and pull requests if you have so ###### Hacking -To get started you'll need a latest GHC release installed. Below is an -example setup using cabal sandboxes. +To get started you'll need a latest GHC release installed. + +Clone the repository: ```bash git clone https://github.com/haskell/haddock.git cd haddock +``` + +and then proceed using your favourite build tool. + +####### Using Cabal sandboxes + +```bash cabal sandbox init cabal sandbox add-source haddock-library cabal sandbox add-source haddock-api @@ -63,9 +71,21 @@ example setup using cabal sandboxes. cabal configure --enable-tests cabal build -j4 # run the test suite + export HADDOCK_PATH="dist/build/haddock/haddock" cabal test ``` +####### Using Stack + +```bash + stack init + stack install + # run the test suite + export HADDOCK_PATH="$HOME/.local/bin/haddock" + stack test +``` + + If you're a GHC developer and want to update Haddock to work with your changes, you should be working on `ghc-head` branch instead of master. See instructions at -- cgit v1.2.3 From e6fd9fc7f23a1be317ad045da5f8248866f80308 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 25 Aug 2015 18:04:47 +0200 Subject: Fix Markdown formatting of README file. --- README.md | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/README.md b/README.md index 367b70e8..160ee995 100644 --- a/README.md +++ b/README.md @@ -46,7 +46,7 @@ format. Please create issues when you have any problems and pull requests if you have some code. -###### Hacking +##### Hacking To get started you'll need a latest GHC release installed. @@ -59,30 +59,30 @@ Clone the repository: and then proceed using your favourite build tool. -####### Using Cabal sandboxes +###### Using Cabal sandboxes ```bash - cabal sandbox init - cabal sandbox add-source haddock-library - cabal sandbox add-source haddock-api - cabal sandbox add-source haddock-test - # adjust -j to the number of cores you want to use - cabal install -j4 --dependencies-only --enable-tests - cabal configure --enable-tests - cabal build -j4 - # run the test suite - export HADDOCK_PATH="dist/build/haddock/haddock" - cabal test +cabal sandbox init +cabal sandbox add-source haddock-library +cabal sandbox add-source haddock-api +cabal sandbox add-source haddock-test +# adjust -j to the number of cores you want to use +cabal install -j4 --dependencies-only --enable-tests +cabal configure --enable-tests +cabal build -j4 +# run the test suite +export HADDOCK_PATH="dist/build/haddock/haddock" +cabal test ``` -####### Using Stack +###### Using Stack ```bash - stack init - stack install - # run the test suite - export HADDOCK_PATH="$HOME/.local/bin/haddock" - stack test +stack init +stack install +# run the test suite +export HADDOCK_PATH="$HOME/.local/bin/haddock" +stack test ``` -- cgit v1.2.3 From 27ffb2c24b8204d1a06bd509c49d3e3d7d2d7aba Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 25 Aug 2015 18:13:36 +0200 Subject: Setup Haddock executable path in Travis configuration. --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index cb76774c..585b0b25 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,7 +22,8 @@ before_install: - cabal install - cd .. - (cd haddock-api/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal test && cabal install) - - (cd haddock-test/ && cabal install --only-dependencies --enable-tests && cabal configure --enable-tests && cabal build && cabal install) + - (cd haddock-test/ && cabal install --only-dependencies && cabal configure && cabal build && cabal install) script: + - export HADDOCK_PATH="dist/build/haddock/haddock" - cabal configure --enable-tests && cabal build && cabal test -- cgit v1.2.3