[project @ 2000-04-21 15:59:13 by panne]

[ghc-hetmet.git] / ghc / compiler / rename / RnEnv.lhs

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 6231217..1ab1482 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -21,7 +21,8 @@ import HsTypes                ( getTyVarName, replaceTyVarName )
 import RnMonad
 import Name            ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
                          ImportReason(..), getSrcLoc, 
-                         mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName,
+                         mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName,
+                         mkIPName, isSystemName,
                          nameOccName, setNameModule, nameModule,
                          pprOccName, isLocallyDefined, nameUnique, nameOccName,
                           occNameUserString,
@@ -34,7 +35,7 @@ import OccName                ( OccName,
                        )
 import TysWiredIn      ( tupleTyCon, unboxedTupleTyCon, listTyCon )
 import Type            ( funTyCon )
-import Module          ( ModuleName, mkThisModule, mkVanillaModule, moduleName )
+import Module          ( ModuleName, mkThisModule, moduleName, mkVanillaModule )
 import TyCon           ( TyCon )
 import FiniteMap
 import Unique          ( Unique, Uniquable(..) )
@@ -56,14 +57,15 @@ import Maybes               ( mapMaybe )
 %*********************************************************
 
 \begin{code}
+newImportedGlobalName :: ModuleName -> OccName -> Module -> RnM d Name
 newImportedGlobalName mod_name occ mod
-  = getNameSupplyRn            `thenRn` \ (us, inst_ns, cache) ->
+  = getNameSupplyRn            `thenRn` \ (us, inst_ns, cache, ipcache) ->
     let
        key = (mod_name, occ)
     in
     case lookupFM cache key of
        Just name -> returnRn name
