diff options
37 files changed, 1017 insertions, 691 deletions
@@ -1,9 +1,11 @@ /dist/ /haddock-api/dist/ /haddock-library/dist/ +/haddock-test/dist/ /html-test/out/ /hypsrc-test/out/ /latex-test/out/ +/hoogle-test/out/ /doc/haddock /doc/haddock.ps diff --git a/.travis.yml b/.travis.yml index c16b1709..585b0b25 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,6 +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 && cabal configure && cabal build && cabal install) script: + - export HADDOCK_PATH="dist/build/haddock/haddock" - cabal configure --enable-tests && cabal build && cabal test @@ -46,25 +46,46 @@ 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. 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 - cabal sandbox init - cabal sandbox add-source haddock-library - cabal sandbox add-source haddock-api - # 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 - cabal test ``` +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 +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 + +```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 diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index a9bc9a8b..f3749a85 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -29,6 +29,8 @@ import Data.Char import Data.List import Data.Maybe import Data.Version + +import System.Directory import System.FilePath import System.IO @@ -47,6 +49,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) 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 diff --git a/haddock.cabal b/haddock.cabal index ec2a43bc..294e1526 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -126,24 +126,31 @@ executable haddock test-suite html-test type: exitcode-stdio-1.0 default-language: Haskell2010 - main-is: run.lhs + main-is: Main.hs hs-source-dirs: html-test - build-depends: base, directory, process, filepath, Cabal + build-depends: base, filepath, haddock-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 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 + +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 diff --git a/hoogle-test/Main.hs b/hoogle-test/Main.hs new file mode 100644 index 00000000..c8cda640 --- /dev/null +++ b/hoogle-test/Main.hs @@ -0,0 +1,31 @@ +{-# 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 ++ + [ "--package-name=test" + , "--package-version=0.0.0" + , "--hoogle" + ] + } 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/hoogle-test/run b/hoogle-test/run new file mode 100755 index 00000000..3e72be80 --- /dev/null +++ b/hoogle-test/run @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ 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 diff --git a/html-test/Main.hs b/html-test/Main.hs new file mode 100755 index 00000000..3880fc3c --- /dev/null +++ b/html-test/Main.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} + + +import Data.Char + +import System.Environment +import System.FilePath + +import Test.Haddock +import Test.Haddock.Xhtml + + +checkConfig :: CheckConfig Xml +checkConfig = CheckConfig + { ccfgRead = \mdl input -> stripIfRequired mdl <$> parseXml input + , ccfgDump = dumpXml + , ccfgEqual = (==) + } + + +dirConfig :: DirConfig +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = checkIgnore + } + + +main :: IO () +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ ["--pretty-html", "--html"] + } + + +stripIfRequired :: String -> Xml -> Xml +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"] + + +checkIgnore :: FilePath -> Bool +checkIgnore file@(c:_) | takeExtension file == ".html" && isUpper c = False +checkIgnore _ = True 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/<modulename>.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 <modulename> - -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 = "<a href=\"" in - case stripPrefix prefix str of - Just str' -> prefix ++ stripLinks (dropWhile (/= '"') str') - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs -\end{code} diff --git a/html-test/run b/html-test/run new file mode 100755 index 00000000..3e72be80 --- /dev/null +++ b/html-test/run @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ 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 = "<a href=\"" in - case stripPrefix prefix str of - Just str' -> 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 = "</a" in - case stripPrefix pref s of - Just str' -> 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/Main.hs b/hypsrc-test/Main.hs new file mode 100644 index 00000000..0490be47 --- /dev/null +++ b/hypsrc-test/Main.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} + + +import Data.Char +import Data.List + +import System.Environment +import System.FilePath + +import Test.Haddock +import Test.Haddock.Xhtml + + +checkConfig :: CheckConfig Xml +checkConfig = CheckConfig + { ccfgRead = \_ input -> strip <$> parseXml input + , ccfgDump = dumpXml + , ccfgEqual = (==) + } + where + strip = stripAnchors' . stripLinks' . stripFooter + stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href + stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name + + +dirConfig :: DirConfig +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = checkIgnore + } + + +main :: IO () +main = do + cfg <- parseArgs checkConfig dirConfig =<< getArgs + runAndCheck $ cfg + { cfgHaddockArgs = cfgHaddockArgs cfg ++ + [ "--pretty-html" + , "--hyperlinked-source" + ] + } + + +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 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 "<a name=\"local-" '\"' "0" - -stripLocalLinks :: String -> String -stripLocalLinks = replaceBetween "<a href=\"#local-" '\"' "0" - -stripLocalReferences :: String -> 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 b/hypsrc-test/run new file mode 100755 index 00000000..3e72be80 --- /dev/null +++ b/hypsrc-test/run @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ 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/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/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/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 diff --git a/latex-test/run b/latex-test/run new file mode 100755 index 00000000..3e72be80 --- /dev/null +++ b/latex-test/run @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export HADDOCK_PATH=$(which haddock) +LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" +MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" +runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ 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} |