Give preference to type over data constructors for doc comment links at renaming time.

Previously this was done in the backends.

Also, warn when a doc comment refers to something that is in scope but which we
don't have the .haddock file for.

These changes mean we can make DocIdentifier [a] into DocIdentifier a.

9 files changed, 38 insertions, 65 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 45399963..ed8d4665 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -232,7 +232,7 @@ markupTag = Markup {
   markupEmpty         = str "",
   markupString        = str,
   markupAppend        = (++),
-  markupIdentifier    = box (TagInline "a") . str . out . head,
+  markupIdentifier    = box (TagInline "a") . str . out,
   markupModule        = box (TagInline "a") . str,
   markupEmphasis      = box (TagInline "i"),
   markupMonospaced    = box (TagInline "tt"),
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 5c21f0cf..fc313888 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -22,8 +22,8 @@ import qualified Pretty
 
 import GHC
 import OccName
-import Name                 ( isTyConName, nameOccName )
-import RdrName              ( rdrNameOcc, isRdrTc )
+import Name                 ( nameOccName )
+import RdrName              ( rdrNameOcc )
 import BasicTypes           ( ipNameName )
 import FastString           ( unpackFS, unpackLitString )
 
@@ -997,9 +997,8 @@ latexMonoMunge c   s = latexMunge c s
 -------------------------------------------------------------------------------
 
 
-parLatexMarkup :: (a -> LaTeX) -> (a -> Bool)
-               -> DocMarkup a (StringContext -> LaTeX)
-parLatexMarkup ppId isTyCon = Markup {
+parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)
+parLatexMarkup ppId = Markup {
   markupParagraph     = \p v -> p v <> text "\\par" $$ text "",
   markupEmpty         = \_ -> empty,
   markupString        = \s v -> text (fixString v s),
@@ -1027,26 +1026,15 @@ parLatexMarkup ppId isTyCon = Markup {
         Verb  -> theid
         Mono  -> theid
         Plain -> text "\\haddockid" <> braces theid
-      where theid = ppId (choose id)
-
-    -- 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 [] = error "empty identifier list in HsDoc"
-    choose [x] = x
-    choose (x:y:_)
-      | isTyCon x = x
-      | otherwise = y
+      where theid = ppId id
 
 
 latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
-latexMarkup = parLatexMarkup ppVerbDocName (isTyConName . getName)
+latexMarkup = parLatexMarkup ppVerbDocName
 
 
 rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
-rdrLatexMarkup = parLatexMarkup ppVerbRdrName isRdrTc
+rdrLatexMarkup = parLatexMarkup ppVerbRdrName
 
 
 docToLaTeX :: Doc DocName -> LaTeX
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 93536834..05ce7dbb 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -28,17 +28,15 @@ import Haddock.Utils
 import Text.XHtml hiding ( name, title, p, quote )
 
 import GHC
-import Name
-import RdrName
 
 
-parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html
-parHtmlMarkup ppId isTyCon = Markup {
+parHtmlMarkup :: (a -> Html) -> DocMarkup a Html
+parHtmlMarkup ppId = Markup {
   markupEmpty         = noHtml,
   markupString        = toHtml,
   markupParagraph     = paragraph,
   markupAppend        = (+++),
-  markupIdentifier    = thecode . ppId . choose,
+  markupIdentifier    = thecode . ppId,
   markupModule        = \m -> let (mdl,ref) = break (=='#') m
                               in ppModuleRef (mkModuleNoPackage mdl) ref,
   markupEmphasis      = emphasize,
@@ -53,17 +51,6 @@ parHtmlMarkup ppId isTyCon = Markup {
   markupExample       = examplesToHtml
   }
   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 [] = error "empty identifier list in HsDoc"
-    choose [x] = x
-    choose (x:y:_)
-      | isTyCon x = x
-      | otherwise = y
-
     examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
 
     exampleToHtml (Example expression result) = htmlExample
@@ -77,17 +64,17 @@ parHtmlMarkup ppId isTyCon = 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 (ppDocName qual) (isTyConName . getName)
+  where fmt = parHtmlMarkup (ppDocName qual)
 
 
 origDocToHtml :: Doc Name -> Html
 origDocToHtml = markup fmt . cleanup
-  where fmt = parHtmlMarkup ppName isTyConName
+  where fmt = parHtmlMarkup ppName
 
 
 rdrDocToHtml :: Doc RdrName -> Html
 rdrDocToHtml = markup fmt . cleanup
-  where fmt = parHtmlMarkup ppRdrName isRdrTc
+  where fmt = parHtmlMarkup ppRdrName
 
 
 docElement :: (Html -> Html) -> Html -> Html
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 88e64cfa..2c10146d 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -58,7 +58,7 @@ renameInterface renamingEnv warnings iface =
 
       -- combine the missing names and filter out the built-ins, which would
       -- otherwise allways be missing.
-      missingNames = nub $ filter isExternalName
+      missingNames = nub $ filter isExternalName  -- XXX: isExternalName filters out too much
                     (missingNames1 ++ missingNames2 ++ missingNames3)
 
       -- filter out certain built in type constructors using their string
@@ -171,11 +171,9 @@ renameDoc d = case d of
   DocParagraph doc -> do
     doc' <- renameDoc doc
     return (DocParagraph doc')
-  DocIdentifier ids -> do
-    lkp <- getLookupRn
-    case [ n | (True, n) <- map lkp ids ] of
-      ids'@(_:_) -> return (DocIdentifier ids')
-      [] -> return (DocIdentifier (map Undocumented ids))
+  DocIdentifier x -> do
+    x' <- rename x
+    return (DocIdentifier x')
   DocModule str -> return (DocModule str)
   DocEmphasis doc -> do
     doc' <- renameDoc doc
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
index d63524b6..57704db7 100644
--- a/src/Haddock/Interface/Rn.hs
+++ b/src/Haddock/Interface/Rn.hs
@@ -5,7 +5,7 @@ import Haddock.Types
 import RnEnv       ( dataTcOccs )
 
 import RdrName     ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName )
-import Name        ( Name )
+import Name        ( Name, isTyConName )
 import Outputable  ( ppr, showSDoc )
 
 rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
@@ -13,10 +13,6 @@ rnHaddockModInfo gre hmod =
   let desc = hmi_description hmod
   in hmod { hmi_description = fmap (rnDoc gre) desc }
 
-ids2string :: [RdrName] -> String
-ids2string []    = []
-ids2string (x:_) = showSDoc $ ppr x
-
 data Id x = Id {unId::x}
 instance Monad Id where (Id v)>>=f = f v; return = Id
 
@@ -38,13 +34,16 @@ rnDoc gre = unId . do_rn
     doc' <- do_rn doc
     return (DocParagraph doc')
 
-  DocIdentifier ids -> do
-    let choices = concatMap dataTcOccs ids
+  DocIdentifier x -> do
+    let choices = dataTcOccs x
     let gres = concatMap (\rdrName ->
                  map gre_name (lookupGRE_RdrName rdrName gre)) choices
-    case gres of
-      []   -> return (DocMonospaced (DocString (ids2string ids)))
-      ids' -> return (DocIdentifier ids')
+    return $ case gres of
+      []   -> DocMonospaced (DocString (showSDoc $ ppr x))  -- TODO: DocIdentifierRdrName
+      [a]  -> DocIdentifier a
+      a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
+        -- If an id can refer to multiple things, we give precedence to type
+        -- constructors.
 
   DocModule str -> return (DocModule str)
 
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index 64f8baab..c1b54b1b 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -65,9 +65,9 @@ binaryInterfaceMagic = 0xD0Cface
 -- we version our interface files accordingly.
 binaryInterfaceVersion :: Word16
 #if __GLASGOW_HASKELL__ == 702
-binaryInterfaceVersion = 17
+binaryInterfaceVersion = 18
 #elif __GLASGOW_HASKELL__ == 703
-binaryInterfaceVersion = 17
+binaryInterfaceVersion = 18
 #else
 #error Unknown GHC version
 #endif
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index 153f6677..f65aee8c 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -121,7 +121,7 @@ data Token
   | TokDefStart
   | TokDefEnd
   | TokSpecial Char
-  | TokIdent [RdrName]
+  | TokIdent RdrName
   | TokString String
   | TokURL String
   | TokPic String
@@ -209,7 +209,7 @@ begin sc = \_ _ _ cont _ -> cont sc
 
 ident :: Action
 ident pos str sc cont dflags = 
-  case strToHsQNames dflags loc id of
+  case parseIdent dflags loc id of
 	Just names -> (TokIdent names, pos) : cont sc
 	Nothing -> (TokString str, pos) : cont sc
  where id = init (tail str)
@@ -220,12 +220,12 @@ ident pos str sc cont dflags =
              AlexPn _ line col ->
                  mkRealSrcLoc filename line col
 
-strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName]
-strToHsQNames dflags loc str0 = 
+parseIdent :: DynFlags -> RealSrcLoc -> String -> Maybe RdrName
+parseIdent dflags loc str0 = 
   let buffer = stringToStringBuffer str0
       pstate = mkPState dflags buffer loc
       result = unP parseIdentifier pstate 
   in case result of 
-       POk _ name -> Just [unLoc name] 
+       POk _ name -> Just (unLoc name)
        _ -> Nothing
 }
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index c9b29bd0..4989a067 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -275,7 +275,8 @@ data Doc id
   | DocAppend (Doc id) (Doc id)
   | DocString String
   | DocParagraph (Doc id)
-  | DocIdentifier [id]
+  | DocIdentifier id
+--  | DocIdentifierOutOfScope [RdrName]
   | DocModule String
   | DocEmphasis (Doc id)
   | DocMonospaced (Doc id)
@@ -310,7 +311,7 @@ data DocMarkup id a = Markup
   , markupString        :: String -> a
   , markupParagraph     :: a -> a
   , markupAppend        :: a -> a -> a
-  , markupIdentifier    :: [id] -> a
+  , markupIdentifier    :: id -> a
   , markupModule        :: String -> a
   , markupEmphasis      :: a -> a
   , markupMonospaced    :: a -> a
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 20598263..478025d8 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -384,7 +384,7 @@ markup m DocEmpty              = markupEmpty m
 markup m (DocAppend d1 d2)     = markupAppend m (markup m d1) (markup m d2)
 markup m (DocString s)         = markupString m s
 markup m (DocParagraph d)      = markupParagraph m (markup m d)
-markup m (DocIdentifier ids)   = markupIdentifier m ids
+markup m (DocIdentifier x)     = markupIdentifier m x
 markup m (DocModule mod0)      = markupModule m mod0
 markup m (DocEmphasis d)       = markupEmphasis m (markup m d)
 markup m (DocMonospaced d)     = markupMonospaced m (markup m d)