Show family TyCons in mk_dict_error in the case of a single match

5 files changed, 87 insertions, 2 deletions

diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index ff6525f24d..7177f7347f 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -46,6 +46,7 @@ import GHC.Types.Name.Set
 import GHC.Types.SrcLoc
 import GHC.Types.Basic
 import GHC.Types.Error
+import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
 
 import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
 import GHC.Unit.Module
@@ -2491,6 +2492,17 @@ mkDictErr ctxt cts
     -- but we really only want to report the latter
     elim_superclasses cts = mkMinimalBySCs ctPred cts
 
+-- [Note: mk_dict_err]
+-- ~~~~~~~~~~~~~~~~~~~
+-- Different dictionary error messages are reported depending on the number of
+-- matches and unifiers:
+--
+--   - No matches, regardless of unifiers: report "No instance for ...".
+--   - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",
+--     and show the matching and unifying instances.
+--   - One match, one or more unifiers: report "Overlapping instances for", show the
+--     matching and unifying instances, and say "The choice depends on the instantion of ...,
+--     and the result of evaluating ...".
 mk_dict_err :: HasCallStack => ReportErrCtxt -> (Ct, ClsInstLookupResult)
             -> TcM SDoc
 -- Report an overlap error if this class constraint results
@@ -2680,12 +2692,24 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
                       , nest 2 (vcat (pp_givens useful_givens))]
 
              ,  ppWhen (isSingleton matches) $
-                parens (vcat [ text "The choice depends on the instantiation of" <+>
-                                  quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))
+                parens (vcat [ ppUnless (null tyCoVars) $
+                                 text "The choice depends on the instantiation of" <+>
+                                   quotes (pprWithCommas ppr tyCoVars)
+                             , ppUnless (null famTyCons) $
+                                 if (null tyCoVars)
+                                   then
+                                     text "The choice depends on the result of evaluating" <+>
+                                       quotes (pprWithCommas ppr famTyCons)
+                                   else
+                                     text "and the result of evaluating" <+>
+                                       quotes (pprWithCommas ppr famTyCons)
                              , ppWhen (null (matching_givens)) $
                                vcat [ text "To pick the first instance above, use IncoherentInstances"
                                     , text "when compiling the other instance declarations"]
                         ])]
+      where
+        tyCoVars = tyCoVarsOfTypesList tys
+        famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys
 
     matching_givens = mapMaybe matchable useful_givens
 
diff --git a/testsuite/tests/indexed-types/should_fail/T20466.hs b/testsuite/tests/indexed-types/should_fail/T20466.hs
new file mode 100644
index 0000000000..5d9aa8db7d
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T20466.hs
@@ -0,0 +1,34 @@
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T20466 where
+
+import Data.Kind (Type)
+
+type family F (a :: Type) :: Type
+
+type family G (a :: Type) :: Type
+
+type Syn a b c = Either (G a) (G b)
+
+class Cls (a :: Type)
+
+instance {-# OVERLAPPABLE #-} Cls a
+
+instance Cls (Either Int Bool)
+
+foo :: forall a b c. Cls (Either a (F (Syn a b c))) => a -> b -> c -> Int
+foo _ _ _ = 42
+
+bar :: forall a b c. a -> b -> c -> Int
+bar = foo
+
+foo' :: Cls (Either Int (F Bool)) => Int
+foo' = 42
+
+bar' :: Int
+bar' = foo'
diff --git a/testsuite/tests/indexed-types/should_fail/T20466.stderr b/testsuite/tests/indexed-types/should_fail/T20466.stderr
new file mode 100644
index 0000000000..90f09648f9
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T20466.stderr
@@ -0,0 +1,25 @@
+
+T20466.hs:28:7:
+     Overlapping instances for Cls (Either a (F (Either (G a) (G b))))
+        arising from a use of ‘foo’
+      Matching instances:
+        instance [overlappable] Cls a -- Defined at T20466.hs:20:31
+        instance Cls (Either Int Bool) -- Defined at T20466.hs:22:10
+      (The choice depends on the instantiation of ‘a, b’
+       and the result of evaluating ‘G, F’
+       To pick the first instance above, use IncoherentInstances
+       when compiling the other instance declarations)
+       In the expression: foo
+        In an equation for ‘bar’: bar = foo
+
+T20466.hs:34:8:
+     Overlapping instances for Cls (Either Int (F Bool))
+        arising from a use of ‘foo'’
+      Matching instances:
+        instance [overlappable] Cls a -- Defined at T20466.hs:20:31
+        instance Cls (Either Int Bool) -- Defined at T20466.hs:22:10
+      (The choice depends on the result of evaluating ‘F’
+       To pick the first instance above, use IncoherentInstances
+       when compiling the other instance declarations)
+     In the expression: foo'
+      In an equation for ‘bar'’: bar' = foo'
diff --git a/testsuite/tests/indexed-types/should_fail/T4485.stderr b/testsuite/tests/indexed-types/should_fail/T4485.stderr
index 6e88858682..e6a3b888ac 100644
--- a/testsuite/tests/indexed-types/should_fail/T4485.stderr
+++ b/testsuite/tests/indexed-types/should_fail/T4485.stderr
@@ -11,6 +11,7 @@ T4485.hs:51:15: error:
                                  (IdentityT IO) (XMLGenT Identity ())
           -- Defined at T4485.hs:46:30
       (The choice depends on the instantiation of ‘m0’
+       and the result of evaluating ‘XML’
        To pick the first instance above, use IncoherentInstances
        when compiling the other instance declarations)
     • In the first argument of ‘($)’, namely ‘asChild’
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index c3d98b43f0..dd87053e5a 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -163,6 +163,7 @@ test('T17008a', normal, compile_fail, ['-fprint-explicit-kinds'])
 test('T13571', normal, compile_fail, [''])
 test('T13571a', normal, compile_fail, [''])
 test('T18648', normal, compile_fail, [''])
+test('T20466', normal, compile_fail, [''])
 test('ExpandTFs', normal, compile_fail, [''])
 test('T20465', normal, compile_fail, [''])
 test('T20521', normal, compile_fail, [''])