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/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 ++++---- 4 files changed, 192 insertions(+), 172 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') 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" -- cgit v1.2.3