From 4f6437613948d90abc9f1e337ad6eb2209186526 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Mon, 7 Jul 2008 10:29:41 +0000
Subject: [PATCH] Fix Trac #2386: exceesive trimming of data types with
 Template Haskell

See Note [Trimming and Template Haskell] in TidyPgm.

Merge to 6.8.4 if we ever release it.
---
 compiler/main/TidyPgm.lhs |   44 +++++++++++++++++++++++++++++---------------
 1 file changed, 29 insertions(+), 15 deletions(-)

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 3779a0a..d87b026 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -150,7 +150,7 @@ mkBootModDetails hsc_env exports type_env insts fam_insts
 
 tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv
 tidyBootTypeEnv exports type_env 
-  = tidyTypeEnv True exports type_env final_ids
+  = tidyTypeEnv True False exports type_env final_ids
   where
 	-- Find the LocalIds in the type env that are exported
 	-- Make them into GlobalIds, and tidy their types
@@ -253,8 +253,7 @@ RHSs, so that they print nicely in interfaces.
 
 \begin{code}
 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
-tidyProgram hsc_env
-                (ModGuts {      mg_module = mod, mg_exports = exports, 
+tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports, 
 				mg_types = type_env, 
 				mg_insts = insts, mg_fam_insts = fam_insts,
 				mg_binds = binds, 
@@ -270,6 +269,7 @@ tidyProgram hsc_env
 	; showPass dflags "Tidy Core"
 
 	; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags
+	      ; th	   = dopt Opt_TemplateHaskell      dflags
 	      ; ext_ids = findExternalIds omit_prags binds
 	      ; ext_rules 
 		   | omit_prags = []
@@ -288,8 +288,8 @@ tidyProgram hsc_env
 	; let { export_set = availsToNameSet exports
 	      ; final_ids  = [ id | id <- bindersOfBinds tidy_binds, 
 				    isExternalName (idName id)]
-              ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env 
-					    final_ids
+              ; tidy_type_env = tidyTypeEnv omit_prags th export_set
+					    type_env final_ids
 	      ; tidy_insts    = tidyInstances (lookup_dfun tidy_type_env) insts
 		-- A DFunId will have a binding in tidy_binds, and so
 		-- will now be in final_env, replete with IdInfo
@@ -337,7 +337,9 @@ lookup_dfun type_env dfun_id
 	_other -> pprPanic "lookup_dfun" (ppr dfun_id)
 
 --------------------------
-tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> TypeEnv
+tidyTypeEnv :: Bool 	-- Compiling without -O, so omit prags
+	    -> Bool	-- Template Haskell is on
+	    -> NameSet -> TypeEnv -> [Id] -> TypeEnv
 
 -- The competed type environment is gotten from
 --	Dropping any wired-in things, and then
@@ -351,10 +353,10 @@ tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> TypeEnv
 -- This truncates the type environment to include only the 
 -- exported Ids and things needed from them, which saves space
 
-tidyTypeEnv omit_prags exports type_env final_ids
-  = let type_env1 = filterNameEnv keep_it type_env
+tidyTypeEnv th omit_prags exports type_env final_ids 
+ = let  type_env1 = filterNameEnv keep_it type_env
 	type_env2 = extendTypeEnvWithIds type_env1 final_ids
-	type_env3 | omit_prags = mapNameEnv (trimThing exports) type_env2
+	type_env3 | omit_prags = mapNameEnv (trimThing th exports) type_env2
 		  | otherwise  = type_env2
     in 
     type_env3
@@ -371,20 +373,32 @@ isWiredInThing :: TyThing -> Bool
 isWiredInThing thing = isWiredInName (getName thing)
 
 --------------------------
-trimThing :: NameSet -> TyThing -> TyThing
+trimThing :: Bool -> NameSet -> TyThing -> TyThing
 -- Trim off inessentials, for boot files and no -O
-trimThing exports (ATyCon tc)
-   | not (mustExposeTyCon exports tc)
-   = ATyCon (makeTyConAbstract tc)
+trimThing th exports (ATyCon tc)
+   | not th && not (mustExposeTyCon exports tc)
+   = ATyCon (makeTyConAbstract tc)	-- Note [Trimming and Template Haskell]
 
-trimThing _exports (AnId id)
+trimThing _th _exports (AnId id)
    | not (isImplicitId id) 
    = AnId (id `setIdInfo` vanillaIdInfo)
 
-trimThing _exports other_thing 
+trimThing _th _exports other_thing 
   = other_thing
 
 
+{- Note [Trimming and Template Haskell]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #2386) this
+	module M(T, makeOne) where
+	  data T = Yay String
+	  makeOne = [| Yay "Yep" |]
+Notice that T is exported abstractly, but makeOne effectively exports it too!
+A module that splices in $(makeOne) will then look for a declartion of Yay,
+so it'd better be there.  Hence, brutally but simply, we switch off type
+constructor trimming if TH is enabled in this module. -}
+
+
 mustExposeTyCon :: NameSet	-- Exports
 		-> TyCon	-- The tycon
 		-> Bool 	-- Can its rep be hidden?
-- 
1.7.10.4