Deal with kind variables brought into scope by a kind signature

This fixes Trac #5937, where a kind variable is mentioned only
in the kind signature of a GADT
   data SMaybe :: (k -> *) -> Maybe k -> * where ...

The main change is that the tcdKindSig field of TyData and TyFamily
now has type Maybe (HsBndrSig (LHsKind name)), where the HsBndrSig
part deals with the kind variables that the signature may bind.

I also removed the now-unused PostTcKind field of UserTyVar and
KindedTyVar.

compiler/hsSyn/HsDecls.lhs

@@ -452,7 +452,7 @@ data TyClDecl name
     TyFamily {  tcdFlavour :: FamilyFlavour,             -- type or data
                 tcdLName   :: Located name,              -- type constructor
                 tcdTyVars  :: [LHsTyVarBndr name],       -- type variables
-                tcdKindSig :: Maybe (LHsKind name)       -- result kind
+                tcdKindSig :: Maybe (HsBndrSig (LHsKind name))  -- result kind
     }
 
 
@@ -470,7 +470,7 @@ data TyClDecl name
                 tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns.
                   -- See Note [tcdTyVars and tcdTyPats] 
 
-                tcdKindSig:: Maybe (LHsKind name),
+                tcdKindSig:: Maybe (HsBndrSig (LHsKind name)),
                         -- ^ Optional kind signature.
                         --
                         -- @(Just k)@ for a GADT-style @data@, or @data
@@ -667,7 +667,7 @@ instance OutputableBndr name
                   derivings
       where
         ppr_sigx Nothing     = empty
-        ppr_sigx (Just kind) = dcolon <+> ppr kind
+        ppr_sigx (Just (HsBSig kind _)) = dcolon <+> ppr kind
 
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
                     tcdFDs  = fds,

compiler/hsSyn/HsTypes.lhs

@@ -30,7 +30,6 @@ module HsTypes (
 	
 	mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
 	hsTyVarName, hsTyVarNames, 
-	hsTyVarKind, hsLTyVarKind, hsTyVarNameKind,
 	hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
 	splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
         splitHsForAllTy, splitLHsForAllTy,
@@ -143,12 +142,10 @@ placeHolderBndrs = panic "placeHolderBndrs"
 data HsTyVarBndr name
   = UserTyVar		-- No explicit kinding
          name 		-- See Note [Printing KindedTyVars]
-         PostTcKind
 
   | KindedTyVar
          name
          (HsBndrSig (LHsKind name))   -- The user-supplied kind signature
-         PostTcKind
       --  *** NOTA BENE *** A "monotype" in a pragma can have
       -- for-alls in it, (mostly to do with dictionaries).  These
       -- must be explicitly Kinded.
@@ -374,19 +371,8 @@ hsExplicitTvs _                                   = []
 
 ---------------------
 hsTyVarName :: HsTyVarBndr name -> name
-hsTyVarName (UserTyVar n _)   = n
-hsTyVarName (KindedTyVar n _ _) = n
-
-hsTyVarKind :: HsTyVarBndr name -> Kind
-hsTyVarKind (UserTyVar _ k)   = k
-hsTyVarKind (KindedTyVar _ _ k) = k
-
-hsLTyVarKind :: LHsTyVarBndr name -> Kind
-hsLTyVarKind  = hsTyVarKind . unLoc
-
-hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind)
-hsTyVarNameKind (UserTyVar n k)   = (n,k)
-hsTyVarNameKind (KindedTyVar n _ k) = (n,k)
+hsTyVarName (UserTyVar n)     = n
+hsTyVarName (KindedTyVar n _) = n
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
@@ -493,8 +479,8 @@ instance (Outputable sig) => Outputable (HsBndrSig sig) where
     ppr (HsBSig ty _) = ppr ty
 
 instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
-    ppr (UserTyVar name _)      = ppr name
-    ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind]
+    ppr (UserTyVar name)        = ppr name
+    ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind]
 
 pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc
 pprHsForAll exp tvs cxt 

compiler/hsSyn/HsUtils.lhs

@@ -268,7 +268,7 @@ mkHsString s = HsString (mkFastString s)
 
 -------------
 userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
-userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
+userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
 \end{code}
 
 

compiler/parser/Parser.y.pp

@@ -722,9 +722,9 @@ data_or_newtype :: { Located NewOrData }
         : 'data'        { L1 DataType }
         | 'newtype'     { L1 NewType }
 
-opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
+opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) }
         :                               { noLoc Nothing }
-        | '::' kind                     { LL (Just $2) }
+        | '::' kind                     { LL (Just (HsBSig $2 placeHolderBndrs)) }
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -1101,8 +1101,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
          | {- empty -}                  { [] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
-        : tyvar                         { L1 (UserTyVar (unLoc $1) placeHolderKind) }
-        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) }
+        : tyvar                         { L1 (UserTyVar (unLoc $1)) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs)) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }

compiler/parser/ParserCore.y

@@ -375,7 +375,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
                   where
                     bsig = HsBSig (toHsKind k) placeHolderBndrs
 

compiler/parser/RdrHsSyn.lhs

@@ -194,7 +194,7 @@ mkTyData :: SrcSpan
          -> Bool                -- True <=> data family instance
          -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-         -> Maybe (LHsKind RdrName)
+         -> Maybe (HsBndrSig (LHsKind RdrName))
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
@@ -208,7 +208,8 @@ mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons m
                                  tcdCtxt = cxt, tcdLName = tc,
                                  tcdTyVars = tyvars, tcdTyPats = typats,
                                  tcdCons = data_cons,
-                                 tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
+                                 tcdKindSig = ksig,
+                                 tcdDerivs = maybe_deriv })) }
 
 mkTySynonym :: SrcSpan
             -> Bool             -- True <=> type family instances
