X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=16f389bf142a66a67629c533022be6617318f571;hb=960a5edb6ac87c7d85e36f4b70be8da0175819f7;hp=64f3498ad422aa5c8e76584d091a51b3f4366669;hpb=30c122df62ec75f9ed7f392f24c2925675bf1d06;p=ghc-hetmet.git

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 64f3498..16f389b 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -20,7 +20,7 @@ import CoreLint
 import CoreUtils
 import VarEnv
 import VarSet
-import Var hiding( mkGlobalId )
+import Var
 import Id
 import IdInfo
 import InstEnv
@@ -142,6 +142,7 @@ mkBootModDetails hsc_env exports type_env insts fam_insts
 			     , md_insts     = insts'
 			     , md_fam_insts = fam_insts
 			     , md_rules     = []
+			     , md_anns      = []
 			     , md_exports   = exports
                              , md_vect_info = noVectInfo
                              })
@@ -150,7 +151,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
@@ -176,7 +177,7 @@ tidyExternalId :: Id -> Id
 -- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.)
 tidyExternalId id 
   = ASSERT2( isLocalId id && isExternalName (idName id), ppr id )
-    mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo
+    mkVanillaGlobal (idName id) (tidyTopType (idType id))
 \end{code}
 
 
@@ -253,14 +254,14 @@ 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, 
 				mg_rules = imp_rules,
                                 mg_vect_info = vect_info,
 				mg_dir_imps = dir_imps, 
+				mg_anns = anns,
                                 mg_deps = deps, 
 				mg_foreign = foreign_stubs,
 			        mg_hpc_info = hpc_info,
@@ -270,6 +271,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 +290,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
@@ -310,7 +312,7 @@ tidyProgram hsc_env
 		"Tidy Core Rules"
 		(pprRules tidy_rules)
 
-        ; let dir_imp_mods = map fst (moduleEnvElts dir_imps)
+        ; let dir_imp_mods = moduleEnvKeys dir_imps
 
 	; return (CgGuts { cg_module   = mod, 
 			   cg_tycons   = alg_tycons,
@@ -326,7 +328,8 @@ tidyProgram hsc_env
 				md_insts     = tidy_insts,
 				md_fam_insts = fam_insts,
 				md_exports   = exports,
-                                md_vect_info = vect_info    -- is already tidy
+				md_anns      = anns,     -- are already tidy
+                                md_vect_info = vect_info --
                               })
 	}
 
@@ -337,7 +340,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 +356,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 omit_prags th 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 +376,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?