diff options
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 54 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 88 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Class.hs | 55 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Instance.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/backpack/should_fail/bkpfail40.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/MissingDefaultMethodBinding.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/all.T | 1 |
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, ['']) |