Improve "ambiguous occurrence" error messages

This error was sometimes a bit confusing, especially when data families
were involved. This commit improves the general presentation of the
"ambiguous occurrence" error, and adds a bit of extra context in the
case of data families.

Fixes #23301

5 files changed, 73 insertions, 24 deletions

diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 7b631edac0..5c23ee60cb 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -60,9 +60,11 @@ import GHC.Driver.Session
 import GHC.Data.FastString
 import Control.Monad
 import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
-import qualified Data.List.NonEmpty as NE
 import qualified GHC.LanguageExtensions as LangExt
+
 import qualified Data.List as List
+import qualified Data.List.NonEmpty as NE
+
 
 {-
 *********************************************************
@@ -501,7 +503,8 @@ addNameClashErrRn rdr_name gres
   -- already, and we don't want an error cascade.
   = return ()
   | otherwise
-  = addErr $ mkNameClashErr rdr_name gres
+  = do { gre_env <- getGlobalRdrEnv
+       ; addErr $ mkNameClashErr gre_env rdr_name gres }
   where
     -- If all the GREs are defined locally, can we skip reporting an ambiguity
     -- error at use sites, because it will have been reported already? See
@@ -514,8 +517,8 @@ addNameClashErrRn rdr_name gres
     num_flds     = length flds
     num_non_flds = length non_flds
 
-mkNameClashErr :: RdrName -> NE.NonEmpty GlobalRdrElt -> TcRnMessage
-mkNameClashErr rdr_name gres = TcRnAmbiguousName rdr_name gres
+mkNameClashErr :: GlobalRdrEnv -> RdrName -> NE.NonEmpty GlobalRdrElt -> TcRnMessage
+mkNameClashErr gre_env rdr_name gres = TcRnAmbiguousName gre_env rdr_name gres
 
 dupNamesErr :: NE.NonEmpty SrcSpan -> NE.NonEmpty RdrName -> RnM ()
 dupNamesErr locs names
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 269063ae65..5a1485c1da 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1840,17 +1840,19 @@ instance Diagnostic TcRnMessage where
     TcRnIllegalInferredTyVars _
       -> mkSimpleDecorated $
          text "Inferred type variables are not allowed"
-    TcRnAmbiguousName name gres
+    TcRnAmbiguousName gre_env name gres
       -> mkSimpleDecorated $
-         vcat [ text "Ambiguous occurrence" <+> quotes (ppr name)
+         vcat [ text "Ambiguous occurrence" <+> quotes (ppr name) <> dot
               , text "It could refer to"
-              , nest 3 (vcat (msg1 : msgs)) ]
+              , nest 3 (vcat msgs) ]
          where
            np1 NE.:| nps = gres
-           msg1 =  text "either" <+> ppr_gre np1
-           msgs = [text "    or" <+> ppr_gre np | np <- nps]
-           ppr_gre gre = sep [ pprAmbiguousGreName gre <> comma
-                             , pprNameProvenance gre]
+           msgs = punctuateFinal comma dot $
+                    text "either" <+> ppr_gre np1
+                 : [text "    or" <+> ppr_gre np | np <- nps]
+
+           ppr_gre gre = pprAmbiguousGreName gre_env gre
+
     TcRnBindingNameConflict name locs
       -> mkSimpleDecorated $
          vcat [text "Conflicting definitions for" <+> quotes (ppr name),
@@ -5439,17 +5441,44 @@ pprUnusedName name reason =
 --                            imported from ‘Prelude’ at T15487.hs:1:8-13
 --                     or ...
 -- See #15487
-pprAmbiguousGreName :: GlobalRdrElt -> SDoc
-pprAmbiguousGreName gre
-  | isRecFldGRE gre
-  = text "the field" <+> quotes (ppr occ) <+> parent_info
+pprAmbiguousGreName :: GlobalRdrEnv -> GlobalRdrElt -> SDoc
+pprAmbiguousGreName gre_env gre
+  | IAmRecField fld_info <- gre_info gre
+  = sep [ text "the field" <+> quotes (ppr occ) <+> parent_info fld_info <> comma
+        , pprNameProvenance gre ]
   | otherwise
-  = quotes (pp_qual <> dot <> ppr occ)
+  = sep [ quotes (pp_qual <> dot <> ppr occ) <> comma
+        , pprNameProvenance gre ]
+
   where
     occ = greOccName gre
-    parent_info = case gre_par gre of
-      NoParent -> empty
-      ParentIs { par_is = par_name } -> text "of record" <+> quotes (ppr par_name)
+    parent_info fld_info =
+      case first_con of
+        PatSynName  ps -> text "of pattern synonym" <+> quotes (ppr ps)
+        DataConName {} ->
+          case gre_par gre of
+            ParentIs par
+              -- For a data family, only reporting the family TyCon can be
+              -- unhelpful (see T23301). So we give a bit of additional
+              -- info in that case.
+              | Just par_gre <- lookupGRE_Name gre_env par
+              , IAmTyCon tc_flav <- gre_info par_gre
+              , OpenFamilyFlavour IAmData _ <- tc_flav
+              -> vcat [ ppr_cons
+                      , text "in a data family instance of" <+> quotes (ppr par) ]
+              | otherwise
+              -> text "of record" <+> quotes (ppr par)
+            NoParent -> ppr_cons
+      where
+        cons :: [ConLikeName]
+        cons = nonDetEltsUniqSet $ recFieldCons fld_info
+        first_con :: ConLikeName
+        first_con = head cons
+        ppr_cons :: SDoc
+        ppr_cons = hsep [ text "belonging to data constructor"
+                        , quotes (ppr $ nameOccName $ conLikeName_Name first_con)
+                        , if length cons > 1 then parens (text "among others") else empty
+                        ]
     pp_qual
         | gre_lcl gre
         = ppr (nameModule $ greName gre)
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 4c2d29a0b5..cd80a3dbc9 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -4024,7 +4024,8 @@ data TcRnMessage where
       T18999_NoDisambiguateRecordFields, T19397E1, T19397E2, T23010_fail,
       tcfail037
   -}
-  TcRnAmbiguousName :: !RdrName -- ^ The name
+  TcRnAmbiguousName :: !GlobalRdrEnv
+                    -> !RdrName -- ^ The name
                     -> !(NE.NonEmpty GlobalRdrElt) -- ^ The possible matches
                     -> TcRnMessage
 
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 637baba3b6..b9153b6473 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -989,7 +989,8 @@ checkHiBootIface'
           -- At least 2 matches: report an ambiguity error.
           (gre1,_):(gre2,_):gres_ids -> do
            addErrAt (nameSrcSpan missing_name) $
-             mkNameClashErr (nameRdrName missing_name) (gre1 NE.:| gre2 : map fst gres_ids)
+             mkNameClashErr gre_env (nameRdrName missing_name)
+               (gre1 NE.:| gre2 : map fst gres_ids)
            return Nothing
 
           -- Single match: resolve the issue.
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index f63d515b83..49c0b10251 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -47,8 +47,8 @@ module GHC.Utils.Outputable (
         blankLine, forAllLit, bullet,
         ($+$),
         cat, fcat,
-        hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
-        ppWhenOption, ppUnlessOption,
+        hang, hangNotEmpty, punctuate, punctuateFinal,
+        ppWhen, ppUnless, ppWhenOption, ppUnlessOption,
         speakNth, speakN, speakNOf, plural, singular,
         isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave,
         unicodeSyntax,
@@ -153,7 +153,7 @@ import Data.List (intersperse)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Semigroup (Arg(..))
 import qualified Data.List.NonEmpty as NEL
-import Data.Time
+import Data.Time ( UTCTime )
 import Data.Time.Format.ISO8601
 import Data.Void
 
@@ -842,6 +842,21 @@ punctuate p (d:ds) = go d ds
                      go d [] = [d]
                      go d (e:es) = (d <> p) : go e es
 
+-- | Punctuate a list, e.g. with commas and dots.
+--
+-- > sep $ punctuateFinal comma dot [text "ab", text "cd", text "ef"]
+-- > ab, cd, ef.
+punctuateFinal :: IsLine doc
+               => doc   -- ^ The interstitial punctuation
+               -> doc   -- ^ The final punctuation
+               -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements
+               -> [doc] -- ^ Punctuated list
+punctuateFinal _ _ []     = []
+punctuateFinal p q (d:ds) = go d ds
+  where
+    go d [] = [d <> q]
+    go d (e:es) = (d <> p) : go e es
+
 ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc
 {-# INLINE CONLIKE ppWhen #-}
 ppWhen True  doc = doc