Fix small bug

The rule is to prefer type constructors to other things when an identifier in a
doc string can refer to multiple things. This stopped working with newer GHC
versions (due to a tiny change in the GHC renamer). We implement this rule
in the HTML backend for now, instead of fixing it in GHC, since we will move
renaming of doc strings to Haddock in the future anyway. 

1 files changed, 17 insertions, 6 deletions

diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index bd305518..9e01e67d 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -1586,13 +1586,13 @@ ppModule mod ref = anchor ! [href ((moduleHtmlFile mod) ++ ref)]
 -- -----------------------------------------------------------------------------
 -- * Doc Markup
 
-parHtmlMarkup :: (a -> Html) -> DocMarkup a Html
-parHtmlMarkup ppId = Markup {
+parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html
+parHtmlMarkup ppId isTyCon = Markup {
   markupParagraph     = paragraph,
   markupEmpty	      = toHtml "",
   markupString        = toHtml,
   markupAppend        = (+++),
-  markupIdentifier    = tt . ppId . head,
+  markupIdentifier    = tt . ppId . choose,
   markupModule        = \m -> let (mod,ref) = break (=='#') m in ppModule (mkModuleNoPackage mod) ref,
   markupEmphasis      = emphasize . toHtml,
   markupMonospaced    = tt . toHtml,
@@ -1604,12 +1604,23 @@ parHtmlMarkup ppId = Markup {
   markupURL	      = \url -> anchor ! [href url] << toHtml url,
   markupAName	      = \aname -> namedAnchor aname << toHtml ""
   }
+  where
+    -- If an id can refer to multiple things, we give precedence to type
+    -- constructors.  This should ideally be done during renaming from RdrName
+    -- to Name, but since we will move this process from GHC into Haddock in
+    -- the future, we fix it here in the meantime.
+    -- TODO: mention this rule in the documentation.
+    choose [x] = x
+    choose (x:y:_)
+      | isTyCon x = x
+      | otherwise = y
+
 
 markupDef (a,b) = dterm << a +++ ddef << b
 
-htmlMarkup = parHtmlMarkup ppDocName
-htmlOrigMarkup = parHtmlMarkup ppName
-htmlRdrMarkup = parHtmlMarkup ppRdrName
+htmlMarkup = parHtmlMarkup ppDocName (isTyConName . getName)
+htmlOrigMarkup = parHtmlMarkup ppName isTyConName
+htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc
 
 -- If the doc is a single paragraph, don't surround it with <P> (this causes
 -- ugly extra whitespace with some browsers).