Use TcRnDiagnostic in GHC.Tc.TyCl.Class (#20117)

The following `TcRnDiagnostic` messages have been introduced:

TcRnIllegalHsigDefaultMethods
TcRnBadGenericMethod
TcRnWarningMinimalDefIncomplete
TcRnDefaultMethodForPragmaLacksBinding
TcRnIgnoreSpecialisePragmaOnDefMethod
TcRnBadMethodErr
TcRnNoExplicitAssocTypeOrDefaultDeclaration

8 files changed, 168 insertions, 49 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index d907d2fbf0..7d4e7e3948 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -82,6 +82,8 @@ import GHC.Utils.Panic
 
 import qualified GHC.LanguageExtensions as LangExt
 
+import GHC.Data.BooleanFormula (pprBooleanFormulaNice)
+
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NE
 import Data.Function (on)
@@ -961,6 +963,36 @@ instance Diagnostic TcRnMessage where
             impMsg  = text "imported from" <+> ppr pragma_warning_import_mod <> extra
             extra | pragma_warning_import_mod == pragma_warning_defined_mod = empty
                   | otherwise = text ", but defined in" <+> ppr pragma_warning_defined_mod
+    TcRnIllegalHsigDefaultMethods name meths
+      -> mkSimpleDecorated $
+        text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file"
+    TcRnBadGenericMethod clas op
+      -> mkSimpleDecorated $
+        hsep [text "Class", quotes (ppr clas),
+          text "has a generic-default signature without a binding", quotes (ppr op)]
+    TcRnWarningMinimalDefIncomplete mindef
+      -> mkSimpleDecorated $
+        vcat [ text "The MINIMAL pragma does not require:"
+          , nest 2 (pprBooleanFormulaNice mindef)
+          , text "but there is no default implementation." ]
+    TcRnDefaultMethodForPragmaLacksBinding sel_id prag
+      -> mkSimpleDecorated $
+        text "The" <+> hsSigDoc prag <+> text "for default method"
+          <+> quotes (ppr sel_id)
+          <+> text "lacks an accompanying binding"
+    TcRnIgnoreSpecialisePragmaOnDefMethod sel_name
+      -> mkSimpleDecorated $
+        text "Ignoring SPECIALISE pragmas on default method"
+          <+> quotes (ppr sel_name)
+    TcRnBadMethodErr{badMethodErrClassName, badMethodErrMethodName}
+      -> mkSimpleDecorated $
+        hsep [text "Class", quotes (ppr badMethodErrClassName),
+          text "does not have a method", quotes (ppr badMethodErrMethodName)]
+    TcRnNoExplicitAssocTypeOrDefaultDeclaration name
+      -> mkSimpleDecorated $
+        text "No explicit" <+> text "associated type"
+          <+> text "or default declaration for"
+          <+> quotes (ppr name)
   diagnosticReason = \case
     TcRnUnknownMessage m
       -> diagnosticReason m
@@ -1276,6 +1308,20 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnPragmaWarning{}
       -> WarningWithFlag Opt_WarnWarningsDeprecations
+    TcRnIllegalHsigDefaultMethods{}
+      -> ErrorWithoutFlag
+    TcRnBadGenericMethod{}
+      -> ErrorWithoutFlag
+    TcRnWarningMinimalDefIncomplete{}
+      -> WarningWithoutFlag
+    TcRnDefaultMethodForPragmaLacksBinding{}
+      -> ErrorWithoutFlag
+    TcRnIgnoreSpecialisePragmaOnDefMethod{}
+      -> WarningWithoutFlag
+    TcRnBadMethodErr{}
+      -> ErrorWithoutFlag
+    TcRnNoExplicitAssocTypeOrDefaultDeclaration{}
+      -> WarningWithFlag (Opt_WarnMissingMethods)
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -1591,7 +1637,13 @@ instance Diagnostic TcRnMessage where
     TcRnNameByTemplateHaskellQuote{} -> noHints
     TcRnIllegalBindingOfBuiltIn{} -> noHints
     TcRnPragmaWarning{} -> noHints
-
+    TcRnIllegalHsigDefaultMethods{} -> noHints
+    TcRnBadGenericMethod{} -> noHints
+    TcRnWarningMinimalDefIncomplete{} -> noHints
+    TcRnDefaultMethodForPragmaLacksBinding{} -> noHints
+    TcRnIgnoreSpecialisePragmaOnDefMethod{} -> noHints
+    TcRnBadMethodErr{} -> noHints
+    TcRnNoExplicitAssocTypeOrDefaultDeclaration{} -> noHints
 
 -- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z",
 -- and so on.  The `and` stands for any `conjunction`, which is passed in.
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 7c2b22d765..34fba52546 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -91,7 +91,7 @@ import GHC.Types.Var.Env (TidyEnv)
 import GHC.Types.Var.Set (TyVarSet, VarSet)
 import GHC.Unit.Types (Module)
 import GHC.Utils.Outputable
-import GHC.Core.Class (Class)
+import GHC.Core.Class (Class, ClassMinimalDef)
 import GHC.Core.Coercion.Axiom (CoAxBranch)
 import GHC.Core.ConLike (ConLike)
 import GHC.Core.DataCon (DataCon)
@@ -2187,9 +2187,93 @@ data TcRnMessage where
     pragma_warning_defined_mod :: ModuleName
   } -> TcRnMessage
 
