aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Backends/Xhtml.hs9
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs6
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs25
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs19
4 files changed, 37 insertions, 22 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 00:09:29 +0000