diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/typecheck/TcHsType.hs | 105 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.hs | 12 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 30 |
3 files changed, 108 insertions, 39 deletions
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index adc25f5ff8..fac6f2e31c 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -49,7 +49,7 @@ module TcHsType ( kindGeneralize, checkExpectedKind_pp, -- Sort-checking kinds - tcLHsKindSig, badKindSig, + tcLHsKindSig, checkDataKindSig, DataSort(..), -- Zonking and promoting zonkPromoteType, @@ -105,7 +105,7 @@ import UniqSupply import Outputable import FastString import PrelNames hiding ( wildCardName ) -import DynFlags ( WarningFlag (Opt_WarnPartialTypeSignatures) ) +import DynFlags import qualified GHC.LanguageExtensions as LangExt import Maybes @@ -2405,12 +2405,101 @@ etaExpandAlgTyCon tc_bndrs kind (subst', tv') = substTyVarBndr subst tv tcb = Bndr tv' (NamedTCB vis) -badKindSig :: Bool -> Kind -> SDoc -badKindSig check_for_type kind - = hang (sep [ text "Kind signature on data type declaration has non-*" - , (if check_for_type then empty else text "and non-variable") <+> - text "return kind" ]) - 2 (ppr kind) +-- | A description of whether something is a +-- +-- * @data@ or @newtype@ ('DataDeclSort') +-- +-- * @data instance@ or @newtype instance@ ('DataInstanceSort') +-- +-- * @data family@ ('DataFamilySort') +-- +-- At present, this data type is only consumed by 'checkDataKindSig'. +data DataSort + = DataDeclSort NewOrData + | DataInstanceSort NewOrData + | DataFamilySort + +-- | Checks that the return kind in a data declaration's kind signature is +-- permissible. There are three cases: +-- +-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ +-- declaration, check that the return kind is @Type@. +-- +-- If the declaration is a @newtype@ or @newtype instance@ and the +-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so +-- that a return kind of the form @TYPE r@ (for some @r@) is permitted. +-- See @Note [Implementation of UnliftedNewtypes]@ in "TcTyClsDecls". +-- +-- If dealing with a @data family@ declaration, check that the return kind is +-- either of the form: +-- +-- 1. @TYPE r@ (for some @r@), or +-- +-- 2. @k@ (where @k@ is a bare kind variable; see #12369) +checkDataKindSig :: DataSort -> Kind -> TcM () +checkDataKindSig data_sort kind = do + dflags <- getDynFlags + checkTc (is_TYPE_or_Type dflags || is_kind_var) (err_msg dflags) + where + pp_dec :: SDoc + pp_dec = text $ + case data_sort of + DataDeclSort DataType -> "data type" + DataDeclSort NewType -> "newtype" + DataInstanceSort DataType -> "data instance" + DataInstanceSort NewType -> "newtype instance" + DataFamilySort -> "data family" + + is_newtype :: Bool + is_newtype = + case data_sort of + DataDeclSort new_or_data -> new_or_data == NewType + DataInstanceSort new_or_data -> new_or_data == NewType + DataFamilySort -> False + + is_data_family :: Bool + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + + 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 TcTyClsDecls. + || 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 kind + + is_TYPE_or_Type :: DynFlags -> Bool + is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE + | otherwise = tcIsLiftedTypeKind kind + + -- In the particular case of a data family, permit a return kind of the + -- form `:: k` (where `k` is a bare kind variable). + is_kind_var :: Bool + is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe kind) + | otherwise = False + + err_msg :: DynFlags -> SDoc + err_msg dflags = + sep [ (sep [ text "Kind signature on" <+> pp_dec <+> + text "declaration 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 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 ] tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] -- Result is in 1-1 correpondence with orig_args diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 25c598df6b..c2f7a1100a 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -687,17 +687,7 @@ tcDataFamInstDecl mb_clsinfo -- we did it before the "extra" tvs from etaExpandAlgTyCon -- would always be eta-reduced ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let allowUnlifted = unlifted_newtypes && new_or_data == NewType - -- 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]. - ; checkTc - (if allowUnlifted - then tcIsRuntimeTypeKind final_res_kind - else tcIsLiftedTypeKind final_res_kind - ) - (badKindSig True res_kind) + ; checkDataKindSig (DataInstanceSort new_or_data) final_res_kind ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs all_pats = pats `chkAppend` extra_pats orig_res_ty = mkTyConApp fam_tc all_pats diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 9d2aea8d15..06a730519b 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1877,15 +1877,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info -- When UnliftedNewtypes is enabled, we loosen this restriction -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). ; let (_, final_res_kind) = splitPiTys res_kind - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; checkTc - ( (if unlifted_newtypes - then tcIsRuntimeTypeKind final_res_kind - else tcIsLiftedTypeKind final_res_kind - ) - || isJust (tcGetCastedTyVar_maybe final_res_kind) - ) - (badKindSig False res_kind) + ; checkDataKindSig DataFamilySort final_res_kind ; tc_rep_name <- newTyConRepName tc_name ; let tycon = mkFamilyTyCon tc_name binders res_kind @@ -2033,15 +2025,8 @@ tcDataDefn roles_info ; tcg_env <- getGblEnv ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind ; let hsc_src = tcg_src tcg_env - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let allowUnlifted = unlifted_newtypes && new_or_data == NewType - ; unless (mk_permissive_kind hsc_src cons || allowUnlifted) $ - checkTc - (if allowUnlifted - then tcIsRuntimeTypeKind final_res_kind - else tcIsLiftedTypeKind final_res_kind - ) - (badKindSig True res_kind) + ; unless (mk_permissive_kind hsc_src cons) $ + checkDataKindSig (DataDeclSort new_or_data) final_res_kind ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta @@ -2077,7 +2062,12 @@ tcDataDefn roles_info where -- Abstract data types in hsig files can have arbitrary kinds, -- because they may be implemented by type synonyms - -- (which themselves can have arbitrary kinds, not just *) + -- (which themselves can have arbitrary kinds, not just *). See #13955. + -- + -- Note that this is only a property that data type declarations possess, + -- so one could not have, say, a data family instance in an hsig file that + -- has kind `Bool`. Therfore, this check need only occur in the code that + -- typechecks data type declarations. mk_permissive_kind HsigFile [] = True mk_permissive_kind _ _ = False @@ -2600,7 +2590,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data ; btys <- tcConArgs hs_args ; let (arg_tys, stricts) = unzip btys ; res_ty <- tcHsOpenType hs_res_ty - -- See Note [Implementation of unlifted newtypes] + -- See Note [Implementation of UnliftedNewtypes] ; dflags <- getDynFlags ; final_arg_tys <- unifyNewtypeKind dflags new_or_data |