+
+  {-| TcRnIllegalHsigDefaultMethods is an error that occurs when a binding for
+     a class default method is provided in a Backpack signature file.
+
+    Test case:
+      bkpfail40
+  -}
+
+  TcRnIllegalHsigDefaultMethods :: !Name -- ^ 'Name' of the class
+                                -> NE.NonEmpty (LHsBind GhcRn) -- ^ default methods
+                                -> TcRnMessage
+  {-| TcRnBadGenericMethod
+     This test ensures that if you provide a "more specific" type signatures
+     for the default method, you must also provide a binding.
+
+     Example:
+     {-# LANGUAGE DefaultSignatures #-}
+
+     class C a where
+       meth :: a
+       default meth :: Num a => a
+       meth = 0
+
+    Test case:
+      testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.hs
+  -}
+  TcRnBadGenericMethod :: !Name   -- ^ 'Name' of the class
+                       -> !Name   -- ^ Problematic method
+                       -> TcRnMessage
+
+  {-| TcRnWarningMinimalDefIncomplete is a warning that one must
+      specify which methods must be implemented by all instances.
+
+     Example:
+       class Cheater a where  -- WARNING LINE
+       cheater :: a
+       {-# MINIMAL #-} -- warning!
+
+     Test case:
+       testsuite/tests/warnings/minimal/WarnMinimal.hs:
+  -}
+  TcRnWarningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage
+
+  {-| TcRnDefaultMethodForPragmaLacksBinding is an error that occurs when
+      a default method pragma is missing an accompanying binding.
+
+    Test cases:
+      testsuite/tests/typecheck/should_fail/T5084.hs
+      testsuite/tests/typecheck/should_fail/T2354.hs
+  -}
+  TcRnDefaultMethodForPragmaLacksBinding
+            :: Id             -- ^ method
+            -> Sig GhcRn      -- ^ the pragma
+            -> TcRnMessage
+  {-| TcRnIgnoreSpecialisePragmaOnDefMethod is a warning that occurs when
+      a specialise pragma is put on a default method.
+
+    Test cases: none
+  -}
+  TcRnIgnoreSpecialisePragmaOnDefMethod
+            :: !Name
+            -> TcRnMessage
+  {-| TcRnBadMethodErr is an error that happens when one attempts to provide a method
+     in a class instance, when the class doesn't have a method by that name.
+
+     Test case:
+       testsuite/tests/th/T12387
+  -}
+  TcRnBadMethodErr
+    :: { badMethodErrClassName  :: !Name
+       , badMethodErrMethodName :: !Name
+       } -> TcRnMessage
+  {-| TcRnNoExplicitAssocTypeOrDefaultDeclaration is an error that occurs
+      when a class instance does not provide an expected associated type
+      or default declaration.
+
+    Test cases:
+      testsuite/tests/deriving/should_compile/T14094
+      testsuite/tests/indexed-types/should_compile/Simple2
+      testsuite/tests/typecheck/should_compile/tc254
+  -}
+  TcRnNoExplicitAssocTypeOrDefaultDeclaration
+            :: Name
+            -> TcRnMessage
+
 -- | Specifies which back ends can handle a requested foreign import or export
 type ExpectedBackends = [Backend]
-
 -- | Specifies which calling convention is unsupported on the current platform
 data UnsupportedCallConvention
   = StdCallConvUnsupported
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index a57f6df973..57f8f19e82 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -18,7 +18,6 @@ module GHC.Tc.TyCl.Class
    , tcClassMinimalDef
    , HsSigFun
    , mkHsSigFun
-   , badMethodErr
    , instDeclCtxt1
    , instDeclCtxt2
    , instDeclCtxt3
@@ -70,6 +69,7 @@ import GHC.Data.BooleanFormula
 
 import Control.Monad
 import Data.List ( mapAccumL, partition )
+import qualified Data.List.NonEmpty as NE
 
 {-
 Dictionary handling
@@ -112,10 +112,6 @@ Death to "ExpandingDicts".
 ************************************************************************
 -}
 
-illegalHsigDefaultMethod :: Name -> TcRnMessage
-illegalHsigDefaultMethod n = TcRnUnknownMessage $ mkPlainError noHints $
-    text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"
-
 tcClassSigs :: Name                -- Name of the class
             -> [LSig GhcRn]
             -> LHsBinds GhcRn
@@ -130,7 +126,7 @@ tcClassSigs clas sigs def_methods
        ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
 
        ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
-       ; sequence_ [ failWithTc (badMethodErr clas n)
+       ; sequence_ [ failWithTc (TcRnBadMethodErr clas n)
                    | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
                    -- Value binding for non class-method (ie no TypeSig)
 
@@ -141,11 +137,12 @@ tcClassSigs clas sigs def_methods
                -- (Generic signatures without value bindings indicate
                -- that a default of this form is expected to be
                -- provided.)
-               when (not (null def_methods)) $
-                failWithTc (illegalHsigDefaultMethod clas)
+               case bagToList def_methods of
+                 []           -> return ()
+                 meth : meths -> failWithTc (TcRnIllegalHsigDefaultMethods clas (meth NE.:| meths))
             else
                -- Error for each generic signature without value binding
-               sequence_ [ failWithTc (badGenericMethod clas n)
+               sequence_ [ failWithTc (TcRnBadGenericMethod clas n)
                          | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
 
        ; traceTc "tcClassSigs 2" (ppr clas)
@@ -236,7 +233,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
 
 tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
   = do { -- No default method
-         mapM_ (addLocMA (badDmPrag sel_id))
+         mapM_ (addLocMA (badDmPrag sel_id ))
                (lookupPragEnv prag_fn (idName sel_id))
        ; return emptyBag }
 
@@ -262,9 +259,8 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
 
        ; spec_prags <- discardConstraints $
                        tcSpecPrags global_dm_id prags
-       ; let dia = TcRnUnknownMessage $
-               mkPlainDiagnostic WarningWithoutFlag noHints $
-                (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name))
+       ; let dia = TcRnIgnoreSpecialisePragmaOnDefMethod sel_name
+
        ; diagnosticTc (not (null spec_prags)) dia
 
        ; let hs_ty = hs_sig_fn sel_name
@@ -340,7 +336,7 @@ tcClassMinimalDef _clas sigs op_info
         -- since you can't write a default implementation.
         when (tcg_src tcg_env /= HsigFile) $
             whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
-                       (\bf -> addDiagnosticTc (warningMinimalDefIncomplete bf))
+                       (\bf -> addDiagnosticTc (TcRnWarningMinimalDefIncomplete bf))
         return mindef
   where
     -- By default require all methods without a default implementation
@@ -441,18 +437,6 @@ This makes the error messages right.
 ************************************************************************
 -}
 
-badMethodErr :: Outputable a => a -> Name -> TcRnMessage
-badMethodErr clas op
-  = TcRnUnknownMessage $ mkPlainError noHints $
-    hsep [text "Class", quotes (ppr clas),
-          text "does not have a method", quotes (ppr op)]
-
-badGenericMethod :: Outputable a => a -> Name -> TcRnMessage
-badGenericMethod clas op
-  = TcRnUnknownMessage $ mkPlainError noHints $
-    hsep [text "Class", quotes (ppr clas),
-          text "has a generic-default signature without a binding", quotes (ppr op)]
-
 {-
 badGenericInstanceType :: LHsBinds Name -> SDoc
 badGenericInstanceType binds
@@ -472,19 +456,10 @@ dupGenericInsts tc_inst_infos
   where
     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 -}
+
 badDmPrag :: TcId -> Sig GhcRn -> TcM ()
 badDmPrag sel_id prag
-  = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $
-    text "The" <+> hsSigDoc prag <+> text "for default method"
-              <+> quotes (ppr sel_id)
-              <+> text "lacks an accompanying binding")
-
-warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage
-warningMinimalDefIncomplete mindef
-  = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $
-  vcat [ text "The MINIMAL pragma does not require:"
-         , nest 2 (pprBooleanFormulaNice mindef)
-         , text "but there is no default implementation." ]
+  = addErrTc (TcRnDefaultMethodForPragmaLacksBinding sel_id prag)
 
 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
 instDeclCtxt1 hs_inst_ty
@@ -563,10 +538,6 @@ warnMissingAT name
        -- hs-boot and signatures never need to provide complete "definitions"
        -- of any sort, as they aren't really defining anything, but just
        -- constraining items which are defined elsewhere.
-       ; let dia = TcRnUnknownMessage $
-               mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints $
-                 (text "No explicit" <+> text "associated type"
-                                     <+> text "or default declaration for"
-                                     <+> quotes (ppr name))
+       ; let dia = TcRnNoExplicitAssocTypeOrDefaultDeclaration name
        ; diagnosticTc  (warn && hsc_src == HsSrcFile) dia
                        }
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index cc7dc750d5..da85cd0881 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -27,8 +27,8 @@ import GHC.Tc.Gen.Bind
 import GHC.Tc.TyCl
 import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )
 import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault,
-                           HsSigFun, mkHsSigFun, badMethodErr,
-                           findMethodBind, instantiateMethod )
+                           HsSigFun, mkHsSigFun, findMethodBind,
+                           instantiateMethod )
 import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
 import GHC.Tc.Gen.Sig
 import GHC.Tc.Utils.Monad
