From f0db1857b053597e9ac43d9ce578e5f5fa0545cb Mon Sep 17 00:00:00 2001
From: "Dr. ERDI Gergo" <gergo@erdi.hu>
Date: Fri, 29 Aug 2014 21:15:22 +0800
Subject: Include pattern synonyms as AConLikes in the type environment, even
 for simplified/boot ModDetails (fixes #9417)

---
 compiler/basicTypes/PatSyn.lhs |  8 +-------
 compiler/main/TidyPgm.lhs      | 15 +++++++++------
 2 files changed, 10 insertions(+), 13 deletions(-)

(limited to 'compiler')

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 c92b5933cd..55efca1c8c 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -141,12 +141,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'
@@ -357,8 +357,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
 
@@ -456,6 +455,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}
-- 
cgit v1.2.1