diff options
Diffstat (limited to 'compiler/GHC/Tc/Gen/HsType.hs')
| -rw-r--r-- | compiler/GHC/Tc/Gen/HsType.hs | 107 |
1 files changed, 74 insertions, 33 deletions
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index cc82f30dbc..61b66f3919 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -2908,9 +2908,9 @@ data ContextKind = TheKind Kind -- ^ a specific kind ----------------------- newExpectedKind :: ContextKind -> TcM Kind -newExpectedKind (TheKind k) = return k -newExpectedKind AnyKind = newMetaKindVar -newExpectedKind OpenKind = newOpenTypeKind +newExpectedKind (TheKind k) = return k +newExpectedKind AnyKind = newMetaKindVar +newExpectedKind OpenKind = newOpenTypeKind ----------------------- expectedKindInCtxt :: UserTypeCtxt -> ContextKind @@ -3579,6 +3579,22 @@ data DataSort | DataInstanceSort NewOrData | DataFamilySort +-- | Local helper type used in 'checkDataKindSig'. +-- +-- Superficially similar to 'ContextKind', but it lacks 'AnyKind' +-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@ +-- provides 'LiftedKind', which is much simpler to match on and +-- handle in 'isAllowedDataResKind'. +data AllowedDataResKind + = AnyTYPEKind + | AnyBoxedKind + | LiftedKind + +isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool +isAllowedDataResKind AnyTYPEKind kind = tcIsRuntimeTypeKind kind +isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind +isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind + -- | Checks that the return kind in a data declaration's kind signature is -- permissible. There are three cases: -- @@ -3603,7 +3619,7 @@ checkDataKindSig :: DataSort -> Kind -- any arguments in the kind are stripped checkDataKindSig data_sort kind = do { dflags <- getDynFlags ; traceTc "checkDataKindSig" (ppr kind) - ; checkTc (is_TYPE_or_Type dflags || is_kind_var) + ; checkTc (tYPE_ok dflags || is_kind_var) (err_msg dflags) } where res_kind = snd (tcSplitPiTys kind) @@ -3626,6 +3642,13 @@ checkDataKindSig data_sort kind DataInstanceSort new_or_data -> new_or_data == NewType DataFamilySort -> False + is_datatype :: Bool + is_datatype = + case data_sort of + DataDeclSort DataType -> True + DataInstanceSort DataType -> True + _ -> False + is_data_family :: Bool is_data_family = case data_sort of @@ -3633,27 +3656,30 @@ checkDataKindSig data_sort kind DataInstanceSort{} -> False DataFamilySort -> True + allowed_kind :: DynFlags -> AllowedDataResKind + allowed_kind dflags + | is_newtype && xopt LangExt.UnliftedNewtypes dflags + -- With UnliftedNewtypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE r` since we don't want to accept + -- Constraint or Nat. + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. + = AnyTYPEKind + | is_data_family + -- If this is a `data family` declaration, we don't need to check if + -- UnliftedNewtypes is enabled, since data family declarations can + -- have return kind `TYPE r` unconditionally (#16827). + = AnyTYPEKind + | is_datatype && xopt LangExt.UnliftedDatatypes dflags + -- With UnliftedDatatypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE (BoxedRep l)`, so that we don't + -- accept result kinds like `TYPE IntRep`. + -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl. + = AnyBoxedKind + | otherwise + = LiftedKind + tYPE_ok :: DynFlags -> Bool - tYPE_ok dflags = - (is_newtype && xopt LangExt.UnliftedNewtypes dflags) - -- With UnliftedNewtypes, we allow kinds other than Type, but they - -- must still be of the form `TYPE r` since we don't want to accept - -- Constraint or Nat. - -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. - || is_data_family - -- If this is a `data family` declaration, we don't need to check if - -- UnliftedNewtypes is enabled, since data family declarations can - -- have return kind `TYPE r` unconditionally (#16827). - - is_TYPE :: Bool - is_TYPE = tcIsRuntimeTypeKind res_kind - - is_Type :: Bool - is_Type = tcIsLiftedTypeKind res_kind - - is_TYPE_or_Type :: DynFlags -> Bool - is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE - | otherwise = is_Type + tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind -- In the particular case of a data family, permit a return kind of the -- form `:: k` (where `k` is a bare kind variable). @@ -3661,17 +3687,32 @@ checkDataKindSig data_sort kind is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind) | otherwise = False + pp_allowed_kind dflags = + case allowed_kind dflags of + AnyTYPEKind -> ppr tYPETyCon + AnyBoxedKind -> ppr boxedRepDataConTyCon + LiftedKind -> ppr liftedTypeKind + err_msg :: DynFlags -> SDoc err_msg dflags = - sep [ (sep [ pp_dec <+> - text "has non-" <> - (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind) - , (if is_data_family then text "and non-variable" else empty) <+> - text "return kind" <+> quotes (ppr res_kind) ]) - , if not (tYPE_ok dflags) && is_TYPE && is_newtype && - not (xopt LangExt.UnliftedNewtypes dflags) - then text "Perhaps you intended to use UnliftedNewtypes" - else empty ] + sep [ sep [ pp_dec <+> + text "has non-" <> + pp_allowed_kind dflags + , (if is_data_family then text "and non-variable" else empty) <+> + text "return kind" <+> quotes (ppr kind) ] + , ext_hint dflags ] + + ext_hint dflags + | tcIsRuntimeTypeKind kind + , is_newtype + , not (xopt LangExt.UnliftedNewtypes dflags) + = text "Perhaps you intended to use UnliftedNewtypes" + | tcIsBoxedTypeKind kind + , is_datatype + , not (xopt LangExt.UnliftedDatatypes dflags) + = text "Perhaps you intended to use UnliftedDatatypes" + | otherwise + = empty -- | Checks that the result kind of a class is exactly `Constraint`, rejecting -- type synonyms and type families that reduce to `Constraint`. See #16826. |