diff options
Diffstat (limited to 'compiler/rename/RnHsSyn.lhs')
| -rw-r--r-- | compiler/rename/RnHsSyn.lhs | 31 |
1 files changed, 24 insertions, 7 deletions
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 7b0591dd19..e2369bb776 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -16,6 +16,7 @@ module RnHsSyn( charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, extractHsTyVars, extractHsTyNames, extractHsTyNames_s, extractFunDepNames, extractHsCtxtTyNames, + extractHsTyVarBndrNames, extractHsTyVarBndrNames_s, -- Free variables hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs @@ -30,6 +31,7 @@ import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( TupleSort ) import SrcLoc +import Panic ( panic ) \end{code} %************************************************************************ @@ -56,6 +58,7 @@ extractFunDepNames :: FunDep Name -> NameSet extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2 extractHsTyNames :: LHsType Name -> NameSet +-- Also extract names in kinds. extractHsTyNames ty = getl ty where @@ -68,22 +71,24 @@ extractHsTyNames ty get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 get (HsIParamTy _ ty) = getl ty get (HsEqTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) + get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) get (HsParTy ty) = getl ty get (HsBangTy _ ty) = getl ty get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) get (HsTyVar tv) = unitNameSet tv get (HsSpliceTy _ fvs _) = fvs get (HsQuasiQuoteTy {}) = emptyNameSet - get (HsKindSig ty _) = getl ty + get (HsKindSig ty ki) = getl ty `unionNameSets` getl ki get (HsForAllTy _ tvs - ctxt ty) = (extractHsCtxtTyNames ctxt - `unionNameSets` getl ty) - `minusNameSet` - mkNameSet (hsLTyVarNames tvs) + ctxt ty) = extractHsTyVarBndrNames_s tvs + (extractHsCtxtTyNames ctxt + `unionNameSets` getl ty) get (HsDocTy ty _) = getl ty get (HsCoreTy {}) = emptyNameSet -- This probably isn't quite right -- but I don't think it matters + get (HsExplicitListTy _ tys) = extractHsTyNames_s tys + get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys + get (HsWrapTy {}) = panic "extractHsTyNames" extractHsTyNames_s :: [LHsType Name] -> NameSet extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys @@ -91,6 +96,18 @@ extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet t extractHsCtxtTyNames :: LHsContext Name -> NameSet extractHsCtxtTyNames (L _ ctxt) = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt + +extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet +extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet +extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki + +extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet +-- Update the name set 'body' by adding the names in the binders +-- kinds and handling scoping. +extractHsTyVarBndrNames_s [] body = body +extractHsTyVarBndrNames_s (b:bs) body = + (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b)) + `unionNameSets` extractHsTyVarBndrNames b \end{code} @@ -125,7 +142,7 @@ hsSigFVs _ = emptyFVs conDeclFVs :: LConDecl Name -> FreeVars conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, con_details = details, con_res = res_ty})) - = delFVs (map hsLTyVarName tyvars) $ + = extractHsTyVarBndrNames_s tyvars $ extractHsCtxtTyNames context `plusFV` conDetailsFVs details `plusFV` conResTyFVs res_ty |