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
-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
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 })
-- NB: Keep this synchronized with 'getInitialKind'
= hsTvbAllKinded tyvars && rhs_annotated rhs
......@@ -1078,15 +1080,22 @@ data FamilyInfo pass
-- | Does this family declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
famDeclHasCusk :: Maybe Bool
-- ^ if associated, does the enclosing class have a CUSK?
-> FamilyDecl pass -> Bool
famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _
famDeclHasCusk :: Bool -- ^ True <=> this is an associated type family,
-- and the parent class has /no/ CUSK
-> FamilyDecl pass
-> Bool
famDeclHasCusk assoc_with_no_cusk
(FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
= hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
-- all un-associated open families have CUSKs
= case fam_info of
ClosedTypeFamily {} -> hsTvbAllKinded tyvars
&& 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?
hasReturnKindSignature :: FamilyResultSig a -> Bool
......
......@@ -917,7 +917,7 @@ getInitialKind cusk
; let parent_tv_prs = tcTyConScopedTyVars tycon
-- See Note [Don't process associated types in kcLHsQTyVars]
; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $
getFamDeclInitialKinds (Just tycon) ats
getFamDeclInitialKinds cusk (Just tycon) ats
; return (tycon : inner_tcs) }
getInitialKind cusk
......@@ -932,8 +932,8 @@ getInitialKind cusk
Nothing -> return liftedTypeKind
; return [tc] }
getInitialKind _ (FamDecl { tcdFam = decl })
= do { tc <- getFamDeclInitialKind Nothing decl
getInitialKind cusk (FamDecl { tcdFam = decl })
= do { tc <- getFamDeclInitialKind cusk Nothing decl
; return [tc] }
getInitialKind cusk (SynDecl { tcdLName = dL->L _ name
......@@ -956,22 +956,24 @@ getInitialKind _ (XTyClDecl _) = panic "getInitialKind"
---------------------------------
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]
-> TcM [TcTyCon]
getFamDeclInitialKinds mb_parent_tycon decls
= mapM (addLocM (getFamDeclInitialKind mb_parent_tycon)) decls
getFamDeclInitialKinds cusk mb_parent_tycon decls
= mapM (addLocM (getFamDeclInitialKind cusk mb_parent_tycon)) decls
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
-> TcM TcTyCon
getFamDeclInitialKind mb_parent_tycon
getFamDeclInitialKind parent_cusk mb_parent_tycon
decl@(FamilyDecl { fdLName = (dL->L _ name)
, fdTyVars = ktvs
, fdResultSig = (dL->L _ resultSig)
, fdInfo = info })
= kcLHsQTyVars name flav cusk ktvs $
= kcLHsQTyVars name flav fam_cusk ktvs $
case resultSig of
KindSig _ ki -> tcLHsKindSig ctxt ki
TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
......@@ -981,15 +983,15 @@ getFamDeclInitialKind mb_parent_tycon
-- by default
| otherwise -> newMetaKindVar
where
mb_cusk = tcTyConIsPoly <$> mb_parent_tycon
cusk = famDeclHasCusk mb_cusk decl
assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk
fam_cusk = famDeclHasCusk assoc_with_no_cusk decl
flav = case info of
DataFamily -> DataFamilyFlavour mb_parent_tycon
OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon )
ClosedTypeFamilyFlavour
ctxt = TyFamResKindCtxt name
getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind"
getFamDeclInitialKind _ _ (XFamilyDecl _) = panic "getFamDeclInitialKind"
------------------------------------------------------------------------
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