@@ -1800,7 +1800,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     -- Check if any method bindings do not correspond to the class.
     -- See Note [Mismatched class methods and associated type families].
     checkMethBindMembership
-      = mapM_ (addErrTc . badMethodErr clas) mismatched_meths
+      = mapM_ (addErrTc . TcRnBadMethodErr (className clas)) mismatched_meths
       where
         bind_nms         = map unLoc $ collectMethodBinders binds
         cls_meth_nms     = map (idName . fst) op_items
diff --git a/testsuite/tests/backpack/should_fail/bkpfail40.stderr b/testsuite/tests/backpack/should_fail/bkpfail40.stderr
index a2f36dfa8e..f221afc7ba 100644
--- a/testsuite/tests/backpack/should_fail/bkpfail40.stderr
+++ b/testsuite/tests/backpack/should_fail/bkpfail40.stderr
@@ -2,5 +2,5 @@
   [1 of 1] Compiling A[sig]           ( p/A.hsig, nothing )
 
 bkpfail40.bkp:3:9: error:
-    • Illegal default method(s) in class definition of C in hsig file
+    • Illegal default method in class definition of C in hsig file
     • In the class declaration for ‘C’
diff --git a/testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.hs b/testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.hs
new file mode 100644
index 0000000000..6ee4c70691
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE DefaultSignatures #-} 
+
+module MissingDefaultMethodBinding where
+
+class C a where
+  meth :: a
+  default meth :: Num a => a
diff --git a/testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.stderr b/testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.stderr
new file mode 100644
index 0000000000..fe752862c1
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.stderr
@@ -0,0 +1,4 @@
+
+MissingDefaultMethodBinding.hs:5:1:
+     Class ‘C’ has a generic-default signature without a binding ‘meth’
+     In the class declaration for ‘C’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 2674798823..51d73be7ed 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -658,3 +658,4 @@ test('T21327', normal, compile_fail, [''])
 test('T21338', normal, compile_fail, [''])
 test('T21158', normal, compile_fail, [''])
 test('T21583', normal, compile_fail, [''])
+test('MissingDefaultMethodBinding', normal, compile_fail, [''])