diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/hsSyn/HsUtils.hs | 30 | ||||
| -rw-r--r-- | compiler/rename/RnBinds.hs | 6 | ||||
| -rw-r--r-- | compiler/rename/RnNames.hs | 11 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hs | 2 |
4 files changed, 30 insertions, 19 deletions
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 6694138d57..77e2c93c5e 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -61,6 +61,7 @@ module HsUtils( -- Collecting binders collectLocalBinders, collectHsValBinders, collectHsBindListBinders, + collectHsValNewBinders, collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, @@ -604,31 +605,36 @@ collectHsValBinders :: HsValBindsLR idL idR -> [idL] collectHsValBinders (ValBindsIn binds _) = collectHsBindsBinders binds collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds where - collect_one (_,binds) acc = collect_binds binds acc + collect_one (_,binds) acc = collect_binds False binds acc + +collectHsValNewBinders :: HsValBindsLR Name idR -> [Name] +collectHsValNewBinders (ValBindsIn binds _) = collect_binds True binds [] +collectHsValNewBinders ValBindsOut{} = panic "collectHsValNewBinders" collectHsBindBinders :: HsBindLR idL idR -> [idL] -collectHsBindBinders b = collect_bind b [] +collectHsBindBinders b = collect_bind False b [] -collect_bind :: HsBindLR idL idR -> [idL] -> [idL] -collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc -collect_bind (FunBind { fun_id = L _ f }) acc = f : acc -collect_bind (VarBind { var_id = f }) acc = f : acc -collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc +collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL] +collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc +collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc +collect_bind _ (VarBind { var_id = f }) acc = f : acc +collect_bind _ (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc = map abe_poly dbinds ++ acc -- ++ foldr collect_bind acc binds -- I don't think we want the binders from the nested binds -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc +collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc = + if omitPatSyn then acc else ps : acc collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] -collectHsBindsBinders binds = collect_binds binds [] +collectHsBindsBinders binds = collect_binds False binds [] collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL] -collectHsBindListBinders = foldr (collect_bind . unLoc) [] +collectHsBindListBinders = foldr (collect_bind False . unLoc) [] -collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL] -collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds +collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL] +collect_binds omitPatSyn binds acc = foldrBag (collect_bind omitPatSyn . unLoc) acc binds collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] -- Used exclusively for the bindings of an instance decl which are all FunBinds diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 1af93f35d2..edbcc9cf05 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -436,12 +436,12 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) }) ; return (bind { fun_id = L nameLoc newname , bind_fvs = placeHolderNamesTc }) } -rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) }) +rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname }) = do { unless (isTopRecNameMaker name_maker) $ addErr localPatternSynonymErr ; addLocM checkConName rdrname - ; name <- applyNameMaker name_maker rdrname - ; return (PatSynBind psb{ psb_id = L nameLoc name }) } + ; name <- lookupLocatedTopBndrRn rdrname + ; return (PatSynBind psb{ psb_id = name }) } where localPatternSynonymErr :: SDoc localPatternSynonymErr diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index bff2ed0f29..237e6c3a46 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -40,6 +40,7 @@ import ErrUtils import Util import FastString import ListSetOps +import Bag import Control.Monad import Data.Map ( Map ) @@ -507,11 +508,11 @@ getLocalNonValBinders fixity_env ; nti_avails <- concatMapM new_assoc inst_decls -- Finish off with value binders: - -- foreign decls for an ordinary module + -- foreign decls and pattern synonyms for an ordinary module -- type sigs in case of a hs-boot file only ; is_boot <- tcIsHsBootOrSig ; let val_bndrs | is_boot = hs_boot_sig_bndrs - | otherwise = for_hs_bndrs + | otherwise = for_hs_bndrs ++ patsyn_hs_bndrs ; val_avails <- mapM new_simple val_bndrs ; let avails = nti_avails ++ val_avails @@ -525,11 +526,15 @@ getLocalNonValBinders fixity_env for_hs_bndrs = [ L decl_loc (unLoc nm) | L decl_loc (ForeignImport nm _ _ _) <- foreign_decls] + patsyn_hs_bndrs :: [Located RdrName] + patsyn_hs_bndrs = [ L decl_loc (unLoc n) + | L decl_loc (PatSynBind PSB{ psb_id = n }) <- bagToList val_bag] + -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders hs_boot_sig_bndrs = [ L decl_loc (unLoc n) | L decl_loc (TypeSig ns _ _) <- val_sigs, n <- ns] - ValBindsIn _ val_sigs = val_binds + ValBindsIn val_bag val_sigs = val_binds -- the SrcSpan attached to the input should be the span of the -- declaration, not just the name diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 95211cbdfc..4395329493 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -114,7 +114,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, -- It uses the fixity env from (A) to bind fixities for view patterns. new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- bind the LHSes (and their fixities) in the global rdr environment - let { val_binders = collectHsValBinders new_lhs ; + let { val_binders = collectHsValNewBinders new_lhs ; all_bndrs = extendNameSetList tc_bndrs val_binders ; val_avails = map Avail val_binders } ; traceRn (text "rnSrcDecls" <+> ppr val_avails) ; |