diff options
| author | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-08-29 21:15:22 +0800 |
|---|---|---|
| committer | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-08-29 21:15:22 +0800 |
| commit | c3342505ff06967536ea80b4df93f20e537d1050 (patch) | |
| tree | d1ce62bcade0377bf66056298387793b6937be15 | |
| parent | 78863edbb0751f5c9694ea10c6132a87cfd0ee10 (diff) | |
| download | haskell-wip/T9417.tar.gz | |
Include pattern synonyms as AConLikes in the type environment,wip/T9417
even for simplified/boot ModDetails (fixes #9417)
| -rw-r--r-- | compiler/basicTypes/PatSyn.lhs | 8 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 15 |
2 files changed, 10 insertions, 13 deletions
diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs index cba8427292..2081b5af84 100644 --- a/compiler/basicTypes/PatSyn.lhs +++ b/compiler/basicTypes/PatSyn.lhs @@ -17,7 +17,7 @@ module PatSyn ( patSynWrapper, patSynMatcher, patSynExTyVars, patSynSig, patSynInstArgTys, patSynInstResTy, - tidyPatSynIds, patSynIds + tidyPatSynIds ) where #include "HsVersions.h" @@ -267,12 +267,6 @@ patSynWrapper = psWrapper patSynMatcher :: PatSyn -> Id patSynMatcher = psMatcher -patSynIds :: PatSyn -> [Id] -patSynIds (MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id }) - = case mb_wrap_id of - Nothing -> [match_id] - Just wrap_id -> [match_id, wrap_id] - tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id }) = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id } diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 6f24e3afb8..4615859126 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -142,12 +142,12 @@ mkBootModDetailsTc hsc_env ; showPass dflags CoreTidy ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts - ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns - ; dfun_ids = map instanceDFunId insts' - ; pat_syn_ids = concatMap patSynIds pat_syns' ; type_env1 = mkBootTypeEnv (availsToNameSet exports) (typeEnvIds type_env) tcs fam_insts - ; type_env' = extendTypeEnvWithIds type_env1 (pat_syn_ids ++ dfun_ids) + ; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns + ; type_env2 = extendTypeEnvWithPatSyns pat_syns' type_env1 + ; dfun_ids = map instanceDFunId insts' + ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids } ; return (ModDetails { md_types = type_env' , md_insts = insts' @@ -360,8 +360,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- This is really the only reason we keep mg_patsyns at all; otherwise -- they could just stay in type_env ; tidy_patsyns = map (tidyPatSynIds (lookup_aux_id tidy_type_env)) patsyns - ; type_env2 = extendTypeEnvList type_env1 - [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] + ; type_env2 = extendTypeEnvWithPatSyns tidy_patsyns type_env1 ; tidy_type_env = tidyTypeEnv omit_prags type_env2 @@ -457,6 +456,10 @@ trimThing (AnId id) trimThing other_thing = other_thing + +extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv +extendTypeEnvWithPatSyns tidy_patsyns type_env + = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] \end{code} \begin{code} |