diff options
Diffstat (limited to 'haddock-test')
-rw-r--r-- | haddock-test/haddock-test.cabal | 28 | ||||
-rw-r--r-- | haddock-test/src/Test/Haddock.hs | 149 | ||||
-rw-r--r-- | haddock-test/src/Test/Haddock/Config.hs | 282 | ||||
-rw-r--r-- | haddock-test/src/Test/Haddock/Process.hs | 48 | ||||
-rw-r--r-- | haddock-test/src/Test/Haddock/Utils.hs | 50 | ||||
-rw-r--r-- | haddock-test/src/Test/Haddock/Xhtml.hs | 94 |
6 files changed, 651 insertions, 0 deletions
diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal new file mode 100644 index 00000000..0394da8f --- /dev/null +++ b/haddock-test/haddock-test.cabal @@ -0,0 +1,28 @@ +name: haddock-test +version: 0.0.1 +synopsis: Test utilities for Haddock +license: BSD3 +author: Simon Marlow, David Waern +maintainer: Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> +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 + ghc-options: -Wall + hs-source-dirs: src + build-depends: base, directory, process, filepath, Cabal, xml, xhtml, syb + + exposed-modules: + Test.Haddock + Test.Haddock.Config + 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 new file mode 100644 index 00000000..e8a0ac8e --- /dev/null +++ b/haddock-test/src/Test/Haddock.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock + ( module Test.Haddock.Config + , runAndCheck, runHaddock, checkFiles + ) 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.Utils + + +data CheckResult + = Fail + | Pass + | NoRef + | Error String + | Accepted + deriving Eq + + +runAndCheck :: Config c -> IO () +runAndCheck cfg = do + runHaddock cfg + checkFiles cfg + + +checkFiles :: Config c -> IO () +checkFiles cfg@(Config { .. }) = do + putStrLn "Testing output files..." + + files <- ignore <$> getDirectoryTree (cfgOutDir cfg) + failed <- liftM catMaybes . forM files $ \file -> do + putStr $ "Checking \"" ++ 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 + putStrLn "All tests passed!" + exitSuccess + else do + maybeDiff cfg failed + exitFailure + where + ignore = filter (not . dcfgCheckIgnore cfgDirConfig) + + +maybeDiff :: Config c -> [FilePath] -> IO () +maybeDiff (Config { cfgDiffTool = Nothing }) _ = pure () +maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do + putStrLn "Diffing failed cases..." + forM_ files $ diffFile cfg diff + + +runHaddock :: Config c -> IO () +runHaddock cfg@(Config { .. }) = do + createEmptyDirectory $ cfgOutDir cfg + + putStrLn "Generating documentation..." + forM_ cfgPackages $ \tpkg -> do + haddockStdOut <- openFile cfgHaddockStdOut WriteMode + 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 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 + | otherwise -> Fail + _ -> Error "Failed to parse input files" + else return NoRef + where + ccfg = cfgCheckConfig cfg + dcfg = cfgDirConfig cfg + + +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 file \"" ++ file ++ "\":" + hFlush stdout + handle <- runProcess' diff $ processConfig + { pcArgs = [outFile', refFile'] + , pcStdOut = Just $ stdout + } + waitForProcess handle >> return () + where + dcfg = cfgDirConfig cfg + ccfg = cfgCheckConfig cfg + outFile' = outFile dcfg file <.> "dump" + 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 + + +outFile :: DirConfig -> FilePath -> FilePath +outFile dcfg file = dcfgOutDir dcfg </> file + + +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 new file mode 100644 index 00000000..8f1f4885 --- /dev/null +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock.Config + ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..) + , defaultDirConfig + , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir + , parseArgs, checkOpt, loadConfig + ) 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 + + +data TestPackage = TestPackage + { tpkgName :: String + , tpkgFiles :: [FilePath] + } + + +data CheckConfig c = CheckConfig + { ccfgRead :: String -> String -> Maybe c + , ccfgDump :: c -> String + , ccfgEqual :: c -> c -> Bool + } + + +data DirConfig = DirConfig + { dcfgSrcDir :: FilePath + , dcfgRefDir :: FilePath + , dcfgOutDir :: FilePath + , dcfgResDir :: FilePath + , dcfgCheckIgnore :: FilePath -> Bool + } + + +defaultDirConfig :: FilePath -> DirConfig +defaultDirConfig baseDir = DirConfig + { dcfgSrcDir = baseDir </> "src" + , dcfgRefDir = baseDir </> "ref" + , dcfgOutDir = baseDir </> "out" + , dcfgResDir = rootDir </> "resources" + , dcfgCheckIgnore = const False + } + where + rootDir = baseDir </> ".." + + +data Config c = Config + { cfgHaddockPath :: FilePath + , cfgPackages :: [TestPackage] + , cfgHaddockArgs :: [String] + , cfgHaddockStdOut :: FilePath + , cfgDiffTool :: Maybe FilePath + , cfgEnv :: Environment + , cfgAccept :: Bool + , cfgCheckConfig :: CheckConfig c + , cfgDirConfig :: DirConfig + } + + +cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config c -> FilePath +cfgSrcDir = dcfgSrcDir . cfgDirConfig +cfgRefDir = dcfgRefDir . cfgDirConfig +cfgOutDir = dcfgOutDir . cfgDirConfig +cfgResDir = dcfgResDir . cfgDirConfig + + + +data Flag + = FlagHaddockPath FilePath + | FlagHaddockOptions String + | FlagHaddockStdOut FilePath + | FlagDiffTool FilePath + | FlagNoDiff + | FlagAccept + | FlagHelp + deriving Eq + + +flagsHaddockPath :: [Flag] -> Maybe FilePath +flagsHaddockPath flags = mlast [ path | FlagHaddockPath 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 [] ["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 ['a'] ["accept"] (NoArg FlagAccept) + "accept generated output" + , Option [] ["no-diff"] (NoArg FlagNoDiff) + "do not print diff for failed cases" + , Option ['h'] ["help"] (NoArg FlagHelp) + "display this help end exit" + ] + + +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 + + unless (null errors) $ do + hPutStr stderr $ concat errors + exitFailure + + when (FlagHelp `elem` flags) $ do + hPutStrLn stderr $ usageInfo "" options + exitSuccess + + return (flags, files) + + +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 + Just path -> pure path + Nothing -> do + hPutStrLn stderr $ "Haddock executable not specified" + exitFailure + + ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath + ["--print-ghc-path"] + + printVersions cfgEnv cfgHaddockPath + + cfgPackages <- processFileArgs dcfg files + + cfgHaddockArgs <- liftM concat . sequence $ + [ pure ["--no-warnings"] + , pure ["--odir=" ++ dcfgOutDir dcfg] + , 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 + + let cfgAccept = FlagAccept `elem` flags + + let cfgCheckConfig = ccfg + let cfgDirConfig = dcfg + + 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 + -- 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 + 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 [TestPackage] +processFileArgs dcfg [] = + processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir + where + isValidEntry entry + | hasExtension entry = isSourceFile entry + | otherwise = isRealDir entry + srcDir = dcfgSrcDir dcfg +processFileArgs dcfg args = processFileArgs' dcfg args + + +processFileArgs' :: DirConfig -> [String] -> IO [TestPackage] +processFileArgs' dcfg args = do + (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args + rootPkg <- pure $ TestPackage + { tpkgName = "" + , tpkgFiles = map (srcDir </>) mdls + } + otherPkgs <- forM dirs $ \dir -> do + let srcDir' = srcDir </> dir + files <- filterM (isModule dir) =<< getDirectoryContents srcDir' + pure $ TestPackage + { tpkgName = dir + , tpkgFiles = map (srcDir' </>) files + } + pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs + where + doesDirectoryExist' path = doesDirectoryExist (srcDir </> path) + isModule dir file = (isSourceFile file &&) <$> + doesFileExist (srcDir </> dir </> file) + srcDir = dcfgSrcDir dcfg + + +isSourceFile :: FilePath -> Bool +isSourceFile file = takeExtension file `elem` [".hs", ".lhs"] + + +isRealDir :: FilePath -> Bool +isRealDir dir = not $ dir `elem` [".", ".."] diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs new file mode 100644 index 00000000..ae720f6f --- /dev/null +++ b/haddock-test/src/Test/Haddock/Process.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards #-} + + +module Test.Haddock.Process where + + +import Control.Monad + +import System.Exit +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..a947fea1 --- /dev/null +++ b/haddock-test/src/Test/Haddock/Utils.hs @@ -0,0 +1,50 @@ +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) + + +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 + 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 == ".." + + +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 diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs new file mode 100644 index 00000000..69361f7c --- /dev/null +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + + +module Test.Haddock.Xhtml + ( Xml(..) + , parseXml, dumpXml + , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter + ) where + + +import Data.Generics.Aliases +import Data.Generics.Schemes + +import Text.XML.Light +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Xhtml + + +newtype Xml = Xml + { xmlElement :: 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 + + +parseXml :: String -> Maybe Xml +parseXml = fmap Xml . parseXMLDoc + + +dumpXml :: Xml -> String +dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement + + +stripLinks :: Xml -> Xml +stripLinks = stripLinksWhen (const True) + + +stripLinksWhen :: (String -> Bool) -> Xml -> Xml +stripLinksWhen p = + processAnchors unlink + where + unlink attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "href" && p val = attr { attrVal = "#" } + | otherwise = attr + + +stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml +stripAnchorsWhen p = + processAnchors unname + where + unname attr@(Attr { attrKey = key, attrVal = val }) + | qName key == "name" && p val = attr { attrVal = "" } + | otherwise = attr + + +processAnchors :: (Attr -> Attr) -> Xml -> Xml +processAnchors f = Xml . everywhere (mkT f) . xmlElement + + +stripFooter :: Xml -> Xml +stripFooter = + Xml . everywhere (mkT defoot) . xmlElement + where + defoot el + | isFooter el = el { elContent = [] } + | otherwise = el + isFooter el = any isFooterAttr $ elAttribs el + isFooterAttr (Attr { .. }) = and + [ qName attrKey == "id" + , attrVal == "footer" + ] + + +xmlElementToXhtml :: Element -> Html +xmlElementToXhtml (Element { .. }) = + Xhtml.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) = Xhtml.toHtml $ cdData text +xmlContentToXhtml (CRef _) = Xhtml.noHtml + + +xmlAttrToXhtml :: Attr -> HtmlAttr +xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal |