[project @ 2000-10-25 15:57:33 by simonpj]

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

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index adcdb82..4fc2a3a 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -27,7 +27,7 @@ import Name           ( Name, NamedThing(..),
                        )
 import NameSet
 import OccName         ( OccName, occNameUserString, occNameFlavour )
-import Module          ( ModuleName, moduleName, mkVanillaModule )
+import Module          ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS )
 import FiniteMap
 import Unique          ( Unique )
 import UniqSupply
@@ -38,6 +38,7 @@ import Util           ( sortLt )
 import List            ( nub )
 import PrelNames       ( mkUnboundName )
 import CmdLineOpts
+import FastString      ( FastString )
 \end{code}
 
 %*********************************************************
@@ -351,15 +352,14 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
                Just name -> pushSrcLocRn loc $
                             addWarnRn (shadowedNameWarn rdr_name)
 
-bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
-                 -> RnMS (a, FreeVars)
+bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
   -- A specialised variant when renaming stuff from interface
   -- files (of which there is a lot)
   --   * one at a time
   --   * no checks for shadowing
   --   * always imported
   --   * deal with free vars
-bindCoreLocalFVRn rdr_name enclosed_scope
+bindCoreLocalRn rdr_name enclosed_scope
   = getSrcLocRn                `thenRn` \ loc ->
     getLocalNameEnv            `thenRn` \ name_env ->
     getNameSupplyRn            `thenRn` \ (us, cache, ipcache) ->
@@ -372,13 +372,12 @@ bindCoreLocalFVRn rdr_name enclosed_scope
     let
        new_name_env = extendRdrEnv name_env rdr_name name
     in
-    setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) ->
-    returnRn (result, delFromNameSet fvs name)
+    setLocalNameEnv new_name_env (enclosed_scope name)
 
-bindCoreLocalsFVRn []     thing_inside = thing_inside []
-bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b   $ \ name' ->
-                                        bindCoreLocalsFVRn bs  $ \ names' ->
-                                        thing_inside (name':names')
+bindCoreLocalsRn []     thing_inside = thing_inside []
+bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b       $ \ name' ->
+                                      bindCoreLocalsRn bs      $ \ names' ->
+                                      thing_inside (name':names')
 
 bindLocalNames names enclosed_scope
   = getLocalNameEnv            `thenRn` \ name_env ->
@@ -408,8 +407,8 @@ bindLocalsFVRn doc rdr_names enclosed_scope
     returnRn (thing, delListFromNameSet fvs names)
 
 -------------------------------------
-bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
-bindUVarRn = bindLocalRn
+bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a
+bindUVarRn = bindCoreLocalRn
 
 -------------------------------------
 extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
@@ -640,18 +639,28 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 filterAvail ie avail = Nothing
 
 -------------------------------------
-sortAvails :: Avails -> Avails
-sortAvails avails = sortLt lt avails
+groupAvails :: Avails -> [(ModuleName, Avails)]
+  -- Group by module and sort by occurrence
+  -- This keeps the list in canonical order
+groupAvails avails 
+  = [ (mkSysModuleNameFS fs, sortLt lt avails)
+    | (fs,avails) <- fmToList groupFM
+    ]
   where
-    a1 `lt` a2 = mod1 < mod2 ||
-                (mod1 == mod2 && occ1 < occ2)
+    groupFM :: FiniteMap FastString Avails
+       -- Deliberatey use the FastString so we
+       -- get a canonical ordering
+    groupFM = foldl add emptyFM avails
+
+    add env avail = addToFM_C combine env mod_fs [avail]
+                 where
+                   mod_fs = moduleNameFS (moduleName (nameModule (availName avail)))
+                   combine old _ = avail:old
+
+    a1 `lt` a2 = occ1 < occ2
               where
-                name1 = availName a1
-                name2 = availName a2
-                mod1  = nameModule name1
-                mod2  = nameModule name2
-                occ1  = nameOccName name1
-                occ2  = nameOccName name2
+                occ1  = nameOccName (availName a1)
+                occ2  = nameOccName (availName a2)
                                
 -------------------------------------
 pprAvail :: AvailInfo -> SDoc
@@ -670,25 +679,6 @@ pprAvail (Avail n) = ppr n
 %************************************************************************
 
 \begin{code}
-type FreeVars  = NameSet
-
-plusFV   :: FreeVars -> FreeVars -> FreeVars
-addOneFV :: FreeVars -> Name -> FreeVars
-unitFV   :: Name -> FreeVars
-emptyFVs :: FreeVars
-plusFVs  :: [FreeVars] -> FreeVars
-mkFVs   :: [Name] -> FreeVars
-
-isEmptyFVs = isEmptyNameSet
-emptyFVs   = emptyNameSet
-plusFVs    = unionManyNameSets
-plusFV     = unionNameSets
-mkFVs     = mkNameSet
-
--- No point in adding implicitly imported names to the free-var set
-addOneFV s n = addOneToNameSet s n
-unitFV     n = unitNameSet n
-
 -- A useful utility
 mapFvRn f xs = mapRn f xs      `thenRn` \ stuff ->
               let