summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/hsSyn/HsUtils.hs30
-rw-r--r--compiler/rename/RnBinds.hs6
-rw-r--r--compiler/rename/RnNames.hs11
-rw-r--r--compiler/rename/RnSource.hs2
-rw-r--r--testsuite/tests/patsyn/should_compile/T9889.hs6
-rw-r--r--testsuite/tests/patsyn/should_compile/all.T1
-rw-r--r--testsuite/tests/patsyn/should_fail/local.stderr2
7 files changed, 39 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) ;
diff --git a/testsuite/tests/patsyn/should_compile/T9889.hs b/testsuite/tests/patsyn/should_compile/T9889.hs
new file mode 100644
index 0000000000..27b219f6ff
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T9889.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+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 91c0012d48..db6cfb57ec 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, [''])
diff --git a/testsuite/tests/patsyn/should_fail/local.stderr b/testsuite/tests/patsyn/should_fail/local.stderr
index a9a8d01af9..ccd2270507 100644
--- a/testsuite/tests/patsyn/should_fail/local.stderr
+++ b/testsuite/tests/patsyn/should_fail/local.stderr
@@ -2,3 +2,5 @@
local.hs:7:5:
Illegal pattern synonym declaration
Pattern synonym declarations are only valid in the top-level scope
+
+local.hs:7:13: Not in scope: data constructor ‘P’
View Lorry Controller Status