From 1bf686940b28394f5d169f297659cd4c66869ec1 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Mon, 24 Feb 2014 06:07:33 +0000 Subject: Fix rendering of Contents when links are present Fixes Haddock Trac #267. --- src/Haddock/Backends/Xhtml.hs | 9 +++++---- src/Haddock/Backends/Xhtml/Decl.hs | 6 +++--- src/Haddock/Backends/Xhtml/DocMarkup.hs | 25 ++++++++++++++++++------- src/Haddock/Backends/Xhtml/Names.hs | 19 +++++++++++-------- 4 files changed, 37 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 35b82a2c..bdd1afdc 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -625,7 +625,8 @@ ppModuleContents qual exports | lev <= n = ( [], items ) | otherwise = ( html:secs, rest2 ) where - html = linkedAnchor (groupId id0) << docToHtml qual doc +++ mk_subsections ssecs + html = linkedAnchor (groupId id0) + << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs (ssecs, rest1) = process lev rest (secs, rest2) = process n rest1 process n (_ : rest) = process n rest @@ -633,7 +634,6 @@ ppModuleContents qual exports mk_subsections [] = noHtml mk_subsections ss = unordList ss - -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents: numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] @@ -654,10 +654,11 @@ processExport summary _ _ qual (ExportGroup lev id0 doc) processExport summary links unicode qual (ExportDecl decl doc subdocs insts) = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode qual processExport summary _ _ qual (ExportNoDecl y []) - = processDeclOneLiner summary $ ppDocName qual Prefix y + = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ - ppDocName qual Prefix y +++ parenList (map (ppDocName qual Prefix) subs) + ppDocName qual Prefix True y + +++ parenList (map (ppDocName qual Prefix True) subs) processExport summary _ _ qual (ExportDoc doc) = nothingIf summary $ docSection_ qual doc processExport summary _ _ _ (ExportModule mdl) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 2ecde081..9e72d4ad 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -273,7 +273,7 @@ ppDataBinderWithVars summ decl = -- | Print an application of a DocName and two lists of HsTypes (kinds, types) ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> Qualification -> Html ppAppNameTypes n ks ts unicode qual = - ppTypeApp n ks ts (ppDocName qual) (ppParendType unicode qual) + ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) -- | Print an application of a DocName and a list of Names @@ -350,7 +350,7 @@ ppFds fds unicode qual = char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 - ppVars = hsep . map (ppDocName qual Prefix) + ppVars = hsep . map (ppDocName qual Prefix True) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification @@ -732,7 +732,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix name +ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index 69bb94c2..16d771ca 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -14,6 +14,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( docToHtml, rdrDocToHtml, origDocToHtml, + docToHtmlNoAnchors, docElement, docSection, docSection_, ) where @@ -31,13 +32,14 @@ import Data.Maybe (fromMaybe) import GHC -parHtmlMarkup :: Qualification -> (a -> Html) -> DocMarkup a Html -parHtmlMarkup qual ppId = Markup { +parHtmlMarkup :: Qualification -> Bool + -> (Bool -> a -> Html) -> DocMarkup a Html +parHtmlMarkup qual insertAnchors ppId = Markup { markupEmpty = noHtml, markupString = toHtml, markupParagraph = paragraph, markupAppend = (+++), - markupIdentifier = thecode . ppId, + markupIdentifier = thecode . ppId insertAnchors, markupIdentifierUnchecked = thecode . ppUncheckedLink qual, markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModuleRef (mkModuleName mdl) ref, @@ -49,7 +51,11 @@ parHtmlMarkup qual ppId = Markup { markupOrderedList = ordList, markupDefList = defList, markupCodeBlock = pre, - markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel, + markupHyperlink = \(Hyperlink url mLabel) + -> if insertAnchors + then anchor ! [href url] + << fromMaybe url mLabel + else toHtml $ fromMaybe url mLabel, markupAName = \aname -> namedAnchor aname << "", markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), markupProperty = pre . toHtml, @@ -80,17 +86,22 @@ parHtmlMarkup qual ppId = Markup { -- ugly extra whitespace with some browsers). FIXME: Does this still apply? docToHtml :: Qualification -> Doc DocName -> Html docToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual (ppDocName qual Raw) + 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 :: Qualification -> Doc DocName -> Html +docToHtmlNoAnchors qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual False (ppDocName qual Raw) origDocToHtml :: Qualification -> Doc Name -> Html origDocToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual (ppName Raw) + where fmt = parHtmlMarkup qual True (const $ ppName Raw) rdrDocToHtml :: Qualification -> Doc RdrName -> Html rdrDocToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual ppRdrName + where fmt = parHtmlMarkup qual True (const ppRdrName) docElement :: (Html -> Html) -> Html -> Html diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 33cd4f78..cf12da40 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -55,19 +55,19 @@ ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TOD -- The Bool indicates if it is to be rendered in infix notation ppLDocName :: Qualification -> Notation -> Located DocName -> Html -ppLDocName qual notation (L _ d) = ppDocName qual notation d +ppLDocName qual notation (L _ d) = ppDocName qual notation True d -ppDocName :: Qualification -> Notation -> DocName -> Html -ppDocName qual notation docName = +ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html +ppDocName qual notation insertAnchors docName = case docName of Documented name mdl -> - linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual notation name mdl + linkIdOcc mdl (Just (nameOccName name)) insertAnchors + << ppQualifyName qual notation name mdl Undocumented name | isExternalName name || isWiredInName name -> ppQualifyName qual notation name (nameModule name) | otherwise -> ppName notation name - -- | Render a name depending on the selected qualification mode ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html ppQualifyName qual notation name mdl = @@ -136,11 +136,14 @@ wrapInfix notation n = case notation of is_star_kind = isTcOcc n && occNameString n == "*" linkId :: Module -> Maybe Name -> Html -> Html -linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) +linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True -linkIdOcc :: Module -> Maybe OccName -> Html -> Html -linkIdOcc mdl mbName = anchor ! [href url] +linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html +linkIdOcc mdl mbName insertAnchors = + if insertAnchors + then anchor ! [href url] + else id where url = case mbName of Nothing -> moduleUrl mdl -- cgit v1.2.3