Refactor LHsTyVarBndrs to fix Trac #6081

This is really a small change, but it touches a lot of files quite
significantly. The real goal is to put the implicitly-bound kind
variables of a data/class decl in the right place, namely on the
LHsTyVarBndrs type, which now looks like

  data LHsTyVarBndrs name
    = HsQTvs { hsq_kvs :: [Name]
             , hsq_tvs :: [LHsTyVarBndr name]
      }

This little change made the type checker neater in a number of
ways, but it was fiddly to push through the changes.

5 files changed, 209 insertions, 159 deletions

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index a8f882a48d..79ccb2179a 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -539,7 +539,7 @@ mkSigTvFn sigs
   = \n -> lookupNameEnv env n `orElse` []
   where
     env :: NameEnv [Name]
-    env = mkNameEnv [ (name, map hsLTyVarName ltvs)
+    env = mkNameEnv [ (name, hsLTyVarNames ltvs)
 		    | L _ (TypeSig names
 			           (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
                     , (L _ name) <- names]
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 9cb04ff47f..b1f393baaf 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -36,7 +36,7 @@ module RnEnv (
 	bindLocatedLocalsFV, bindLocatedLocalsRn,
 	extendTyVarEnvFVRn,
 
-	checkDupRdrNames, checkDupAndShadowedRdrNames,
+	checkDupRdrNames, checkShadowedRdrNames,
         checkDupNames, checkDupAndShadowedNames, 
 	addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
 	warnUnusedMatches,
@@ -1185,7 +1185,8 @@ bindLocatedLocalsRn :: [Located RdrName]
 	    	    -> ([Name] -> RnM a)
 	    	    -> RnM a
 bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
-  = do { checkDupAndShadowedRdrNames rdr_names_w_loc
+  = do { checkDupRdrNames rdr_names_w_loc
+       ; checkShadowedRdrNames rdr_names_w_loc
 
 	-- Make fresh Names and extend the environment
        ; names <- newLocalBndrsRn rdr_names_w_loc
@@ -1243,11 +1244,10 @@ checkDupNames names
 		-- See Note [Binders in Template Haskell] in Convert
 
 ---------------------
-checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM ()
-checkDupAndShadowedRdrNames loc_rdr_names
-  = do	{ checkDupRdrNames loc_rdr_names
-	; envs <- getRdrEnvs
-	; checkShadowedOccs envs loc_occs }
+checkShadowedRdrNames :: [Located RdrName] -> RnM ()
+checkShadowedRdrNames loc_rdr_names
+  = do { envs <- getRdrEnvs
+       ; checkShadowedOccs envs loc_occs }
   where
     loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names]
 
@@ -1645,8 +1645,10 @@ data HsDocContext
   | SpliceTypeCtx (LHsType RdrName)
   | ClassInstanceCtx
   | VectDeclCtx (Located RdrName)
+  | GenericCtx SDoc   -- Maybe we want to use this more!
 
 docOfHsDocContext :: HsDocContext -> SDoc
+docOfHsDocContext (GenericCtx doc) = doc
 docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc
 docOfHsDocContext PatCtx = text "In a pattern type-signature"
 docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma"
@@ -1666,5 +1668,4 @@ docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input")
 docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty
 docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances")
 docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
-
 \end{code}
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index d0302a19a2..3e3c2b66d2 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -162,9 +162,9 @@ matchNameMaker ctxt = LamMk report_unused
                       StmtCtxt GhciStmt -> False
                       _                 -> True
 
-rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name))
+rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name))
 rnHsSigCps sig 
-  = CpsRn (rnHsBndrSig True PatCtx sig)
+  = CpsRn (rnHsBndrSig PatCtx sig)
 
 newPatName :: NameMaker -> Located RdrName -> CpsRn Name
 newPatName (LamMk report_unused) rdr_name
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 8c338c810a..9509b0a4b2 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -43,7 +43,6 @@ import Outputable
 import Bag
 import BasicTypes       ( RuleName )
 import FastString
-import Util		( filterOut )
 import SrcLoc
 import DynFlags
 import HscTypes		( HscEnv, hsc_dflags )
@@ -485,7 +484,9 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
 	     --     to remove the context).
 
 rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars)
-rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, fid_defn = defn })
+rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
+                                  ,  fid_pats = HsWB { hswb_cts = pats }
+                                  , fid_defn = defn })
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
        ; let loc = case pats of
                      []             -> pprPanic "rnFamInstDecl" (ppr tycon)
@@ -494,8 +495,9 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
              (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
 
 
-       ; kv_names <- mkTyVarBndrNames mb_cls (map (L loc) kv_rdr_names)
-       ; tv_names <- mkTyVarBndrNames mb_cls (map (L loc) tv_rdr_names)
+       ; rdr_env  <- getLocalRdrEnv
+       ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
+       ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
        	     -- All the free vars of the family patterns
              -- with a sensible binding location
        ; ((pats', defn'), fvs) 
@@ -516,8 +518,8 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
 
        ; let all_fvs = fvs `addOneFV` unLoc tycon'
        ; return ( FamInstDecl { fid_tycon = tycon'
-                              , fid_pats = HsBSig pats' (kv_names, tv_names)
-                              , fid_defn = defn', fid_fvs = all_fvs }
+                              , fid_pats  = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
+                              , fid_defn  = defn', fid_fvs = all_fvs }
                 , all_fvs ) }
        	     -- type instance => use, hence addOneFV
 \end{code}
@@ -543,13 +545,13 @@ For the method bindings in class and instance decls, we extend the
 type variable environment iff -fglasgow-exts
 
 \begin{code}
-extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
+extendTyVarEnvForMethodBinds :: LHsTyVarBndrs Name
                              -> RnM (Bag (LHsBind Name), FreeVars)
                              -> RnM (Bag (LHsBind Name), FreeVars)
 extendTyVarEnvForMethodBinds tyvars thing_inside
   = do	{ scoped_tvs <- xoptM Opt_ScopedTypeVariables
 	; if scoped_tvs then
-		extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
+		extendTyVarEnvFVRn (hsLTyVarNames tyvars) thing_inside
 	  else
 		thing_inside }
 \end{code}
@@ -584,7 +586,8 @@ standaloneDerivErr
 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
   = do { let rdr_names_w_loc = map get_var vars
-       ; checkDupAndShadowedRdrNames rdr_names_w_loc
+       ; checkDupRdrNames rdr_names_w_loc
+       ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
        ; bindHsRuleVars rule_name vars names $ \ vars' -> 
     do { (lhs', fv_lhs') <- rnLExpr lhs
@@ -610,7 +613,7 @@ bindHsRuleVars rule_name vars names thing_inside
         thing_inside (RuleBndr (L loc n) : vars')
 
     go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside
-      = rnHsBndrSig True doc bsig $ \ bsig' ->
+      = rnHsBndrSig doc bsig $ \ bsig' ->
         go vars ns $ \ vars' ->
         thing_inside (RuleBndrSig (L loc n) bsig' : vars')
 
@@ -841,38 +844,40 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
 -- in a class decl
 rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
                             , tcdFlavour = flav, tcdKindSig = kind })
-  = do { let tv_rdr_names = hsLTyVarLocNames tyvars
-       ; checkDupRdrNames tv_rdr_names     -- Check for duplicated bindings
-       ; tv_names <- mkTyVarBndrNames mb_cls tv_rdr_names
-       ; bindTyVarsRn fmly_doc tyvars tv_names $ \tyvars' ->
+  = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
     do { tycon' <- lookupLocatedTopBndrRn tycon
        ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
        ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
                            , tcdFlavour = flav, tcdKindSig = kind' }
-                , fv_kind) } }
+                , fv_kind ) }
   where 
      fmly_doc = TyFamilyCtx tycon
+     kvs = extractRdrKindSigVars kind
 
 -- "data", "newtype" declarations
 -- both top level and (for an associated type) in an instance decl
