Commit 6a8b4290 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix scoping of kind variables in instance declarations

Fixes Trac #6118
parent 86904405
......@@ -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])
......
......@@ -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]
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment