[Git][ghc/ghc][master] Use TcRnDiagnostic in GHC.Tc.TyCl.Class (#20117)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Aug 29 08:18:40 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
68e6786f by Giles Anderson at 2022-08-29T00:01:35+02:00
Use TcRnDiagnostic in GHC.Tc.TyCl.Class (#20117)
The following `TcRnDiagnostic` messages have been introduced:
TcRnIllegalHsigDefaultMethods
TcRnBadGenericMethod
TcRnWarningMinimalDefIncomplete
TcRnDefaultMethodForPragmaLacksBinding
TcRnIgnoreSpecialisePragmaOnDefMethod
TcRnBadMethodErr
TcRnNoExplicitAssocTypeOrDefaultDeclaration
- - - - -
8 changed files:
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- testsuite/tests/backpack/should_fail/bkpfail40.stderr
- + testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.hs
- + testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
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.
=====================================
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
=====================================
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
}
=====================================
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
=====================================
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’
=====================================
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
=====================================
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’
=====================================
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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68e6786f3d1bde5d044a649462cdf2b6034a2df8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68e6786f3d1bde5d044a649462cdf2b6034a2df8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220829/87bc5529/attachment-0001.html>
More information about the ghc-commits
mailing list