[project @ 2001-12-07 07:37:43 by sof]

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

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index f317462..affbcc9 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -28,7 +28,7 @@ import HscTypes               ( Provenance(..), pprNameProvenance, hasBetterProv,
 import RnMonad
 import Name            ( Name, 
                          getSrcLoc, nameIsLocalOrFrom,
-                         mkLocalName, mkGlobalName,
+                         mkLocalName, mkGlobalName, nameModule,
                          mkIPName, nameOccName, nameModule_maybe,
                          setNameModuleAndLoc
                        )
@@ -53,12 +53,11 @@ import SrcLoc               ( SrcLoc, noSrcLoc )
 import Outputable
 import ListSetOps      ( removeDups, equivClasses )
 import Util            ( sortLt )
+import BasicTypes      ( mapIPName )
 import List            ( nub )
 import UniqFM          ( lookupWithDefaultUFM )
 import CmdLineOpts
 import FastString      ( FastString )
-
-import Maybe           ( isJust )
 \end{code}
 
 %*********************************************************
@@ -163,21 +162,24 @@ newGlobalName mod_name occ
                     name       = mkGlobalName uniq mod occ noSrcLoc
                     new_cache  = addToFM cache key name
 
-newIPName rdr_name
+newIPName rdr_name_ip
   = getNameSupplyRn            `thenRn` \ name_supply ->
     let
        ipcache = nsIPs name_supply
     in
     case lookupFM ipcache key of
-       Just name -> returnRn name
-       Nothing   -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_`
-                    returnRn name
+       Just name_ip -> returnRn name_ip
+       Nothing      -> setNameSupplyRn new_ns  `thenRn_`
+                       returnRn name_ip
                  where
                     (us', us1)  = splitUniqSupply (nsUniqs name_supply)
                     uniq        = uniqFromSupply us1
-                    name        = mkIPName uniq key
-                    new_ipcache = addToFM ipcache key name
-    where key = (rdrNameOcc rdr_name)
+                    name_ip     = mapIPName mk_name rdr_name_ip
+                    mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name)
+                    new_ipcache = addToFM ipcache key name_ip
+                    new_ns      = name_supply {nsUniqs = us', nsIPs = new_ipcache}
+    where 
+       key = rdr_name_ip       -- Ensures that ?x and %x get distinct Names
 \end{code}
 
 %*********************************************************
@@ -242,6 +244,31 @@ lookupTopBndrRn rdr_name
 lookupSigOccRn :: RdrName -> RnMS Name
 lookupSigOccRn = lookupBndrRn
 
+-- lookupInstDeclBndr is used for the binders in an 
+-- instance declaration.   Here we use the class name to
+-- disambiguate.  
+
+lookupInstDeclBndr :: Name -> RdrName -> RnMS Name
+       -- We use the selector name as the binder
+lookupInstDeclBndr cls_name rdr_name
+  | isOrig rdr_name    -- Occurs in derived instances, where we just
+                       -- refer diectly to the right method
+  = lookupOrigName rdr_name
+
+  | otherwise  
+  = getGlobalAvails    `thenRn` \ avail_env ->
+    case lookupNameEnv avail_env cls_name of
+         -- class not in scope; don't fail as later checks will catch this,
+         -- but just return (bogus) name. Icky.
+       Nothing -> returnRn (mkUnboundName rdr_name)
+       Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of
+                               (n:ns)-> ASSERT( null ns ) returnRn n
+                               []    -> failWithRn (mkUnboundName rdr_name)
+                                                   (unknownNameErr rdr_name)
+       other               -> pprPanic "lookupInstDeclBndr" (ppr cls_name)
+  where
+    occ = rdrNameOcc rdr_name
+
 -- lookupOccRn looks up an occurrence of a RdrName
 lookupOccRn :: RdrName -> RnMS Name
 lookupOccRn rdr_name
@@ -596,24 +623,8 @@ bindTyVars2Rn doc_str tyvar_names enclosed_scope
     bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
     enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
 
-bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
-             -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
-             -> RnMS (a, FreeVars)
-bindTyVarsFVRn doc_str rdr_names enclosed_scope
-  = bindTyVars2Rn doc_str rdr_names    $ \ names tyvars ->
-    enclosed_scope tyvars              `thenRn` \ (thing, fvs) ->
-    returnRn (thing, delListFromNameSet fvs names)
-
-bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
-             -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
-             -> RnMS (a, FreeVars)
-bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
-  = bindTyVars2Rn doc_str rdr_names    $ \ names tyvars ->
-    enclosed_scope names tyvars                `thenRn` \ (thing, fvs) ->
-    returnRn (thing, delListFromNameSet fvs names)
-
 bindPatSigTyVars :: [RdrNameHsType]
-                -> ([Name] -> RnMS (a, FreeVars))
+                -> RnMS (a, FreeVars)
                 -> RnMS (a, FreeVars)
   -- Find the type variables in the pattern type 
   -- signatures that must be brought into scope
@@ -634,7 +645,7 @@ bindPatSigTyVars tys enclosed_scope
        doc_sig        = text "In a pattern type-signature"
     in
     bindLocatedLocalsRn doc_sig located_tyvars $ \ names ->
-    enclosed_scope names                       `thenRn` \ (thing, fvs) ->
+    enclosed_scope                             `thenRn` \ (thing, fvs) ->
     returnRn (thing, delListFromNameSet fvs names)
 
 
@@ -811,7 +822,6 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
 addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
 
-emptyAvailEnv = emptyNameEnv
 unitAvailEnv :: AvailInfo -> AvailEnv
 unitAvailEnv a = unitNameEnv (availName a) a