-rnTyClDecl _ (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
+rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
   = do { tycon' <- lookupLocatedTopBndrRn tycon
-       ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) tyvars $ \ tyvars' ->
+       ; let kvs = extractTyDefnKindVars defn
+       ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
+       ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) mb_cls kvs tyvars $ \ tyvars' ->
                                     do { (defn', fvs) <- rnTyDefn tycon defn
                                        ; return ((tyvars', defn'), fvs) }
        ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars'
                         , tcdTyDefn = defn', tcdFVs = fvs }, fvs) }
 
-rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
-		         tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
-		         tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
-                         tcdDocs = docs})
+rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
+		              tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
+		              tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
+                              tcdDocs = docs})
   = do	{ lcls' <- lookupLocatedTopBndrRn lcls
         ; let cls' = unLoc lcls'
+              kvs = []  -- No scoped kind vars except those in 
+                        -- kind signatures on the tyvars
 
 	-- Tyvars scope over superclass context and method signatures
 	; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
-	    <- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do
+	    <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do
          	 -- Checks for distinct tyvars
 	     { (context', cxt_fvs) <- rnContext cls_doc context
 	     ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
@@ -1043,21 +1048,6 @@ is jolly confusing.  See Trac #4875
 
 \begin{code}
 ---------------
-mkTyVarBndrNames :: Maybe a -> [Located RdrName] -> RnM [Name]
-mkTyVarBndrNames Nothing tv_rdr_names
-  = newLocalBndrsRn tv_rdr_names
-mkTyVarBndrNames (Just _) tv_rdr_names
-  = do { rdr_env <- getLocalRdrEnv
-       ; let mk_tv_name :: Located RdrName -> RnM Name
-              -- Use the same Name as the parent class decl
-             mk_tv_name (L l tv_rdr)
-               = case lookupLocalRdrEnv rdr_env tv_rdr of 
-                    Just n  -> return n
-                    Nothing -> newLocalBndrRn (L l tv_rdr)
-
-       ; mapM mk_tv_name tv_rdr_names }
-
----------------
 badAssocRhs :: [Name] -> RnM ()
 badAssocRhs ns
   = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") 
@@ -1082,22 +1072,21 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 	   -- For GADT syntax, the tvs are all the quantified tyvars
 	   -- Hence the 'filter' in the ResTyH98 case only
         ; rdr_env <- getLocalRdrEnv
-        ; let in_scope tv  = tv `elemLocalRdrEnv` rdr_env
-	      arg_tys      = hsConDeclArgTys details
-	      mentioned_tvs = case res_ty of
-	      	    	       ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
-	      	    	       ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+        ; let arg_tys    = hsConDeclArgTys details
+	      (free_kvs, free_tvs) = case res_ty of
+	      	    	       	       ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
+	      	    	       	       ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 
          -- With an Explicit forall, check for unused binders
 	 -- With Implicit, find the mentioned ones, and use them as binders
 	; new_tvs <- case expl of
-	    	       Implicit -> return (userHsTyVarBndrs loc mentioned_tvs)
-            	       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs
+	    	       Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
+            	       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
                                       ; return tvs }
 
         ; mb_doc' <- rnMbLHsDoc mb_doc 
 
-        ; bindHsTyVars doc new_tvs $ \new_tyvars -> do
+        ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
 	{ (new_context, fvs1) <- rnContext doc lcxt
 	; (new_details, fvs2) <- rnConDeclDetails doc details
         ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
@@ -1106,7 +1095,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
                   fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
  where
     doc = ConDeclCtx name
-    get_rdr_tvs tys = snd (extractHsTysRdrTyVars (cxt ++ tys))
+    get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
 
 rnConResult :: HsDocContext -> Name
             -> HsConDetails (LHsType Name) [ConDeclField Name]
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 99401faefc..1b2e8417f3 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -16,7 +16,7 @@ module RnTypes (
 	rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind, rnLHsMaybeKind,
 	rnHsSigType, rnLHsInstType, rnConDeclFields,
-        rnIPName,
+        rnIPName, newTyVarNameRn,
 
 	-- Precence related stuff
 	mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
@@ -26,9 +26,9 @@ module RnTypes (
 	rnSplice, checkTH,
 
         -- Binding related stuff
-        bindSigTyVarsFV, bindHsTyVars, bindTyVarsRn, rnHsBndrSig,
-        extractHsTyRdrTyVars, extractHsTysRdrTyVars
-
+        bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
+        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+        extractRdrKindSigVars, extractTyDefnKindVars, filterInScope
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -54,8 +54,9 @@ import BasicTypes	( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi
 			  Fixity(..), FixityDirection(..) )
 import Outputable
 import FastString
+import Maybes
 import Data.List        ( nub )
-import Control.Monad	( unless )
+import Control.Monad	( unless, when )
 
 #include "HsVersions.h"
 \end{code}
@@ -78,7 +79,7 @@ rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
 rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 -- Rename the type in an instance or standalone deriving decl
 rnLHsInstType doc_str ty 
-  = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty
+  = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
        ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
        ; return (ty', fvs) }
   where
@@ -108,13 +109,13 @@ rnLHsType = rnLHsTyKi True
 rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
 rnLHsKind = rnLHsTyKi False
 
-rnLHsMaybeKind  :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName))
-                -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars)
+rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
+                -> RnM (Maybe (LHsKind Name), FreeVars)
 rnLHsMaybeKind _ Nothing 
   = return (Nothing, emptyFVs)
-rnLHsMaybeKind doc (Just bsig) 
-  = rnHsBndrSig False doc bsig $ \ bsig' -> 
-    return (Just bsig', emptyFVs)
+rnLHsMaybeKind doc (Just kind) 
+  = do { (kind', fvs) <- rnLHsKind doc kind
+       ; return (Just kind', fvs) }
 
 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
 rnHsType = rnHsTyKi True
@@ -128,33 +129,33 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
 	-- Implicit quantifiction in source code (no kinds on tyvars)
 	-- Given the signature  C => T  we universally quantify 
 	-- over FV(T) \ {in-scope-tyvars} 
-    name_env <- getLocalRdrEnv
+    rdr_env <- getLocalRdrEnv
     loc <- getSrcSpanM
     let
-	(_kvs, mentioned) = extractHsTysRdrTyVars (ty:ctxt)
+	(forall_kvs, forall_tvs) = filterInScope rdr_env $
+                                   extractHsTysRdrTyVars (ty:ctxt)
            -- In for-all types we don't bring in scope
            -- kind variables mentioned in kind signatures
            -- (Well, not yet anyway....)
            --    f :: Int -> T (a::k)    -- Not allowed
 
-	-- Don't quantify over type variables that are in scope;
-	-- when GlasgowExts is off, there usually won't be any, except for
-	-- class signatures:
-	--	class C a where { op :: a -> a }
-	forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned
-	tyvar_bndrs   = userHsTyVarBndrs loc forall_tyvars
+           -- The filterInScope is to ensure that we don't quantify over
+	   -- type variables that are in scope; when GlasgowExts is off,
+	   -- there usually won't be any, except for class signatures:
+	   --	class C a where { op :: a -> a }
+	tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
 
-    rnForAll doc Implicit tyvar_bndrs lctxt ty
+    rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
 
 rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
   = ASSERT ( isType ) do { 	-- Explicit quantification.
          -- Check that the forall'd tyvars are actually 
 	 -- mentioned in the type, and produce a warning if not
-         let (_kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
+         let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
              in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
        ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
 
-       ; rnForAll doc Explicit forall_tyvars lctxt tau }
+       ; rnForAll doc Explicit kvs forall_tyvars lctxt tau }
 
 rnHsTyKi isType _ (HsTyVar rdr_name)
   = do { name <- rnTyVar isType rdr_name
@@ -310,11 +311,15 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
 
 
 \begin{code}
-rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
+rnForAll :: HsDocContext -> HsExplicitFlag 
+         -> [RdrName]                -- Kind variables
+         -> LHsTyVarBndrs RdrName   -- Type variables
 	 -> LHsContext RdrName -> LHsType RdrName 
          -> RnM (HsType Name, FreeVars)
 
-rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
+rnForAll doc exp kvs forall_tyvars ctxt ty
+  | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt)
+  = rnHsType doc (unLoc ty)
 	-- One reason for this case is that a type like Int#
 	-- starts off as (HsForAllTy Nothing [] Int), in case
 	-- there is some quantification.  Now that we have quantified
@@ -323,8 +328,8 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
 	-- get an error, because the body of a genuine for-all is
 	-- of kind *.
 
-rnForAll doc exp forall_tyvars ctxt ty
-  = bindHsTyVars doc forall_tyvars $ \ new_tyvars ->
+  | otherwise
+  = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
     do { (new_ctxt, fvs1) <- rnContext doc ctxt
        ; (new_ty, fvs2) <- rnLHsType doc ty
        ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
@@ -346,51 +351,70 @@ bindSigTyVarsFV tvs thing_inside
 		bindLocalNamesFV tvs thing_inside }
 
 ---------------
-bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName]
-	      -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-	      -> RnM (a, FreeVars)
-bindHsTyVars doc tv_bndrs thing_inside
-  = do { checkDupAndShadowedRdrNames rdr_names_w_loc
-       ; names <- newLocalBndrsRn rdr_names_w_loc
-       ; bindTyVarsRn doc tv_bndrs names thing_inside }
-  where
-    rdr_names_w_loc = hsLTyVarLocNames tv_bndrs
-
----------------
-bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] -> [Name]
-	     -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-	     -> RnM (a, FreeVars)
--- Rename the HsTyVarBndrs, giving them the specified names
--- *and* bringing into scope the kind variables bound in 
--- any kind signatures
-
-bindTyVarsRn doc tv_bndrs names thing_inside
-  = go tv_bndrs names $ \ tv_bndrs' -> 
-    bindLocalNamesFV names (thing_inside tv_bndrs')
-  where
-    go [] [] thing_inside = thing_inside []
-
-    go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside
-      = go tvs ns $ \ tvs' ->
-        thing_inside (L loc (UserTyVar n) : tvs')
-
-    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') : tvs')
+bindHsTyVars :: HsDocContext 
+             -> Maybe a                 -- Just _  => an associated type decl
+             -> [RdrName]               -- Kind variables from scope
+             -> LHsTyVarBndrs RdrName   -- Type variables
+             -> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
+             -> RnM (b, FreeVars)
+-- (a) Bring kind variables into scope 
+--     both (i) passed in (kv_bndrs) and (ii) mentioned in the kinds of tv_bndrs
+-- (b) Bring type variables into scope
+bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
+  = do { rdr_env <- getLocalRdrEnv
+       ; let tvs = hsQTvBndrs tv_bndrs
+             kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
+                                 , let (_, kvs) = extractHsTyRdrTyVars kind
+                                 , kv <- kvs ]
+             all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
+                       nub (kv_bndrs ++ kvs_from_tv_bndrs)
+       ; poly_kind <- xoptM Opt_PolyKinds
+       ; unless (poly_kind || null all_kvs) 
+                (addErr (badKindBndrs doc all_kvs))
+       ; loc <- getSrcSpanM
+       ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
+       ; bindLocalNamesFV kv_names $ 
+    do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
+
+    	     rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
+    	     rn_tv_bndr (L loc (UserTyVar rdr)) 
+    	       = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+    	            ; return (L loc (UserTyVar nm), emptyFVs) }
+    	     rn_tv_bndr (L loc (KindedTyVar rdr kind)) 
+    	       = do { sig_ok <- xoptM Opt_KindSignatures
+                    ; unless sig_ok (badSigErr False doc kind)
+                    ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+    	            ; (kind', fvs) <- rnLHsKind doc kind
+    	            ; return (L loc (KindedTyVar nm kind'), fvs) }
+
+       -- Check for duplicate or shadowed tyvar bindrs
+       ; checkDupRdrNames tv_names_w_loc
+       ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
+
+       ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
+       ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
+                        do { env <- getLocalRdrEnv
+                           ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env))
+                           ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
+       ; return (res, fvs1 `plusFV` fvs2) } }
 
-    -- Lists of unequal length
-    go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)
+newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
+newTyVarNameRn mb_assoc rdr_env loc rdr
+  | Just _ <- mb_assoc    -- Use the same Name as the parent class decl
+  , Just n <- lookupLocalRdrEnv rdr_env rdr
+  = return n   
+  | otherwise 
+  = newLocalBndrRn (L loc rdr)
 
 --------------------------------
-rnHsBndrSig :: Bool    -- True <=> type sig, False <=> kind sig
-            -> HsDocContext
-            -> HsBndrSig (LHsType RdrName)
-            -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars))
+rnHsBndrSig :: HsDocContext
+            -> HsWithBndrs (LHsType RdrName)
+            -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars))
             -> RnM (a, FreeVars)
-rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside
-  = do { let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
-       ; checkHsBndrFlags is_type doc ty tv_bndrs 
+rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
+  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
+       ; unless sig_ok (badSigErr True doc ty)
+       ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
        ; name_env <- getLocalRdrEnv
        ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
                                                , not (tv `elemLocalRdrEnv` name_env) ]
@@ -398,26 +422,13 @@ rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside
                                                , not (kv `elemLocalRdrEnv` name_env) ]
        ; bindLocalNamesFV kv_names $ 
          bindLocalNamesFV tv_names $ 
