diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 58 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 44 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/HsType.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 35 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/TcMType.hs | 34 | ||||
| -rw-r--r-- | compiler/GHC/Types/Error/Codes.hs | 3 |
7 files changed, 129 insertions, 60 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 3de952f2d8..432163d6f1 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -40,7 +40,7 @@ import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst ) import GHC.Core.InstEnv import GHC.Core.TyCo.Rep (Type(..)) import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, - pprSourceTyCon, pprTyVars, pprWithTYPE) + pprSourceTyCon, pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType) import GHC.Core.PatSyn ( patSynName, pprPatSynType ) import GHC.Core.Predicate import GHC.Core.Type @@ -1453,6 +1453,34 @@ instance Diagnostic TcRnMessage where TcRnTyThingUsedWrong sort thing name -> mkSimpleDecorated $ pprTyThingUsedWrong sort thing name + TcRnCannotDefaultKindVar var knd -> + mkSimpleDecorated $ + (vcat [ text "Cannot default kind variable" <+> quotes (ppr var) + , text "of kind:" <+> ppr knd + , text "Perhaps enable PolyKinds or add a kind signature" ]) + TcRnUninferrableTyvar tidied_tvs context -> + mkSimpleDecorated $ + pprWithExplicitKindsWhen True $ + vcat [ text "Uninferrable type variable" + <> plural tidied_tvs + <+> pprWithCommas pprTyVar tidied_tvs + <+> text "in" + , pprUninferrableTyvarCtx context ] + TcRnSkolemEscape escapees tv orig_ty -> + mkSimpleDecorated $ + pprWithExplicitKindsWhen True $ + vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees + , quotes $ pprTyVars escapees + , text "would escape" <+> itsOrTheir escapees <+> text "scope" + ] + , sep [ text "if I tried to quantify" + , pprTyVar tv + , text "in this type:" + ] + , nest 2 (pprTidiedType orig_ty) + , text "(Indeed, I sometimes struggle even printing this correctly," + , text " due to its ill-scoped nature.)" + ] diagnosticReason = \case TcRnUnknownMessage m @@ -1931,6 +1959,12 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnTyThingUsedWrong{} -> ErrorWithoutFlag + TcRnCannotDefaultKindVar{} + -> ErrorWithoutFlag + TcRnUninferrableTyvar{} + -> ErrorWithoutFlag + TcRnSkolemEscape{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -2427,6 +2461,12 @@ instance Diagnostic TcRnMessage where -> noHints TcRnTyThingUsedWrong{} -> noHints + TcRnCannotDefaultKindVar{} + -> noHints + TcRnUninferrableTyvar{} + -> noHints + TcRnSkolemEscape{} + -> noHints diagnosticCode = constructorCode @@ -4505,3 +4545,19 @@ pprStageCheckReason = \case text "instance for" <+> quotes (ppr t) StageCheckSplice t -> quotes (ppr t) + +pprUninferrableTyvarCtx :: UninferrableTyvarCtx -> SDoc +pprUninferrableTyvarCtx = \case + UninfTyCtx_ClassContext theta -> + sep [ text "the class context:", pprTheta theta ] + UninfTyCtx_DataContext theta -> + sep [ text "the datatype context:", pprTheta theta ] + UninfTyCtx_ProvidedContext theta -> + sep [ text "the provided context:" , pprTheta theta ] + UninfTyCtx_TyfamRhs rhs_ty -> + sep [ text "the type family equation right-hand side:" , ppr rhs_ty ] + UninfTyCtx_TysynRhs rhs_ty -> + sep [ text "the type synonym right-hand side:" , ppr rhs_ty ] + UninfTyCtx_Sig exp_kind full_hs_ty -> + hang (text "the kind" <+> ppr exp_kind) 2 + (text "of the type signature:" <+> ppr full_hs_ty) diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index aa43f6f581..d84aca8146 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -94,6 +94,7 @@ module GHC.Tc.Errors.Types ( , HsigShapeMismatchReason(..) , WrongThingSort(..) , StageCheckReason(..) + , UninferrableTyvarCtx(..) ) where import GHC.Prelude @@ -3257,6 +3258,41 @@ data TcRnMessage where -> !Name -- ^ Name of the thing used wrongly. -> TcRnMessage + {-| TcRnCannotDefaultKindVar is an error that occurs when attempting to use + unconstrained kind variables whose type isn't @Type@, without -XPolyKinds. + + Test cases: + T11334b + -} + TcRnCannotDefaultKindVar + :: !TyVar -- ^ The unconstrained variable. + -> !Kind -- ^ Kind of the variable. + -> TcRnMessage + + {-| TcRnUninferrableTyvar is an error that occurs when metavariables + in a type could not be defaulted. + + Test cases: + T17301, T17562, T17567, T17567StupidTheta, T15474, T21479 + -} + TcRnUninferrableTyvar + :: ![TyCoVar] -- ^ The variables that could not be defaulted. + -> !UninferrableTyvarCtx -- ^ Description of the surrounding context. + -> TcRnMessage + + {-| TcRnSkolemEscape is an error that occurs when type variables from an + outer scope is used in a context where they should be locally scoped. + + Test cases: + T15076, T15076b, T14880-2, T15825, T14880, T15807, T16946, T14350, + T14040A, T15795, T15795a, T14552 + -} + TcRnSkolemEscape + :: ![TcTyVar] -- ^ The variables that would escape. + -> !TcTyVar -- ^ The variable that is being quantified. + -> !Type -- ^ The type in which they occur. + -> TcRnMessage + deriving Generic -- | Things forbidden in @type data@ declarations. @@ -4538,3 +4574,11 @@ data WrongThingSort data StageCheckReason = StageCheckInstance !InstanceWhat !PredType | StageCheckSplice !Name + +data UninferrableTyvarCtx + = UninfTyCtx_ClassContext [TcType] + | UninfTyCtx_DataContext [TcType] + | UninfTyCtx_ProvidedContext [TcType] + | UninfTyCtx_TyfamRhs TcType + | UninfTyCtx_TysynRhs TcType + | UninfTyCtx_Sig TcType (LHsSigType GhcRn) diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index c002d8cc3e..0a0ec7230a 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -473,7 +473,7 @@ tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs -- Default any unconstrained variables free in the kind -- See Note [Escaping kind in type signatures] ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind - ; doNotQuantifyTyVars exp_kind_dvs (mk_doc exp_kind) + ; doNotQuantifyTyVars exp_kind_dvs (err_ctx exp_kind) ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs) ; outer_bndrs <- scopedSortOuter outer_bndrs @@ -488,10 +488,9 @@ tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs ; return (implic, mkInfForAllTys kvs ty1) } where - mk_doc exp_kind tidy_env + err_ctx exp_kind tidy_env = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind - ; return (tidy_env2, hang (text "The kind" <+> ppr exp_kind) - 2 (text "of type signature:" <+> ppr full_hs_ty)) } + ; return (tidy_env2, UninfTyCtx_Sig exp_kind full_hs_ty) } diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index f3e02c0fd0..afb2047d63 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -35,7 +35,8 @@ import GHC.Driver.Config.HsToCore import GHC.Hs import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) - , mkTcRnUnknownMessage, IllegalNewtypeReason (..) ) + , mkTcRnUnknownMessage, IllegalNewtypeReason (..) + , UninferrableTyvarCtx (..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -2455,11 +2456,9 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs -- class (forall a. a b ~ a c) => C b c -- The kind of `a` is unconstrained. ; dvs <- candidateQTyVarsOfTypes ctxt - ; let mk_doc tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt - ; return ( tidy_env2 - , sep [ text "the class context:" - , pprTheta ctxt ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; let err_ctx tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt + ; return (tidy_env2, UninfTyCtx_ClassContext ctxt) } + ; doNotQuantifyTyVars dvs err_ctx -- The pushLevelAndSolveEqualities will report errors for any -- unsolved equalities, so these zonks should not encounter @@ -2873,11 +2872,9 @@ tcTySynRhs roles_info tc_name hs_ty -- type T = forall a. Proxy a -- The kind of `a` is unconstrained. ; dvs <- candidateQTyVarsOfType rhs_ty - ; let mk_doc tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty - ; return ( tidy_env2 - , sep [ text "the type synonym right-hand side:" - , ppr rhs_ty ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; let err_ctx tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty + ; return (tidy_env2, UninfTyCtx_TysynRhs rhs_ty) } + ; doNotQuantifyTyVars dvs err_ctx ; ze <- mkEmptyZonkEnv NoFlexi ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs @@ -2918,12 +2915,10 @@ tcDataDefn err_ctxt roles_info tc_name -- data (forall a. a b ~ a c) => T b c -- The kind of 'a' is unconstrained. ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta - ; let mk_doc tidy_env + ; let err_ctx tidy_env = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta - ; return ( tidy_env2 - , sep [ text "the datatype context:" - , pprTheta theta ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; return (tidy_env2, UninfTyCtx_DataContext theta) } + ; doNotQuantifyTyVars dvs err_ctx -- Check that we don't use kind signatures without the extension ; kind_signatures <- xoptM LangExt.KindSignatures @@ -3178,12 +3173,10 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType -- Example: typecheck/should_fail/T17301 ; dvs_rhs <- candidateQTyVarsOfType rhs_ty - ; let mk_doc tidy_env + ; let err_ctx tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty - ; return ( tidy_env2 - , sep [ text "type family equation right-hand side:" - , ppr rhs_ty ] ) } - ; doNotQuantifyTyVars dvs_rhs mk_doc + ; return (tidy_env2, UninfTyCtx_TyfamRhs rhs_ty) } + ; doNotQuantifyTyVars dvs_rhs err_ctx ; ze <- mkEmptyZonkEnv NoFlexi ; (ze, final_tvs) <- zonkTyBndrsX ze final_tvs diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 8741770977..82fa7db1f7 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -194,12 +194,10 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details -- Report un-quantifiable type variables: -- see Note [Unquantified tyvars in a pattern synonym] ; dvs <- candidateQTyVarsOfTypes prov_theta - ; let mk_doc tidy_env + ; let err_ctx tidy_env = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env prov_theta - ; return ( tidy_env2 - , sep [ text "the provided context:" - , pprTheta theta ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; return ( tidy_env2, UninfTyCtx_ProvidedContext theta ) } + ; doNotQuantifyTyVars dvs err_ctx ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) ; rec_fields <- lookupConstructorFields name diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index e3ca947cdd..e14dae75cf 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -131,7 +131,6 @@ import GHC.Types.Name import GHC.Types.Var.Set import GHC.Builtin.Types -import GHC.Types.Error import GHC.Types.Var.Env import GHC.Types.Unique.Set import GHC.Types.Basic ( TypeOrKind(..) @@ -1853,10 +1852,7 @@ defaultTyVar def_strat tv ; writeMetaTyVar kv liftedTypeKind ; return True } | otherwise - = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') - , text "of kind:" <+> ppr (tyVarKind kv') - , text "Perhaps enable PolyKinds or add a kind signature" ]) + = do { addErr $ TcRnCannotDefaultKindVar kv' (tyVarKind kv') -- We failed to default it, so return False to say so. -- Hence, it'll get skolemised. That might seem odd, but we must either -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType @@ -2053,7 +2049,7 @@ C. Examine the class declaration at the top of this Note again. -} doNotQuantifyTyVars :: CandidatesQTvs - -> (TidyEnv -> TcM (TidyEnv, SDoc)) + -> (TidyEnv -> TcM (TidyEnv, UninferrableTyvarCtx)) -- ^ like "the class context (D a b, E foogle)" -> TcM () -- See Note [Error on unconstrained meta-variables] @@ -2072,14 +2068,7 @@ doNotQuantifyTyVars dvs where_found ; unless (null leftover_metas) $ do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas ; (tidy_env2, where_doc) <- where_found tidy_env1 - ; let msg = mkTcRnUnknownMessage $ - mkPlainError noHints $ - pprWithExplicitKindsWhen True $ - vcat [ text "Uninferrable type variable" - <> plural tidied_tvs - <+> pprWithCommas pprTyVar tidied_tvs - <+> text "in" - , where_doc ] + ; let msg = TcRnUninferrableTyvar tidied_tvs where_doc ; failWithTcM (tidy_env2, msg) } ; traceTc "doNotQuantifyTyVars success" empty } @@ -2741,21 +2730,8 @@ naughtyQuantification orig_ty tv escapees -- variables; very confusing to users! orig_ty' = tidyType env orig_ty1 - ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) - msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen True $ - vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' - , quotes $ ppr_tidied escapees' - , text "would escape" <+> itsOrTheir escapees' <+> text "scope" - ] - , sep [ text "if I tried to quantify" - , ppr_tidied [tv] - , text "in this type:" - ] - , nest 2 (pprTidiedType orig_ty') - , text "(Indeed, I sometimes struggle even printing this correctly," - , text " due to its ill-scoped nature.)" - ] + tidied = map (tidyTyCoVarOcc env) escapees' + msg = TcRnSkolemEscape tidied (tidyTyCoVarOcc env tv) orig_ty' ; failWithTcM (env, msg) } diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 1f9fb29905..a5c751ed3d 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -539,6 +539,9 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnBadlyStaged" = 28914 GhcDiagnosticCode "TcRnStageRestriction" = 18157 GhcDiagnosticCode "TcRnTyThingUsedWrong" = 10969 + GhcDiagnosticCode "TcRnCannotDefaultKindVar" = 79924 + GhcDiagnosticCode "TcRnUninferrableTyvar" = 16220 + GhcDiagnosticCode "TcRnSkolemEscape" = 71451 -- IllegalNewtypeReason GhcDiagnosticCode "DoesNotHaveSingleField" = 23517 |