From d504a2864a4e1982e142cf88c023e7caeea3b76f Mon Sep 17 00:00:00 2001
From: Simon Jakobi <simon.jakobi@gmail.com>
Date: Fri, 22 Jun 2018 21:37:22 +0200
Subject: Don't warn about ambiguous identifiers when the candidate names
 belong to the same type

This also changes the defaulting heuristic for ambiguous identifiers.
We now prefer local names primarily, and type constructors or class
names secondarily.

Partially fixes #854.
---
 haddock-api/src/Haddock/Interface/LexParseRn.hs | 53 ++++++++++++++++---------
 1 file changed, 35 insertions(+), 18 deletions(-)

diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 731f2a35..e83708d0 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -Wwarn #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
   -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.LexParseRn
@@ -18,7 +19,11 @@ module Haddock.Interface.LexParseRn
   , processModuleHeader
   ) where
 
+import Avail
+import Control.Arrow
+import Control.Monad
 import Data.List
+import Data.Ord
 import Documentation.Haddock.Doc (metaDocConcat)
 import DynFlags (languageExtensions)
 import qualified GHC.LanguageExtensions as LangExt
@@ -94,11 +99,9 @@ rename dflags gre = rn
         -- Generate the choices for the possible kind of thing this
         -- is.
         let choices = dataTcOccs x
-        -- Try to look up all the names in the GlobalRdrEnv that match
-        -- the names.
-        let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
 
-        case names of
+        -- Lookup any GlobalRdrElts that match the choices.
+        case concatMap (\c -> lookupGRE_RdrName c gre) choices of
           -- We found no names in the env so we start guessing.
           [] ->
             case choices of
@@ -117,12 +120,10 @@ rename dflags gre = rn
 
           -- There is only one name in the environment that matches so
           -- use it.
-          [a] -> pure (DocIdentifier a)
+          [a] -> pure (DocIdentifier (gre_name a))
 
-          -- But when there are multiple names available, default to
-          -- type constructors: somewhat awfully GHC returns the
-          -- values in the list positionally.
-          a:b:_ -> ambiguous dflags x (if isTyConName a then a else b) names
+          -- There are multiple names available.
+          gres -> ambiguous dflags x gres
 
       DocWarning doc -> DocWarning <$> rn doc
       DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -167,16 +168,32 @@ outOfScope dflags x =
       pure (monospaced a)
     monospaced a = DocMonospaced (DocString (showPpr dflags a))
 
--- | Warn about an ambiguous identifier.
-ambiguous :: DynFlags -> RdrName -> Name -> [Name] -> ErrMsgM (Doc Name)
-ambiguous dflags x dflt names = do
-  tell [msg]
+-- | Handle ambiguous identifiers.
+--
+-- Prefers local names primarily and type constructors or class names secondarily.
+--
+-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
+ambiguous :: DynFlags
+          -> RdrName
+          -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
+          -> ErrMsgM (Doc Name)
+ambiguous dflags x gres = do
+  let noChildren = map availName (gresToAvailInfo gres)
+      dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
+      msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
+            concatMap (\n -> "    * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
+            "    You may be able to disambiguate the identifier by qualifying it or\n" ++
+            "    by hiding some imports.\n" ++
+            "    Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+  -- TODO: Once we have a syntax for namespace qualification (#667) we may also
+  -- want to emit a warning when an identifier is a data constructor for a type
+  -- of the same name, but not the only constructor.
+  -- For example, for @data D = C | D@, someone may want to reference the @D@
+  -- constructor.
+  when (length noChildren > 1) $ tell [msg]
   pure (DocIdentifier dflt)
   where
-    msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
-          concatMap (\n -> "    * " ++ defnLoc n ++ "\n") names ++
-          "    You may be able to disambiguate the identifier by qualifying it or\n" ++
-          "    by hiding some imports.\n" ++
-          "    Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
+    isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
+    isLocalName _ = False
     x_str = '\'' : showPpr dflags x ++ "'"
     defnLoc = showSDoc dflags . pprNameDefnLoc
-- 
cgit v1.2.3