[project @ 2004-09-30 10:35:15 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 8bbe4a3..821f6a9 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -42,16 +42,15 @@ 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 )
+import PrelNames       ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE, consDataConKey, hasKey )
 import UniqSupply
 import BasicTypes      ( IPName, mapIPName )
 import SrcLoc          ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
@@ -130,7 +129,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 
@@ -433,16 +432,22 @@ dataTcOccs :: RdrName -> [RdrName]
 -- If the input is a data constructor, return both it and a type
 -- constructor.  This is useful when we aren't sure which we are
 -- looking at.
---
--- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName,
---      and we don't have a systematic way to find the TyCon's Name from
---      the DataCon's name.  Sigh
 dataTcOccs rdr_name
-  | isDataOcc occ = [rdr_name_tc, rdr_name]
-  | otherwise    = [rdr_name]
+  | Just n <- isExact_maybe rdr_name           -- Ghastly special case
+  , n `hasKey` consDataConKey = [rdr_name]     -- see note below
+  | isDataOcc occ            = [rdr_name_tc, rdr_name]
+  | otherwise                = [rdr_name]
   where    
     occ        = rdrNameOcc rdr_name
     rdr_name_tc = setRdrNameSpace rdr_name tcName
+
+-- If the user typed "[]" or "(,,)", we'll generate an Exact RdrName,
+-- and setRdrNameSpace generates an Orig, which is fine
+-- But it's not fine for (:), because there *is* no corresponding type
+-- constructor.  If we generate an Orig tycon for GHC.Base.(:), it'll
+-- appear to be in scope (because Orig's simply allocate a new name-cache
+-- entry) and then we get an error when we use dataTcOccs in 
+-- TcRnDriver.tcRnGetInfo.  Large sigh.
 \end{code}
 
 %************************************************************************
@@ -584,7 +589,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)
@@ -635,7 +640,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
@@ -669,7 +674,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") <+>
@@ -699,7 +704,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
@@ -729,13 +736,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)
@@ -745,7 +748,7 @@ badOrigBinding name
        -- The rdrNameOcc is because we don't want to print Prelude.(,)
 
 dupNamesErr descriptor (L loc name : dup_things)
-  = addSrcSpan loc $
+  = setSrcSpan loc $
     addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
              $$ 
              descriptor)