[commit: ghc] wip/T9889: Pattern synonym names need to be in scope before renaming bindings (#9889) (7f801ff)
git at git.haskell.org
git at git.haskell.org
Wed Dec 17 14:07:40 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T9889
Link : http://ghc.haskell.org/trac/ghc/changeset/7f801ff8b1286c330466c5de65fca1b5c19d07f1/ghc
>---------------------------------------------------------------
commit 7f801ff8b1286c330466c5de65fca1b5c19d07f1
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date: Wed Dec 17 22:05:05 2014 +0800
Pattern synonym names need to be in scope before renaming bindings (#9889)
>---------------------------------------------------------------
7f801ff8b1286c330466c5de65fca1b5c19d07f1
compiler/hsSyn/HsUtils.hs | 30 +++++++++++++++-----------
compiler/rename/RnBinds.hs | 6 +++---
compiler/rename/RnNames.hs | 11 +++++++---
compiler/rename/RnSource.hs | 2 +-
testsuite/tests/patsyn/should_compile/T9889.hs | 5 +++++
testsuite/tests/patsyn/should_compile/all.T | 1 +
6 files changed, 36 insertions(+), 19 deletions(-)
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 6694138..77e2c93 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 1af93f3..edbcc9c 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 at PSB{ psb_id = rdrname@(L nameLoc _) })
+rnBindLHS name_maker _ (PatSynBind psb at 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 bff2ed0..237e6c3 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 95211cb..4395329 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) ;
diff --git a/testsuite/tests/patsyn/should_compile/T9889.hs b/testsuite/tests/patsyn/should_compile/T9889.hs
new file mode 100644
index 0000000..f418a51
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T9889.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+pattern Id x = x
+
+Id x = True
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 91c0012..db6cfb5 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -20,3 +20,4 @@ test('T8968-2', normal, compile, [''])
test('T8968-3', normal, compile, [''])
test('ImpExp_Imp', [extra_clean(['ImpExp_Exp.hi', 'ImpExp_Exp.o'])], multimod_compile, ['ImpExp_Imp', '-v0'])
test('T9857', normal, compile, [''])
+test('T9889', normal, compile, [''])
More information about the ghc-commits
mailing list