@@ -225,7 +226,7 @@ mkTySynonym loc is_family lhs rhs
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
            -> LHsType RdrName   -- LHS
-           -> Maybe (LHsKind RdrName) -- Optional kind signature
+           -> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature
            -> P (LTyClDecl RdrName)
 mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
@@ -501,9 +502,9 @@ checkTyVars tycl_hdr tparms = mapM chk tparms
   where
         -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs)))
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
+        | isRdrTyVar tv    = return (L l (UserTyVar tv))
     chk t@(L l _)
         = parseErrorSDoc l $
           vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)

compiler/rename/RnTypes.lhs

@@ -106,12 +106,13 @@ rnLHsType = rnLHsTyKi True
 rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
 rnLHsKind = rnLHsTyKi False
 
-rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName) 
-                -> RnM (Maybe (LHsKind Name), FreeVars)
-rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs)
-rnLHsMaybeKind doc (Just k) 
-  = do { (k', fvs) <- rnLHsKind doc k
-       ; return (Just k', fvs) }
+rnLHsMaybeKind  :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName))
+                -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars)
+rnLHsMaybeKind _ Nothing 
+  = return (Nothing, emptyFVs)
+rnLHsMaybeKind doc (Just bsig) 
+  = rnHsBndrSig False doc bsig $ \ bsig' -> 
+    return (Just bsig', emptyFVs)
 
 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
 rnHsType = rnHsTyKi True
@@ -404,14 +405,14 @@ bindTyVarsRn doc tv_bndrs names thing_inside
   where
     go [] [] thing_inside = thing_inside []
 
-    go (L loc (UserTyVar _ tck) : tvs) (n : ns) thing_inside
+    go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside
       = go tvs ns $ \ tvs' ->
-        thing_inside (L loc (UserTyVar n tck) : tvs')
+        thing_inside (L loc (UserTyVar n) : tvs')
 
-    go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside
+    go (L loc (KindedTyVar _ bsig) : tvs) (n : ns) thing_inside
       = rnHsBndrSig False doc bsig $ \ bsig' ->
         go tvs ns $ \ tvs' ->
-        thing_inside (L loc (KindedTyVar n bsig' tck) : tvs')
+        thing_inside (L loc (KindedTyVar n bsig') : tvs')
 
     -- Lists of unequal length
     go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)

compiler/typecheck/TcEnv.lhs

@@ -20,7 +20,7 @@ module TcEnv(
         tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom,
         
         -- Local environment
-        tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv,
+        tcExtendKindEnv, tcExtendTcTyThingEnv,
         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
         tcExtendGhciEnv, tcExtendLetEnv,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
@@ -340,11 +340,6 @@ tcExtendKindEnv things thing_inside
     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
     extend env  = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
 
-tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r
-tcExtendKindEnvTvs bndrs thing_inside
-  = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
-                    (thing_inside bndrs)
-
 -----------------------
 -- Scoped type and kind variables
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r

compiler/typecheck/TcHsType.lhs

@@ -785,7 +785,7 @@ bindScopedKindVars hs_tvs thing_inside
   where
     kvs :: [KindVar]   -- All skolems
     kvs = [ mkKindSigVar kv 
-          | L _ (KindedTyVar _ (HsBSig _ kvs) _) <- hs_tvs
+          | L _ (KindedTyVar _ (HsBSig _ kvs)) <- hs_tvs
           , kv <- kvs ]
 
 tcHsTyVarBndrs :: [LHsTyVarBndr Name] 
@@ -818,7 +818,7 @@ tcHsTyVarBndr (L _ hs_tv)
            _ -> do
        { kind <- case hs_tv of
                    UserTyVar {} -> newMetaKindVar
-                   KindedTyVar _ (HsBSig kind _) _ -> tcLHsKind kind
+                   KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind
        ; return (mkTyVar name kind) } } }
 
 ------------------
@@ -908,7 +908,7 @@ kcLookupKind nm
            _                   -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
 
 kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a
--- Used for the type varaibles of a type or class decl,
+-- Used for the type variables of a type or class decl,
 -- when doing the initial kind-check.  
 kcTyClTyVars name hs_tvs thing_inside
   = bindScopedKindVars hs_tvs $
@@ -920,10 +920,10 @@ kcTyClTyVars name hs_tvs thing_inside
         ; tcExtendKindEnv name_ks (thing_inside res_k) }
   where
     kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind)
-    kc_tv (L _ (UserTyVar n _)) exp_k 
+    kc_tv (L _ (UserTyVar n)) exp_k 
       = do { check_in_scope n exp_k
            ; return (n, exp_k) }
-    kc_tv (L _ (KindedTyVar n (HsBSig hs_k _) _)) exp_k
+    kc_tv (L _ (KindedTyVar n (HsBSig hs_k _))) exp_k
       = do { k <- tcLHsKind hs_k
            ; _ <- unifyKind k exp_k
            ; check_in_scope n exp_k

compiler/typecheck/TcTyClsDecls.lhs

@@ -431,13 +431,14 @@ kcFamilyDecl (TySynonym {}) = return ()
 kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d)
 
 ------------------
-kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM ()
+kcResultKind :: Maybe (HsBndrSig (LHsKind Name)) -> Kind -> TcM ()
 kcResultKind Nothing res_k
   = discardResult (unifyKind res_k liftedTypeKind)
       --             type family F a 
       -- defaults to type family F a :: *
-kcResultKind (Just k) res_k
-  = do { k' <- tcLHsKind k
+kcResultKind (Just (HsBSig k ns)) res_k
+  = do { let kvs = map mkKindSigVar ns 
+       ; k' <- tcExtendTyVarEnv kvs (tcLHsKind k)
        ; discardResult (unifyKind k' res_k) }
 \end{code}