[project @ 2004-11-09 13:27:05 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 14957f9..1ac5485 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -42,21 +42,21 @@ import RdrName              ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
                          isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv,
                          Provenance(..), pprNameProvenance, ImportSpec(..) 
                        )
-import HsTypes         ( hsTyVarName, replaceTyVarName )
+import HsTypes         ( replaceTyVarName )
 import HscTypes                ( availNames, ModIface(..), FixItem(..), lookupFixity )
 import TcRnMonad
 import Name            ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
                          nameSrcLoc, nameOccName, nameModuleName, nameParent )
 import NameSet
-import OccName         ( tcName, isDataOcc, occNameFlavour, reportIfUnused,
-                         isVarOcc )
+import OccName         ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
 import Module          ( Module, ModuleName, moduleName, mkHomeModule )
 import PrelNames       ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE, consDataConKey, hasKey )
 import UniqSupply
 import BasicTypes      ( IPName, mapIPName )
 import SrcLoc          ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
-                         srcLocSpan )
+                         srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine )
 import Outputable
+import Util            ( sortLe )
 import ListSetOps      ( removeDups )
 import List            ( nubBy )
 import CmdLineOpts
@@ -130,7 +130,7 @@ lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedBndrRn = wrapLocM lookupBndrRn
 
 lookupBndrRn :: RdrName -> RnM Name
--- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd
+-- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd
 lookupBndrRn rdr_name
   = getLocalRdrEnv             `thenM` \ local_env ->
     case lookupLocalRdrEnv local_env rdr_name of 
@@ -590,7 +590,7 @@ bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
              -> RnM a
 bindTyVarsRn doc_str tyvar_names enclosed_scope
   = let
-       located_tyvars = [L loc (hsTyVarName tv) | L loc tv <- tyvar_names] 
+       located_tyvars = hsLTyVarLocNames tyvar_names
     in
     bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
     enclosed_scope (zipWith replace tyvar_names names)
@@ -641,7 +641,7 @@ checkShadowing doc_str loc_rdr_names
       check_shadow (L loc rdr_name)
        |  rdr_name `elemLocalRdrEnv` local_env 
        || not (null (lookupGRE_RdrName rdr_name global_env ))
-       = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name)
+       = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name)
         | otherwise = returnM ()
     in
     mappM_ check_shadow loc_rdr_names
@@ -675,7 +675,7 @@ warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
 warnUnusedModules mods
   = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
   where
-    bleat (mod,loc) = addSrcSpan loc $ addWarn (mk_warn mod)
+    bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod)
     mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> 
                         text "is imported, but nothing from it is used",
                         parens (ptext SLIT("except perhaps instances visible in") <+>
@@ -705,7 +705,9 @@ warnUnusedBinds names  = mappM_ warnUnusedName (filter reportable names)
 
 warnUnusedName :: (Name, Maybe Provenance) -> RnM ()
 warnUnusedName (name, prov)
-  = addWarnAt loc (sep [msg <> colon, nest 4 (ppr name)])
+  = addWarnAt loc $
+    sep [msg <> colon, 
+        nest 2 $ occNameFlavour (nameOccName name) <+> quotes (ppr name)]
        -- TODO should be a proper span
   where
     (loc,msg) = case prov of
@@ -735,13 +737,9 @@ shadowedNameWarn doc shadow
               ptext SLIT("shadows an existing binding")]
     $$ doc
 
-unknownNameErr name
+unknownNameErr rdr_name
   = sep [ptext SLIT("Not in scope:"), 
-        if isVarOcc occ_name then quotes (ppr name)
-                             else text (occNameFlavour occ_name) 
-                                       <+> quotes (ppr name)]
-  where
-    occ_name = rdrNameOcc name
+        nest 2 $ occNameFlavour (rdrNameOcc rdr_name) <+> quotes (ppr rdr_name)]
 
 unknownInstBndrErr cls op
   = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls)
@@ -750,9 +748,18 @@ badOrigBinding name
   = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
        -- The rdrNameOcc is because we don't want to print Prelude.(,)
 
-dupNamesErr descriptor (L loc name : dup_things)
-  = addSrcSpan loc $
-    addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
-             $$ 
-             descriptor)
+dupNamesErr :: SDoc -> [Located RdrName] -> RnM ()
+dupNamesErr descriptor located_names
+  = setSrcSpan big_loc $
+    addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1),
+                 locations,
+                 descriptor])
+  where
+    L _ name1 = head located_names
+    locs      = map getLoc located_names
+    big_loc   = foldr1 combineSrcSpans locs
+    one_line  = srcSpanStartLine big_loc == srcSpanEndLine big_loc
+    locations | one_line  = empty 
+             | otherwise = ptext SLIT("Bound at:") <+> 
+                           vcat (map ppr (sortLe (<=) locs))
 \end{code}