diff options
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']) |