From ef16b9f8f73e6a4d639919152925ab83d9b1024f Mon Sep 17 00:00:00 2001
From: Simon Jakobi <simon.jakobi@gmail.com>
Date: Fri, 8 Jun 2018 22:20:30 +0200
Subject: Renamer: Warn about ambiguous identifiers (#831)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* Renamer: Warn about ambiguous identifiers

Example:

    Warning: 'elem' is ambiguous. It is defined
        * in ‘Data.Foldable’
        * at /home/simon/tmp/hdk/src/Lib.hs:7:1
        You may be able to disambiguate the identifier by qualifying it or
        by hiding some imports.
        Defaulting to 'elem' defined at /home/simon/tmp/hdk/src/Lib.hs:7:1

Fixes #830.

* Deduplicate warnings

Fixes #832.
---
 haddock-api/src/Haddock/Interface.hs            |  4 ++--
 haddock-api/src/Haddock/Interface/LexParseRn.hs | 20 +++++++++++++++++---
 2 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 89064a6c..a66745ea 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -184,10 +184,10 @@ processModule verbosity modsum flags modMap instIfaceMap = do
 
   if not $ isBootSummary modsum then do
     out verbosity verbose "Creating interface..."
-    (interface, msg) <- {-# SCC createIterface #-}
+    (interface, msgs) <- {-# SCC createIterface #-}
                         withTiming getDynFlags "createInterface" (const ()) $ do
                           runWriterGhc $ createInterface tm flags modMap instIfaceMap
-    liftIO $ mapM_ putStrLn msg
+    liftIO $ mapM_ putStrLn (nub msgs)
     dflags <- getDynFlags
     let (haddockable, haddocked) = ifaceHaddockCoverage interface
         percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index cbe55dc4..5d3cf2a6 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -28,7 +28,7 @@ import Haddock.Interface.ParseModuleHeader
 import Haddock.Parser
 import Haddock.Types
 import Name
-import Outputable ( showPpr )
+import Outputable ( showPpr, showSDoc )
 import RdrName
 import EnumSet
 import RnEnv (dataTcOccs)
@@ -120,11 +120,11 @@ rename dflags gre = rn
           -- There is only one name in the environment that matches so
           -- use it.
           [a] -> pure (DocIdentifier a)
+
           -- But when there are multiple names available, default to
           -- type constructors: somewhat awfully GHC returns the
           -- values in the list positionally.
-          a:b:_ | isTyConName a -> pure (DocIdentifier a)
-                | otherwise -> pure (DocIdentifier b)
+          a:b:_ -> ambiguous dflags x (if isTyConName a then a else b) names
 
       DocWarning doc -> DocWarning <$> rn doc
       DocEmphasis doc -> DocEmphasis <$> rn doc
@@ -168,3 +168,17 @@ outOfScope dflags x =
       tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope."]
       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]
+  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
+    x_str = '\'' : showPpr dflags x ++ "'"
+    defnLoc = showSDoc dflags . pprNameDefnLoc
-- 
cgit v1.2.3