[commit: ghc] wip/T15449, wip/T16188, wip/llvm-configure-opts: Minor refactor of CUSK handling (9bb23d5)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branches: wip/T15449,wip/T16188,wip/llvm-configure-opts
Link       : http://ghc.haskell.org/trac/ghc/changeset/9bb23d5f8bd7a135670864dfa09dd39a60e94d28/ghc

>---------------------------------------------------------------

commit 9bb23d5f8bd7a135670864dfa09dd39a60e94d28
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Feb 7 09:51:36 2019 +0000

    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.


>---------------------------------------------------------------

9bb23d5f8bd7a135670864dfa09dd39a60e94d28
 compiler/hsSyn/HsDecls.hs          | 29 +++++++++++++++++++----------
 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 5b06db8..c18a9ae 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 7bf5e20..1333489 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 ()