Fix rendering of Contents when links are present

Fixes Haddock Trac #267.

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