-       Nothing   -> setNameSupplyRn (us', inst_ns, new_cache)  `thenRn_`
+       Nothing   -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
                     returnRn name
                  where
                     (us', us1) = splitUniqSupply us
@@ -73,8 +75,8 @@ newImportedGlobalName mod_name occ mod
 
 updateProvenances :: [Name] -> RnM d ()
 updateProvenances names
-  = getNameSupplyRn            `thenRn` \ (us, inst_ns, cache) ->
-    setNameSupplyRn (us, inst_ns, update cache names)
+  = getNameSupplyRn            `thenRn` \ (us, inst_ns, cache, ipcache) ->
+    setNameSupplyRn (us, inst_ns, update cache names, ipcache)
   where
     update cache []          = cache
     update cache (name:names) = WARN( not (key `elemFM` cache), ppr name )
@@ -90,9 +92,9 @@ newImportedBinder mod rdr_name
 -- Make an imported global name, checking first to see if it's in the cache
 mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name
 mkImportedGlobalName mod_name occ
-  = lookupModuleRn mod_name `thenRn` \ mod ->
-    newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name)
+  = newImportedGlobalName mod_name occ (mkVanillaModule mod_name)
        
+mkImportedGlobalFromRdrName :: RdrName -> RnM d Name 
 mkImportedGlobalFromRdrName rdr_name
   | isQual rdr_name
   = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
@@ -110,7 +112,7 @@ newLocalTopBinder :: Module -> OccName
               -> RnM d Name
 newLocalTopBinder mod occ rec_exp_fn loc
   =    -- First check the cache
-    getNameSupplyRn            `thenRn` \ (us, inst_ns, cache) ->
+    getNameSupplyRn            `thenRn` \ (us, inst_ns, cache, ipcache) ->
     let 
        key          = (moduleName mod,occ)
        mk_prov name = LocalDef loc (rec_exp_fn name)
@@ -134,7 +136,7 @@ newLocalTopBinder mod occ rec_exp_fn loc
                        new_name = setNameProvenance name (mk_prov new_name)
                        new_cache = addToFM cache key new_name
                     in
-                    setNameSupplyRn (us, inst_ns, new_cache)           `thenRn_`
+                    setNameSupplyRn (us, inst_ns, new_cache, ipcache)  `thenRn_`
                     returnRn new_name
                     
        -- Miss in the cache!
@@ -145,8 +147,21 @@ newLocalTopBinder mod occ rec_exp_fn loc
                        new_name   = mkGlobalName uniq mod occ (mk_prov new_name)
                        new_cache  = addToFM cache key new_name
                   in
-                  setNameSupplyRn (us', inst_ns, new_cache)            `thenRn_`
+                  setNameSupplyRn (us', inst_ns, new_cache, ipcache)   `thenRn_`
                   returnRn new_name
+
+getIPName rdr_name
+  = getNameSupplyRn            `thenRn` \ (us, inst_ns, cache, ipcache) ->
+    case lookupFM ipcache key of
+       Just name -> returnRn name
+       Nothing   -> setNameSupplyRn (us', inst_ns, cache, new_ipcache) `thenRn_`
+                    returnRn name
+                 where
+                    (us', us1)  = splitUniqSupply us
+                    uniq        = uniqFromSupply us1
+                    name        = mkIPName uniq key
+                    new_ipcache = addToFM ipcache key name
+    where key = (rdrNameOcc rdr_name)
 \end{code}
 
 %*********************************************************
@@ -214,7 +229,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
        returnRn ()
     )                                  `thenRn_`
        
-    getNameSupplyRn            `thenRn` \ (us, inst_ns, cache) ->
+    getNameSupplyRn            `thenRn` \ (us, inst_ns, cache, ipcache) ->
     getModeRn                  `thenRn` \ mode ->
     let
        n          = length rdr_names_w_loc
@@ -229,7 +244,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
                     -- Keep track of whether the name originally came from 
                     -- an interface file.
     in
-    setNameSupplyRn (us', inst_ns, cache)      `thenRn_`
+    setNameSupplyRn (us', inst_ns, cache, ipcache)     `thenRn_`
 
     let
        new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
@@ -254,13 +269,13 @@ bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
 bindCoreLocalFVRn rdr_name enclosed_scope
   = getSrcLocRn                `thenRn` \ loc ->
     getLocalNameEnv            `thenRn` \ name_env ->
-    getNameSupplyRn            `thenRn` \ (us, inst_ns, cache) ->
+    getNameSupplyRn            `thenRn` \ (us, inst_ns, cache, ipcache) ->
     let
        (us', us1) = splitUniqSupply us
        uniq       = uniqFromSupply us1
        name       = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
     in
-    setNameSupplyRn (us', inst_ns, cache)      `thenRn_`
+    setNameSupplyRn (us', inst_ns, cache, ipcache)     `thenRn_`
     let
        new_name_env = extendRdrEnv name_env rdr_name name
     in
@@ -574,7 +589,7 @@ mkExportAvails mod_name unqual_imp name_env avails
 
 plusExportAvails ::  ExportAvails ->  ExportAvails ->  ExportAvails
 plusExportAvails (m1, e1) (m2, e2)
-  = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
+  = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
        -- ToDo: wasteful: we do this once for each constructor!
 \end{code}
 
@@ -583,12 +598,24 @@ plusExportAvails (m1, e1) (m2, e2)
 
 \begin{code}
 plusAvail (Avail n1)      (Avail n2)       = Avail n1
-plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
+plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
 -- Added SOF 4/97
 #ifdef DEBUG
 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
 #endif
 
+addAvail :: AvailEnv -> AvailInfo -> AvailEnv
+addAvail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
+
+emptyAvailEnv = emptyNameEnv
+unitAvailEnv :: AvailInfo -> AvailEnv
+unitAvailEnv a = unitNameEnv (availName a) a
+
+plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
+plusAvailEnv = plusNameEnv_C plusAvail
+
+availEnvElts = nameEnvElts
+
 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
 
@@ -603,6 +630,10 @@ availNames :: AvailInfo -> [Name]
 availNames (Avail n)      = [n]
 availNames (AvailTC n ns) = ns
 
+addSysAvails :: AvailInfo -> [Name] -> AvailInfo
+addSysAvails avail          []  = avail
+addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
+
 filterAvail :: RdrNameIE       -- Wanted
            -> AvailInfo        -- Available
            -> Maybe AvailInfo  -- Resulting available; 
@@ -638,20 +669,12 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 
 filterAvail ie avail = Nothing
 
+pprAvail :: AvailInfo -> SDoc
+pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
+                                       []  -> empty
+                                       ns' -> parens (hsep (punctuate comma (map ppr ns')))
 
--- In interfaces, pprAvail gets given the OccName of the "host" thing
-pprAvail avail = getPprStyle $ \ sty ->
-                if ifaceStyle sty then
-                   ppr_avail (pprOccName . nameOccName) avail
-                else
-                   ppr_avail ppr avail
-
-ppr_avail pp_name (AvailTC n ns) = hsep [
-                                    pp_name n,
-                                    parens  $ hsep $ punctuate comma $
-                                    map pp_name ns
-                                  ]
-ppr_avail pp_name (Avail n) = pp_name n
+pprAvail (Avail n) = ppr n
 \end{code}