Fix scoping of kind variables in instance declarations

Fixes Trac #6118

3 files changed, 50 insertions, 27 deletions

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 2504ad892e..6b12e8e867 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -33,7 +33,7 @@ module HsTypes (
         
         mkHsQTvs, hsQTvBndrs,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
-        hsTyVarName, hsTyVarNames, mkHsWithBndrs,
+        hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
         splitLHsInstDeclTy_maybe,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
@@ -50,6 +50,7 @@ import HsLit
 
 import NameSet( FreeVars )
 import Name( Name )
+import RdrName( RdrName )
 import Type
 import HsDoc
 import BasicTypes
@@ -142,9 +143,14 @@ data LHsTyVarBndrs name
     }
   deriving( Data, Typeable )
 
-mkHsQTvs :: [LHsTyVarBndr name] -> LHsTyVarBndrs name
+mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName
+-- Just at RdrName because in the Name variant we should know just
+-- what the kind-variable binders are; and we don't
 mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs }
 
+emptyHsQTvs :: LHsTyVarBndrs name   -- Use only when you know there are no kind binders
+emptyHsQTvs =  HsQTvs { hsq_kvs = [], hsq_tvs = [] }
+
 hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
 hsQTvBndrs = hsq_tvs
 
@@ -368,18 +374,18 @@ data ConDeclField name  -- Record fields have Haddoc docs on them
 --
 -- A valid type must have one for-all at the top of the type, or of the fn arg types
 
-mkImplicitHsForAllTy ::                        LHsContext name -> LHsType name -> HsType name
-mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
+mkImplicitHsForAllTy ::                           LHsContext RdrName -> LHsType RdrName -> HsType RdrName
+mkExplicitHsForAllTy :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
 mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit []  ctxt ty
 mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
 
-mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
+mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
 -- Smart constructor for HsForAllTy
 mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
 mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp (mkHsQTvs tvs) ctxt ty
 
 -- mk_forall_ty makes a pure for-all type (no context)
-mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
+mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsType RdrName -> HsType RdrName
 mk_forall_ty exp  tvs  (L _ (HsParTy ty))                    = mk_forall_ty exp tvs ty
 mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
 mk_forall_ty exp  tvs  ty                                    = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty
@@ -406,12 +412,15 @@ hsTyVarName (KindedTyVar n _) = n
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
 
-hsTyVarNames :: [HsTyVarBndr name] -> [name]
-hsTyVarNames tvs = map hsTyVarName tvs
-
 hsLTyVarNames :: LHsTyVarBndrs name -> [name]
+-- Type variables only
 hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
 
+hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name]
+-- Kind and type variables
+hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
+  = kvs ++ map hsLTyVarName tvs
+
 hsLTyVarLocName :: LHsTyVarBndr name -> Located name
 hsLTyVarLocName = fmap hsTyVarName
 
@@ -450,7 +459,7 @@ splitLHsForAllTy poly_ty
   = case unLoc poly_ty of
         HsParTy ty              -> splitLHsForAllTy ty
         HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
-        _                       -> (mkHsQTvs [], [], poly_ty)
+        _                       -> (emptyHsQTvs, [], poly_ty)
         -- The type vars should have been computed by now, even if they were implicit
 
 splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 79ccb2179a..e1001eca15 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, hsLTyVarNames ltvs)
+    env = mkNameEnv [ (name, hsLKiTyVarNames ltvs)  -- Kind variables and type variables
 		    | L _ (TypeSig names
 			           (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
                     , (L _ name) <- names]
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9509b0a4b2..e2ad3e0b89 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -436,13 +436,14 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
            Just (inst_tyvars, _, L _ cls,_) ->
 
     do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
-             tv_names = hsLTyVarNames inst_tyvars
+             ktv_names = hsLKiTyVarNames inst_tyvars
 
        -- Rename the associated types, and type signatures
        -- Both need to have the instance type variables in scope
+       ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
        ; ((ats', other_sigs'), more_fvs) 
-             <- extendTyVarEnvFVRn tv_names $
-                do { (ats', at_fvs) <- rnATInstDecls cls tv_names ats
+             <- extendTyVarEnvFVRn ktv_names $
+                do { (ats', at_fvs) <- rnATInstDecls cls inst_tyvars ats
                    ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
                    ; return ( (ats', other_sigs')
                             , at_fvs `plusFV` sig_fvs) }
@@ -452,7 +453,7 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
 	-- the bindings are for the right class
 	-- (Slightly strangely) when scoped type variables are on, the 
         -- forall-d tyvars scope over the method bindings too
-       ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $
+       ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
                                 rnMethodBinds cls (mkSigTvFn other_sigs')
 					          mbinds    
 
@@ -527,9 +528,19 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
 Renaming of the associated types in instances.  
 
 \begin{code}
-rnATInstDecls :: Name        -- Class
-              -> [Name]      -- Type variable binders (but NOT kind variables)
-                         -- See Note [Renaming associated types] in RnTypes
+rnATDecls :: Name      -- Class
+          -> LHsTyVarBndrs Name
+          -> [LTyClDecl RdrName] 
+          -> RnM ([LTyClDecl Name], FreeVars)
+rnATDecls cls hs_tvs at_decls
+  = rnList (rnTyClDecl (Just (cls, tv_ns))) at_decls
+  where
+    tv_ns = hsLTyVarNames hs_tvs
+    -- Type variable binders (but NOT kind variables)
+    -- See Note [Renaming associated types] in RnTypes
+
+rnATInstDecls :: Name      -- Class
+              -> LHsTyVarBndrs Name
               -> [LFamInstDecl RdrName] 
               -> RnM ([LFamInstDecl Name], FreeVars)
 -- Used for the family declarations and defaults in a class decl
@@ -537,21 +548,25 @@ rnATInstDecls :: Name        -- Class
 -- 
 -- NB: We allow duplicate associated-type decls; 
 --     See Note [Associated type instances] in TcInstDcls
-rnATInstDecls cls tvs atDecls 
-  = rnList (rnFamInstDecl (Just (cls, tvs))) atDecls
+rnATInstDecls cls hs_tvs at_insts
+  = rnList (rnFamInstDecl (Just (cls, tv_ns))) at_insts
+  where
+    tv_ns = hsLTyVarNames hs_tvs
+    -- Type variable binders (but NOT kind variables)
+    -- See Note [Renaming associated types] in RnTypes
 \end{code}
 
 For the method bindings in class and instance decls, we extend the 
 type variable environment iff -fglasgow-exts
 
 \begin{code}
-extendTyVarEnvForMethodBinds :: LHsTyVarBndrs Name
+extendTyVarEnvForMethodBinds :: [Name]
                              -> RnM (Bag (LHsBind Name), FreeVars)
                              -> RnM (Bag (LHsBind Name), FreeVars)
-extendTyVarEnvForMethodBinds tyvars thing_inside
+extendTyVarEnvForMethodBinds ktv_names thing_inside
   = do	{ scoped_tvs <- xoptM Opt_ScopedTypeVariables
 	; if scoped_tvs then
-		extendTyVarEnvFVRn (hsLTyVarNames tyvars) thing_inside
+		extendTyVarEnvFVRn ktv_names thing_inside
 	  else
 		thing_inside }
 \end{code}
@@ -882,9 +897,8 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 	     { (context', cxt_fvs) <- rnContext cls_doc context
 	     ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
 			 -- The fundeps have no free variables
-             ; let tv_ns = hsLTyVarNames tyvars'
-             ; (ats',     fv_ats)     <- rnList (rnTyClDecl (Just (cls', tv_ns))) ats
-             ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tv_ns at_defs
+             ; (ats',     fv_ats)     <- rnATDecls cls' tyvars' ats
+             ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tyvars' at_defs
 	     ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
 	     ; let fvs = cxt_fvs     `plusFV`
 	                 sig_fvs     `plusFV`
@@ -913,7 +927,7 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 	-- we want to name both "x" tyvars with the same unique, so that they are
 	-- easy to group together in the typechecker.  
 	; (mbinds', meth_fvs) 
-	    <- extendTyVarEnvForMethodBinds tyvars' $
+	    <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
 		-- No need to check for duplicate method signatures
 		-- since that is done by RnNames.extendGlobalRdrEnvRn
 		-- and the methods are already in scope