-    do { (ty', fvs1) <- rnLHsTyKi is_type doc ty
-       ; (res, fvs2) <- thing_inside (HsBSig ty' (kv_names, tv_names))
+    do { (ty', fvs1) <- rnLHsType doc ty
+       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names })
        ; return (res, fvs1 `plusFV` fvs2) } }
 
-checkHsBndrFlags :: Bool -> HsDocContext 
-                 -> LHsType RdrName -> [RdrName] -> RnM ()
-checkHsBndrFlags is_type doc ty tv_bndrs
-  | is_type     -- Type
-  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
-       ; unless sig_ok (badSigErr True doc ty) }
-  | otherwise   -- Kind
-  = do { sig_ok <- xoptM Opt_KindSignatures
-       ; unless sig_ok (badSigErr False doc ty)
-       ; poly_kind <- xoptM Opt_PolyKinds
-       ; unless (poly_kind || null tv_bndrs) 
-                (addErr (badKindBndrs doc ty tv_bndrs)) }
-
-badKindBndrs :: HsDocContext -> LHsKind RdrName -> [RdrName] -> SDoc
-badKindBndrs doc _kind kvs
-  = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs
+badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
+badKindBndrs doc kvs
+  = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
                  <+> pprQuotedList kvs)
               2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
          , docOfHsDocContext doc ]
