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

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

diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index fb0b5c6..e2094c8 100644 (file)
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -10,16 +10,17 @@ module RnNames (
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt, opt_NoImplicitPrelude )
+import CmdLineOpts     ( DynFlag(..), opt_NoImplicitPrelude )
 
 import HsSyn           ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
+                         ForeignDecl(..), ForKind(..), isDynamicExtName,
                          collectTopBinders
                        )
 import RdrHsSyn                ( RdrNameIE, RdrNameImportDecl,
                          RdrNameHsModule, RdrNameHsDecl
                        )
-import RnIfaces                ( getInterfaceExports, getDeclBinders, 
-                         recordLocalSlurps, findAndReadIface )
+import RnIfaces                ( getInterfaceExports, recordLocalSlurps )
+import RnHiFiles       ( getTyClDeclBinders )
 import RnEnv
 import RnMonad
 
@@ -33,10 +34,10 @@ import Name         ( Name, nameSrcLoc,
                          setLocalNameSort, nameOccName,  nameEnvElts )
 import HscTypes                ( Provenance(..), ImportReason(..), GlobalRdrEnv,
                          GenAvailInfo(..), AvailInfo, Avails, AvailEnv )
-import RdrName         ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, 
-                         isQual, isUnqual )
+import RdrName         ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isUnqual )
 import OccName         ( setOccNameSpace, dataName )
 import NameSet         ( elemNameSet, emptyNameSet )
+import SrcLoc          ( SrcLoc )
 import Outputable
 import Maybes          ( maybeToBool, catMaybes, mapMaybe )
 import UniqFM          ( emptyUFM, listToUFM )
@@ -168,15 +169,19 @@ importsFromImportDecl :: (Name -> Bool)           -- OK to omit qualifier
 
 importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
   = pushSrcLocRn iloc $
-    getInterfaceExports imp_mod_name from      `thenRn` \ (imp_mod, avails) ->
+    getInterfaceExports imp_mod_name from      `thenRn` \ (imp_mod, avails_by_module) ->
 
-    if null avails then
+    if null avails_by_module then
        -- If there's an error in getInterfaceExports, (e.g. interface
        -- file not found) we get lots of spurious errors from 'filterImports'
        returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
     else
 
-    filterImports imp_mod_name import_spec avails   `thenRn` \ (filtered_avails, hides, explicits) ->
+    let
+       avails :: Avails
+       avails = concat (map snd avails_by_module)
+    in
+    filterImports imp_mod_name import_spec avails      `thenRn` \ (filtered_avails, hides, explicits) ->
 
     let
        mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) 
@@ -193,7 +198,7 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i
 
 \begin{code}
 importsFromLocalDecls mod_name rec_exp_fn decls
-  = mapRn (getLocalDeclBinders mod rec_exp_fn) decls   `thenRn` \ avails_s ->
+  = mapRn (getLocalDeclBinders (newLocalName mod rec_exp_fn)) decls    `thenRn` \ avails_s ->
 
     let
        avails = concat avails_s
@@ -220,21 +225,40 @@ importsFromLocalDecls mod_name rec_exp_fn decls
   where
     mod = mkModuleInThisPackage mod_name
 
-getLocalDeclBinders :: Module 
-                   -> (Name -> Bool)   -- Is-exported predicate
+---------------------------
+getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name)
                    -> RdrNameHsDecl -> RnMG Avails
-getLocalDeclBinders mod rec_exp_fn (ValD binds)
+getLocalDeclBinders new_name (ValD binds)
   = mapRn do_one (bagToList (collectTopBinders binds))
   where
-    do_one (rdr_name, loc) = newLocalName mod rec_exp_fn rdr_name loc  `thenRn` \ name ->
+    do_one (rdr_name, loc) = new_name rdr_name loc     `thenRn` \ name ->
                             returnRn (Avail name)
 
-getLocalDeclBinders mod rec_exp_fn decl
-  = getDeclBinders (newLocalName mod rec_exp_fn) decl  `thenRn` \ maybe_avail ->
-    case maybe_avail of
-       Nothing    -> returnRn []               -- Instance decls and suchlike
-       Just avail -> returnRn [avail]
+getLocalDeclBinders new_name (TyClD tycl_decl)
+  = getTyClDeclBinders new_name tycl_decl      `thenRn` \ avail ->
+    returnRn [avail]
+
+getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ ext_nm _ loc))
+  | binds_haskell_name kind
+  = new_name nm loc                `thenRn` \ name ->
+    returnRn [Avail name]
+
+  | otherwise          -- a foreign export
+  = lookupOrigName nm `thenRn_` 
+    returnRn []
+  where
+    binds_haskell_name (FoImport _) = True
+    binds_haskell_name FoLabel      = True
+    binds_haskell_name FoExport     = isDynamicExtName ext_nm
+
+getLocalDeclBinders new_name (FixD _)    = returnRn []
+getLocalDeclBinders new_name (DeprecD _) = returnRn []
+getLocalDeclBinders new_name (DefD _)    = returnRn []
+getLocalDeclBinders new_name (InstD _)   = returnRn []
+getLocalDeclBinders new_name (RuleD _)   = returnRn []
+
 
+---------------------------
 newLocalName mod rec_exp_fn rdr_name loc 
   = check_unqual rdr_name loc          `thenRn_`
     newTopBinder mod rdr_name loc      `thenRn` \ name ->
@@ -275,7 +299,7 @@ filterImports :: ModuleName                 -- The module being imported
 filterImports mod Nothing imports
   = returnRn (imports, [], emptyNameSet)
 
-filterImports mod (Just (want_hiding, import_items)) avails
+filterImports mod (Just (want_hiding, import_items)) total_avails
   = flatMapRn get_item import_items            `thenRn` \ avails_w_explicits ->
     let
        (item_avails, explicits_s) = unzip avails_w_explicits
@@ -284,14 +308,14 @@ filterImports mod (Just (want_hiding, import_items)) avails
     if want_hiding 
     then       
        -- All imported; item_avails to be hidden
-       returnRn (avails, item_avails, emptyNameSet)
+       returnRn (total_avails, item_avails, emptyNameSet)
     else
        -- Just item_avails imported; nothing to be hidden
        returnRn (item_avails, [], explicits)
   where
     import_fm :: FiniteMap OccName AvailInfo
     import_fm = listToFM [ (nameOccName name, avail) 
-                        | avail <- avails,
+                        | avail <- total_avails,
                           name  <- availNames avail]
        -- Even though availNames returns data constructors too,
        -- they won't make any difference because naked entities like T