[commit: ghc] master: Change definition of CUSK for data and class definitions (#9200). (6485930)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/64859308231551de2aed839003994b29b99409c0/ghc

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

commit 64859308231551de2aed839003994b29b99409c0
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Aug 6 09:56:50 2014 -0400

    Change definition of CUSK for data and class definitions (#9200).
    
    Now, a CUSK is when (and only when) all type variables are annotated.
    This allows classes to participate in polymorphic recursion.


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

64859308231551de2aed839003994b29b99409c0
 compiler/hsSyn/HsTypes.lhs      |  7 ++++++-
 compiler/typecheck/TcHsType.lhs | 19 ++++++++++++++-----
 2 files changed, 20 insertions(+), 6 deletions(-)

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 08a0eef..eada762 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -25,7 +25,7 @@ module HsTypes (
 
         ConDeclField(..), pprConDeclFields,
         
-        mkHsQTvs, hsQTvBndrs,
+        mkHsQTvs, hsQTvBndrs, isHsKindedTyVar,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
         hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
@@ -188,6 +188,11 @@ data HsTyVarBndr name
          (LHsKind name)  -- The user-supplied kind signature
   deriving (Data, Typeable)
 
+-- | Does this 'HsTyVarBndr' come with an explicit kind annotation?
+isHsKindedTyVar :: HsTyVarBndr name -> Bool
+isHsKindedTyVar (UserTyVar {})   = False
+isHsKindedTyVar (KindedTyVar {}) = True
+
 data HsType name
   = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
                                         -- the user wrote it originally, so that the printer can
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index cdeb191..14a3c17 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -1068,10 +1068,15 @@ kcStrategy d@(ForeignType {}) = pprPanic "kcStrategy" (ppr d)
 kcStrategy (FamDecl fam_decl)
   = kcStrategyFamDecl fam_decl
 kcStrategy (SynDecl {})       = ParametricKinds
-kcStrategy (DataDecl { tcdDataDefn = HsDataDefn { dd_kindSig = m_ksig }})
-  | Just _ <- m_ksig            = FullKindSignature
-  | otherwise                   = ParametricKinds
-kcStrategy (ClassDecl {})     = ParametricKinds
+kcStrategy decl@(DataDecl {})  = kcStrategyAlgDecl decl
+kcStrategy decl@(ClassDecl {}) = kcStrategyAlgDecl decl
+
+kcStrategyAlgDecl :: TyClDecl Name -> KindCheckingStrategy
+kcStrategyAlgDecl decl
+  | all (isHsKindedTyVar . unLoc) (hsQTvBndrs $ tcdTyVars decl)
+  = FullKindSignature
+  | otherwise
+  = ParametricKinds
 
 -- if the ClosedTypeFamily has no equations, do the defaulting to *, etc.
 kcStrategyFamDecl :: FamilyDecl Name -> KindCheckingStrategy
@@ -1259,7 +1264,11 @@ kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> TcM a -> TcM a
 kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
   = kcScopedKindVars kvs $
     do 	{ tc_kind <- kcLookupKind name
-	; let (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) tc_kind
+	; let (_, mono_kind)   = splitForAllTys tc_kind
+                     -- if we have a FullKindSignature, the tc_kind may already
+                     -- be generalized. The kvs get matched up while kind-checking
+                     -- the types in kc_tv, below
+              (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) mono_kind
                      -- There should be enough arrows, because
                      -- getInitialKinds used the tcdTyVars
         ; name_ks <- zipWithM kc_tv hs_tvs arg_ks