diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-06-06 11:39:41 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-06-06 13:06:09 +0100 |
commit | 7ac600d5fcd74db1f991555de6e415030970d5f3 (patch) | |
tree | 7d5e8aab6abdadf800c542face81d718d6856e11 /compiler/deSugar | |
parent | 6e50553c153f1160e3475e8c727f38b842aee96c (diff) | |
download | haskell-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.lhs | 21 | ||||
-rw-r--r-- | compiler/deSugar/MatchCon.lhs | 2 |
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 |