diff options
| -rw-r--r-- | compiler/typecheck/TcHsType.hs | 97 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 172 |
2 files changed, 135 insertions, 134 deletions
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 50263f7fc7..b2c3bcd5aa 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -38,8 +38,8 @@ module TcHsType ( -- Kind-checking types -- No kind generalisation, no checkValidType + InitialKindStrategy(..), kcDeclHeader, - kcInferDeclHeader, tcNamedWildCardBinders, tcHsLiftedType, tcHsOpenType, tcHsLiftedTypeNC, tcHsOpenTypeNC, @@ -1790,12 +1790,26 @@ newWildTyVar * * ********************************************************************* -} -{- Note [kcDeclHeader vs kcInferDeclHeader] +data InitialKindStrategy + = InitialKindCheck (Maybe Kind) + | InitialKindInfer + +kcDeclHeader + :: InitialKindStrategy + -> Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon +kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig +kcDeclHeader InitialKindInfer = kcInferDeclHeader + +{- Note [kcCheckDeclHeader vs kcInferDeclHeader] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -kcDeclHeader and kcInferDeclHeader are responsible for getting the initial kind +kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind of a type constructor. -* kcDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that +* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that case, find the full, final, poly-kinded kind of the TyCon. It's very like a term-level binding where we have a complete type signature for the function. @@ -1807,26 +1821,24 @@ of a type constructor. -} ------------------------------ -kcDeclHeader - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> Maybe Kind -- ^ Just sig <=> Standalone kind signature, fully zonked! (zonkTcTypeToType) +kcCheckDeclHeader + :: Maybe Kind -- ^ Just sig <=> Standalone kind signature, fully zonked! (zonkTcTypeToType) -- Nothing <=> Complete user-specified kind (CUSK) + -> Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn -- ^ Binders in the header - -> Maybe (TcM Kind) -- ^ The result kind + -> TcM ContextKind -- ^ The result kind -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcDeclHeader name flav msig ktvs kc_res_ki = - case msig of - Just sig -> kcDeclHeader_sig name flav sig ktvs kc_res_ki - Nothing -> kcDeclHeader_cusk name flav ktvs kc_res_ki +kcCheckDeclHeader (Just sig) = kcCheckDeclHeader_sig sig +kcCheckDeclHeader Nothing = kcCheckDeclHeader_cusk -kcDeclHeader_cusk +kcCheckDeclHeader_cusk :: Name -- ^ of the thing being checked -> TyConFlavour -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn -- ^ Binders in the header - -> Maybe (TcM Kind) -- ^ The result kind + -> TcM ContextKind -- ^ The result kind -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcDeclHeader_cusk name flav +kcCheckDeclHeader_cusk name flav (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki -- CUSK case @@ -1837,9 +1849,7 @@ kcDeclHeader_cusk name flav solveEqualities $ bindImplicitTKBndrs_Q_Skol kv_ns $ bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ - case kc_res_ki of - Nothing -> return liftedTypeKind - Just kc -> kc + newExpectedKind =<< kc_res_ki -- Now, because we're in a CUSK, -- we quantify over the mentioned kind vars @@ -1879,7 +1889,7 @@ kcDeclHeader_cusk name flav -- doesn't work, we catch it here, before an error cascade ; checkTyConTelescope tycon - ; traceTc "kcDeclHeader_cusk " $ + ; traceTc "kcCheckDeclHeader_cusk " $ vcat [ text "name" <+> ppr name , text "kv_ns" <+> ppr kv_ns , text "hs_tvs" <+> ppr hs_tvs @@ -1898,7 +1908,7 @@ kcDeclHeader_cusk name flav where ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind -kcDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec +kcCheckDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec -- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and -- other kinds). @@ -1908,11 +1918,11 @@ kcInferDeclHeader :: Name -- ^ of the thing being checked -> TyConFlavour -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn - -> TcM Kind -- ^ The result kind + -> TcM ContextKind -- ^ The result kind -> TcM TcTyCon -- ^ A suitably-kinded non-generalized TcTyCon kcInferDeclHeader name flav (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) thing_inside + , hsq_explicit = hs_tvs }) kc_res_ki -- No standalane kind signature and no CUSK. -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls = do { (scoped_kvs, (tc_tvs, res_kind)) @@ -1920,7 +1930,7 @@ kcInferDeclHeader name flav -- See Note [Inferring kinds for type declarations] in TcTyClsDecls <- bindImplicitTKBndrs_Q_Tv kv_ns $ bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ - thing_inside + newExpectedKind =<< kc_res_ki -- Why "_Tv" not "_Skol"? See third wrinkle in -- Note [Inferring kinds for type declarations] in TcTyClsDecls, @@ -1958,15 +1968,15 @@ kcInferDeclHeader name flav kcInferDeclHeader _ _ (XLHsQTyVars nec) _ = noExtCon nec -- | Kind-check a declaration header against a standalone kind signature. --- See Note [Arity inference in kcDeclHeader_sig] -kcDeclHeader_sig - :: Name -- ^ of the thing being checked +-- See Note [Arity inference in kcCheckDeclHeader_sig] +kcCheckDeclHeader_sig + :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) + -> Name -- ^ of the thing being checked -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) -> LHsQTyVars GhcRn -- ^ Binders in the header - -> Maybe (TcM Kind) -- ^ The result kind + -> TcM ContextKind -- ^ The result kind -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcDeclHeader_sig name flav kisig ktvs kc_res_ki = +kcCheckDeclHeader_sig kisig name flav ktvs kc_res_ki = addTyConFlavCtxt name flav $ pushTcLevelM_ $ solveEqualities $ -- #16687 @@ -2020,7 +2030,10 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki = -- ^^^^^^^^^ -- We do it here because at this point the environment has been -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. - m_res_ki <- sequenceA @Maybe kc_res_ki + m_res_ki <- kc_res_ki >>= \ctx_k -> + case ctx_k of + AnyKind -> return Nothing + _ -> Just <$> newExpectedKind ctx_k -- Step 2: split off invisible binders. -- For example: @@ -2029,7 +2042,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki = -- type family F -- -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'? - -- See Note [Arity inference in kcDeclHeader_sig] + -- See Note [Arity inference in kcCheckDeclHeader_sig] let (invis_binders, r_ki) = split_invis kisig' m_res_ki -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders. @@ -2043,7 +2056,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki = -- -- Here we unify Maybe k ~ Maybe j whenIsJust m_res_ki $ \res_ki -> - discardResult $ -- See Note [discardResult in kcDeclHeader_sig] + discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind Nothing r_ki res_ki -- Zonk the implicitly quantified variables. @@ -2054,7 +2067,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki = all_tv_prs = implicit_tv_prs ++ explicit_tv_prs tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav - traceTc "kcDeclHeader_sig done:" $ vcat + traceTc "kcCheckDeclHeader_sig done:" $ vcat [ text "tyConName = " <+> ppr (tyConName tc) , text "kisig =" <+> debugPprType kisig , text "tyConKind =" <+> debugPprType (tyConKind tc) @@ -2149,7 +2162,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki = UserTyVar _ _ -> return () KindedTyVar _ v v_hs_ki -> do v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki - discardResult $ -- See Note [discardResult in kcDeclHeader_sig] + discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind (Just (HsTyVar noExtField NotPromoted v)) (tyBinderType tb) v_ki @@ -2157,7 +2170,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki = -- Split the invisible binders that should become a part of 'tyConBinders' -- rather than 'tyConResKind'. - -- See Note [Arity inference in kcDeclHeader_sig] + -- See Note [Arity inference in kcCheckDeclHeader_sig] split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind) split_invis sig_ki Nothing = -- instantiate all invisible binders @@ -2173,7 +2186,7 @@ kcDeclHeader_sig name flav kisig ktvs kc_res_ki = data ZippedBinder = ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn)) --- See Note [Arity inference in kcDeclHeader_sig] +-- See Note [Arity inference in kcCheckDeclHeader_sig] zipBinders :: Kind -- kind signature -> [LHsTyVarBndr GhcRn] -- user-written binders @@ -2207,9 +2220,9 @@ tooManyBindersErr ki bndrs = hang (text "but extra binders found:") 4 (fsep (map ppr bndrs)) -{- Note [Arity inference in kcDeclHeader_sig] +{- Note [Arity inference in kcCheckDeclHeader_sig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a kind signature 'kisig' and a declaration header, kcDeclHeader_sig +Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig verifies that the declaration conforms to the signature. The end result is a TcTyCon 'tc' such that: @@ -2246,7 +2259,7 @@ This difference determines the arity: That is, the arity of S1 is 0, while the arity of S2 is 2. -'kcDeclHeader_sig' needs to infer the desired arity to split the standalone +'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone kind signature into binders and the result kind. It does so in two rounds: 1. zip user-written binders (vis_tcbs) @@ -2317,7 +2330,7 @@ The resulting arity of G is 3+1=4. (length vis_tcbs = 3, -} -{- Note [discardResult in kcDeclHeader_sig] +{- Note [discardResult in kcCheckDeclHeader_sig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use 'unifyKind' to check inline kind annotations in declaration headers against the signature. @@ -2454,7 +2467,7 @@ Then `a` first appears /after/ `f`, so the kind of `T2` should be: T2 :: forall f a. f a -> Type -In order to make this distinction, we need to know (in kcDeclHeader) which +In order to make this distinction, we need to know (in kcCheckDeclHeader) which type variables have been bound by the parent class (if there is one). With the class-bound variables in hand, we can ensure that we always quantify these first. diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 8883bd8c1b..02d2c62631 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -487,9 +487,9 @@ to Note [Single function non-recursive binding special-case]: Unfortunately this requires reworking a bit of the code in 'kcLTyClDecl' so I've decided to punt unless someone shouts about it. -Note [Don't process associated types in kcInferDeclHeader] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, we processed associated types in the thing_inside in kcInferDeclHeader, +Note [Don't process associated types in getInitialKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, we processed associated types in the thing_inside in getInitialKind, but this was wrong -- we want to do ATs sepearately. The consequence for not doing it this way is #15142: @@ -786,7 +786,7 @@ These design choices are implemented by two completely different code paths for * Declarations with a standalone kind signature or a complete user-specified - kind signature (CUSK). Handed by the kcDeclHeader. + kind signature (CUSK). Handed by the kcCheckDeclHeader. * Declarations without a kind signature (standalone or CUSK) are handled by kcInferDeclHeader; see Note [Inferring kinds for type declarations]. @@ -1016,11 +1016,24 @@ inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] inferInitialKinds decls = do { traceTc "inferInitialKinds {" empty - ; tcs <- concatMapM (addLocM inferInitialKind) decls + ; tcs <- concatMapM infer_initial_kind decls ; traceTc "inferInitialKinds done }" empty ; return tcs } + where + infer_initial_kind = addLocM (getInitialKind InitialKindInfer) + +-- Check type/class declarations against their standalone kind signatures or +-- CUSKs, producing a generalized TcTyCon for each. +checkInitialKinds :: [(LTyClDecl GhcRn, Maybe Kind)] -> TcM [TcTyCon] +checkInitialKinds = concatMapM check_initial_kind + where + check_initial_kind (dL -> L l d, msig) = + setSrcSpan l (getInitialKind (InitialKindCheck msig) d) + +-- | Get the initial kind of a TyClDecl, either generalized or non-generalized, +-- depending on the InitialKindStrategy. +getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] -inferInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon] -- Allocate a fresh kind variable for each TyCon and Class -- For each tycon, return a TcTyCon with kind k -- where k is the kind of tc, derived from the LHS @@ -1033,43 +1046,72 @@ inferInitialKind :: TyClDecl GhcRn -> TcM [TcTyCon] -- * The kind signatures on type-variable binders -- * The result kinds signature on a TyClDecl -- --- No family instances are passed to inferInitialKinds - -inferInitialKind +-- No family instances are passed to checkInitialKinds/inferInitialKinds +getInitialKind strategy (ClassDecl { tcdLName = dL->L _ name , tcdTyVars = ktvs , tcdATs = ats }) - = do { tycon <- kcInferDeclHeader name ClassFlavour ktvs $ - return constraintKind - ; let parent_tv_prs = tcTyConScopedTyVars tycon - -- See Note [Don't process associated types in kcInferDeclHeader] + = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ + return (TheKind constraintKind) + ; let parent_tv_prs = tcTyConScopedTyVars cls + -- See Note [Don't process associated types in getInitialKind] ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocM (get_fam_decl_initial_kind (Just tycon))) ats - ; return (tycon : inner_tcs) } + mapM (addLocM (getAssocFamInitialKind cls)) ats + ; return (cls : inner_tcs) } + where + getAssocFamInitialKind cls = + case strategy of + InitialKindInfer -> get_fam_decl_initial_kind (Just cls) + InitialKindCheck _ -> check_initial_kind_assoc_fam cls -inferInitialKind +getInitialKind strategy (DataDecl { tcdLName = dL->L _ name , tcdTyVars = ktvs , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_ND = new_or_data } }) = do { let flav = newOrDataToFlavour new_or_data - ; tc <- kcInferDeclHeader name flav ktvs $ + ctxt = DataKindCtxt name + ; tc <- kcDeclHeader strategy name flav ktvs $ case m_sig of - Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig Nothing -> dataDeclDefaultResultKind new_or_data ; return [tc] } -inferInitialKind (FamDecl { tcdFam = decl }) +getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) = do { tc <- get_fam_decl_initial_kind Nothing decl ; return [tc] } -inferInitialKind (SynDecl { tcdLName = dL->L _ name, tcdTyVars = ktvs }) - = do { tc <- kcInferDeclHeader name TypeSynonymFlavour ktvs newMetaKindVar - ; return [tc] } +getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = + FamilyDecl { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } } ) + = do { let flav = getFamFlav Nothing info + ctxt = TyFamResKindCtxt name + ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return AnyKind + ; return [tc] } -inferInitialKind (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec -inferInitialKind (XTyClDecl nec) = noExtCon nec +getInitialKind strategy + (SynDecl { tcdLName = dL->L _ name + , tcdTyVars = ktvs + , tcdRhs = rhs }) + = do { let ctxt = TySynKindCtxt name + ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ + case strategy of + InitialKindInfer -> return AnyKind + InitialKindCheck _ -> + case hsTyKindSig rhs of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return AnyKind + ; return [tc] } + +getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec +getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec +getInitialKind _ (XTyClDecl nec) = noExtCon nec get_fam_decl_initial_kind :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls @@ -1080,76 +1122,20 @@ get_fam_decl_initial_kind mb_parent_tycon , fdTyVars = ktvs , fdResultSig = (dL->L _ resultSig) , fdInfo = info } - = kcInferDeclHeader name flav ktvs $ + = kcDeclHeader InitialKindInfer name flav ktvs $ case resultSig of - KindSig _ ki -> tcLHsKindSig ctxt ki - TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki _ -- open type families have * return kind by default - | tcFlavourIsOpen flav -> return liftedTypeKind + | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) -- closed type families have their return kind inferred -- by default - | otherwise -> newMetaKindVar + | otherwise -> return AnyKind where flav = getFamFlav mb_parent_tycon info ctxt = TyFamResKindCtxt name get_fam_decl_initial_kind _ (XFamilyDecl nec) = noExtCon nec --- Check type/class declarations against their standalone kind signatures or --- CUSKs, producing a generalized TcTyCon for each. -checkInitialKinds :: [(LTyClDecl GhcRn, Maybe Kind)] -> TcM [TcTyCon] -checkInitialKinds = concatMapM check_initial_kind - where - check_initial_kind (dL -> L l d, msig) = - setSrcSpan l (checkInitialKind msig d) - -checkInitialKind :: Maybe Kind -> TyClDecl GhcRn -> TcM [TcTyCon] -checkInitialKind msig - (ClassDecl { tcdLName = dL->L _ name - , tcdTyVars = ktvs - , tcdATs = ats }) - = do { cls <- kcDeclHeader name ClassFlavour msig ktvs $ - Just $ return constraintKind - ; let parent_tv_prs = tcTyConScopedTyVars cls - -- See Note [Don't process associated types in kcInferDeclHeader] - ; inner_tcs <- - tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocM (check_initial_kind_assoc_fam cls)) ats - ; return (cls : inner_tcs) } -checkInitialKind msig - (DataDecl { tcdLName = dL->L _ name - , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig - , dd_ND = new_or_data } }) - = do { let flav = newOrDataToFlavour new_or_data - ctxt = DataKindCtxt name - ; tc <- kcDeclHeader name flav msig ktvs $ - Just $ case m_sig of - Just ksig -> tcLHsKindSig ctxt ksig - Nothing -> dataDeclDefaultResultKind new_or_data - ; return [tc] } -checkInitialKind msig (FamDecl { tcdFam = - FamilyDecl { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } } ) - = do { let flav = getFamFlav Nothing info - ctxt = TyFamResKindCtxt name - ; tc <- kcDeclHeader name flav msig ktvs $ - fmap (tcLHsKindSig ctxt) (famResultKindSignature resultSig) - ; return [tc] } -checkInitialKind msig - (SynDecl { tcdLName = dL->L _ name - , tcdTyVars = ktvs - , tcdRhs = rhs }) - = do { let ctxt = TySynKindCtxt name - ; tc <- kcDeclHeader name TypeSynonymFlavour msig ktvs $ - fmap (tcLHsKindSig ctxt) (hsTyKindSig rhs) - ; return [tc] } - -checkInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec -checkInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec -checkInitialKind _ (XTyClDecl nec) = noExtCon nec - -- See Note [Standalone kind signatures for associated types] check_initial_kind_assoc_fam :: TcTyCon -- parent class @@ -1161,8 +1147,10 @@ check_initial_kind_assoc_fam cls , fdTyVars = ktvs , fdResultSig = unLoc -> resultSig , fdInfo = info } - = kcDeclHeader name flav Nothing ktvs $ - fmap (tcLHsKindSig ctxt) (famResultKindSignature resultSig) + = kcDeclHeader (InitialKindCheck Nothing) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return (TheKind liftedTypeKind) where ctxt = TyFamResKindCtxt name flav = getFamFlav (Just cls) info @@ -1202,13 +1190,13 @@ have before standalone kind signatures: -} -- See Note [Data declaration default result kind] -dataDeclDefaultResultKind :: NewOrData -> TcM Kind +dataDeclDefaultResultKind :: NewOrData -> TcM ContextKind dataDeclDefaultResultKind new_or_data = do -- See Note [Implementation of UnliftedNewtypes] unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - case new_or_data of - NewType | unlifted_newtypes -> newOpenTypeKind - _ -> pure liftedTypeKind + return $ case new_or_data of + NewType | unlifted_newtypes -> OpenKind + _ -> TheKind liftedTypeKind {- Note [Data declaration default result kind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2445,7 +2433,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty -- have checked that the number of patterns matches tyConArity -- This code is closely related to the code - -- in TcHsType.kcDeclHeader_cusk + -- in TcHsType.kcCheckDeclHeader_cusk ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))) <- pushTcLevelM_ $ solveEqualities $ |