summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2014-06-06 11:39:41 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2014-06-06 13:06:09 +0100
commit7ac600d5fcd74db1f991555de6e415030970d5f3 (patch)
tree7d5e8aab6abdadf800c542face81d718d6856e11 /compiler/deSugar
parent6e50553c153f1160e3475e8c727f38b842aee96c (diff)
downloadhaskell-7ac600d5fcd74db1f991555de6e415030970d5f3.tar.gz
Make the matcher and wrapper Ids in PatSyn into LocalIds, not GlobalIds
This was a serious bug, exposed by Trac #9175. The matcher and wrapper must be LocalIds, like record selectors and dictionary functions, for the reasons now documented in Note [Exported LocalIds] in Id.lhs In fixing this I found - PatSyn should have an Id inside it (apart from the wrapper and matcher) It should be a Name. Hence psId --> psName, with knock-on consequences - Tidying of PatSyns in TidyPgm was wrong - The keep-alive set in Desugar.deSugar (now) doesn't need pattern synonyms in it I also cleaned up the interface to PatSyn a little, so there's a tiny knock-on effect in Haddock; hence the haddock submodule update. It's very hard to make a test for this bug, so I haven't.
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Desugar.lhs21
-rw-r--r--compiler/deSugar/MatchCon.lhs2
2 files changed, 7 insertions, 16 deletions
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index a103e7e0fe..3160b35f15 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -52,8 +52,6 @@ import OrdList
import Data.List
import Data.IORef
import Control.Monad( when )
-import Data.Maybe ( mapMaybe )
-import UniqFM
\end{code}
%************************************************************************
@@ -125,27 +123,20 @@ deSugar hsc_env
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
- ; let patsyn_defs = [(patSynId ps, ps) | ps <- patsyns]
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
- , ds_fords `appendStubC` hpc_init
- , patsyn_defs) }
+ , ds_fords `appendStubC` hpc_init) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> do
+ Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
do { -- Add export flags to bindings
keep_alive <- readIORef keep_var
- ; let (rules_for_locals, rules_for_imps)
- = partition isLocalRule all_rules
- final_patsyns = addExportFlagsAndRules target export_set keep_alive [] patsyn_defs
- exp_patsyn_wrappers = mapMaybe (patSynWrapper . snd) final_patsyns
- exp_patsyn_matchers = map (patSynMatcher . snd) final_patsyns
- keep_alive' = addListToUFM keep_alive (map (\x -> (x, getName x)) (exp_patsyn_wrappers ++ exp_patsyn_matchers))
- final_prs = addExportFlagsAndRules target
- export_set keep_alive' rules_for_locals (fromOL all_prs)
+ ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
+ final_prs = addExportFlagsAndRules target export_set keep_alive
+ rules_for_locals (fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
-- Notice that we put the whole lot in a big Rec, even the foreign binds
@@ -189,7 +180,7 @@ deSugar hsc_env
mg_fam_insts = fam_insts,
mg_inst_env = inst_env,
mg_fam_inst_env = fam_inst_env,
- mg_patsyns = map snd . filter (isExportedId . fst) $ final_patsyns,
+ mg_patsyns = filter ((`elemNameSet` export_set) . patSynName) patsyns,
mg_rules = ds_rules_for_imps,
mg_binds = ds_binds,
mg_foreign = ds_fords,
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 4eec0d24bd..8e581f66e2 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -158,7 +158,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
ex_tvs = case con1 of
RealDataCon dcon1 -> dataConExTyVars dcon1
- PatSynCon psyn1 -> patSynExTyVars psyn1
+ PatSynCon psyn1 -> patSynExTyVars psyn1
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats