haddock-test (empty) → 0.0.1
raw patch · 7 files changed
+692/−0 lines, 7 filesdep +Cabaldep +basedep +bytestringsetup-changed
Dependencies added: Cabal, base, bytestring, directory, filepath, process, syb, xhtml, xml
Files
- Setup.lhs +3/−0
- haddock-test.cabal +28/−0
- src/Test/Haddock.hs +178/−0
- src/Test/Haddock/Config.hs +290/−0
- src/Test/Haddock/Process.hs +49/−0
- src/Test/Haddock/Utils.hs +50/−0
- src/Test/Haddock/Xhtml.hs +94/−0
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ haddock-test.cabal view
@@ -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 >= 4.3 && < 4.10, bytestring, 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
+ src/Test/Haddock.hs view
@@ -0,0 +1,178 @@+{-# 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 qualified Data.ByteString.Char8 as BS++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+ let pc = processConfig+ { pcArgs = concat+ [ cfgHaddockArgs+ , pure $ "--odir=" ++ outDir cfgDirConfig tpkg+ , tpkgFiles tpkg+ ]+ , pcEnv = Just $ cfgEnv+ , pcStdOut = Just $ haddockStdOut+ }+ handle <- runProcess' cfgHaddockPath pc+ 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 <- readOut cfg file+ mref <- readRef cfg 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++-- We use ByteString here to ensure that no lazy I/O is performed.+-- This way to ensure that the reference file isn't held open in+-- case after `diffFile` (which is problematic if we need to rewrite+-- the reference file in `maybeAcceptFile`)++-- | Read the reference artifact for a test+readRef :: Config c -> FilePath -> IO (Maybe c)+readRef cfg file =+ ccfgRead ccfg . BS.unpack+ <$> BS.readFile (refFile dcfg file)+ where+ ccfg = cfgCheckConfig cfg+ dcfg = cfgDirConfig cfg++-- | Read (and clean) the test output artifact for a test+readOut :: Config c -> FilePath -> IO (Maybe c)+readOut cfg file =+ fmap (ccfgClean ccfg file) . ccfgRead ccfg . BS.unpack+ <$> BS.readFile (outFile dcfg file)+ where+ ccfg = cfgCheckConfig cfg+ dcfg = cfgDirConfig cfg+++diffFile :: Config c -> FilePath -> FilePath -> IO ()+diffFile cfg diff file = do+ Just out <- readOut cfg file+ Just ref <- readRef cfg 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 file result+ | cfgAccept cfg && result `elem` [NoRef, Fail] = do+ Just out <- readOut cfg file+ writeFile (refFile dcfg file) $ ccfgDump ccfg out+ pure Accepted+ where+ dcfg = cfgDirConfig cfg+ ccfg = cfgCheckConfig cfg+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
+ src/Test/Haddock/Config.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++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 -> Maybe c+ -- ^ @f contents@ parses file contents @contents@ to+ -- produce a thing to be compared.+ , ccfgClean :: String -> c -> c+ -- ^ @f fname x@ cleans @x@ to such that it can be compared+ , 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"++ (comp, _, cfg) <- configure normal (Just ghcPath) Nothing+ defaultProgramConfiguration+#if MIN_VERSION_Cabal(1,23,0)+ pkgIndex <- getInstalledPackages normal comp [GlobalPackageDB] cfg+#else+ pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg+#endif+ 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` [".", ".."]
+ src/Test/Haddock/Process.hs view
@@ -0,0 +1,49 @@+{-# 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+ }+ deriving (Show)+++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
+ src/Test/Haddock/Utils.hs view
@@ -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
+ src/Test/Haddock/Xhtml.hs view
@@ -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