[project @ 2000-01-28 20:52:37 by lewie]
[ghc-hetmet.git] / ghc / compiler / rename / RnEnv.lhs
index b2c8101..b4bb690 100644 (file)
@@ -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,
+                         mkIPName, isSystemName,
                          nameOccName, setNameModule, nameModule,
                          pprOccName, isLocallyDefined, nameUnique, nameOccName,
                           occNameUserString,
@@ -29,7 +30,7 @@ import Name           ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
                        )
 import NameSet
 import OccName         ( OccName,
-                         mkDFunOcc, 
+                         mkDFunOcc, occNameUserString, occNameString,
                          occNameFlavour
                        )
 import TysWiredIn      ( tupleTyCon, unboxedTupleTyCon, listTyCon )
@@ -57,13 +58,13 @@ import Maybes               ( mapMaybe )
 
 \begin{code}
 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 +74,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,7 +91,8 @@ 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
-  = newImportedGlobalName mod_name occ (mkVanillaModule mod_name)
+  = lookupModuleRn mod_name `thenRn` \ mod ->
+    newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name)
        
 mkImportedGlobalFromRdrName rdr_name
   | isQual rdr_name
@@ -109,7 +111,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)
@@ -133,7 +135,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!
@@ -144,8 +146,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}
 
 %*********************************************************
@@ -168,8 +183,11 @@ Make a name for the dict fun for an instance decl
 \begin{code}
 newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name
 newDFunName key@(cl_occ, tycon_occ) loc
-  = newInstUniq key    `thenRn` \ inst_uniq ->
-    newImplicitBinder (mkDFunOcc cl_occ tycon_occ inst_uniq) loc
+  = newInstUniq string `thenRn` \ inst_uniq ->
+    newImplicitBinder (mkDFunOcc string inst_uniq) loc
+  where
+       -- Any string that is somewhat unique will do
+    string = occNameString cl_occ ++ occNameString tycon_occ
 \end{code}
 
 \begin{code}
@@ -210,7 +228,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
@@ -225,7 +243,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)
@@ -250,13 +268,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
@@ -289,6 +307,10 @@ bindLocalsFVRn doc rdr_names enclosed_scope
     returnRn (thing, delListFromNameSet fvs names)
 
 -------------------------------------
+bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
+bindUVarRn = bindLocalRn
+
+-------------------------------------
 extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
        -- This tiresome function is used only in rnDecl on InstDecl
 extendTyVarEnvFVRn tyvars enclosed_scope
@@ -453,7 +475,7 @@ whether there are any instance decls in this module are ``special''.
 The name cache should have the correct provenance, though.
 
 \begin{code}
-lookupImplicitOccRn :: RdrName -> RnMS Name 
+lookupImplicitOccRn :: RdrName -> RnM d Name 
 lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
 \end{code}
 
@@ -623,7 +645,10 @@ filterAvail (IEVar v)      avail@(AvailTC n ns) = Just (AvailTC n (filter wanted
        --      import A( op ) 
        -- where op is a class operation
 
-filterAvail (IEThingAll _) avail@(AvailTC _ _)  = Just avail
+filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
+       -- We don't complain even if the IE says T(..), but
+       -- no constrs/class ops of T are available
+       -- Instead that's caught with a warning by the caller
 
 filterAvail ie avail = Nothing
 
@@ -686,18 +711,19 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
 %************************************************************************
 
 
+
 \begin{code}
-warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d ()
+warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d ()
 
-warnUnusedTopNames names
-  | not opt_WarnUnusedBinds && not opt_WarnUnusedImports
-  = returnRn ()        -- Don't force ns unless necessary
+warnUnusedImports names
+  | not opt_WarnUnusedImports
+  = returnRn ()        -- Don't force names unless necessary
   | otherwise
-  = warnUnusedBinds (\ is_local -> not is_local) names
+  = warnUnusedBinds (const True) names
 
 warnUnusedLocalBinds ns
   | not opt_WarnUnusedBinds = returnRn ()
-  | otherwise              = warnUnusedBinds (\ is_local -> is_local) ns
+  | otherwise              = warnUnusedBinds (const True) ns
 
 warnUnusedMatches names
   | opt_WarnUnusedMatches = warnUnusedGroup (const True) names
@@ -723,34 +749,36 @@ warnUnusedBinds warn_when_local names
 
 -------------------------
 
+--     NOTE: the function passed to warnUnusedGroup is
+--     now always (const True) so we should be able to
+--     simplify the code slightly.  I'm leaving it there
+--     for now just in case I havn't realised why it was there.
+--     Looks highly bogus to me.  SLPJ Dec 99
+
 warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d ()
 warnUnusedGroup emit_warning names
+  | null filtered_names         = returnRn ()
   | not (emit_warning is_local) = returnRn ()
   | otherwise
-  = case filter isReportable names of
-      []       -> returnRn ()
-      repnames -> warn repnames
+  = pushSrcLocRn def_loc       $
+    addWarnRn                  $
+    sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))]
   where
-  warn repnames = pushSrcLocRn def_loc $
-                  addWarnRn            $
-                  sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr repnames)))]
-
-  name1 = head names
-
-  (is_local, def_loc, msg)
-          = case getNameProvenance name1 of
+    filtered_names = filter reportable names
+    name1         = head filtered_names
+    (is_local, def_loc, msg)
+       = case getNameProvenance name1 of
                LocalDef loc _                       -> (True, loc, text "Defined but not used")
                NonLocalDef (UserImport mod loc _) _ ->
                 (True, loc, text "Imported from" <+> quotes (ppr mod) <+> 
                                                      text "but not used")
                other -> (False, getSrcLoc name1, text "Strangely defined but not used")
 
-  isReportable = not . startsWithUnderscore . occNameUserString  . nameOccName
-    -- Haskell 98 encourages compilers to suppress warnings about
-    -- unused names in a pattern if they start with "_".
-  startsWithUnderscore ('_' : _) = True
-    -- Suppress warnings for names starting with an underscore
-  startsWithUnderscore other     = False
+    reportable name = case occNameUserString (nameOccName name) of
+                       ('_' : _) -> False
+                       zz_other  -> True
+       -- Haskell 98 encourages compilers to suppress warnings about
+       -- unused names in a pattern if they start with "_".
 \end{code}
 
 \begin{code}
@@ -790,4 +818,3 @@ dupNamesErr descriptor ((name,loc) : dup_things)
              $$ 
              (ptext SLIT("in") <+> descriptor))
 \end{code}
-