diff options
| author | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-09-20 15:51:21 +0200 |
|---|---|---|
| committer | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-10-05 13:01:05 +0200 |
| commit | 671af0abf135ce96f7c0c6e9b4607f033597f807 (patch) | |
| tree | 924a6a61e6a94ff29fdfee9ea1415798a9d62e2a | |
| parent | ab8112f4cc647e70971ab361c537e96dca21a14b (diff) | |
| download | haskell-wip/adinapoli-issue-20119-part-2.tar.gz | |
Eradicate TcRnUnknownMessage from GHC.Tc.Derivwip/adinapoli-issue-20119-part-2
This (big) commit finishes porting the GHC.Tc.Deriv module to support
the new diagnostic infrastructure (#18516) by getting rid of the legacy
calls to `TcRnUnknownMessage`. This work ended up being quite pervasive
and touched not only the Tc.Deriv module but also the Tc.Deriv.Utils and
Tc.Deriv.Generics module, which needed to be adapted to use the new
infrastructure. This also required generalising `Validity`.
More specifically, this is a breakdown of the work done:
* Add and use the TcRnUselessTypeable data constructor
* Add and use TcRnDerivingDefaults data constructor
* Add and use the TcRnNonUnaryTypeclassConstraint data constructor
* Add and use TcRnPartialTypeSignatures
* Add T13324_compile2 test to test another part of the
TcRnPartialTypeSignatures diagnostic
* Add and use TcRnCannotDeriveInstance data constructor, which introduces a
new data constructor to TcRnMessage called TcRnCannotDeriveInstance, which
is further sub-divided to carry a `DeriveInstanceErrReason` which explains
the reason why we couldn't derive a typeclass instance.
* Add DerivErrSafeHaskellGenericInst data constructor to DeriveInstanceErrReason
* Add DerivErrDerivingViaWrongKind and DerivErrNoEtaReduce
* Introduce the SuggestExtensionInOrderTo Hint, which adds (and use) a new
constructor to the hint type `LanguageExtensionHint` called `SuggestExtensionInOrderTo`,
which can be used to give a bit more "firm" recommendations when it's
obvious what the required extension is, like in the case for the
`DerivingStrategies`, which automatically follows from having enabled
both `DeriveAnyClass` and `GeneralizedNewtypeDeriving`.
* Wildcard-free pattern matching in mk_eqn_stock, which removes `_` in
favour of pattern matching explicitly on `CanDeriveAnyClass` and
`NonDerivableClass`, because that determine whether or not we can
suggest to the user `DeriveAnyClass` or not.
39 files changed, 1002 insertions, 351 deletions
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 184edf021d..f82bf38abe 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -22,7 +22,6 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin -import GHC.Core.Predicate import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) @@ -47,7 +46,6 @@ import GHC.Core.Type import GHC.Utils.Error import GHC.Core.DataCon import GHC.Data.Maybe -import GHC.Types.Hint import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Set as NameSet @@ -513,7 +511,7 @@ derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = , text "via_tvs" <+> ppr via_tvs ] (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred when (cls_arg_kinds `lengthIsNot` 1) $ - failWithTc (nonUnaryErr deriv_pred) + failWithTc (TcRnNonUnaryTypeclassConstraint deriv_pred) let [cls_arg_kind] = cls_arg_kinds mb_deriv_strat = fmap unLoc mb_lderiv_strat if (className cls == typeableClassName) @@ -658,8 +656,8 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) mb_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust mb_match) - (derivingViaKindErr cls inst_ty_kind - via_ty via_kind) + (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind) let Just kind_subst = mb_match ki_subst_range = getTCvSubstRangeFVs kind_subst @@ -739,11 +737,7 @@ tcStandaloneDerivInstType ctxt pure (tvs, SupplyContext theta, cls, inst_tys) warnUselessTypeable :: TcM () -warnUselessTypeable - = do { addDiagnosticTc $ TcRnUnknownMessage - $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDerivingTypeable) noHints $ - text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } +warnUselessTypeable = addDiagnosticTc TcRnUselessTypeable ------------------------------------------------------------------ deriveTyData :: TyCon -> [Type] -- LHS of data or data instance @@ -779,7 +773,8 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind -- Check that the result really is well-kinded ; checkTc (enough_args && isJust mb_match) - (derivingKindErr tc cls cls_tys cls_arg_kind enough_args) + (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $ + DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep) ; let -- Returns a singleton-element list if using ViaStrategy and an -- empty list otherwise. Useful for free-variable calculations. @@ -824,7 +819,8 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind via_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust via_match) - (derivingViaKindErr cls inst_ty_kind via_ty via_kind) + (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind) let Just via_subst = via_match pure $ propagate_subst via_subst tkvs' cls_tys' @@ -845,7 +841,8 @@ deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind ; let final_tc_app = mkTyConApp tc final_tc_args final_cls_args = final_cls_tys ++ [final_tc_app] ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) - (derivingEtaErr cls final_cls_tys final_tc_app) + (TcRnCannotDeriveInstance cls final_cls_tys Nothing NoGeneralizedNewtypeDeriving $ + DerivErrNoEtaReduce final_tc_app) -- Check that -- (a) The args to drop are all type variables; eg reject: -- data instance T a Int = .... deriving( Monad ) @@ -1154,9 +1151,7 @@ mkEqnHelp :: Maybe OverlapMode mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do is_boot <- tcIsHsBootOrSig - when is_boot $ - bale_out (text "Cannot derive instances in hs-boot files" - $+$ text "Write an instance declaration instead") + when is_boot $ bale_out DerivErrBootFileFound runReaderT mk_eqn deriv_env where deriv_env = DerivEnv { denv_overlap_mode = overlap_mode @@ -1166,7 +1161,8 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do , denv_ctxt = deriv_ctxt , denv_strat = deriv_strat } - bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg + bale_out = + failWithTc . TcRnCannotDeriveInstance cls cls_args deriv_strat NoGeneralizedNewtypeDeriving mk_eqn :: DerivM EarlyDerivSpec mk_eqn = do @@ -1188,7 +1184,7 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args dit <- expectAlgTyConApp cls_tys inst_ty unless (isNewTyCon (dit_rep_tc dit)) $ - derivingThingFailWith False gndNonNewtypeErr + derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData mkNewTypeEqn True dit Nothing -> mk_eqn_no_strategy @@ -1200,7 +1196,7 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do -- property is important. expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type) expectNonNullaryClsArgs inst_tys = - maybe (derivingThingFailWith False derivingNullaryErr) pure $ + maybe (derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrNullaryClasses) pure $ snocView inst_tys -- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application @@ -1217,9 +1213,7 @@ expectAlgTyConApp :: [Type] -- All but the last argument to the class in a expectAlgTyConApp cls_tys inst_ty = do fam_envs <- lift tcGetFamInstEnvs case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of - Nothing -> derivingThingFailWith False $ - text "The last argument of the instance must be a" - <+> text "data or newtype application" + Nothing -> derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrLastArgMustBeApp Just dit -> do expectNonDataFamTyCon dit pure dit @@ -1234,8 +1228,8 @@ expectNonDataFamTyCon (DerivInstTys { dit_tc = tc , dit_rep_tc = rep_tc }) = -- If it's still a data family, the lookup failed; i.e no instance exists when (isDataFamilyTyCon rep_tc) $ - derivingThingFailWith False $ - text "No family instance for" <+> quotes (pprTypeApp tc tc_args) + derivingThingFailWith NoGeneralizedNewtypeDeriving $ + DerivErrNoFamilyInstance tc tc_args mk_deriv_inst_tys_maybe :: FamInstEnvs -> [Type] -> Type -> Maybe DerivInstTys @@ -1362,20 +1356,31 @@ mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys = do DerivEnv { denv_cls = cls , denv_ctxt = deriv_ctxt } <- ask dflags <- getDynFlags + let isDeriveAnyClassEnabled = + deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock { dsm_stock_dit = dit , dsm_stock_gen_fn = gen_fn } - StockClassError msg -> derivingThingFailWith False msg - _ -> derivingThingFailWith False (nonStdErr cls) + StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why + CanDeriveAnyClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotStockDeriveable isDeriveAnyClassEnabled) + -- In the 'NonDerivableClass' case we can't derive with either stock or anyclass + -- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's + -- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it. + NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotStockDeriveable YesDeriveAnyClassEnabled) mk_eqn_anyclass :: DerivM EarlyDerivSpec mk_eqn_anyclass = do dflags <- getDynFlags - case canDeriveAnyClass dflags of - IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass - NotValid msg -> derivingThingFailWith False msg + let isDeriveAnyClassEnabled = + deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + case xopt LangExt.DeriveAnyClass dflags of + True -> mk_eqn_from_mechanism DerivSpecAnyClass + False -> derivingThingFailWith NoGeneralizedNewtypeDeriving + (DerivErrNotDeriveable isDeriveAnyClassEnabled) mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class -> Type -- The newtype's representation type @@ -1432,24 +1437,24 @@ mk_eqn_no_strategy = do DerivEnv { denv_cls = cls , denv_ctxt = deriv_ctxt } <- ask dflags <- getDynFlags + let isDeriveAnyClassEnabled = + deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) -- See Note [Deriving instances for classes themselves] - let dac_error msg + let dac_error | isClassTyCon rep_tc - = quotes (ppr tc) <+> text "is a type class," - <+> text "and can only have a derived instance" - $+$ text "if DeriveAnyClass is enabled" + = DerivErrOnlyAnyClassDeriveable tc isDeriveAnyClassEnabled | otherwise - = nonStdErr cls $$ msg + = DerivErrNotStockDeriveable isDeriveAnyClassEnabled case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of - NonDerivableClass msg -> derivingThingFailWith False (dac_error msg) - StockClassError msg -> derivingThingFailWith False msg - CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ - DerivSpecStock { dsm_stock_dit = dit - , dsm_stock_gen_fn = gen_fn } - CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass + NonDerivableClass -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error + StockClassError why -> derivingThingFailWith NoGeneralizedNewtypeDeriving why + CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ + DerivSpecStock { dsm_stock_dit = dit + , dsm_stock_gen_fn = gen_fn } + CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass {- ************************************************************************ @@ -1482,11 +1487,7 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags deriveAnyClass = xopt LangExt.DeriveAnyClass dflags - bale_out = derivingThingFailWith newtype_deriving - - non_std = nonStdErr cls - suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's" - <+> text "newtype-deriving extension" + bale_out = derivingThingFailWith (usingGeneralizedNewtypeDeriving newtype_deriving) -- Here is the plan for newtype derivings. We see -- newtype T a1...an = MkT (t ak+1...an) @@ -1555,9 +1556,6 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys -- And the [a] must not mention 'b'. That's all handled -- by nt_eta_rity. - cant_derive_err = ppUnless eta_ok eta_msg - eta_msg = text "cannot eta-reduce the representation type enough" - massert (cls_tys `lengthIs` (classArity cls - 1)) if newtype_strat then @@ -1569,8 +1567,7 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys -- See Note [Determining whether newtype-deriving is appropriate] if eta_ok && newtype_deriving then mk_eqn_newtype dit rep_inst_ty - else bale_out (cant_derive_err $$ - if newtype_deriving then empty else suggest_gnd) + else bale_out (DerivErrCannotEtaReduceEnough eta_ok) else if might_be_newtype_derivable && ((newtype_deriving && not deriveAnyClass) @@ -1578,7 +1575,7 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys then mk_eqn_newtype dit rep_inst_ty else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tycon rep_tycon of - StockClassError msg + StockClassError why -- There's a particular corner case where -- -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are @@ -1592,18 +1589,18 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys -> mk_eqn_newtype dit rep_inst_ty -- Otherwise, throw an error for a stock class | might_be_newtype_derivable && not newtype_deriving - -> bale_out (msg $$ suggest_gnd) + -> bale_out why | otherwise - -> bale_out msg + -> bale_out why -- Must use newtype deriving or DeriveAnyClass - NonDerivableClass _msg + NonDerivableClass -- Too hard, even with newtype deriving - | newtype_deriving -> bale_out cant_derive_err + | newtype_deriving -> bale_out (DerivErrCannotEtaReduceEnough eta_ok) -- Try newtype deriving! -- Here we suggest GeneralizedNewtypeDeriving even in cases -- where it may not be applicable. See #9600. - | otherwise -> bale_out (non_std $$ suggest_gnd) + | otherwise -> bale_out DerivErrNewtypeNonDeriveableClass -- DeriveAnyClass CanDeriveAnyClass -> do @@ -1613,16 +1610,7 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys -- See Note [Deriving strategies] when (newtype_deriving && deriveAnyClass) $ lift $ addDiagnosticTc - $ TcRnUnknownMessage - $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDerivingDefaults) noHints - $ sep - [ text "Both DeriveAnyClass and" - <+> text "GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy" - <+> text "for instantiating" <+> ppr cls - , text "Use DerivingStrategies to pick" - <+> text "a different strategy" - ] + $ TcRnDerivingDefaults cls mk_eqn_from_mechanism DerivSpecAnyClass -- CanDeriveStock CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ @@ -1931,7 +1919,7 @@ doDerivInstErrorChecks1 mechanism = lift $ addUsedDataCons rdr_env rep_tc unless (not hidden_data_cons) $ - bale_out $ derivingHiddenErr tc + bale_out $ DerivErrDataConsNotAllInScope tc -- Ensure that a class's associated type variables are suitable for -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is @@ -1970,24 +1958,12 @@ doDerivInstErrorChecks1 mechanism = last_cls_tv = assert (notNull cls_tyvars ) last cls_tyvars - cant_derive_err - = vcat [ ppUnless no_adfs adfs_msg - , maybe empty at_without_last_cls_tv_msg - at_without_last_cls_tv - , maybe empty at_last_cls_tv_in_kinds_msg - at_last_cls_tv_in_kinds - ] - adfs_msg = text "the class has associated data types" - at_without_last_cls_tv_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "is not parameterized over the last type variable") - 2 (text "of the class" <+> quotes (ppr cls)) - at_last_cls_tv_in_kinds_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "contains the last type variable") - 2 (text "of the class" <+> quotes (ppr cls) - <+> text "in a kind, which is not (yet) allowed") - unless ats_look_sensible $ bale_out cant_derive_err + unless ats_look_sensible $ + bale_out (DerivErrHasAssociatedDatatypes + (hasAssociatedDataFamInsts (not no_adfs)) + (associatedTyLastVarInKind at_last_cls_tv_in_kinds) + (associatedTyNotParamOverLastTyVar at_without_last_cls_tv) + ) doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan -> DerivSpecMechanism -> TcM () @@ -2004,39 +1980,28 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism ; case wildcard of Nothing -> pure () Just span -> setSrcSpan span $ do - checkTc xpartial_sigs (partial_sig_msg [pts_suggestion]) - diagnosticTc wpartial_sigs (partial_sig_msg noHints) + let suggParSigs = suggestPartialTypeSignatures xpartial_sigs + let dia = TcRnPartialTypeSignatures suggParSigs theta + checkTc xpartial_sigs dia + diagnosticTc wpartial_sigs dia -- Check for Generic instances that are derived with an exotic -- deriving strategy like DAC -- See Note [Deriving strategies] ; when (exotic_mechanism && className clas `elem` genericClassNames) $ - do { failIfTc (safeLanguageOn dflags) gen_inst_err + do { failIfTc (safeLanguageOn dflags) + (TcRnCannotDeriveInstance clas mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrSafeHaskellGenericInst) ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } } where exotic_mechanism = not $ isDerivSpecStock mechanism - partial_sig_msg :: [GhcHint] -> TcRnMessage - partial_sig_msg hints = TcRnUnknownMessage - $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialTypeSignatures) hints $ - text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) - - pts_suggestion :: GhcHint - pts_suggestion - = UnknownHint (text "To use the inferred type, enable PartialTypeSignatures") - - gen_inst_err :: TcRnMessage - gen_inst_err = TcRnUnknownMessage - $ mkPlainError noHints $ - text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." - -derivingThingFailWith :: Bool -- If True, add a snippet about how not even - -- GeneralizedNewtypeDeriving would make this - -- declaration work. This only kicks in when - -- an explicit deriving strategy is not given. - -> SDoc -- The error message +derivingThingFailWith :: UsingGeneralizedNewtypeDeriving + -- ^ If 'YesGeneralizedNewtypeDeriving', add a snippet about + -- how not even GeneralizedNewtypeDeriving would make this + -- declaration work. This only kicks in when + -- an explicit deriving strategy is not given. + -> DeriveInstanceErrReason -- The reason the derivation failed -> DerivM a derivingThingFailWith newtype_deriving msg = do err <- derivingThingErrM newtype_deriving msg @@ -2067,7 +2032,7 @@ genDerivStuff mechanism loc clas inst_tys tyvars tyfam_insts <- -- canDeriveAnyClass should ensure that this code can't be reached -- unless -XDeriveAnyClass is enabled. - assertPpr (isValid (canDeriveAnyClass dflags)) + assertPpr (xopt LangExt.DeriveAnyClass dflags) (ppr "genDerivStuff: bad derived class" <+> ppr clas) $ mapM (tcATDefault loc mini_subst emptyNameSet) (classATItems clas) @@ -2218,100 +2183,26 @@ What con2tag/tag2con functions are available? ************************************************************************ -} -nonUnaryErr :: LHsSigType GhcRn -> TcRnMessage -nonUnaryErr ct = TcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr ct) - <+> text "is not a unary constraint, as expected by a deriving clause" - -nonStdErr :: Class -> SDoc -nonStdErr cls = - quotes (ppr cls) - <+> text "is not a stock derivable class (Eq, Show, etc.)" - -gndNonNewtypeErr :: SDoc -gndNonNewtypeErr = - text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" - -derivingNullaryErr :: SDoc -derivingNullaryErr = text "Cannot derive instances for nullary classes" - -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> TcRnMessage -derivingKindErr tc cls cls_tys cls_kind enough_args - = TcRnUnknownMessage $ mkPlainError noHints $ - sep [ hang (text "Cannot derive well-kinded instance of form" - <+> quotes (pprClassPred cls cls_tys - <+> parens (ppr tc <+> text "..."))) - 2 gen1_suggestion - , nest 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind)) - ] - where - gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args - = text "(Perhaps you intended to use PolyKinds)" - | otherwise = Outputable.empty - -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> TcRnMessage -derivingViaKindErr cls cls_kind via_ty via_kind - = TcRnUnknownMessage $ mkPlainDiagnostic ErrorWithoutFlag noHints $ - hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) - -derivingEtaErr :: Class -> [Type] -> Type -> TcRnMessage -derivingEtaErr cls cls_tys inst_ty - = TcRnUnknownMessage $ mkPlainDiagnostic ErrorWithoutFlag noHints $ - sep [text "Cannot eta-reduce to an instance of form", - nest 2 (text "instance (...) =>" - <+> pprClassPred cls (cls_tys ++ [inst_ty]))] - -derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> SDoc -> TcRnMessage -derivingThingErr newtype_deriving cls cls_args mb_strat why - = derivingThingErr' newtype_deriving cls cls_args mb_strat - (maybe empty derivStrategyName mb_strat) why - -derivingThingErrM :: Bool -> SDoc -> DerivM TcRnMessage +derivingThingErrM :: UsingGeneralizedNewtypeDeriving + -> DeriveInstanceErrReason + -> DerivM TcRnMessage derivingThingErrM newtype_deriving why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask - pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why + pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why -derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM TcRnMessage +derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage derivingThingErrMechanism mechanism why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask - pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat - (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why - -derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> TcRnMessage -derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why - = TcRnUnknownMessage $ mkPlainError noHints $ - sep [(hang (text "Can't make a derived instance of") - 2 (quotes (ppr pred) <+> via_mechanism) - $$ nest 2 extra) <> colon, - nest 2 why] + pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why where - strat_used = isJust mb_strat - extra | not strat_used, newtype_deriving - = text "(even with cunning GeneralizedNewtypeDeriving)" - | otherwise = empty - pred = mkClassPred cls cls_args - via_mechanism | strat_used - = text "with the" <+> strat_msg <+> text "strategy" - | otherwise - = empty - -derivingHiddenErr :: TyCon -> SDoc -derivingHiddenErr tc - = hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") - 2 (text "so you cannot derive an instance for it") + newtype_deriving :: UsingGeneralizedNewtypeDeriving + newtype_deriving + = if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving + else NoGeneralizedNewtypeDeriving standaloneCtxt :: LHsSigWcType GhcRn -> SDoc standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index 4ad9c8b849..3d71c25b7d 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -27,6 +27,7 @@ import GHC.Core.Type import GHC.Tc.Utils.TcType import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor +import GHC.Tc.Errors.Types import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) @@ -47,7 +48,7 @@ import GHC.Builtin.Names import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Driver.Session -import GHC.Utils.Error( Validity'(..), Validity, andValid ) +import GHC.Utils.Error( Validity'(..), andValid ) import GHC.Types.SrcLoc import GHC.Data.Bag import GHC.Types.Var.Env @@ -146,7 +147,7 @@ following constraints are satisfied. -} -canDoGenerics :: TyCon -> Validity +canDoGenerics :: TyCon -> Validity' [DeriveGenericsErrReason] -- canDoGenerics determines if Generic/Rep can be derived. -- -- Check (a) from Note [Requirements for deriving Generic and Rep] is taken @@ -158,14 +159,14 @@ canDoGenerics tc = mergeErrors ( -- Check (b) from Note [Requirements for deriving Generic and Rep]. (if (not (null (tyConStupidTheta tc))) - then (NotValid (tc_name <+> text "must not have a datatype context")) + then (NotValid $ DerivErrGenericsMustNotHaveDatatypeContext tc_name) else IsValid) -- See comment below : (map bad_con (tyConDataCons tc))) where -- The tc can be a representation tycon. When we want to display it to the -- user (in an error message) we should print its parent - tc_name = ppr $ case tyConFamInst_maybe tc of + tc_name = case tyConFamInst_maybe tc of Just (ptc, _) -> ptc _ -> tc @@ -175,12 +176,12 @@ canDoGenerics tc -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors - bad_con dc = if (any bad_arg_type (map scaledThing $ dataConOrigArgTys dc)) - then (NotValid (ppr dc <+> text - "must not have exotic unlifted or polymorphic arguments")) - else (if (not (isVanillaDataCon dc)) - then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) - else IsValid) + bad_con :: DataCon -> Validity' DeriveGenericsErrReason + bad_con dc = if any bad_arg_type (map scaledThing $ dataConOrigArgTys dc) + then NotValid $ DerivErrGenericsMustNotHaveExoticArgs dc + else if not (isVanillaDataCon dc) + then NotValid $ DerivErrGenericsMustBeVanillaDataCon dc + else IsValid -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) @@ -194,19 +195,20 @@ canDoGenerics tc allowedUnliftedTy :: Type -> Bool allowedUnliftedTy = isJust . unboxedRepRDRs -mergeErrors :: [Validity] -> Validity +mergeErrors :: [Validity' a] -> Validity' [a] mergeErrors [] = IsValid mergeErrors (NotValid s:t) = case mergeErrors t of - IsValid -> NotValid s - NotValid s' -> NotValid (s <> text ", and" $$ s') + IsValid -> NotValid [s] + NotValid s' -> NotValid (s : s') mergeErrors (IsValid : t) = mergeErrors t + -- NotValid s' -> NotValid (s <> text ", and" $$ s') -- A datatype used only inside of canDoGenerics1. It's the result of analysing -- a type term. data Check_for_CanDoGenerics1 = CCDG1 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in -- this type? - , _ccdg1_errors :: Validity -- errors generated by this type + , _ccdg1_errors :: Validity' DeriveGenericsErrReason -- errors generated by this type } {- @@ -241,15 +243,14 @@ explicitly, even though foldDataConArgs is also doing this internally. -- -- It returns IsValid if deriving is possible. It returns (NotValid reason) -- if not. -canDoGenerics1 :: TyCon -> Validity +canDoGenerics1 :: TyCon -> Validity' [DeriveGenericsErrReason] canDoGenerics1 rep_tc = canDoGenerics rep_tc `andValid` additionalChecks where additionalChecks -- check (d) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = NotValid $ - text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" + | null (tyConTyVars rep_tc) = NotValid [ + DerivErrGenericsMustHaveSomeTypeParams rep_tc] | otherwise = mergeErrors $ concatMap check_con data_cons @@ -258,15 +259,12 @@ canDoGenerics1 rep_tc = j@(NotValid {}) -> [j] IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con - bad :: DataCon -> SDoc -> SDoc - bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg - - check_vanilla :: DataCon -> Validity + check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason check_vanilla con | isVanillaDataCon con = IsValid - | otherwise = NotValid (bad con existential) + | otherwise = NotValid $ DerivErrGenericsMustNotHaveExistentials con - bmzero = CCDG1 False IsValid - bmbad con s = CCDG1 True $ NotValid $ bad con s + bmzero = CCDG1 False IsValid + bmbad con = CCDG1 True $ NotValid (DerivErrGenericsWrongArgKind con) bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) -- check (e) from Note [Requirements for deriving Generic and Rep] @@ -279,30 +277,25 @@ canDoGenerics1 rep_tc = -- (component_0,component_1,...,component_n) , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) - then bmbad con wrong_arg + then bmbad con else foldr bmplus bmzero components -- (dom -> rng), where the head of ty is not a tuple tycon , ft_fun = \dom rng -> -- cf #8516 if _ccdg1_hasParam dom - then bmbad con wrong_arg + then bmbad con else bmplus dom rng -- (ty arg), where head of ty is neither (->) nor a tuple constructor and -- the parameter of interest does not occur in ty , ft_ty_app = \_ _ arg -> arg - , ft_bad_app = bmbad con wrong_arg + , ft_bad_app = bmbad con , ft_forall = \_ body -> body -- polytypes are handled elsewhere } where caseVar = CCDG1 True IsValid - - existential = text "must not have existential arguments" - wrong_arg = text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" - {- ************************************************************************ * * diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 444b372ada..d97db525eb 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -17,7 +17,6 @@ module GHC.Tc.Deriv.Utils ( PredOrigin(..), ThetaOrigin(..), mkPredOrigin, mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin, checkOriginativeSideConditions, hasStockDeriving, - canDeriveAnyClass, std_class_via_coercible, non_coercible_class, newDerivClsInst, extendLocalInstEnv ) where @@ -45,13 +44,13 @@ import GHC.Types.SrcLoc import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics +import GHC.Tc.Errors.Types import GHC.Tc.Types.Origin import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Builtin.Names.TH (liftClassKey) import GHC.Core.TyCon import GHC.Core.Multiplicity -import GHC.Core.TyCo.Ppr (pprSourceTyCon) import GHC.Core.Type import GHC.Utils.Misc import GHC.Types.Var.Set @@ -432,9 +431,9 @@ data OriginativeDerivStatus = CanDeriveStock -- Stock class, can derive (SrcSpan -> TyCon -> [Type] -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) - | StockClassError SDoc -- Stock class, but can't do it + | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it | CanDeriveAnyClass -- See Note [Deriving any class] - | NonDerivableClass SDoc -- Cannot derive with either stock or anyclass + | NonDerivableClass -- Cannot derive with either stock or anyclass -- A stock class is one either defined in the Haskell report or for which GHC -- otherwise knows how to generate code for (possibly requiring the use of a @@ -561,8 +560,7 @@ function determines the criteria that needs to be met in order for a particular stock class to be able to be derived successfully. A class might be able to be used in a deriving clause if -XDeriveAnyClass -is willing to support it. The canDeriveAnyClass function checks if this is the -case. +is willing to support it. -} hasStockDeriving @@ -702,14 +700,15 @@ checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc -- e.g. deriving( Eq s ) -- ...if not, try falling back on DeriveAnyClass. - | NotValid err <- canDeriveAnyClass dflags - = NonDerivableClass err -- Neither anyclass nor stock work + | xopt LangExt.DeriveAnyClass dflags + = CanDeriveAnyClass -- DeriveAnyClass should work | otherwise - = CanDeriveAnyClass -- DeriveAnyClass should work + = NonDerivableClass -- Neither anyclass nor stock work + -classArgsErr :: Class -> [Type] -> SDoc -classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class" +classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason +classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys) -- Side conditions (whether the datatype must have at least one constructor, -- required language extensions, etc.) for using GHC's stock deriving @@ -756,15 +755,6 @@ stockSideConditions deriv_ctxt cls cond_vanilla = cond_stdOK deriv_ctxt True -- Vanilla data constructors but allow no data cons or polytype arguments -canDeriveAnyClass :: DynFlags -> Validity --- IsValid: we can (try to) derive it via an empty instance declaration --- NotValid s: we can't, reason s -canDeriveAnyClass dflags - | not (xopt LangExt.DeriveAnyClass dflags) - = NotValid (text "Try enabling DeriveAnyClass") - | otherwise - = IsValid -- OK! - type Condition = DynFlags @@ -774,17 +764,10 @@ type Condition -> TyCon -- ^ For data families, this is the representation 'TyCon'. -- Otherwise, this is the same as the other 'TyCon' argument. - -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is - -- possible. Otherwise, it's @'NotValid' err@, where @err@ - -- explains what went wrong. - -orCond :: Condition -> Condition -> Condition -orCond c1 c2 dflags tc rep_tc - = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of - (IsValid, _) -> IsValid -- c1 succeeds - (_, IsValid) -> IsValid -- c21 succeeds - (NotValid x, NotValid y) -> NotValid (x $$ text " or" $$ y) - -- Both fail + -> Validity' DeriveInstanceErrReason + -- ^ 'IsValid' if deriving an instance for this 'TyCon' is + -- possible. Otherwise, it's @'NotValid' err@, where @err@ + -- explains what went wrong. andCond :: Condition -> Condition -> Condition andCond c1 c2 dflags tc rep_tc @@ -821,15 +804,14 @@ cond_stdOK cond_stdOK deriv_ctxt permissive dflags tc rep_tc = valid_ADT `andValid` valid_misc where - valid_ADT, valid_misc :: Validity + valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason valid_ADT | isAlgTyCon tc || isDataFamilyTyCon tc = IsValid | otherwise -- Complain about functions, primitive types, and other tycons that -- stock deriving can't handle. - = NotValid $ text "The last argument of the instance must be a" - <+> text "data or newtype application" + = NotValid DerivErrLastArgMustBeApp valid_misc = case deriv_ctxt of @@ -841,52 +823,62 @@ cond_stdOK deriv_ctxt permissive dflags tc rep_tc | null data_cons -- 1. , not permissive -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid` - NotValid (no_cons_why rep_tc $$ empty_data_suggestion) + NotValid (no_cons_why rep_tc) | not (null con_whys) - -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard) + -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys | otherwise -> IsValid - empty_data_suggestion = - text "Use EmptyDataDeriving to enable deriving for empty data types" - possible_fix_suggestion wildcard + has_wildcard wildcard = case wildcard of - Just _ -> - text "Possible fix: fill in the wildcard constraint yourself" - Nothing -> - text "Possible fix: use a standalone deriving declaration instead" + Just _ -> YesHasWildcard + Nothing -> NoHasWildcard data_cons = tyConDataCons rep_tc con_whys = getInvalids (map check_con data_cons) - check_con :: DataCon -> Validity + check_con :: DataCon -> Validity' DeriveInstanceBadConstructor check_con con | not (null eq_spec) -- 2. - = bad "is a GADT" + = bad DerivErrBadConIsGADT | not (null ex_tvs) -- 3. - = bad "has existential type variables in its type" + = bad DerivErrBadConHasExistentials | not (null theta) -- 4. - = bad "has constraints in its type" + = bad DerivErrBadConHasConstraints | not (permissive || all isTauTy (map scaledThing $ dataConOrigArgTys con)) -- 5. - = bad "has a higher-rank type" + = bad DerivErrBadConHasHigherRankType | otherwise = IsValid where (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con - bad msg = NotValid (badCon con (text msg)) + bad mkErr = NotValid $ mkErr con -no_cons_why :: TyCon -> SDoc -no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - text "must have at least one data constructor" +no_cons_why :: TyCon -> DeriveInstanceErrReason +no_cons_why = DerivErrNoConstructors cond_RepresentableOk :: Condition -cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc +cond_RepresentableOk _ _ rep_tc = + case canDoGenerics rep_tc of + IsValid -> IsValid + NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs cond_Representable1Ok :: Condition -cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc +cond_Representable1Ok _ _ rep_tc = + case canDoGenerics1 rep_tc of + IsValid -> IsValid + NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs cond_enumOrProduct :: Class -> Condition cond_enumOrProduct cls = cond_isEnumeration `orCond` (cond_isProduct `andCond` cond_args cls) + where + orCond :: Condition -> Condition -> Condition + orCond c1 c2 dflags tc rep_tc + = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of + (IsValid, _) -> IsValid -- c1 succeeds + (_, IsValid) -> IsValid -- c21 succeeds + (NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y + -- Both fail + cond_args :: Class -> Condition -- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types @@ -896,8 +888,7 @@ cond_args :: Class -> Condition cond_args cls _ _ rep_tc = case bad_args of [] -> IsValid - (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls)) - 2 (text "for type" <+> quotes (ppr ty))) + (ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty where bad_args = [ arg_ty | con <- tyConDataCons rep_tc , Scaled _ arg_ty <- dataConOrigArgTys con @@ -919,20 +910,14 @@ cond_args cls _ _ rep_tc cond_isEnumeration :: Condition cond_isEnumeration _ _ rep_tc | isEnumerationTyCon rep_tc = IsValid - | otherwise = NotValid why - where - why = sep [ quotes (pprSourceTyCon rep_tc) <+> - text "must be an enumeration type" - , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ] - -- See Note [Enumeration types] in GHC.Core.TyCon + | otherwise = NotValid $ DerivErrMustBeEnumType rep_tc cond_isProduct :: Condition cond_isProduct _ _ rep_tc - | Just _ <- tyConSingleDataCon_maybe rep_tc = IsValid - | otherwise = NotValid why - where - why = quotes (pprSourceTyCon rep_tc) <+> - text "must have precisely one constructor" + | Just _ <- tyConSingleDataCon_maybe rep_tc + = IsValid + | otherwise + = NotValid $ DerivErrMustHaveExactlyOneConstructor rep_tc cond_functorOK :: Bool -> Bool -> Condition -- OK for Functor/Foldable/Traversable class @@ -943,12 +928,10 @@ cond_functorOK :: Bool -> Bool -> Condition -- (e) no "stupid context" on data type cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc | null tc_tvs - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters") + = NotValid $ DerivErrMustHaveSomeParameters rep_tc | not (null bad_stupid_theta) - = NotValid (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) + = NotValid $ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta | otherwise = allValid (map check_con data_cons) @@ -962,7 +945,7 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc data_cons = tyConDataCons rep_tc check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) - check_universal :: DataCon -> Validity + check_universal :: DataCon -> Validity' DeriveInstanceErrReason check_universal con | allowExQuantifiedLastTyVar = IsValid -- See Note [DeriveFoldable with ExistentialQuantification] @@ -972,31 +955,26 @@ cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con)) = IsValid -- See Note [Check that the type variable is truly universal] | otherwise - = NotValid (badCon con existential) + = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConExistential con] - ft_check :: DataCon -> FFoldType Validity + ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason) ft_check con = FT { ft_triv = IsValid, ft_var = IsValid - , ft_co_var = NotValid (badCon con covariant) + , ft_co_var = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConCovariant con] , ft_fun = \x y -> if allowFunctions then x `andValid` y - else NotValid (badCon con functions) + else NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConFunTypes con] , ft_tup = \_ xs -> allValid xs , ft_ty_app = \_ _ x -> x - , ft_bad_app = NotValid (badCon con wrong_arg) + , ft_bad_app = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConWrongArg con] , ft_forall = \_ x -> x } - existential = text "must be truly polymorphic in the last argument of the data type" - covariant = text "must not use the type variable in a function argument" - functions = text "must not contain function types" - wrong_arg = text "must use the type variable only as the last argument of a data type" checkFlag :: LangExt.Extension -> Condition checkFlag flag dflags _ _ | xopt flag dflags = IsValid | otherwise = NotValid why where - why = text "You need " <> text flag_str - <+> text "to derive an instance for this class" - flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of + why = DerivErrLangExtRequired the_flag + the_flag = case [ flagSpecFlag f | f <- xFlags , flagSpecFlag f == flag ] of [s] -> s other -> pprPanic "checkFlag" (ppr other) @@ -1021,9 +999,6 @@ non_coercible_class cls , genClassKey, gen1ClassKey, typeableClassKey , traversableClassKey, liftClassKey ]) -badCon :: DataCon -> SDoc -> SDoc -badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg - ------------------------------------------------------------------ newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 6975eeb9d3..bde384887a 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -9,17 +9,24 @@ module GHC.Tc.Errors.Ppr ( import GHC.Prelude +import Data.Maybe (isJust) + +import GHC.Builtin.Names import GHC.Core.Class (Class(..)) import GHC.Core.Coercion (pprCoAxBranchUser) import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch) +import GHC.Core.DataCon (DataCon) import GHC.Core.FamInstEnv (famInstAxiom) import GHC.Core.InstEnv -import GHC.Core.TyCo.Ppr (pprKind, pprParendType, pprType, pprWithTYPE, pprWithExplicitKindsWhen) +import GHC.Core.TyCon (isNewTyCon) +import GHC.Core.TyCo.Ppr (pprKind, pprParendType, pprType, pprWithTYPE, + pprWithExplicitKindsWhen, pprTheta, pprClassPred, pprTypeApp, + pprSourceTyCon) import GHC.Core.Type import GHC.Data.Bag import GHC.Tc.Errors.Types import GHC.Tc.Types.Rank (Rank(..)) -import GHC.Tc.Utils.TcType (TcType, tcSplitForAllTyVars) +import GHC.Tc.Utils.TcType (TcType, tcSplitForAllTyVars, mkClassPred) import GHC.Types.Error import GHC.Types.FieldLabel (FieldLabelString, flIsOverloaded, flSelector) import GHC.Types.Id (isRecordSelector) @@ -31,8 +38,8 @@ import GHC.Types.Var.Env (emptyTidyEnv) import GHC.Types.Var.Set (pprVarSet, pluralVarSet) import GHC.Driver.Flags import GHC.Hs -import GHC.Utils.Outputable import GHC.Utils.Misc (capitalise) +import GHC.Utils.Outputable import GHC.Unit.State (pprWithUnitState, UnitState) import qualified GHC.LanguageExtensions as LangExt import qualified Data.List.NonEmpty as NE @@ -471,6 +478,29 @@ instance Diagnostic TcRnMessage where NotClosed _ _ -> msg : causes reason _ -> let (xs0, xs1) = splitAt 1 $ causes reason in fmap (msg <+>) xs0 ++ xs1 + TcRnUselessTypeable + -> mkSimpleDecorated $ + text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" + TcRnDerivingDefaults cls + -> mkSimpleDecorated $ sep + [ text "Both DeriveAnyClass and" + <+> text "GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy" + <+> text "for instantiating" <+> ppr cls + ] + TcRnNonUnaryTypeclassConstraint ct + -> mkSimpleDecorated $ + quotes (ppr ct) + <+> text "is not a unary constraint, as expected by a deriving clause" + TcRnPartialTypeSignatures _ theta + -> mkSimpleDecorated $ + text "Found type wildcard" <+> quotes (char '_') + <+> text "standing for" <+> quotes (pprTheta theta) + TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason + -> mkSimpleDecorated $ + derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason + diagnosticReason = \case TcRnUnknownMessage m @@ -644,6 +674,43 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnStaticFormNotClosed{} -> ErrorWithoutFlag + TcRnUselessTypeable + -> WarningWithFlag Opt_WarnDerivingTypeable + TcRnDerivingDefaults{} + -> WarningWithFlag Opt_WarnDerivingDefaults + TcRnNonUnaryTypeclassConstraint{} + -> ErrorWithoutFlag + TcRnPartialTypeSignatures{} + -> WarningWithFlag Opt_WarnPartialTypeSignatures + TcRnCannotDeriveInstance _ _ _ _ rea + -> case rea of + DerivErrNotWellKinded{} -> ErrorWithoutFlag + DerivErrSafeHaskellGenericInst -> ErrorWithoutFlag + DerivErrDerivingViaWrongKind{} -> ErrorWithoutFlag + DerivErrNoEtaReduce{} -> ErrorWithoutFlag + DerivErrBootFileFound -> ErrorWithoutFlag + DerivErrDataConsNotAllInScope{} -> ErrorWithoutFlag + DerivErrGNDUsedOnData -> ErrorWithoutFlag + DerivErrNullaryClasses -> ErrorWithoutFlag + DerivErrLastArgMustBeApp -> ErrorWithoutFlag + DerivErrNoFamilyInstance{} -> ErrorWithoutFlag + DerivErrNotStockDeriveable{} -> ErrorWithoutFlag + DerivErrHasAssociatedDatatypes{} -> ErrorWithoutFlag + DerivErrNewtypeNonDeriveableClass -> ErrorWithoutFlag + DerivErrCannotEtaReduceEnough{} -> ErrorWithoutFlag + DerivErrOnlyAnyClassDeriveable{} -> ErrorWithoutFlag + DerivErrNotDeriveable{} -> ErrorWithoutFlag + DerivErrNotAClass{} -> ErrorWithoutFlag + DerivErrNoConstructors{} -> ErrorWithoutFlag + DerivErrLangExtRequired{} -> ErrorWithoutFlag + DerivErrDunnoHowToDeriveForType{} -> ErrorWithoutFlag + DerivErrMustBeEnumType{} -> ErrorWithoutFlag + DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag + DerivErrMustHaveSomeParameters{} -> ErrorWithoutFlag + DerivErrMustNotHaveClassContext{} -> ErrorWithoutFlag + DerivErrBadConstructor{} -> ErrorWithoutFlag + DerivErrGenerics{} -> ErrorWithoutFlag + DerivErrEnumOrProduct{} -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -833,6 +900,103 @@ instance Diagnostic TcRnMessage where -> noHints TcRnStaticFormNotClosed{} -> noHints + TcRnUselessTypeable + -> noHints + TcRnDerivingDefaults{} + -> [useDerivingStrategies] + TcRnNonUnaryTypeclassConstraint{} + -> noHints + TcRnPartialTypeSignatures suggestParSig _ + -> case suggestParSig of + YesSuggestPartialTypeSignatures + -> let info = text "to use the inferred type" + in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures] + NoSuggestPartialTypeSignatures + -> noHints + TcRnCannotDeriveInstance cls _ _ newtype_deriving rea + -> deriveInstanceErrReasonHints cls newtype_deriving rea + + +deriveInstanceErrReasonHints :: Class + -> UsingGeneralizedNewtypeDeriving + -> DeriveInstanceErrReason + -> [GhcHint] +deriveInstanceErrReasonHints cls newtype_deriving = \case + DerivErrNotWellKinded _ _ n_args_to_keep + | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0 + -> [suggestExtension LangExt.PolyKinds] + | otherwise + -> noHints + DerivErrSafeHaskellGenericInst -> noHints + DerivErrDerivingViaWrongKind{} -> noHints + DerivErrNoEtaReduce{} -> noHints + DerivErrBootFileFound -> noHints + DerivErrDataConsNotAllInScope{} -> noHints + DerivErrGNDUsedOnData -> noHints + DerivErrNullaryClasses -> noHints + DerivErrLastArgMustBeApp -> noHints + DerivErrNoFamilyInstance{} -> noHints + DerivErrNotStockDeriveable deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrHasAssociatedDatatypes{} + -> noHints + DerivErrNewtypeNonDeriveableClass + | newtype_deriving == NoGeneralizedNewtypeDeriving + -> [useGND] + | otherwise + -> noHints + DerivErrCannotEtaReduceEnough{} + | newtype_deriving == NoGeneralizedNewtypeDeriving + -> [useGND] + | otherwise + -> noHints + DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrNotDeriveable deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrNotAClass{} + -> noHints + DerivErrNoConstructors{} + -> let info = text "to enable deriving for empty data types" + in [useExtensionInOrderTo info LangExt.EmptyDataDeriving] + DerivErrLangExtRequired{} + -- This is a slightly weird corner case of GHC: we are failing + -- to derive a typeclass instance because a particular 'Extension' + -- is not enabled (and so we report in the main error), but here + -- we don't want to /repeat/ to enable the extension in the hint. + -> noHints + DerivErrDunnoHowToDeriveForType{} + -> noHints + DerivErrMustBeEnumType rep_tc + -- We want to suggest GND only if this /is/ a newtype. + | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc + -> [useGND] + | otherwise + -> noHints + DerivErrMustHaveExactlyOneConstructor{} + -> noHints + DerivErrMustHaveSomeParameters{} + -> noHints + DerivErrMustNotHaveClassContext{} + -> noHints + DerivErrBadConstructor wcard _ + -> case wcard of + Nothing -> noHints + Just YesHasWildcard -> [SuggestFillInWildcardConstraint] + Just NoHasWildcard -> [SuggestAddStandaloneDerivation] + DerivErrGenerics{} + -> noHints + DerivErrEnumOrProduct{} + -> noHints messageWithInfoDiagnosticMessage :: UnitState -> ErrInfo @@ -919,3 +1083,210 @@ formatExportItemError exportedThing reason = hsep [ text "The export item" , quotes exportedThing , text reason ] + +useDerivingStrategies :: GhcHint +useDerivingStrategies = + useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies + +useGND :: GhcHint +useGND = let info = text "for GHC's" <+> text "newtype-deriving extension" + in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving + +cannotMakeDerivedInstanceHerald :: Class + -> [Type] + -> Maybe (DerivStrategy GhcTc) + -> UsingGeneralizedNewtypeDeriving + -> Bool -- ^ If False, only prints the why. + -> SDoc + -> SDoc +cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why = + if pprHerald + then sep [(hang (text "Can't make a derived instance of") + 2 (quotes (ppr pred) <+> via_mechanism) + $$ nest 2 extra) <> colon, + nest 2 why] + else why + where + strat_used = isJust mb_strat + extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving) + = text "(even with cunning GeneralizedNewtypeDeriving)" + | otherwise = empty + pred = mkClassPred cls cls_args + via_mechanism | strat_used + , Just strat <- mb_strat + = text "with the" <+> (derivStrategyName strat) <+> text "strategy" + | otherwise + = empty + +badCon :: DataCon -> SDoc -> SDoc +badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg + +derivErrDiagnosticMessage :: Class + -> [Type] + -> Maybe (DerivStrategy GhcTc) + -> UsingGeneralizedNewtypeDeriving + -> Bool -- If True, includes the herald \"can't make a derived..\" + -> DeriveInstanceErrReason + -> SDoc +derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case + DerivErrNotWellKinded tc cls_kind _ + -> sep [ hang (text "Cannot derive well-kinded instance of form" + <+> quotes (pprClassPred cls cls_tys + <+> parens (ppr tc <+> text "..."))) + 2 empty + , nest 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind)) + ] + DerivErrSafeHaskellGenericInst + -> text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." + DerivErrDerivingViaWrongKind cls_kind via_ty via_kind + -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) + DerivErrNoEtaReduce inst_ty + -> sep [text "Cannot eta-reduce to an instance of form", + nest 2 (text "instance (...) =>" + <+> pprClassPred cls (cls_tys ++ [inst_ty]))] + DerivErrBootFileFound + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Cannot derive instances in hs-boot files" + $+$ text "Write an instance declaration instead") + DerivErrDataConsNotAllInScope tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") + 2 (text "so you cannot derive an instance for it")) + DerivErrGNDUsedOnData + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes") + DerivErrNullaryClasses + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Cannot derive instances for nullary classes") + DerivErrLastArgMustBeApp + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + ( text "The last argument of the instance must be a" + <+> text "data or newtype application") + DerivErrNoFamilyInstance tc tc_args + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "No family instance for" <+> quotes (pprTypeApp tc tc_args)) + DerivErrNotStockDeriveable _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)") + DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg + , case at_without_last_cls_tv of + YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc + NoAssociatedTyNotParamOverLastTyVar -> empty + , case at_last_cls_tv_in_kinds of + YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc + NoAssocTyLastVarInKind -> empty + ] + where + + adfs_msg = text "the class has associated data types" + + at_without_last_cls_tv_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "is not parameterized over the last type variable") + 2 (text "of the class" <+> quotes (ppr cls)) + + at_last_cls_tv_in_kinds_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "contains the last type variable") + 2 (text "of the class" <+> quotes (ppr cls) + <+> text "in a kind, which is not (yet) allowed") + DerivErrNewtypeNonDeriveableClass + -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled) + DerivErrCannotEtaReduceEnough eta_ok + -> let cant_derive_err = ppUnless eta_ok eta_msg + eta_msg = text "cannot eta-reduce the representation type enough" + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + cant_derive_err + DerivErrOnlyAnyClassDeriveable tc _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr tc) <+> text "is a type class," + <+> text "and can only have a derived instance" + $+$ text "if DeriveAnyClass is enabled") + DerivErrNotDeriveable _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty + DerivErrNotAClass predType + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr predType) <+> text "is not a class") + DerivErrNoConstructors rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor") + DerivErrLangExtRequired ext + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "You need " <> ppr ext + <+> text "to derive an instance for this class") + DerivErrDunnoHowToDeriveForType ty + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (hang (text "Don't know how to derive" <+> quotes (ppr cls)) + 2 (text "for type" <+> quotes (ppr ty))) + DerivErrMustBeEnumType rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (sep [ quotes (pprSourceTyCon rep_tc) <+> + text "must be an enumeration type" + , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]) + + DerivErrMustHaveExactlyOneConstructor rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor") + DerivErrMustHaveSomeParameters rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters") + DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) + DerivErrBadConstructor _ reasons + -> let why = vcat $ map renderReason reasons + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why + where + renderReason = \case + DerivErrBadConExistential con + -> badCon con $ text "must be truly polymorphic in the last argument of the data type" + DerivErrBadConCovariant con + -> badCon con $ text "must not use the type variable in a function argument" + DerivErrBadConFunTypes con + -> badCon con $ text "must not contain function types" + DerivErrBadConWrongArg con + -> badCon con $ text "must use the type variable only as the last argument of a data type" + DerivErrBadConIsGADT con + -> badCon con $ text "is a GADT" + DerivErrBadConHasExistentials con + -> badCon con $ text "has existential type variables in its type" + DerivErrBadConHasConstraints con + -> badCon con $ text "has constraints in its type" + DerivErrBadConHasHigherRankType con + -> badCon con $ text "has a higher-rank type" + DerivErrGenerics reasons + -> let why = vcat $ map renderReason reasons + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why + where + renderReason = \case + DerivErrGenericsMustNotHaveDatatypeContext tc_name + -> ppr tc_name <+> text "must not have a datatype context" + DerivErrGenericsMustNotHaveExoticArgs dc + -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments" + DerivErrGenericsMustBeVanillaDataCon dc + -> ppr dc <+> text "must be a vanilla data constructor" + DerivErrGenericsMustHaveSomeTypeParams rep_tc + -> text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters" + DerivErrGenericsMustNotHaveExistentials con + -> badCon con $ text "must not have existential arguments" + DerivErrGenericsWrongArgKind con + -> badCon con $ + text "applies a type to an argument involving the last parameter" + $$ text "but the applied type is not of kind * -> *" + DerivErrEnumOrProduct this that + -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this + ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (ppr1 $$ text " or" $$ ppr2) diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 7bcd83c98c..a7418e7e58 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -13,6 +13,23 @@ module GHC.Tc.Errors.Types ( , SuggestUndecidableInstances(..) , suggestUndecidableInstances , NotClosedReason(..) + , SuggestPartialTypeSignatures(..) + , suggestPartialTypeSignatures + , DeriveInstanceErrReason(..) + , UsingGeneralizedNewtypeDeriving(..) + , usingGeneralizedNewtypeDeriving + , DeriveAnyClassEnabled(..) + , deriveAnyClassEnabled + , DeriveInstanceBadConstructor(..) + , HasWildcard(..) + , hasWildcard + , DeriveGenericsErrReason(..) + , HasAssociatedDataFamInsts(..) + , hasAssociatedDataFamInsts + , AssociatedTyLastVarInKind(..) + , associatedTyLastVarInKind + , AssociatedTyNotParamOverLastTyVar(..) + , associatedTyNotParamOverLastTyVar ) where import GHC.Prelude @@ -35,13 +52,15 @@ import GHC.Utils.Outputable import GHC.Core.Class (Class) import GHC.Core.Coercion.Axiom (CoAxBranch) import GHC.Core.ConLike (ConLike) +import GHC.Core.DataCon (DataCon) import GHC.Core.FamInstEnv (FamInst) import GHC.Core.InstEnv (ClsInst) import GHC.Core.TyCon (TyCon, TyConFlavour) -import GHC.Core.Type (Kind, Type, Var) +import GHC.Core.Type (Kind, Type, Var, ThetaType, PredType) import GHC.Unit.State (UnitState) import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic +import qualified GHC.LanguageExtensions as LangExt import qualified Data.List.NonEmpty as NE import Data.Typeable hiding (TyCon) @@ -1231,6 +1250,129 @@ data TcRnMessage where -} TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage + {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that + occurs when trying to derive an instance of the 'Typeable' class. Deriving + 'Typeable' is no longer necessary (hence the \"useless\") as all types + automatically derive 'Typeable' in modern GHC versions. + + Example(s): None. + + Test cases: warnings/should_compile/DerivingTypeable + -} + TcRnUselessTypeable :: TcRnMessage + + {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that + occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are + enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not + be what the user wants. + + Example(s): None. + + Test cases: typecheck/should_compile/T15839a + deriving/should_compile/T16179 + -} + TcRnDerivingDefaults :: !Class -> TcRnMessage + + {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC + encounters a non-unary constraint when trying to derive a typeclass. + + Example(s): + class A + deriving instance A + data B deriving A -- We cannot derive A, is not unary (i.e. 'class A a'). + + Test cases: deriving/should_fail/T7959 + deriving/should_fail/drvfail005 + deriving/should_fail/drvfail009 + deriving/should_fail/drvfail006 + -} + TcRnNonUnaryTypeclassConstraint :: !(LHsSigType GhcRn) -> TcRnMessage + + {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures) + that occurs when a wildcard '_' is found in place of a type in a signature or a + type class derivation + + Example(s): + foo :: _ -> Int + foo = ... + + deriving instance _ => Eq (Foo a) + + Test cases: dependent/should_compile/T11241 + dependent/should_compile/T15076 + dependent/should_compile/T14880-2 + typecheck/should_compile/T17024 + typecheck/should_compile/T10072 + partial-sigs/should_fail/TidyClash2 + partial-sigs/should_fail/Defaulting1MROff + partial-sigs/should_fail/WildcardsInPatternAndExprSig + partial-sigs/should_fail/T10615 + partial-sigs/should_fail/T14584a + partial-sigs/should_fail/TidyClash + partial-sigs/should_fail/T11122 + partial-sigs/should_fail/T14584 + partial-sigs/should_fail/T10045 + partial-sigs/should_fail/PartialTypeSignaturesDisabled + partial-sigs/should_fail/T10999 + partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature + partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice + partial-sigs/should_fail/WildcardInstantiations + partial-sigs/should_run/T15415 + partial-sigs/should_compile/T10463 + partial-sigs/should_compile/T15039a + partial-sigs/should_compile/T16728b + partial-sigs/should_compile/T15039c + partial-sigs/should_compile/T10438 + partial-sigs/should_compile/SplicesUsed + partial-sigs/should_compile/T18008 + partial-sigs/should_compile/ExprSigLocal + partial-sigs/should_compile/T11339a + partial-sigs/should_compile/T11670 + partial-sigs/should_compile/WarningWildcardInstantiations + partial-sigs/should_compile/T16728 + partial-sigs/should_compile/T12033 + partial-sigs/should_compile/T15039b + partial-sigs/should_compile/T10403 + partial-sigs/should_compile/T11192 + partial-sigs/should_compile/T16728a + partial-sigs/should_compile/TypedSplice + partial-sigs/should_compile/T15039d + partial-sigs/should_compile/T11016 + partial-sigs/should_compile/T13324_compile2 + linear/should_fail/LinearPartialSig + polykinds/T14265 + polykinds/T14172 + -} + TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage + + {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance + can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason + this error arose. + + Example(s): None. + + Test cases: generics/T10604/T10604_no_PolyKinds + deriving/should_fail/drvfail009 + deriving/should_fail/drvfail-functor2 + deriving/should_fail/T10598_fail3 + deriving/should_fail/deriving-via-fail2 + deriving/should_fail/deriving-via-fail + deriving/should_fail/T16181 + -} + TcRnCannotDeriveInstance :: !Class + -- ^ The typeclass we are trying to derive + -- an instance for + -> [Type] + -- ^ The typeclass arguments, if any. + -> !(Maybe (DerivStrategy GhcTc)) + -- ^ The derivation strategy, if any. + -> !UsingGeneralizedNewtypeDeriving + -- ^ Is '-XGeneralizedNewtypeDeriving' enabled? + -> !DeriveInstanceErrReason + -- ^ The specific reason why we couldn't derive + -- an instance for the class. + -> TcRnMessage + -- | Which parts of a record field are affected by a particular error or warning. data RecordFieldPart = RecordFieldConstructor !Name @@ -1291,3 +1433,183 @@ suggestUndecidableInstances False = NoSuggestUndecidableInstaces data NotClosedReason = NotLetBoundReason | NotTypeClosed VarSet | NotClosed Name NotClosedReason + +data SuggestPartialTypeSignatures + = YesSuggestPartialTypeSignatures + | NoSuggestPartialTypeSignatures + deriving (Show, Eq) + +suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures +suggestPartialTypeSignatures True = YesSuggestPartialTypeSignatures +suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures + +data UsingGeneralizedNewtypeDeriving + = YesGeneralizedNewtypeDeriving + | NoGeneralizedNewtypeDeriving + deriving Eq + +usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving +usingGeneralizedNewtypeDeriving True = YesGeneralizedNewtypeDeriving +usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving + +data DeriveAnyClassEnabled + = YesDeriveAnyClassEnabled + | NoDeriveAnyClassEnabled + deriving Eq + +deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled +deriveAnyClassEnabled True = YesDeriveAnyClassEnabled +deriveAnyClassEnabled False = NoDeriveAnyClassEnabled + +-- | Why a particular typeclass instance couldn't be derived. +data DeriveInstanceErrReason + = + -- | The typeclass instance is not well-kinded. + DerivErrNotWellKinded !TyCon + -- ^ The type constructor that occurs in + -- the typeclass instance declaration. + !Kind + -- ^ The typeclass kind. + !Int + -- ^ The number of typeclass arguments that GHC + -- kept. See Note [tc_args and tycon arity] in + -- GHC.Tc.Deriv. + -- | Generic instances can only be derived using the stock strategy + -- in Safe Haskell. + | DerivErrSafeHaskellGenericInst + | DerivErrDerivingViaWrongKind !Kind !Type !Kind + | DerivErrNoEtaReduce !Type + -- ^ The instance type + -- | We cannot derive instances in boot files + | DerivErrBootFileFound + | DerivErrDataConsNotAllInScope !TyCon + -- | We cannot use GND on non-newtype types + | DerivErrGNDUsedOnData + -- | We cannot derive instances of nullary classes + | DerivErrNullaryClasses + -- | Last arg must be newtype or data application + | DerivErrLastArgMustBeApp + | DerivErrNoFamilyInstance !TyCon [Type] + | DerivErrNotStockDeriveable !DeriveAnyClassEnabled + | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts + !AssociatedTyLastVarInKind + !AssociatedTyNotParamOverLastTyVar + | DerivErrNewtypeNonDeriveableClass + | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK? + | DerivErrOnlyAnyClassDeriveable !TyCon + -- ^ Type constructor for which the instance + -- is requested + !DeriveAnyClassEnabled + -- ^ Whether or not -XDeriveAnyClass is enabled + -- already. + -- | Stock deriving won't work, but perhas DeriveAnyClass will. + | DerivErrNotDeriveable !DeriveAnyClassEnabled + -- | The given 'PredType' is not a class. + | DerivErrNotAClass !PredType + -- | The given (representation of the) 'TyCon' has no + -- data constructors. + | DerivErrNoConstructors !TyCon + | DerivErrLangExtRequired !LangExt.Extension + -- | GHC simply doesn't how to how derive the input 'Class' for the given + -- 'Type'. + | DerivErrDunnoHowToDeriveForType !Type + -- | The given 'TyCon' must be an enumeration. + -- See Note [Enumeration types] in GHC.Core.TyCon + | DerivErrMustBeEnumType !TyCon + -- | The given 'TyCon' must have /precisely/ one constructor. + | DerivErrMustHaveExactlyOneConstructor !TyCon + -- | The given data type must have some parameters. + | DerivErrMustHaveSomeParameters !TyCon + -- | The given data type must not have a class context. + | DerivErrMustNotHaveClassContext !TyCon !ThetaType + -- | We couldn't derive an instance for a particular data constructor + -- for a variety of reasons. + | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor] + -- | We couldn't derive a 'Generic' instance for the given type for a + -- variety of reasons + | DerivErrGenerics [DeriveGenericsErrReason] + -- | We couldn't derive an instance either because the type was not an + -- enum type or because it did have more than one constructor. + | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason + +data DeriveInstanceBadConstructor + = + -- | The given 'DataCon' must be truly polymorphic in the + -- last argument of the data type. + DerivErrBadConExistential !DataCon + -- | The given 'DataCon' must not use the type variable in a function argument" + | DerivErrBadConCovariant !DataCon + -- | The given 'DataCon' must not contain function types + | DerivErrBadConFunTypes !DataCon + -- | The given 'DataCon' must use the type variable only + -- as the last argument of a data type + | DerivErrBadConWrongArg !DataCon + -- | The given 'DataCon' is a GADT so we cannot directly + -- derive an istance for it. + | DerivErrBadConIsGADT !DataCon + -- | The given 'DataCon' has existentials type vars in its type. + | DerivErrBadConHasExistentials !DataCon + -- | The given 'DataCon' has constraints in its type. + | DerivErrBadConHasConstraints !DataCon + -- | The given 'DataCon' has a higher-rank type. + | DerivErrBadConHasHigherRankType !DataCon + +data DeriveGenericsErrReason + = -- | The type must not have some datatype context. + DerivErrGenericsMustNotHaveDatatypeContext !TyCon + -- | The data constructor must not have exotic unlifted + -- or polymorphic arguments. + | DerivErrGenericsMustNotHaveExoticArgs !DataCon + -- | The data constructor must be a vanilla constructor. + | DerivErrGenericsMustBeVanillaDataCon !DataCon + -- | The type must have some type parameters. + -- check (d) from Note [Requirements for deriving Generic and Rep] + -- in GHC.Tc.Deriv.Generics. + | DerivErrGenericsMustHaveSomeTypeParams !TyCon + -- | The data constructor must not have existential arguments. + | DerivErrGenericsMustNotHaveExistentials !DataCon + -- | The derivation applies a type to an argument involving + -- the last parameter but the applied type is not of kind * -> *. + | DerivErrGenericsWrongArgKind !DataCon + +data HasWildcard + = YesHasWildcard + | NoHasWildcard + deriving Eq + +hasWildcard :: Bool -> HasWildcard +hasWildcard True = YesHasWildcard +hasWildcard False = NoHasWildcard + +-- | A type representing whether or not the input type has associated data family instances. +data HasAssociatedDataFamInsts + = YesHasAdfs + | NoHasAdfs + deriving Eq + +hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts +hasAssociatedDataFamInsts True = YesHasAdfs +hasAssociatedDataFamInsts False = NoHasAdfs + +-- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass +-- contains the last type variable of the class in a kind, which is not (yet) allowed +-- by GHC. +data AssociatedTyLastVarInKind + = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class + | NoAssocTyLastVarInKind + deriving Eq + +associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind +associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc +associatedTyLastVarInKind Nothing = NoAssocTyLastVarInKind + +-- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a +-- typeclass is not parameterized over the last type variable of the class +data AssociatedTyNotParamOverLastTyVar + = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class + | NoAssociatedTyNotParamOverLastTyVar + deriving Eq + +associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar +associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc +associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index aa5b2a5770..fced578e64 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -41,6 +41,7 @@ module GHC.Types.Error , suggestExtensionsWithInfo , suggestAnyExtension , suggestAnyExtensionWithInfo + , useExtensionInOrderTo , noHints -- * Rendering Messages diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs index f6e9445976..d0980bce95 100644 --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -11,6 +11,7 @@ module GHC.Types.Hint ( , suggestExtensionsWithInfo , suggestAnyExtension , suggestAnyExtensionWithInfo + , useExtensionInOrderTo ) where import GHC.Prelude @@ -38,10 +39,16 @@ data AvailableBindings -- ^ An unknown binding (i.e. too complicated to turn into a 'Name') data LanguageExtensionHint - = -- | Suggest to enable the input extension. If the input 'SDoc' - -- is not empty, it will contain some extra information about the - -- why the extension is required, but it's totally irrelevant/redundant - -- for IDEs and other tools. + = -- | Suggest to enable the input extension. This is the hint that + -- GHC emits if this is not a \"known\" fix, i.e. this is GHC giving + -- its best guess on what extension might be necessary to make a + -- certain program compile. For example, GHC might suggests to + -- enable 'BlockArguments' when the user simply formatted incorrectly + -- the input program, so GHC here is trying to be as helpful as + -- possible. + -- If the input 'SDoc' is not empty, it will contain some extra + -- information about the why the extension is required, but + -- it's totally irrelevant/redundant for IDEs and other tools. SuggestSingleExtension !SDoc !LangExt.Extension -- | Suggest to enable the input extensions. The list -- is to be intended as /disjuctive/ i.e. the user is @@ -57,6 +64,17 @@ data LanguageExtensionHint -- information about the why the extensions are required, but -- it's totally irrelevant/redundant for IDEs and other tools. | SuggestExtensions !SDoc [LangExt.Extension] + -- | Suggest to enable the input extension in order to fix + -- a certain problem. This is the suggestion that GHC emits when + -- is more-or-less clear \"what's going on\". For example, if + -- both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are + -- turned on, the right thing to do is to enabled 'DerivingStrategies', + -- so in contrast to 'SuggestSingleExtension' GHC will be a bit more + -- \"imperative\" (i.e. \"Use X Y Z in order to ... \"). + -- If the input 'SDoc' is not empty, it will contain some extra + -- information about the why the extensions are required, but + -- it's totally irrelevant/redundant for IDEs and other tools. + | SuggestExtensionInOrderTo !SDoc !LangExt.Extension -- | Suggests a single extension without extra user info. suggestExtension :: LangExt.Extension -> GhcHint @@ -82,6 +100,9 @@ suggestAnyExtension exts = SuggestExtension (SuggestAnyExtension empty exts) suggestAnyExtensionWithInfo :: SDoc -> [LangExt.Extension] -> GhcHint suggestAnyExtensionWithInfo extraInfo exts = SuggestExtension (SuggestAnyExtension extraInfo exts) +useExtensionInOrderTo :: SDoc -> LangExt.Extension -> GhcHint +useExtensionInOrderTo extraInfo ext = SuggestExtension (SuggestExtensionInOrderTo extraInfo ext) + -- | A type for hints emitted by GHC. -- A /hint/ suggests a possible way to deal with a particular warning or error. data GhcHint @@ -269,6 +290,25 @@ data GhcHint -} | SuggestFixOrphanInstance + {-| Suggests to use a standalone deriving declaration when GHC + can't derive a typeclass instance in a trivial way. + + Triggered by: 'GHC.Tc.Errors.Types.DerivBadErrConstructor' + Test cases(s): typecheck/should_fail/tcfail086 + -} + | SuggestAddStandaloneDerivation + + {-| Suggests the user to fill in the wildcard constraint to + disambiguate which constraint that is. + + Example: + deriving instance _ => Eq (Foo f a) + + Triggered by: 'GHC.Tc.Errors.Types.DerivBadErrConstructor' + Test cases(s): partial-sigs/should_fail/T13324_fail2 + -} + | SuggestFillInWildcardConstraint + -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way -- to instantiate a particular signature, where the first argument is diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs index 6651fbd2e3..00ffb9173a 100644 --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -34,6 +34,8 @@ instance Outputable GhcHint where SuggestExtensions extraUserInfo exts -> let header = text "Enable all of the following extensions:" in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo + SuggestExtensionInOrderTo extraUserInfo ext -> + (text "Use" <+> ppr ext) $$ extraUserInfo SuggestMissingDo -> text "Possibly caused by a missing 'do'?" SuggestLetInDo @@ -120,6 +122,10 @@ instance Outputable GhcHint where -> vcat [ text "Move the instance declaration to the module of the class or of the type, or" , text "wrap the type with a newtype and declare the instance on the new type." ] + SuggestAddStandaloneDerivation + -> text "Use a standalone deriving declaration instead" + SuggestFillInWildcardConstraint + -> text "Fill in the wildcard constraint yourself" perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/testsuite/tests/deriving/should_compile/T16179.stderr b/testsuite/tests/deriving/should_compile/T16179.stderr index ae40e85a0e..735bd49b46 100644 --- a/testsuite/tests/deriving/should_compile/T16179.stderr +++ b/testsuite/tests/deriving/should_compile/T16179.stderr @@ -2,5 +2,6 @@ T16179.hs:7:30: warning: [-Wderiving-defaults (in -Wdefault)] • Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled Defaulting to the DeriveAnyClass strategy for instantiating C - Use DerivingStrategies to pick a different strategy • In the newtype declaration for ‘T’ + Suggested fix: + Use DerivingStrategies to pick a different strategy diff --git a/testsuite/tests/deriving/should_fail/T10598_fail2.stderr b/testsuite/tests/deriving/should_fail/T10598_fail2.stderr index 227be95c02..7cfcbcdabb 100644 --- a/testsuite/tests/deriving/should_fail/T10598_fail2.stderr +++ b/testsuite/tests/deriving/should_fail/T10598_fail2.stderr @@ -2,11 +2,13 @@ T10598_fail2.hs:5:37: error: • Can't make a derived instance of ‘Eq A’ with the anyclass strategy: - Try enabling DeriveAnyClass • In the data declaration for ‘A’ + Suggested fix: Perhaps you intended to use DeriveAnyClass T10598_fail2.hs:6:37: error: • Can't make a derived instance of ‘Eq B’ with the newtype strategy: - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘B’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension diff --git a/testsuite/tests/deriving/should_fail/T1133A.stderr b/testsuite/tests/deriving/should_fail/T1133A.stderr index 1c8f686f2a..dd750cef2b 100644 --- a/testsuite/tests/deriving/should_fail/T1133A.stderr +++ b/testsuite/tests/deriving/should_fail/T1133A.stderr @@ -3,5 +3,7 @@ T1133A.hs:7:28: error: • Can't make a derived instance of ‘Enum X’: ‘X’ must be an enumeration type (an enumeration consists of one or more nullary, non-GADT constructors) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘X’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension diff --git a/testsuite/tests/deriving/should_fail/T11509_1.stderr b/testsuite/tests/deriving/should_fail/T11509_1.stderr index 305e8e8307..5ca2d46832 100644 --- a/testsuite/tests/deriving/should_fail/T11509_1.stderr +++ b/testsuite/tests/deriving/should_fail/T11509_1.stderr @@ -5,3 +5,4 @@ T11509_1.hs:53:1: error: if DeriveAnyClass is enabled • In the stand-alone deriving instance for ‘(Typeable a, SC (Serializable a)) => SC (Serializable (MyList a))’ + Suggested fix: Perhaps you intended to use DeriveAnyClass diff --git a/testsuite/tests/deriving/should_fail/T12163.stderr b/testsuite/tests/deriving/should_fail/T12163.stderr index 708a1b0990..ba6879839c 100644 --- a/testsuite/tests/deriving/should_fail/T12163.stderr +++ b/testsuite/tests/deriving/should_fail/T12163.stderr @@ -2,5 +2,5 @@ T12163.hs:8:16: error: • Can't make a derived instance of ‘Functor (T a)’: Constructor ‘Mk’ is a GADT - Possible fix: use a standalone deriving declaration instead • In the data declaration for ‘T’ + Suggested fix: Use a standalone deriving declaration instead diff --git a/testsuite/tests/deriving/should_fail/T12512.stderr b/testsuite/tests/deriving/should_fail/T12512.stderr index 78c49f4233..86d22c0124 100644 --- a/testsuite/tests/deriving/should_fail/T12512.stderr +++ b/testsuite/tests/deriving/should_fail/T12512.stderr @@ -2,11 +2,11 @@ T12512.hs:10:1: error: • Can't make a derived instance of ‘Wat1 (# a, b #)’: ‘Wat1’ is not a stock derivable class (Eq, Show, etc.) - Try enabling DeriveAnyClass • In the stand-alone deriving instance for ‘Wat1 (# a, b #)’ + Suggested fix: Perhaps you intended to use DeriveAnyClass T12512.hs:13:1: error: • Can't make a derived instance of ‘Wat2 (# a | b #)’: ‘Wat2’ is not a stock derivable class (Eq, Show, etc.) - Try enabling DeriveAnyClass • In the stand-alone deriving instance for ‘Wat2 (# a | b #)’ + Suggested fix: Perhaps you intended to use DeriveAnyClass diff --git a/testsuite/tests/deriving/should_fail/T18127b.stderr b/testsuite/tests/deriving/should_fail/T18127b.stderr index 9d2a289e44..9062ae38cf 100644 --- a/testsuite/tests/deriving/should_fail/T18127b.stderr +++ b/testsuite/tests/deriving/should_fail/T18127b.stderr @@ -2,8 +2,8 @@ T18127b.hs:7:40: error: • Can't make a derived instance of ‘Eq T1’: Constructor ‘MkT1’ has a higher-rank type - Possible fix: use a standalone deriving declaration instead • In the data declaration for ‘T1’ + Suggested fix: Use a standalone deriving declaration instead T18127b.hs:7:44: error: • Can't make a derived instance of ‘Generic T1’: @@ -13,8 +13,8 @@ T18127b.hs:7:44: error: T18127b.hs:8:42: error: • Can't make a derived instance of ‘Eq (T2 a)’: Constructor ‘MkT2’ has a higher-rank type - Possible fix: use a standalone deriving declaration instead • In the data declaration for ‘T2’ + Suggested fix: Use a standalone deriving declaration instead T18127b.hs:8:46: error: • Can't make a derived instance of ‘Generic (T2 a)’: diff --git a/testsuite/tests/deriving/should_fail/T3101.stderr b/testsuite/tests/deriving/should_fail/T3101.stderr index 7c976178c4..cacd549cee 100644 --- a/testsuite/tests/deriving/should_fail/T3101.stderr +++ b/testsuite/tests/deriving/should_fail/T3101.stderr @@ -2,5 +2,5 @@ T3101.hs:9:12: Can't make a derived instance of ‘Show Boom’: Constructor ‘Boom’ has a higher-rank type - Possible fix: use a standalone deriving declaration instead In the data declaration for ‘Boom’ + Suggested fix: Use a standalone deriving declaration instead diff --git a/testsuite/tests/deriving/should_fail/T3833.stderr b/testsuite/tests/deriving/should_fail/T3833.stderr index 001fdc4c64..64983faedf 100644 --- a/testsuite/tests/deriving/should_fail/T3833.stderr +++ b/testsuite/tests/deriving/should_fail/T3833.stderr @@ -2,5 +2,7 @@ T3833.hs:10:1: error: • Can't make a derived instance of ‘Monoid (DecodeMap e)’: ‘Monoid’ is not a stock derivable class (Eq, Show, etc.) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the stand-alone deriving instance for ‘Monoid (DecodeMap e)’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension diff --git a/testsuite/tests/deriving/should_fail/T3834.stderr b/testsuite/tests/deriving/should_fail/T3834.stderr index 23a605f614..35ce31a161 100644 --- a/testsuite/tests/deriving/should_fail/T3834.stderr +++ b/testsuite/tests/deriving/should_fail/T3834.stderr @@ -2,5 +2,7 @@ T3834.hs:9:1: error: • Can't make a derived instance of ‘C T’: ‘C’ is not a stock derivable class (Eq, Show, etc.) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the stand-alone deriving instance for ‘C T’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension diff --git a/testsuite/tests/deriving/should_fail/T7401_fail.stderr b/testsuite/tests/deriving/should_fail/T7401_fail.stderr index 7f26d3b9e4..ab6397fd0c 100644 --- a/testsuite/tests/deriving/should_fail/T7401_fail.stderr +++ b/testsuite/tests/deriving/should_fail/T7401_fail.stderr @@ -2,5 +2,6 @@ T7401_fail.hs:4:17: error: • Can't make a derived instance of ‘Eq D’: ‘D’ must have at least one data constructor - Use EmptyDataDeriving to enable deriving for empty data types • In the data declaration for ‘D’ + Suggested fix: + Use EmptyDataDeriving to enable deriving for empty data types diff --git a/testsuite/tests/deriving/should_fail/T7959.stderr b/testsuite/tests/deriving/should_fail/T7959.stderr index 0ba77ffb8b..6991c57d0f 100644 --- a/testsuite/tests/deriving/should_fail/T7959.stderr +++ b/testsuite/tests/deriving/should_fail/T7959.stderr @@ -1,7 +1,8 @@ T7959.hs:5:1: error: - • Can't make a derived instance of ‘A’: Try enabling DeriveAnyClass + • Can't make a derived instance of ‘A’: • In the stand-alone deriving instance for ‘A’ + Suggested fix: Perhaps you intended to use DeriveAnyClass T7959.hs:6:17: error: • ‘A’ is not a unary constraint, as expected by a deriving clause diff --git a/testsuite/tests/deriving/should_fail/T9600.stderr b/testsuite/tests/deriving/should_fail/T9600.stderr index 734e3af997..6ff63108f9 100644 --- a/testsuite/tests/deriving/should_fail/T9600.stderr +++ b/testsuite/tests/deriving/should_fail/T9600.stderr @@ -2,5 +2,7 @@ T9600.hs:4:39: error: • Can't make a derived instance of ‘Applicative Foo’: ‘Applicative’ is not a stock derivable class (Eq, Show, etc.) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘Foo’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension diff --git a/testsuite/tests/deriving/should_fail/drvfail008.stderr b/testsuite/tests/deriving/should_fail/drvfail008.stderr index e942f087e7..4ed9375d61 100644 --- a/testsuite/tests/deriving/should_fail/drvfail008.stderr +++ b/testsuite/tests/deriving/should_fail/drvfail008.stderr @@ -2,5 +2,7 @@ drvfail008.hs:11:43: error: • Can't make a derived instance of ‘Monad M’: ‘Monad’ is not a stock derivable class (Eq, Show, etc.) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘M’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension diff --git a/testsuite/tests/generics/GenCannotDoRep0_0.stderr b/testsuite/tests/generics/GenCannotDoRep0_0.stderr index c808430dde..ced307d7c9 100644 --- a/testsuite/tests/generics/GenCannotDoRep0_0.stderr +++ b/testsuite/tests/generics/GenCannotDoRep0_0.stderr @@ -5,8 +5,8 @@ GenCannotDoRep0_0.hs:6:14: warning: [-Wdeprecated-flags (in -Wdefault)] GenCannotDoRep0_0.hs:13:45: error: • Can't make a derived instance of ‘Generic Dynamic’: Constructor ‘Dynamic’ has existential type variables in its type - Possible fix: use a standalone deriving declaration instead • In the data declaration for ‘Dynamic’ + Suggested fix: Use a standalone deriving declaration instead GenCannotDoRep0_0.hs:28:1: error: • Can't make a derived instance of ‘Generic (D Int a)’: diff --git a/testsuite/tests/generics/GenCannotDoRep1_0.stderr b/testsuite/tests/generics/GenCannotDoRep1_0.stderr index 1a576e6cb1..604ad0c14c 100644 --- a/testsuite/tests/generics/GenCannotDoRep1_0.stderr +++ b/testsuite/tests/generics/GenCannotDoRep1_0.stderr @@ -2,5 +2,5 @@ GenCannotDoRep1_0.hs:9:49: error: • Can't make a derived instance of ‘Generic1 Dynamic’: Constructor ‘Dynamic’ has existential type variables in its type - Possible fix: use a standalone deriving declaration instead • In the data declaration for ‘Dynamic’ + Suggested fix: Use a standalone deriving declaration instead diff --git a/testsuite/tests/generics/T10604/T10604_no_PolyKinds.stderr b/testsuite/tests/generics/T10604/T10604_no_PolyKinds.stderr index ca87502a90..1f1c2178f6 100644 --- a/testsuite/tests/generics/T10604/T10604_no_PolyKinds.stderr +++ b/testsuite/tests/generics/T10604/T10604_no_PolyKinds.stderr @@ -1,6 +1,6 @@ T10604_no_PolyKinds.hs:8:35: error: • Cannot derive well-kinded instance of form ‘Generic1 (F ...)’ - (Perhaps you intended to use PolyKinds) Class ‘Generic1’ expects an argument of kind ‘* -> *’ • In the data declaration for ‘F’ + Suggested fix: Perhaps you intended to use PolyKinds diff --git a/testsuite/tests/generics/T5462No1.stderr b/testsuite/tests/generics/T5462No1.stderr index 0b718d648e..b4977caa23 100644 --- a/testsuite/tests/generics/T5462No1.stderr +++ b/testsuite/tests/generics/T5462No1.stderr @@ -4,17 +4,19 @@ T5462No1.hs:25:42: error: • Can't make a derived instance of ‘GFunctor F’: ‘GFunctor’ is not a stock derivable class (Eq, Show, etc.) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘F’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension T5462No1.hs:27:23: error: • Can't make a derived instance of ‘C1 G’: ‘C1’ is not a stock derivable class (Eq, Show, etc.) - Try enabling DeriveAnyClass • In the data declaration for ‘G’ + Suggested fix: Perhaps you intended to use DeriveAnyClass T5462No1.hs:28:23: error: • Can't make a derived instance of ‘C2 H’: ‘C2’ is not a stock derivable class (Eq, Show, etc.) - Try enabling DeriveAnyClass • In the data declaration for ‘H’ + Suggested fix: Perhaps you intended to use DeriveAnyClass diff --git a/testsuite/tests/module/mod53.stderr b/testsuite/tests/module/mod53.stderr index 754c4524a5..b8f442214b 100644 --- a/testsuite/tests/module/mod53.stderr +++ b/testsuite/tests/module/mod53.stderr @@ -2,5 +2,5 @@ mod53.hs:4:22: error: Can't make a derived instance of ‘C T’: ‘C’ is not a stock derivable class (Eq, Show, etc.) - Try enabling DeriveAnyClass In the data declaration for ‘T’ + Suggested fix: Perhaps you intended to use DeriveAnyClass diff --git a/testsuite/tests/parser/should_fail/readFail039.stderr b/testsuite/tests/parser/should_fail/readFail039.stderr index 0200cdabd6..9f14dd1845 100644 --- a/testsuite/tests/parser/should_fail/readFail039.stderr +++ b/testsuite/tests/parser/should_fail/readFail039.stderr @@ -2,5 +2,7 @@ readFail039.hs:9:14: error: • Can't make a derived instance of ‘C Foo’: ‘C’ is not a stock derivable class (Eq, Show, etc.) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘Foo’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension diff --git a/testsuite/tests/partial-sigs/should_compile/T13324_compile2.hs b/testsuite/tests/partial-sigs/should_compile/T13324_compile2.hs new file mode 100644 index 0000000000..670744e668 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/T13324_compile2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +module T13324_compile where + +data Option a = None | Some a + +deriving instance _ => Show (Option a) diff --git a/testsuite/tests/partial-sigs/should_compile/T13324_compile2.stderr b/testsuite/tests/partial-sigs/should_compile/T13324_compile2.stderr new file mode 100644 index 0000000000..5648054c39 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/T13324_compile2.stderr @@ -0,0 +1,7 @@ + +T13324_compile2.hs:7:19: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Show a’ + • In the instance declaration for ‘Show (Option a)’ + Suggested fix: + Perhaps you intended to use PartialTypeSignatures + to use the inferred type diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T index 99627a15c2..6367aa16f5 100644 --- a/testsuite/tests/partial-sigs/should_compile/all.T +++ b/testsuite/tests/partial-sigs/should_compile/all.T @@ -82,6 +82,7 @@ test('T12845', normal, compile, ['']) test('T19106', normal, compile, ['']) test('T12844', normal, compile, ['']) test('T13324_compile', normal, compile, ['-Wno-partial-type-signatures']) +test('T13324_compile2', normal, compile, ['-Wpartial-type-signatures']) test('T13482', normal, compile, ['']) test('T14217', normal, compile_fail, ['']) test('T14643', normal, compile, ['']) diff --git a/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr b/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr index 75e4829cdb..5b82ae3e44 100644 --- a/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T13324_fail2.stderr @@ -8,5 +8,5 @@ T13324_fail2.hs:7:1: error: T13324_fail2.hs:11:1: error: • Can't make a derived instance of ‘Eq (T a)’: Constructor ‘MkT’ is a GADT - Possible fix: fill in the wildcard constraint yourself • In the stand-alone deriving instance for ‘_ => Eq (T a)’ + Suggested fix: Fill in the wildcard constraint yourself diff --git a/testsuite/tests/safeHaskell/ghci/p16.stderr b/testsuite/tests/safeHaskell/ghci/p16.stderr index 36ee15327d..69a10da8db 100644 --- a/testsuite/tests/safeHaskell/ghci/p16.stderr +++ b/testsuite/tests/safeHaskell/ghci/p16.stderr @@ -5,8 +5,10 @@ <interactive>:16:29: error: • Can't make a derived instance of ‘Op T2’: ‘Op’ is not a stock derivable class (Eq, Show, etc.) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘T2’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension <interactive>:19:9: error: • Data constructor not in scope: T2 :: T -> t diff --git a/testsuite/tests/typecheck/should_compile/T15839a.stderr b/testsuite/tests/typecheck/should_compile/T15839a.stderr index b4aef83367..75d46f4889 100644 --- a/testsuite/tests/typecheck/should_compile/T15839a.stderr +++ b/testsuite/tests/typecheck/should_compile/T15839a.stderr @@ -2,5 +2,6 @@ T15839a.hs:6:30: warning: [-Wderiving-defaults (in -Wdefault)] • Both DeriveAnyClass and GeneralizedNewtypeDeriving are enabled Defaulting to the DeriveAnyClass strategy for instantiating C - Use DerivingStrategies to pick a different strategy • In the newtype declaration for ‘T’ + Suggested fix: + Use DerivingStrategies to pick a different strategy diff --git a/testsuite/tests/typecheck/should_fail/tcfail086.stderr b/testsuite/tests/typecheck/should_fail/tcfail086.stderr index 0ea0b71c41..db83adda8c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail086.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail086.stderr @@ -2,5 +2,5 @@ tcfail086.hs:6:38: error: • Can't make a derived instance of ‘Eq Ex’: Constructor ‘Ex’ has existential type variables in its type - Possible fix: use a standalone deriving declaration instead • In the data declaration for ‘Ex’ + Suggested fix: Use a standalone deriving declaration instead diff --git a/testsuite/tests/typecheck/should_fail/tcfail117.stderr b/testsuite/tests/typecheck/should_fail/tcfail117.stderr index 41caeaea92..153acb2bf1 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail117.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail117.stderr @@ -3,8 +3,10 @@ tcfail117.hs:6:32: error: • Can't make a derived instance of ‘Enum N1’: ‘N1’ must be an enumeration type (an enumeration consists of one or more nullary, non-GADT constructors) - Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension • In the newtype declaration for ‘N1’ + Suggested fix: + Perhaps you intended to use GeneralizedNewtypeDeriving + for GHC's newtype-deriving extension tcfail117.hs:7:32: error: • Can't make a derived instance of ‘Enum N2’: diff --git a/testsuite/tests/warnings/should_compile/DerivingTypeable.hs b/testsuite/tests/warnings/should_compile/DerivingTypeable.hs new file mode 100644 index 0000000000..dc8f93660e --- /dev/null +++ b/testsuite/tests/warnings/should_compile/DerivingTypeable.hs @@ -0,0 +1,8 @@ +module DerivingTypeable where + +import Data.Typeable + +data Foo = + Foo Int + | Bar Char + deriving Typeable diff --git a/testsuite/tests/warnings/should_compile/DerivingTypeable.stderr b/testsuite/tests/warnings/should_compile/DerivingTypeable.stderr new file mode 100644 index 0000000000..20a19ab530 --- /dev/null +++ b/testsuite/tests/warnings/should_compile/DerivingTypeable.stderr @@ -0,0 +1,3 @@ +DerivingTypeable.hs:8:12: warning: [-Wderiving-typeable] + Deriving ‘Typeable’ has no effect: all types now auto-derive Typeable + In the data declaration for ‘Foo’ diff --git a/testsuite/tests/warnings/should_compile/all.T b/testsuite/tests/warnings/should_compile/all.T index 849ae5edfa..2934db7ad4 100644 --- a/testsuite/tests/warnings/should_compile/all.T +++ b/testsuite/tests/warnings/should_compile/all.T @@ -46,3 +46,4 @@ test('T19564d', normal, compile, ['']) # Also, suppress uniques as one of the warnings is unstable in CI, otherwise. test('T19296', normal, compile, ['-fdiagnostics-show-caret -Wredundant-constraints -dsuppress-uniques']) test('DodgyExports01', normal, compile, ['-Wdodgy-exports']) +test('DerivingTypeable', normal, compile, ['-Wderiving-typeable']) |