From 978dbc859df09eb991d9ccc0911276cc9655b783 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 26 Mar 2018 23:35:59 -0700 Subject: @since includes package name (#749) * Metadoc stores a package name This means that '@since' annotations can be package aware. * Get the package name the right way This should extract the package name for `@since` annotations the right way. I had to move `modulePackageInfo` around to do this and, in the process, I took the liberty to update it. Since it appears that finding the package name is something that can fail, I added a warning for this case. * Silence warnings * Hide package for local 'since' annotations As discussed, this is still the usual case (and we should avoid being noisy for it). Although this commit is large, it is basically only about threading a 'Maybe Package' from 'Haddock.render' all the way to 'Haddock.Backends.Xhtml.DocMarkup.renderMeta'. * Bump binary interface version * Add a '--since-qual' option This controls when to qualify since annotations with the package they come from. The default is always, but I've left an 'external' variant where only those annotations coming from outside of the current package are qualified. * Make ParserSpec work * Make Fixtures work * Use package name even if package version is not available The @since stuff needs only the package name passed in, so it makes sense to not be forced to pass in a version too. --- haddock-api/src/Haddock.hs | 72 ++++------ haddock-api/src/Haddock/Backends/Xhtml.hs | 110 +++++++-------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 147 +++++++++++---------- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 50 ++++--- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 57 ++++---- haddock-api/src/Haddock/Interface/Create.hs | 48 ++++--- haddock-api/src/Haddock/Interface/LexParseRn.hs | 21 +-- .../src/Haddock/Interface/ParseModuleHeader.hs | 6 +- haddock-api/src/Haddock/InterfaceFile.hs | 11 +- haddock-api/src/Haddock/Options.hs | 39 +++++- haddock-api/src/Haddock/Parser.hs | 4 +- haddock-api/src/Haddock/Types.hs | 6 + 12 files changed, 319 insertions(+), 252 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index dc903e08..00eb50f6 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -25,7 +25,6 @@ module Haddock ( withGhc ) where -import Data.Version import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Meta import Haddock.Backends.Xhtml.Themes (getThemes) @@ -42,7 +41,6 @@ import Haddock.Options import Haddock.Utils import Control.Monad hiding (forM_) -import Control.Applicative import Data.Foldable (forM_, foldl') import Data.Traversable (for) import Data.List (isPrefixOf) @@ -151,7 +149,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do -- or which exits with an error or help message. (flags, files) <- parseHaddockOpts args shortcutFlags flags - qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} + qual <- rightOrThrowE (qualification flags) + sinceQual <- rightOrThrowE (sinceQualification flags) -- inject dynamic-too into flags before we proceed flags' <- ghc flags $ do @@ -184,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags flags qual packages ifaces + liftIO $ renderStep dflags flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -194,7 +193,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags qual packages [] + liftIO $ renderStep dflags flags sinceQual qual packages [] -- | Create warnings about potential misuse of -optghc warnings :: [String] -> [String] @@ -228,8 +227,9 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags qual pkgs interfaces = do +renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption + -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep dflags flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs @@ -238,12 +238,12 @@ renderStep dflags flags qual pkgs interfaces = do ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - - render dflags flags qual interfaces installedIfaces extSrcMap + render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render dflags flags qual ifaces installedIfaces extSrcMap = do +render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface] + -> [InstalledInterface] -> Map Module FilePath -> IO () +render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -270,6 +270,10 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do pkgKey = moduleUnitId pkgMod pkgStr = Just (unitIdString pkgKey) pkgNameVer = modulePackageInfo dflags flags pkgMod + pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) + sincePkg = case sinceQual of + External -> pkgName + Always -> Nothing (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags @@ -338,7 +342,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ppHtmlContents dflags' odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty - (makeContentsQual qual) + sincePkg (makeContentsQual qual) return () copyHtmlBits odir libDir themes withQuickjump @@ -348,7 +352,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode qual + opt_contents_url opt_index_url unicode sincePkg qual pretty withQuickjump return () copyHtmlBits odir libDir themes withQuickjump @@ -358,7 +362,12 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do case pkgNameVer of - Nothing -> putStrLn . unlines $ + (Just (PackageName pkgNameFS), Just pkgVer) -> + let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title + | otherwise = unpackFS pkgNameFS + in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) + visibleIfaces odir + _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle." , "" @@ -366,14 +375,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ++ " using the --package-name" , " and --package-version arguments." ] - Just (PackageName pkgNameFS, pkgVer) -> - let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title - | otherwise = unpackFS pkgNameFS - in withTiming (pure dflags') "ppHoogle" (const ()) $ do - _ <- {-# SCC ppHoogle #-} - ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) - visibleIfaces odir - return () when (Flag_LaTeX `elem` flags) $ do withTiming (pure dflags') "ppLatex" (const ()) $ do @@ -388,26 +389,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces return () --- | From GHC 7.10, this function has a potential to crash with a --- nasty message such as @expectJust getPackageDetails@ because --- package name and versions can no longer reliably be extracted in --- all cases: if the package is not installed yet then this info is no --- longer available. The @--package-name@ and @--package-version@ --- Haddock flags allow the user to specify this information and it is --- returned here if present: if it is not present, the error will --- occur. Nasty but that's how it is for now. Potential TODO. -modulePackageInfo :: DynFlags - -> [Flag] -- ^ Haddock flags are checked as they may - -- contain the package name or version - -- provided by the user which we - -- prioritise - -> Module -> Maybe (PackageName, Data.Version.Version) -modulePackageInfo dflags flags modu = - cmdline <|> pkgDb - where - cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags - pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu) - ------------------------------------------------------------------------------- -- * Reading and dumping interface files @@ -628,10 +609,15 @@ getPrologue dflags flags = h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! parseParas dflags str + return . Just $! parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" +rightOrThrowE :: Either String b -> IO b +rightOrThrowE (Left msg) = throwE msg +rightOrThrowE (Right x) = pure x + + #ifdef IN_GHC_TREE getInTreeDir :: IO String diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index d03cf0ba..c9a262a4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -70,6 +70,7 @@ ppHtml :: DynFlags -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) + -> Maybe String -- ^ Package name -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> Bool -- ^ Also write Quickjump index @@ -78,7 +79,7 @@ ppHtml :: DynFlags ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode - qual debug withQuickjump = do + pkg qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i @@ -88,7 +89,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents - prologue debug (makeContentsQual qual) + prologue debug pkg (makeContentsQual qual) when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package @@ -96,12 +97,12 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug when withQuickjump $ - ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual visible_ifaces mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces + maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO () @@ -258,11 +259,12 @@ ppHtmlContents -> WikiURLs -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool + -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () ppHtmlContents dflags odir doctitle _maybe_package themes mathjax_url maybe_index_url - maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do + maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do let tree = mkModuleTree dflags showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces @@ -276,41 +278,41 @@ ppHtmlContents dflags odir doctitle _maybe_package bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ - ppPrologue qual doctitle prologue, - ppSignatureTree qual sig_tree, - ppModuleTree qual tree + ppPrologue pkg qual doctitle prologue, + ppSignatureTree pkg qual sig_tree, + ppModuleTree pkg qual tree ] createDirectoryIfMissing True odir writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) -ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html -ppPrologue _ _ Nothing = noHtml -ppPrologue qual title (Just doc) = - divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) +ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html +ppPrologue _ _ _ Nothing = noHtml +ppPrologue pkg qual title (Just doc) = + divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc)) -ppSignatureTree :: Qualification -> [ModuleTree] -> Html -ppSignatureTree qual ts = - divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts) +ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html +ppSignatureTree pkg qual ts = + divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) -ppModuleTree :: Qualification -> [ModuleTree] -> Html -ppModuleTree _ [] = mempty -ppModuleTree qual ts = - divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) +ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html +ppModuleTree _ _ [] = mempty +ppModuleTree pkg qual ts = + divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts) -mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html -mkNodeList qual ss p ts = case ts of +mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html +mkNodeList pkg qual ss p ts = case ts of [] -> noHtml - _ -> unordList (zipWith (mkNode qual ss) ps ts) + _ -> unordList (zipWith (mkNode pkg qual ss) ps ts) where ps = [ p ++ '.' : show i | i <- [(1::Int)..]] -mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf _pkg srcPkg short ts) = +mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html +mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of @@ -330,14 +332,14 @@ mkNode qual ss p (Node s leaf _pkg srcPkg short ts) = Nothing -> toHtml s ) - shortDescr = maybe noHtml (origDocToHtml qual) short + shortDescr = maybe noHtml (origDocToHtml pkg qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg subtree = if null ts then noHtml else collapseDetails p DetailsOpen ( thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++ - mkNodeList qual (s:ss) p ts + mkNodeList pkg qual (s:ss) p ts ) @@ -350,10 +352,11 @@ ppJsonIndex :: FilePath -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) -> Bool + -> Maybe Package -> QualOption -> [Interface] -> IO () -ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do createDirectoryIfMissing True odir IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do Builder.hPutBuilder h (encodeToBuilder modules) @@ -371,7 +374,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value] goExport mdl qual item - | Just item_html <- processExport True links_info unicode qual item + | Just item_html <- processExport True links_info unicode pkg qual item = [ Object [ "display_html" .= String (showHtmlFragment item_html) , "name" .= String (intercalate " " (map nameString names)) @@ -529,11 +532,11 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes -> Maybe String -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> Bool -> QualOption + -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode qual debug iface = do + maybe_contents_url maybe_index_url unicode pkg qual debug iface = do let mdl = ifaceMod iface aliases = ifaceModuleAliases iface @@ -555,7 +558,7 @@ ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), - ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual + ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual ] createDirectoryIfMissing True odir @@ -565,9 +568,9 @@ signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html -ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual - = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual + = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++ description +++ synopsis +++ divInterface (maybe_doc_hdr +++ bdy +++ orphans) @@ -585,7 +588,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual description | isNoHtml doc = doc | otherwise = divDescription $ sectionName << "Description" +++ doc - where doc = docSection Nothing qual (ifaceRnDoc iface) + where doc = docSection Nothing pkg qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis @@ -595,7 +598,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual collapseDetails "syn" DetailsClosed ( thesummary << "Synopsis" +++ shortDeclList ( - mapMaybe (processExport True linksInfo unicode qual) exports + mapMaybe (processExport True linksInfo unicode pkg qual) exports ) ! collapseToggle "syn" "" ) @@ -609,19 +612,20 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual bdy = foldr (+++) noHtml $ - mapMaybe (processExport False linksInfo unicode qual) exports + mapMaybe (processExport False linksInfo unicode pkg qual) exports orphans = - ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual + ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual linksInfo = (maybe_source_url, maybe_wiki_url) -ppModuleContents :: Qualification +ppModuleContents :: Maybe Package -- ^ This package + -> Qualification -> [ExportItem DocNameI] - -> Bool -- ^ Orphans sections + -> Bool -- ^ Orphans sections -> Html -ppModuleContents qual exports orphan +ppModuleContents pkg qual exports orphan | null sections && not orphan = noHtml | otherwise = contentsDiv where @@ -641,7 +645,7 @@ ppModuleContents qual exports orphan | otherwise = ( html:secs, rest2 ) where html = linkedAnchor (groupId id0) - << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs + << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs (ssecs, rest1) = process lev rest (secs, rest2) = process n rest1 process n (_ : rest) = process n rest @@ -661,22 +665,22 @@ numberSectionHeadings = go 1 = other : go n es -processExport :: Bool -> LinksInfo -> Bool -> Qualification +processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances -processExport summary _ _ qual (ExportGroup lev id0 doc) - = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) -processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice) - = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual -processExport summary _ _ qual (ExportNoDecl y []) +processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport summary _ _ pkg qual (ExportGroup lev id0 doc) + = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc) +processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) + = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual +processExport summary _ _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y -processExport summary _ _ qual (ExportNoDecl y subs) +processExport summary _ _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ ppDocName qual Prefix True y +++ parenList (map (ppDocName qual Prefix True) subs) -processExport summary _ _ qual (ExportDoc doc) - = nothingIf summary $ docSection_ Nothing qual doc -processExport summary _ _ _ (ExportModule mdl) +processExport summary _ _ pkg qual (ExportDoc doc) + = nothingIf summary $ docSection_ Nothing pkg qual doc +processExport summary _ _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d92bdd3a..815ecee9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -43,17 +43,18 @@ import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI -> [(HsDecl DocNameI, DocForDecl DocName)] -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)] - -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html -ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode + -> Maybe Package -> Qualification -> Html +ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of + TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual + TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigWcType lty) fixities splice unicode qual + (hsSigWcType lty) fixities splice unicode pkg qual SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - ty fixities splice unicode qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + ty fixities splice unicode pkg qual + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ -> noHtml DerivD _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -61,28 +62,29 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = + Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc doc (map unLoc lnames) lty fixities - splice unicode qual + splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode qual = + Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) - splice unicode qual HideEmptyContexts + splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual + Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice + unicode pkg qual | summary = pref1 | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual) - +++ docSection Nothing qual doc + +++ docSection Nothing pkg qual doc where pref1 = hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames @@ -92,15 +94,15 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> - Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html + Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) - splice unicode qual emptyCtxts = + splice unicode pkg qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) - splice unicode qual emptyCtxts + splice unicode pkg qual emptyCtxts where occnames = map (nameOccName . getName) docnames addFixities html @@ -110,12 +112,14 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI -> DocForDecl DocName -> (Html, Html, Html) - -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts + -> Splice -> Unicode -> Maybe Package -> Qualification + -> HideEmptyContexts -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) + splice unicode pkg qual emptyCtxts | summary = pref1 - | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc + | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc + subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc where curName = getName <$> listToMaybe docnames argDoc n = Map.lookup n argDocs @@ -181,23 +185,23 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] - -> Splice -> Unicode -> Qualification -> Html + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities - splice unicode qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual -ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" + splice unicode pkg qual + = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual +ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI - -> Splice -> Unicode -> Qualification -> Html + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) - splice unicode qual + splice unicode pkg qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) - splice unicode qual ShowEmptyToplevelContexts + splice unicode pkg qual ShowEmptyToplevelContexts where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) @@ -206,7 +210,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars fixs | summary = noHtml | otherwise = ppFixities fixities qual -ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" +ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html @@ -297,11 +301,13 @@ ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> - FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html -ppTyFam summary associated links instances fixities loc doc decl splice unicode qual + FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package -> + Qualification -> Html +ppTyFam summary associated links instances fixities loc doc decl splice unicode + pkg qual | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit + | otherwise = header_ +++ docSection Nothing pkg qual doc +++ instancesBit where docname = unLoc $ fdLName decl @@ -312,10 +318,10 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode instancesBit | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary - = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns + = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise - = ppInstances links (OriginFamily docname) instances splice unicode qual + = ppInstances links (OriginFamily docname) instances splice unicode pkg qual -- Individual equation of a closed type family ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl @@ -343,9 +349,10 @@ ppPseudoFamilyDecl links splice unicode qual ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI - -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppAssocType summ links doc (L loc decl) fixities splice unicode qual = - ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual + -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package + -> Qualification -> Html +ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = + ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual -------------------------------------------------------------------------------- @@ -454,22 +461,22 @@ ppFds fds unicode qual = ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan -> [(DocName, DocForDecl DocName)] - -> Splice -> Unicode -> Qualification -> Html + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc - subdocs splice unicode qual = + subdocs splice unicode pkg qual = if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False ( - [ ppAssocType summary links doc at [] splice unicode qual | at <- ats + [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ -- ToDo: add associated type defaults [ ppFunSig summary links loc doc names (hsSigWcType typ) - [] splice unicode qual + [] splice unicode pkg qual | L _ (TypeSig lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] @@ -480,20 +487,20 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual nm = unLoc lname -ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppShortClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI - -> Splice -> Unicode -> Qualification -> Html + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) - splice unicode qual - | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual - | otherwise = classheader +++ docSection Nothing qual d + splice unicode pkg qual + | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual + | otherwise = classheader +++ docSection Nothing pkg qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where sigs = map unLoc lsigs @@ -510,14 +517,14 @@ ppClassDecl summary links instances fixities loc d subdocs hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual + atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual | at <- ats , let n = unL . fdLName $ unL at doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) - subfixs splice unicode qual + subfixs splice unicode pkg qual | L _ (ClassOpSig _ lnames typ) <- lsigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name subdocs @@ -551,17 +558,17 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Parens x) = ppMinimal p (unLoc x) instancesBit = ppInstances links (OriginClass nm) instances - splice unicode qual + splice unicode pkg qual -ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppInstances :: LinksInfo -> InstOrigin DocName -> [DocInstance DocNameI] - -> Splice -> Unicode -> Qualification + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppInstances links origin instances splice unicode qual - = subInstances qual instName links True (zipWith instDecl [1..] instances) +ppInstances links origin instances splice unicode pkg qual + = subInstances pkg qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where instName = getOccString origin @@ -572,10 +579,10 @@ ppInstances links origin instances splice unicode qual ppOrphanInstances :: LinksInfo -> [DocInstance DocNameI] - -> Splice -> Unicode -> Qualification + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppOrphanInstances links instances splice unicode qual - = subOrphanInstances qual links True (zipWith instDecl [1..] instances) +ppOrphanInstances links instances splice unicode pkg qual + = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances) where instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) @@ -713,12 +720,12 @@ ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] [(DocName, DocForDecl DocName)] -> SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> [(HsDecl DocNameI, DocForDecl DocName)] -> - Splice -> Unicode -> Qualification -> Html + Splice -> Unicode -> Maybe Package -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats - splice unicode qual + splice unicode pkg qual | summary = ppShortDataDecl summary False dataDecl pats unicode qual - | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit + | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdName dataDecl @@ -738,14 +745,14 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats | null cons = keyword "where" | otherwise = if isH98 then noHtml else keyword "where" - constrBit = subConstructors qual - [ ppSideBySideConstr subdocs subfixs unicode qual c + constrBit = subConstructors pkg qual + [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc (getConNames (unLoc c)))) fixities ] - patternBit = subPatterns qual + patternBit = subPatterns pkg qual [ (hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode @@ -757,7 +764,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats ] instancesBit = ppInstances links (OriginData docname) instances - splice unicode qual + splice unicode pkg qual @@ -824,8 +831,8 @@ ppConstrHdr forall_ tvs ctxt unicode qual | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) + -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl +ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) = (decl, mbDoc, fieldPart) where decl = case con of @@ -851,7 +858,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) RecCon (L _ fields) -> [doRecordFields fields] _ -> [] - doRecordFields fields = subFields qual + doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) doGADTCon :: Located (HsType DocNameI) -> Html diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 2990e1e4..ed323a90 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -171,10 +171,10 @@ flatten x = [x] -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. -hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html -hackMarkup fmt' h' = +hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html +hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' - in html +++ renderMeta fmt' (metaConcat ms) + in html +++ renderMeta fmt' currPkg (metaConcat ms) where hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> (Html, [Meta]) @@ -193,45 +193,50 @@ hackMarkup fmt' h' = (y, m') = hackMarkup' fmt d' in (markupAppend fmt x y, m ++ m') -renderMeta :: DocMarkup id Html -> Meta -> Html -renderMeta fmt (Meta { _version = Just x }) = +renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html +renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) = markupParagraph fmt . markupEmphasis fmt . toHtml $ - "Since: " ++ formatVersion x + "Since: " ++ formatPkgMaybe pkg ++ formatVersion x where formatVersion v = concat . intersperse "." $ map show v -renderMeta _ _ = noHtml + formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-" + formatPkgMaybe _ = "" +renderMeta _ _ _ = noHtml -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first. markupHacked :: DocMarkup id Html + -> Maybe Package -- this package -> Maybe String -> MDoc id -> Html -markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten +markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten -- If the doc is a single paragraph, don't surround it with

(this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply? -docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See - -- comments on 'toHack' for details. +docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See + -- comments on 'toHack' for details. + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docToHtml n qual = markupHacked fmt n . cleanup +docToHtml n pkg qual = markupHacked fmt pkg n . cleanup where fmt = parHtmlMarkup qual True (ppDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. -docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' +docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup +docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup where fmt = parHtmlMarkup qual False (ppDocName qual Raw) -origDocToHtml :: Qualification -> MDoc Name -> Html -origDocToHtml qual = markupHacked fmt Nothing . cleanup +origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html +origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup where fmt = parHtmlMarkup qual True (const $ ppName Raw) -rdrDocToHtml :: Qualification -> MDoc RdrName -> Html -rdrDocToHtml qual = markupHacked fmt Nothing . cleanup +rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html +rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup where fmt = parHtmlMarkup qual True (const ppRdrName) @@ -243,14 +248,17 @@ docElement el content_ = docSection :: Maybe Name -- ^ Name of the thing this doc is for + -> Maybe Package -- ^ Current package -> Qualification -> Documentation DocName -> Html -docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation +docSection n pkg qual = + maybe noHtml (docSection_ n pkg qual) . combineDocumentation -docSection_ :: Maybe Name -- ^ Name of the thing this doc is for +docSection_ :: Maybe Name -- ^ Name of the thing this doc is for + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docSection_ n qual = - (docElement thediv <<) . docToHtml (getOccString <$> n) qual +docSection_ n pkg qual = + (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual cleanup :: MDoc a -> MDoc a diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 217ca2af..501caa4b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -128,38 +128,39 @@ divSubDecls cssClass captionName = maybe noHtml wrap subCaption = paragraph ! [theclass "caption"] << captionName -subDlist :: Qualification -> [SubDecl] -> Maybe Html -subDlist _ [] = Nothing -subDlist qual decls = Just $ ulist << map subEntry decls +subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html +subDlist _ _ [] = Nothing +subDlist pkg qual decls = Just $ ulist << map subEntry decls where subEntry (decl, mdoc, subs) = li << (define ! [theclass "src"] << decl +++ - docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs)) + docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs)) -subTable :: Qualification -> [SubDecl] -> Maybe Html -subTable _ [] = Nothing -subTable qual decls = Just $ table << aboves (concatMap subRow decls) +subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html +subTable _ _ [] = Nothing +subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls) where subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <-> - docElement td << fmap (docToHtml Nothing qual) mdoc) + docElement td << fmap (docToHtml Nothing pkg qual) mdoc) : map (cell . (td <<)) subs -- | Sub table with source information (optional). -subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html -subTableSrc _ _ _ [] = Nothing -subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) +subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Maybe Html +subTableSrc _ _ _ _ [] = Nothing +subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where subRow ((decl, mdoc, subs),L loc dn) = (td ! [theclass "src clearfix"] << (thespan ! [theclass "inst-left"] << decl) <+> linkHtml loc dn <-> - docElement td << fmap (docToHtml Nothing qual) mdoc + docElement td << fmap (docToHtml Nothing pkg qual) mdoc ) : map (cell . (td <<)) subs linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn @@ -170,49 +171,49 @@ subBlock [] = Nothing subBlock hs = Just $ toHtml hs -subArguments :: Qualification -> [SubDecl] -> Html -subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual +subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html +subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual subAssociatedTypes :: [Html] -> Html subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock -subConstructors :: Qualification -> [SubDecl] -> Html -subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual +subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html +subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual -subPatterns :: Qualification -> [SubDecl] -> Html -subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual +subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html +subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual -subFields :: Qualification -> [SubDecl] -> Html -subFields qual = divSubDecls "fields" "Fields" . subDlist qual +subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html +subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual -subEquations :: Qualification -> [SubDecl] -> Html -subEquations qual = divSubDecls "equations" "Equations" . subTable qual +subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html +subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual -- | Generate sub table for instance declarations, with source -subInstances :: Qualification +subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Html -subInstances qual nm lnks splice = maybe noHtml wrap . instTable +subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents)) - instTable = subTableSrc qual lnks splice + instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] summary = thesummary << "Instances" id_ = makeAnchorId $ "i:" ++ nm -subOrphanInstances :: Qualification +subOrphanInstances :: Maybe Package -> Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Html -subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable +subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice + instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice id_ = makeAnchorId $ "orphans" diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index deef7ad3..a35e2053 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -46,7 +46,6 @@ import Data.Traversable import Avail hiding (avail) import qualified Avail -import qualified Packages import qualified Module import qualified SrcLoc import ConLike (ConLike(..)) @@ -55,13 +54,14 @@ import HscTypes import Name import NameSet import NameEnv +import Packages ( lookupModuleInAllPackages, PackageName(..) ) import Bag import RdrName import TcRnTypes -import FastString (concatFS) +import FastString ( concatFS, unpackFS ) import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O -import HsDecls ( getConDetails ) +import HsDecls ( getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -85,12 +85,22 @@ createInterface tm flags modMap instIfaceMap = do !instances = modInfoInstances mi !fam_instances = md_fam_insts md !exportedNames = modInfoExportsWithSelectors mi + (pkgNameFS, _) = modulePackageInfo dflags flags mdl + pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings , tcg_exports = all_exports }, md) = tm_internals_ tm + -- The 'pkgName' is necessary to decide what package to mention in "@since" + -- annotations. Not having it is not fatal though. + -- + -- Cabal can be trusted to pass the right flags, so this warning should be + -- mostly encountered when running Haddock outside of Cabal. + when (isNothing pkgName) $ + liftErrMsg $ tell [ "Warning: Package name is not available." ] + -- The renamed source should always be available to us, but it's best -- to be on the safe side. (group_, imports, mayExports, mayDocHeader) <- @@ -103,7 +113,7 @@ createInterface tm flags modMap instIfaceMap = do opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl -- Process the top-level module header documentation. - (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader + (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader let declsWithDocs = topDecls group_ @@ -130,13 +140,13 @@ createInterface tm flags modMap instIfaceMap = do warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) maps@(!docMap, !argMap, !declMap, _) <- - liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) + liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs) let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. - exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre + exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre exportedNames decls maps fixMap unrestrictedImportedMods splices exports all_exports instIfaceMap dflags @@ -190,6 +200,7 @@ createInterface tm flags modMap instIfaceMap = do , ifaceTokenizedSrc = tokenizedSrc } + -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This @@ -266,7 +277,7 @@ lookupModuleDyn :: lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = - case Packages.lookupModuleInAllPackages dflags mdlName of + case lookupModuleInAllPackages dflags mdlName of (m,_):_ -> m [] -> Module.mkModule Module.mainUnitId mdlName @@ -346,11 +357,12 @@ type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap) -- find its names, its subordinates, and its doc strings. Process doc strings -- into 'Doc's. mkMaps :: DynFlags + -> Maybe Package -- this package -> GlobalRdrEnv -> [Name] -> [(LHsDecl GhcRn, [HsDocString])] -> ErrMsgM Maps -mkMaps dflags gre instances decls = do +mkMaps dflags pkgName gre instances decls = do (a, b, c) <- unzip3 <$> traverse mappings decls pure ( f' (map (nubByName fst) a) , f (filterMapping (not . M.null) b) @@ -377,8 +389,8 @@ mkMaps dflags gre instances decls = do declDoc :: [HsDocString] -> Map Int HsDocString -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = do - doc' <- processDocStrings dflags gre strs - m' <- traverse (processDocStringParas dflags gre) m + doc' <- processDocStrings dflags pkgName gre strs + m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') (doc, args) <- declDoc docStrs (typeDocs decl) @@ -605,12 +617,13 @@ collectDocs = go Nothing [] mkExportItems :: Bool -- is it a signature -> IfaceMap + -> Maybe Package -- this package -> Module -- this module -> Module -- semantic module -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl GhcRn] -- renamed source declarations + -> [LHsDecl GhcRn] -- renamed source declarations -> Maps -> FixMap -> M.Map ModuleName [ModuleName] @@ -621,12 +634,12 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem GhcRn] mkExportItems - is_sig modMap thisMod semMod warnings gre exportedNames decls + is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap unrestricted_imp_mods splices exportList allExports instIfaceMap dflags = case exportList of Nothing -> - fullModuleContents is_sig modMap thisMod semMod warnings gre + fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap splices instIfaceMap dflags allExports Just exports -> liftM concat $ mapM lookupExport exports @@ -636,14 +649,14 @@ mkExportItems return [ExportGroup lev "" doc] lookupExport (IEDoc docStr, _) = liftErrMsg $ do - doc <- processDocStringParas dflags gre docStr + doc <- processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] lookupExport (IEDocNamed str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do - doc <- processDocStringParas dflags gre docStr + doc <- processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] lookupExport (IEModuleContents (L _ mod_name), _) @@ -962,6 +975,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = fullModuleContents :: Bool -- is it a signature -> IfaceMap + -> Maybe Package -- this package -> Module -- this module -> Module -- semantic module -> WarningMap @@ -975,7 +989,7 @@ fullModuleContents :: Bool -- is it a signature -> DynFlags -> Avails -> ErrMsgGhc [ExportItem GhcRn] -fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames +fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do let availEnv = availsToNameEnv (nubAvails avails) (concat . concat) `fmap` (for decls $ \decl -> do @@ -984,7 +998,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames doc <- liftErrMsg (processDocString dflags gre docStr) return [[ExportGroup lev "" doc]] (L _ (DocD (DocCommentNamed _ docStr))) -> do - doc <- liftErrMsg (processDocStringParas dflags gre docStr) + doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) return [[ExportDoc doc]] (L _ (ValD valDecl)) | name:_ <- collectHsBindBinders valDecl diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 1269df3f..9a978f9f 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -33,34 +33,35 @@ import RdrName import EnumSet import RnEnv (dataTcOccs) -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] +processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) -processDocStrings dflags gre strs = do - mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs +processDocStrings dflags pkg gre strs = do + mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs case mdoc of -- We check that we don't have any version info to render instead -- of just checking if there is no comment: there may not be a -- comment but we still want to pass through any meta data. - MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing + MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) -processDocStringParas dflags gre (HsDocString fs) = - overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs) +processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString + -> ErrMsgM (MDoc Name) +processDocStringParas dflags pkg gre (HsDocString fs) = + overDocF (rename dflags gre) $ parseParas dflags pkg (unpackFS fs) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre (HsDocString fs) = rename dflags gre $ parseString dflags (unpackFS fs) -processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString +processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) -processModuleHeader dflags gre safety mayStr = do +processModuleHeader dflags pkgName gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs - (hmi, doc) = parseModuleHeader dflags str + (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr Nothing -> pure Nothing diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 6690c22d..050901b6 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -24,8 +24,8 @@ import RdrName -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName) -parseModuleHeader dflags str0 = +parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) +parseModuleHeader dflags pkgName str0 = let getKey :: String -> String -> (Maybe String,String) getKey key str = case parseKey key str of @@ -52,7 +52,7 @@ parseModuleHeader dflags str0 = hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags str9) + }, parseParas dflags pkgName str9) -- | This function is how we read keys. -- diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index bbd8d04e..d5bbce2c 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805) -binaryInterfaceVersion = 32 +binaryInterfaceVersion = 33 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -486,8 +486,13 @@ instance Binary a => Binary (TableCell a) where return (TableCell i j c) instance Binary Meta where - put_ bh Meta { _version = v } = put_ bh v - get bh = (\v -> Meta { _version = v }) <$> get bh + put_ bh (Meta v p) = do + put_ bh v + put_ bh p + get bh = do + v <- get bh + p <- get bh + return (Meta v p) instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where put_ bh MetaDoc { _meta = m, _doc = d } = do diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 0609aa63..b5e987d8 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -29,19 +29,23 @@ module Haddock.Options ( optLaTeXStyle, optMathjax, qualification, + sinceQualification, verbosity, ghcFlags, reexportFlags, readIfaceArgs, optPackageName, - optPackageVersion + optPackageVersion, + modulePackageInfo ) where import qualified Data.Char as Char import Data.Version +import Control.Applicative import Distribution.Verbosity import FastString +import GHC ( DynFlags, Module, moduleUnitId ) import Haddock.Types import Haddock.Utils import Packages @@ -103,6 +107,7 @@ data Flag | Flag_PackageName String | Flag_PackageVersion String | Flag_Reexport String + | Flag_SinceQualification String deriving (Eq, Show) @@ -210,7 +215,9 @@ options backwardsCompat = Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") "name of the package being documented", Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") - "version of the package being documented in usual x.y.z.w format" + "version of the package being documented in usual x.y.z.w format", + Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL") + "package qualification of @since, one of\n'always' (default) or 'only-external'" ] @@ -310,6 +317,14 @@ qualification flags = [arg] -> Left $ "unknown qualification type " ++ show arg _:_ -> Left "qualification option given multiple times" +sinceQualification :: [Flag] -> Either String SinceQual +sinceQualification flags = + case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of + [] -> Right Always + ["always"] -> Right Always + ["external"] -> Right External + [arg] -> Left $ "unknown since-qualification type " ++ show arg + _:_ -> Left "since-qualification option given multiple times" verbosity :: [Flag] -> Verbosity verbosity flags = @@ -344,3 +359,23 @@ readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] optLast :: [a] -> Maybe a optLast [] = Nothing optLast xs = Just (last xs) + + +-- | This function has a potential to return 'Nothing' because package name and +-- versions can no longer reliably be extracted in all cases: if the package is +-- not installed yet then this info is no longer available. +-- +-- The @--package-name@ and @--package-version@ Haddock flags allow the user to +-- specify this information manually and it is returned here if present. +modulePackageInfo :: DynFlags + -> [Flag] -- ^ Haddock flags are checked as they may contain + -- the package name or version provided by the user + -- which we prioritise + -> Module + -> (Maybe PackageName, Maybe Data.Version.Version) +modulePackageInfo dflags flags modu = + ( optPackageName flags <|> fmap packageName pkgDb + , optPackageVersion flags <|> fmap packageVersion pkgDb + ) + where + pkgDb = lookupPackage dflags (moduleUnitId modu) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 47bf814b..58500f1b 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -28,8 +28,8 @@ import RdrName (RdrName) import SrcLoc (mkRealSrcLoc, unLoc) import StringBuffer (stringToStringBuffer) -parseParas :: DynFlags -> String -> MetaDoc mod RdrName -parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName +parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p parseString :: DynFlags -> String -> DocH mod RdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 2810862f..36ed7baf 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -578,6 +578,12 @@ data HideEmptyContexts = HideEmptyContexts | ShowEmptyToplevelContexts +-- | When to qualify @since@ annotations with their package +data SinceQual + = Always + | External -- ^ only qualify when the thing being annotated is from + -- an external package + ----------------------------------------------------------------------------- -- * Error handling ----------------------------------------------------------------------------- -- cgit v1.2.3