diff options
49 files changed, 1130 insertions, 719 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-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 1554a33c..660bbe90 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -522,10 +522,10 @@ ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual - = ppModuleContents qual exports +++ + = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ description +++ synopsis +++ - divInterface (maybe_doc_hdr +++ bdy) + divInterface (maybe_doc_hdr +++ bdy +++ orphans) where exports = numberSectionHeadings (ifaceRnExportItems iface) @@ -564,6 +564,9 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual foldr (+++) noHtml $ mapMaybe (processExport False linksInfo unicode qual) exports + orphans = + ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual + linksInfo = (maybe_source_url, maybe_wiki_url) @@ -604,16 +607,22 @@ ppTyClBinderWithVarsMini mdl decl = ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName -ppModuleContents :: Qualification -> [ExportItem DocName] -> Html -ppModuleContents qual exports - | null sections = noHtml - | otherwise = contentsDiv +ppModuleContents :: Qualification + -> [ExportItem DocName] + -> Bool -- ^ Orphans sections + -> Html +ppModuleContents qual exports orphan + | null sections && not orphan = noHtml + | otherwise = contentsDiv where contentsDiv = divTableOfContents << ( sectionName << "Contents" +++ - unordList sections) + unordList (sections ++ orphanSection)) (sections, _leftovers{-should be []-}) = process 0 exports + orphanSection + | orphan = [ linkedAnchor "section.orphans" << "Orphan instances" ] + | otherwise = [] process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) process _ [] = ([], []) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index e20c9813..a7a0a2d6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -16,7 +16,7 @@ module Haddock.Backends.Xhtml.Decl ( ppDecl, - ppTyName, ppTyFamHeader, ppTypeApp, + ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances, tyvarNames ) where @@ -561,14 +561,32 @@ ppInstances links origin instances splice unicode qual instName = getOccString origin instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = - ((ppInstHead links splice unicode qual mdoc origin no inst), loc) + ((ppInstHead links splice unicode qual mdoc origin False no inst), loc) + + +ppOrphanInstances :: LinksInfo + -> [DocInstance DocName] + -> Splice -> Unicode -> Qualification + -> Html +ppOrphanInstances links instances splice unicode qual + = subOrphanInstances qual links True (zipWith instDecl [1..] instances) + where + instOrigin :: InstHead name -> InstOrigin name + instOrigin inst = OriginClass (ihdClsName inst) + + instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl no (inst, mdoc, loc) = + ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification -> Maybe (MDoc DocName) - -> InstOrigin DocName -> Int -> InstHead DocName + -> InstOrigin DocName + -> Bool -- ^ Is instance orphan + -> Int -- ^ Normal + -> InstHead DocName -> SubDecl -ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = +ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = case ihdInstType of ClassInst { .. } -> ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ @@ -576,7 +594,7 @@ ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) = , [subInstDetails iid ats sigs] ) where - iid = instanceId origin no ihd + iid = instanceId origin no orphan ihd sigs = ppInstanceSigs links splice unicode qual clsiSigs ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys TypeInst rhs -> @@ -618,8 +636,9 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin DocName -> Int -> InstHead DocName -> String -instanceId origin no ihd = concat +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String +instanceId origin no orphan ihd = concat $ + [ "o:" | orphan ] ++ [ qual origin , ":" ++ getOccString origin , ":" ++ (occNameString . getOccName . ihdClsName) ihd diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index d24ed9c4..98df09fe 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -31,7 +31,7 @@ module Haddock.Backends.Xhtml.Layout ( subConstructors, subEquations, subFields, - subInstances, subInstHead, subInstDetails, + subInstances, subOrphanInstances, subInstHead, subInstDetails, subMethods, subMinimal, @@ -200,7 +200,17 @@ subInstances qual nm lnks splice = maybe noHtml wrap . instTable subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm - + +subOrphanInstances :: Qualification + -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Html +subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable + where + wrap = ((h1 << "Orphan instances") +++) + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + id_ = makeAnchorId $ "orphans" + + subInstHead :: String -- ^ Instance unique id (for anchor generation) -> Html -- ^ Header content (instance name and type) -> Html diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index afb5111e..62b0aea9 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -228,7 +228,7 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) foldl' keep_old old_env exported_names | otherwise = foldl' keep_new old_env exported_names where - exported_names = ifaceVisibleExports iface + exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index faf043aa..20971071 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -60,7 +60,18 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces attach iface = do newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) (ifaceExportItems iface) - return $ iface { ifaceExportItems = newItems } + let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface) + return $ iface { ifaceExportItems = newItems + , ifaceOrphanInstances = orphanInstances + } + +attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] +attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = + [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) + | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] + , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is + , not $ isInstanceHidden expInfo cls tys + ] attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c41946f5..6466acfb 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -150,6 +150,8 @@ createInterface tm flags modMap instIfaceMap = do , ifaceModuleAliases = aliases , ifaceInstances = instances , ifaceFamInstances = fam_instances + , ifaceOrphanInstances = [] -- Filled in `attachInstances` + , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap , ifaceTokenizedSrc = tokenizedSrc diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 6ff4b571..0f97ee3b 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -47,13 +47,17 @@ renameInterface dflags renamingEnv warnings iface = (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) - (finalModuleDoc, missingNames4) + (renamedOrphanInstances, missingNames4) + = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface)) + + (finalModuleDoc, missingNames5) = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would - -- otherwise allways be missing. + -- otherwise always be missing. missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much - (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4) + (missingNames1 ++ missingNames2 ++ missingNames3 + ++ missingNames4 ++ missingNames5) -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API. @@ -72,7 +76,8 @@ renameInterface dflags renamingEnv warnings iface = return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap, ifaceRnArgMap = rnArgMap, - ifaceRnExportItems = renamedExportItems } + ifaceRnExportItems = renamedExportItems, + ifaceRnOrphanInstances = renamedOrphanInstances} -------------------------------------------------------------------------------- @@ -560,6 +565,13 @@ renameWc rn_thing (HsWC { hswc_body = thing }) ; return (HsWC { hswc_body = thing' , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) } +renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName) +renameDocInstance (inst, idoc, L l n) = do + inst' <- renameInstHead inst + n' <- rename n + idoc' <- mapM renameDoc idoc + return (inst', idoc',L l n') + renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) @@ -570,11 +582,7 @@ renameExportItem item = case item of decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(inst, idoc, L l n) -> do - inst' <- renameInstHead inst - n' <- rename n - idoc' <- mapM renameDoc idoc - return (inst', idoc',L l n') + instances' <- forM instances renameDocInstance fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b837970b..34e99a8a 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -126,6 +126,10 @@ data Interface = Interface , ifaceInstances :: ![ClsInst] , ifaceFamInstances :: ![FamInst] + -- | Orphan instances + , ifaceOrphanInstances :: ![DocInstance Name] + , ifaceRnOrphanInstances :: ![DocInstance DocName] + -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. , ifaceHaddockCoverage :: !(Int, Int) 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..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 diff --git a/haddock.cabal b/haddock.cabal index 9150e5ac..007d71d5 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/html-test/src/Operators.hs b/html-test/src/Operators.hs index f7b4d0ab..0b633c3f 100644 --- a/html-test/src/Operators.hs +++ b/html-test/src/Operators.hs @@ -1,4 +1,6 @@ {-# LANGUAGE PatternSynonyms, TypeOperators, TypeFamilies, MultiParamTypeClasses, GADTs #-} +{-# LANGUAGE FunctionalDependencies #-} + -- | Test operators with or without fixity declarations module Operators where @@ -42,7 +44,9 @@ data family a ** b infix 9 ** -- | Class with fixity, including associated types -class a ><> b where +class a ><> b | a -> b where + -- Dec 2015: Added @a -> b@ functional dependency to clean up ambiguity + -- See GHC #11264 type a <>< b :: * data a ><< b (>><), (<<>) :: a -> b -> () diff --git a/html-test/src/OrphanInstances.hs b/html-test/src/OrphanInstances.hs new file mode 100644 index 00000000..a005c4a2 --- /dev/null +++ b/html-test/src/OrphanInstances.hs @@ -0,0 +1,7 @@ +module OrphanInstances where + +import OrphanInstancesType +import OrphanInstancesClass + +instance AClass AnotherType where + aClass (AType n) = n diff --git a/html-test/src/OrphanInstancesClass.hs b/html-test/src/OrphanInstancesClass.hs new file mode 100644 index 00000000..4b51acfc --- /dev/null +++ b/html-test/src/OrphanInstancesClass.hs @@ -0,0 +1,4 @@ +module OrphanInstancesClass (AClass(..)) where + +class AClass a where + aClass :: a -> Int diff --git a/html-test/src/OrphanInstancesType.hs b/html-test/src/OrphanInstancesType.hs new file mode 100644 index 00000000..b3c3145e --- /dev/null +++ b/html-test/src/OrphanInstancesType.hs @@ -0,0 +1,3 @@ +module OrphanInstancesType (AType(..)) where + +data AType = AType Int 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} |