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

diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs
index d639e96..40b7d31 100644
--- a/ghc/compiler/iface/IfaceEnv.lhs
+++ b/ghc/compiler/iface/IfaceEnv.lhs
@@ -6,11 +6,13 @@ module IfaceEnv (
 	lookupIfaceTop, lookupIfaceExt,
 	lookupOrig, lookupIfaceTc,
 	newIfaceName, newIfaceNames,
-	extendIfaceIdEnv, extendIfaceTyVarEnv,
+	extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv,
 	tcIfaceLclId,     tcIfaceTyVar, 
 
+	lookupAvail, ifaceExportNames,
+
 	-- Name-cache stuff
-	allocateGlobalBinder, initNameCache
+	allocateGlobalBinder, initNameCache, 
    ) where
 
 #include "HsVersions.h"
@@ -18,19 +20,23 @@ module IfaceEnv (
 import TcRnMonad
 import IfaceType	( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
 import TysWiredIn	( tupleTyCon, tupleCon )
-import HscTypes		( NameCache(..), HscEnv(..), 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,
+			  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, mkModule, emptyModuleEnv, 
+import Module		( Module, emptyModuleEnv, 
 			  lookupModuleEnv, extendModuleEnv_C )
 import UniqSupply	( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply )
 import FiniteMap	( emptyFM, lookupFM, addToFM )
@@ -59,6 +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)
     	; name_supply <- getNameCache
 	; let (name_supply', name) = allocateGlobalBinder 
 					name_supply mod occ
@@ -73,12 +80,11 @@ allocateGlobalBinder
 allocateGlobalBinder name_supply mod occ mb_parent loc
   = case lookupOrigNameCache (nsNames name_supply) mod occ of
 	-- A hit in the cache!  We are at the binding site of the name.
-	-- This is the moment when we know the defining Module and SrcLoc
+	-- This is the moment when we know the defining parent and SrcLoc
 	-- of the Name, so we set these fields in the Name we return.
 	--
-	-- This is essential, to get the right Module in a Name.
-	-- Also: then (bogus) multiple bindings of the same Name
-	-- 		get different SrcLocs can can be reported as such.
+	-- Then (bogus) multiple bindings of the same Name
+	-- get different SrcLocs can can be reported as such.
 	--
 	-- Possible other reason: it might be in the cache because we
 	-- 	encountered an occurrence before the binding site for an
@@ -126,16 +132,55 @@ 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
+-- yet have read the interface for this module
+lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n; 
+			       ; return [n'] }
+lookupAvail mod (AvailTC p_occ occs) 
+  = do { p_name <- lookupOrig mod p_occ
+       ; let lookup_sub occ | occ == p_occ = return p_name
+			    | otherwise	   = lookup_orig mod occ (Just p_name)
+       ; mappM lookup_sub occs }
+	-- Remember that 'occs' is all the exported things, including
+	-- the parent.  It's possible to export just class ops without
+	-- the class, via C( op ). If the class was exported too we'd
+	-- have C( C, op )
+
+	-- The use of lookupOrigSub here (rather than lookupOrig) 
+	-- ensures that the subordinate names record their parent; 
+	-- and that in turn ensures that the GlobalRdrEnv
+	-- has the correct parent for all the names in its range.
+	-- For imported things, we may only suck in the interface later, if ever.
+	-- Reason for all this:
+	--   Suppose module M exports type A.T, and constructor A.MkT
+	--   Then, we know that A.MkT is a subordinate name of A.T,
+	--   even though we aren't at the binding site of A.T
+	--   And it's important, because we may simply re-export A.T
+	--   without ever sucking in the declaration itself.
+
+
 lookupOrig :: Module -> OccName -> TcRnIf a b Name
 -- Even if we get a miss in the original-name cache, we 
 -- make a new External Name. 
 -- We fake up 
---	Module to AnotherPackage
 -- 	SrcLoc to noSrcLoc
 --	Parent no Nothing
 -- They'll be overwritten, in due course, by LoadIface.loadDecl.
+lookupOrig mod occ = lookup_orig mod occ Nothing
 
-lookupOrig mod occ 
+lookup_orig :: Module -> OccName ->  Maybe Name -> TcRnIf a b Name
+-- Used when we know the parent of the thing we are looking up
+lookup_orig mod occ mb_parent
   = do 	{ 	-- First ensure that mod and occ are evaluated
 		-- If not, chaos can ensue:
 		-- 	we read the name-cache
@@ -151,7 +196,7 @@ lookupOrig mod occ
 
 	{ let { (us', us1)      = splitUniqSupply (nsUniqs name_supply)
 	      ;	uniq   	  	= uniqFromSupply us1
-	      ;	name            = mkExternalName uniq mod occ Nothing noSrcLoc
+	      ;	name            = mkExternalName uniq mod occ mb_parent noSrcLoc
 	      ;	new_cache       = extend_name_cache (nsNames name_supply) mod occ name
 	      ;	new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
 	  }
@@ -247,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