Commit 9bb23d5f authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Minor refactor of CUSK handling

Previously, in getFamDeclInitialKind, we were figuring
out whether the enclosing class decl had a CUSK very
indirectly, via tcTyConIsPoly.  This patch just makes
the computation much more direct and easy to grok.

No change in behaviour.
parent cefb780e
Pipeline #1990 passed with stages
in 381 minutes and 5 seconds
...@@ -680,7 +680,9 @@ countTyClDecls decls ...@@ -680,7 +680,9 @@ countTyClDecls decls
-- | Does this declaration have a complete, user-supplied kind signature? -- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures] -- See Note [CUSKs: complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl GhcRn -> Bool hsDeclHasCusk :: TyClDecl GhcRn -> Bool
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl hsDeclHasCusk (FamDecl { tcdFam = fam_decl })
= famDeclHasCusk False fam_decl
-- False: this is not: an associated type of a class with no cusk
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
-- NB: Keep this synchronized with 'getInitialKind' -- NB: Keep this synchronized with 'getInitialKind'
= hsTvbAllKinded tyvars && rhs_annotated rhs = hsTvbAllKinded tyvars && rhs_annotated rhs
...@@ -1078,15 +1080,22 @@ data FamilyInfo pass ...@@ -1078,15 +1080,22 @@ data FamilyInfo pass
-- | Does this family declaration have a complete, user-supplied kind signature? -- | Does this family declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures] -- See Note [CUSKs: complete user-supplied kind signatures]
famDeclHasCusk :: Maybe Bool famDeclHasCusk :: Bool -- ^ True <=> this is an associated type family,
-- ^ if associated, does the enclosing class have a CUSK? -- and the parent class has /no/ CUSK
-> FamilyDecl pass -> Bool -> FamilyDecl pass
famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _ -> Bool
famDeclHasCusk assoc_with_no_cusk
(FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars , fdTyVars = tyvars
, fdResultSig = L _ resultSig }) , fdResultSig = L _ resultSig })
= hsTvbAllKinded tyvars && hasReturnKindSignature resultSig = case fam_info of
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True ClosedTypeFamily {} -> hsTvbAllKinded tyvars
-- all un-associated open families have CUSKs && hasReturnKindSignature resultSig
_ -> not assoc_with_no_cusk
-- Un-associated open type/data families have CUSKs
-- Associated type families have CUSKs iff the parent class does
famDeclHasCusk _ (XFamilyDecl {}) = panic "famDeclHasCusk"
-- | Does this family declaration have user-supplied return kind signature? -- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool hasReturnKindSignature :: FamilyResultSig a -> Bool
......
...@@ -917,7 +917,7 @@ getInitialKind cusk ...@@ -917,7 +917,7 @@ getInitialKind cusk
; let parent_tv_prs = tcTyConScopedTyVars tycon ; let parent_tv_prs = tcTyConScopedTyVars tycon
-- See Note [Don't process associated types in kcLHsQTyVars] -- See Note [Don't process associated types in kcLHsQTyVars]
; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $ ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $
getFamDeclInitialKinds (Just tycon) ats getFamDeclInitialKinds cusk (Just tycon) ats
; return (tycon : inner_tcs) } ; return (tycon : inner_tcs) }
getInitialKind cusk getInitialKind cusk
...@@ -932,8 +932,8 @@ getInitialKind cusk ...@@ -932,8 +932,8 @@ getInitialKind cusk
Nothing -> return liftedTypeKind Nothing -> return liftedTypeKind
; return [tc] } ; return [tc] }
getInitialKind _ (FamDecl { tcdFam = decl }) getInitialKind cusk (FamDecl { tcdFam = decl })
= do { tc <- getFamDeclInitialKind Nothing decl = do { tc <- getFamDeclInitialKind cusk Nothing decl
; return [tc] } ; return [tc] }
getInitialKind cusk (SynDecl { tcdLName = dL->L _ name getInitialKind cusk (SynDecl { tcdLName = dL->L _ name
...@@ -956,22 +956,24 @@ getInitialKind _ (XTyClDecl _) = panic "getInitialKind" ...@@ -956,22 +956,24 @@ getInitialKind _ (XTyClDecl _) = panic "getInitialKind"
--------------------------------- ---------------------------------
getFamDeclInitialKinds getFamDeclInitialKinds
:: Maybe TcTyCon -- ^ Enclosing class TcTyCon, if any :: Bool -- ^ True <=> cusk
-> Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls
-> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
-> TcM [TcTyCon] -> TcM [TcTyCon]
getFamDeclInitialKinds mb_parent_tycon decls getFamDeclInitialKinds cusk mb_parent_tycon decls
= mapM (addLocM (getFamDeclInitialKind mb_parent_tycon)) decls = mapM (addLocM (getFamDeclInitialKind cusk mb_parent_tycon)) decls
getFamDeclInitialKind getFamDeclInitialKind
:: Maybe TcTyCon -- ^ Enclosing class TcTyCon, if any :: Bool -- ^ True <=> cusk
-> Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls
-> FamilyDecl GhcRn -> FamilyDecl GhcRn
-> TcM TcTyCon -> TcM TcTyCon
getFamDeclInitialKind mb_parent_tycon getFamDeclInitialKind parent_cusk mb_parent_tycon
decl@(FamilyDecl { fdLName = (dL->L _ name) decl@(FamilyDecl { fdLName = (dL->L _ name)
, fdTyVars = ktvs , fdTyVars = ktvs
, fdResultSig = (dL->L _ resultSig) , fdResultSig = (dL->L _ resultSig)
, fdInfo = info }) , fdInfo = info })
= kcLHsQTyVars name flav cusk ktvs $ = kcLHsQTyVars name flav fam_cusk ktvs $
case resultSig of case resultSig of
KindSig _ ki -> tcLHsKindSig ctxt ki KindSig _ ki -> tcLHsKindSig ctxt ki
TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
...@@ -981,15 +983,15 @@ getFamDeclInitialKind mb_parent_tycon ...@@ -981,15 +983,15 @@ getFamDeclInitialKind mb_parent_tycon
-- by default -- by default
| otherwise -> newMetaKindVar | otherwise -> newMetaKindVar
where where
mb_cusk = tcTyConIsPoly <$> mb_parent_tycon assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk
cusk = famDeclHasCusk mb_cusk decl fam_cusk = famDeclHasCusk assoc_with_no_cusk decl
flav = case info of flav = case info of
DataFamily -> DataFamilyFlavour mb_parent_tycon DataFamily -> DataFamilyFlavour mb_parent_tycon
OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon )
ClosedTypeFamilyFlavour ClosedTypeFamilyFlavour
ctxt = TyFamResKindCtxt name ctxt = TyFamResKindCtxt name
getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind" getFamDeclInitialKind _ _ (XFamilyDecl _) = panic "getFamDeclInitialKind"
------------------------------------------------------------------------ ------------------------------------------------------------------------
kcLTyClDecl :: LTyClDecl GhcRn -> TcM () kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment