aboutsummaryrefslogtreecommitdiff
path: root/haddock-test/src/Test/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-test/src/Test/Haddock')
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs286
-rw-r--r--haddock-test/src/Test/Haddock/Process.hs48
-rw-r--r--haddock-test/src/Test/Haddock/Utils.hs50
-rw-r--r--haddock-test/src/Test/Haddock/Xhtml.hs94
4 files changed, 478 insertions, 0 deletions
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
new file mode 100644
index 00000000..cd878178
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -0,0 +1,286 @@
+{-# 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 -> 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"
+
+ (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` [".", ".."]
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-18 04:22:34 +0000