X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceEnv.lhs;h=40b7d31f138aefdb9756f7a0766aa8c92af77320;hb=f5ca07d670fd2fcd196aa670890257117a015728;hp=d36dce4bdc854b501a097ab8348e74aa9ab06e51;hpb=2f17466f56b1f3e0aef92aed1aa7e307a3227515;p=ghc-hetmet.git

diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs
index d36dce4..40b7d31 100644
--- a/ghc/compiler/iface/IfaceEnv.lhs
+++ b/ghc/compiler/iface/IfaceEnv.lhs
@@ -4,11 +4,13 @@
 module IfaceEnv (
 	newGlobalBinder, newIPName, newImplicitBinder, 
 	lookupIfaceTop, lookupIfaceExt,
-	lookupOrig, lookupAvail, lookupIfaceTc,
+	lookupOrig, lookupIfaceTc,
 	newIfaceName, newIfaceNames,
-	extendIfaceIdEnv, extendIfaceTyVarEnv,
+	extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv,
 	tcIfaceLclId,     tcIfaceTyVar, 
 
+	lookupAvail, ifaceExportNames,
+
 	-- Name-cache stuff
 	allocateGlobalBinder, initNameCache, 
    ) where
@@ -18,17 +20,20 @@ module IfaceEnv (
 import TcRnMonad
 import IfaceType	( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
 import TysWiredIn	( tupleTyCon, tupleCon )
-import HscTypes		( NameCache(..), HscEnv(..), GenAvailInfo(..), OrigNameCache )
+import HscTypes		( NameCache(..), HscEnv(..), GenAvailInfo(..), 
+			  IfaceExport, OrigNameCache )
+import Type		( mkOpenTvSubst, substTy )
 import TyCon		( TyCon, tyConName )
+import Unify		( TypeRefinement )
 import DataCon		( dataConWorkId, dataConName )
-import Var		( TyVar, Id, varName )
+import Var		( TyVar, Id, varName, setIdType, idType )
 import Name		( Name, nameUnique, nameModule, 
 			  nameOccName, nameSrcLoc, 
 			  getOccName, nameParent_maybe,
 		  	  isWiredInName, mkIPName,
 			  mkExternalName, mkInternalName )
-
-import OccName		( OccName, isTupleOcc_maybe, tcName, dataName,
+import NameSet		( NameSet, emptyNameSet, addListToNameSet )
+import OccName		( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv,
 			  lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
 import PrelNames	( gHC_PRIM, pREL_TUP )
 import Module		( Module, emptyModuleEnv, 
@@ -60,7 +65,7 @@ newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name
 
 newGlobalBinder mod occ mb_parent loc
   = do	{ mod `seq` occ `seq` return ()	-- See notes with lookupOrig_help
-	; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
+	-- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc)
     	; name_supply <- getNameCache
 	; let (name_supply', name) = allocateGlobalBinder 
 					name_supply mod occ
@@ -127,6 +132,14 @@ newImplicitBinder base_name mk_sys_occ
 		    Just parent_name  -> parent_name
 		    Nothing 	      -> base_name
 
+ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet
+ifaceExportNames exports 
+  = foldlM do_one emptyNameSet exports
+  where
+    do_one acc (mod, exports)  = foldlM (do_avail mod) acc exports
+    do_avail mod acc avail = do { ns <- lookupAvail mod avail
+				; return (addListToNameSet acc ns) }
+
 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
 -- Find all the names arising from an import
 -- Make sure the parent info is correct, even though we may not
@@ -279,6 +292,14 @@ tcIfaceLclId occ
 		  `orElse` 
 		  pprPanic "tcIfaceLclId" (ppr occ)) }
 
+refineIfaceIdEnv :: TypeRefinement -> IfL a -> IfL a
+refineIfaceIdEnv (tv_subst, _) thing_inside
+  = do	{ env <- getLclEnv
+	; let { id_env' = mapOccEnv refine_id (if_id_env env)
+	      ;	refine_id id = setIdType id (substTy subst (idType id))
+	      ;	subst = mkOpenTvSubst tv_subst }
+	; setLclEnv (env { if_id_env = id_env' }) thing_inside }
+	
 extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
 extendIfaceIdEnv ids thing_inside
   = do	{ env <- getLclEnv