@@ -779,7 +790,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
 %*********************************************************
 
 \begin{code}
-warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [RdrName] -> TcM ()
+warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
 warnUnusedForAlls in_doc bound mentioned_rdrs
   = ifWOptM Opt_WarnUnusedMatches $
     mapM_ add_warn bound_but_not_used
@@ -868,8 +879,6 @@ checkTH e what 	-- Raise an error in a stage-1 compiler
 %*                                                                    *
 %************************************************************************
 
-extractHsTyRdrNames finds the free variables of a HsType
-It's used when making the for-alls explicit.
 
 Note [Kind and type-variable binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -902,7 +911,16 @@ See also Note [HsBSig binder lists] in HsTypes
 \begin{code}
 type FreeKiTyVars = ([RdrName], [RdrName])
 
+filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
+filterInScope rdr_env (kvs, tvs) 
+  = (filterOut in_scope kvs, filterOut in_scope tvs)
+  where
+    in_scope tv = tv `elemLocalRdrEnv` rdr_env
+
 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
+-- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
+--                        or the free (sort, kind) variables of a HsKind
+-- It's used when making the for-alls explicit.
 -- See Note [Kind and type-variable binders]
 extractHsTyRdrTyVars ty 
   = case extract_lty ty ([],[]) of
@@ -914,12 +932,46 @@ extractHsTysRdrTyVars ty
   = case extract_ltys ty ([],[]) of
      (kvs, tvs) -> (nub kvs, nub tvs)
 
+extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
+extractRdrKindSigVars Nothing = []
+extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
+
+extractTyDefnKindVars :: HsTyDefn RdrName -> [RdrName]
+-- Get the scoped kind variables mentioned free in the constructor decls
+-- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
+-- Here k should scope over the whole definition
+extractTyDefnKindVars (TySynonym { td_synRhs = ty}) 
+  = fst (extractHsTyRdrTyVars ty)
+extractTyDefnKindVars (TyData { td_ctxt = ctxt, td_kindSig = ksig
+                              , td_cons = cons, td_derivs = derivs })
+  = fst $ extract_lctxt ctxt $
+          extract_mb extract_lkind ksig $
+          extract_mb extract_ltys derivs $
+          foldr (extract_con . unLoc) ([],[]) cons
+  where
+    extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
+    extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
+                         , con_cxt = ctxt, con_details = details }) acc
+      = extract_hs_tv_bndrs qvs acc $
+        extract_lctxt ctxt $
+        extract_ltys (hsConDeclArgTys details) ([],[])
+
+
 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
-extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
+extract_lctxt ctxt = extract_ltys (unLoc ctxt)
 
 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
 extract_ltys tys acc = foldr extract_lty acc tys
 
+extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
+extract_mb _ Nothing  acc = acc
+extract_mb f (Just x) acc = f x acc
+
+extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
+extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
+                                          (_, res_kvs) -> (res_kvs, acc_tvs)
+                                        -- Kinds shouldn't have sort signatures!
+
 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_lty (L _ ty) acc
   = case ty of
@@ -943,19 +995,27 @@ extract_lty (L _ ty) acc
       HsExplicitTupleTy _ tys   -> extract_ltys tys acc
       HsTyLit _                 -> acc
       HsWrapTy _ _              -> panic "extract_lty"
-      HsKindSig ty ki           -> case extract_lty ty acc of { (kvs1, tvs) ->
-                                   case extract_lty ki ([],kvs1) of { (_, kvs2) -> 
-                                        -- Kinds shouldn't have sort signatures!
-                                   (kvs2, tvs) }}
-      HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
-      HsForAllTy _ tvs cx ty    -> (acc_kvs ++ body_kvs, 
-                                    acc_tvs ++ filterOut (`elem` locals_tvs) body_tvs)
-                                where
-                                   (body_kvs, body_tvs) = extract_lctxt cx (extract_lty ty ([],[]))
-                                   (acc_kvs, acc_tvs) = acc
-                                   locals_tvs = hsLTyVarNames tvs
-                                        -- Currently we don't have a syntax to explicity bind 
-                                        -- kind variables, so these are all type variables
+      HsKindSig ty ki           -> extract_lty ty (extract_lkind ki acc)
+      HsForAllTy _ tvs cx ty    -> extract_hs_tv_bndrs tvs acc $
+                                   extract_lctxt cx   $
+                                   extract_lty ty ([],[])
+
+extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
+                    -> FreeKiTyVars -> FreeKiTyVars
+extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) 
+                    acc@(acc_kvs, acc_tvs)   -- Note accumulator comes first
+                    (body_kvs, body_tvs)
+  | null tvs
+  = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
+  | otherwise
+  = (outer_kvs ++ body_kvs,
+     outer_tvs ++ filterOut (`elem` local_tvs) body_tvs)
+  where
+    local_tvs = map hsLTyVarName tvs
+        -- Currently we don't have a syntax to explicitly bind 
+        -- kind variables, so these are all type variables
+
+    (outer_kvs, outer_tvs) = foldr extract_lkind acc [k | L _ (KindedTyVar _ k) <- tvs]
 
 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_tv tv acc