diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2019-02-07 09:51:36 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-02-08 11:00:26 -0500 |
commit | 9bb23d5f8bd7a135670864dfa09dd39a60e94d28 (patch) | |
tree | 9c090ff340e0e46ee0a9840b9c011bc0a9f6a063 | |
parent | cefb780ee7ae3c3be873324423358eafd4ba5a17 (diff) | |
download | haskell-9bb23d5f8bd7a135670864dfa09dd39a60e94d28.tar.gz |
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.
-rw-r--r-- | compiler/hsSyn/HsDecls.hs | 29 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 28 |
2 files changed, 34 insertions, 23 deletions
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 5b06db8c02..c18a9ae1fc 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -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 _ - , 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 +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 }) + = 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 diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 7bf5e20431..1333489ad8 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 - flav = case info of + 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 () |