aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
authorMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-02-24 06:07:33 +0000
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-02-24 06:09:54 +0000
commit1bf686940b28394f5d169f297659cd4c66869ec1 (patch)
treed2107dc6b2a4efd5d482ea11a02faceb31e0f8ac /src/Haddock/Backends/Xhtml
parent6ca276702d04c9183caa98d1848f6aa5b88a8755 (diff)
Fix rendering of Contents when links are present
Fixes Haddock Trac #267.
Diffstat (limited to 'src/Haddock/Backends/Xhtml')
-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
3 files changed, 32 insertions, 18 deletions
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