Improve error message for non-matching file name

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

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 2909af3..d9802f5 100644 (file)
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -25,7 +25,8 @@ module RnEnv (
        getLookupOccRn,
 
        newLocalsRn, newIPNameRn,
-       bindLocalNames, bindLocalNamesFV, bindLocalNamesFV_WithFixities,
+       bindLocalNames, bindLocalNamesFV, 
+       MiniFixityEnv, bindLocalNamesFV_WithFixities,
        bindLocatedLocalsFV, bindLocatedLocalsRn,
        bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
        bindTyVarsRn, extendTyVarEnvFVRn,
@@ -36,7 +37,7 @@ module RnEnv (
        mapFvRn, mapFvRnCPS,
        warnUnusedMatches, warnUnusedModules, warnUnusedImports, 
        warnUnusedTopBinds, warnUnusedLocalBinds,
-       dataTcOccs, unknownNameErr,
+       dataTcOccs, unknownNameErr
     ) where
 
 #include "HsVersions.h"
@@ -55,12 +56,12 @@ import Name         ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
                          nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName )
 import NameSet
 import NameEnv
-import UniqFM
+import LazyUniqFM
 import DataCon         ( dataConFieldLabels )
-import OccName         ( OccName, tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
-                         reportIfUnused, occNameFS )
+import OccName
 import Module          ( Module, ModuleName )
-import PrelNames       ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey )
+import PrelNames       ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, 
+                         consDataConKey, hasKey, forall_tv_RDR )
 import UniqSupply
 import BasicTypes      ( IPName, mapIPName, Fixity )
 import SrcLoc          ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
@@ -70,9 +71,30 @@ import Util
 import Maybes
 import ListSetOps      ( removeDups )
 import List            ( nubBy )
-import Monad           ( when )
 import DynFlags
 import FastString
+import Control.Monad
+\end{code}
+
+\begin{code}
+-- XXX
+thenM :: Monad a => a b -> (b -> a c) -> a c
+thenM = (>>=)
+
+thenM_ :: Monad a => a b -> a c -> a c
+thenM_ = (>>)
+
+returnM :: Monad m => a -> m a
+returnM = return
+
+mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
+mappM = mapM
+
+mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
+mappM_ = mapM_
+
+checkM :: Monad m => Bool -> m () -> m ()
+checkM = unless
 \end{code}
 
 %*********************************************************
@@ -525,6 +547,13 @@ lookupLocalDataTcNames rdr_name
     }
 
 --------------------------------
+type MiniFixityEnv = OccEnv (Located Fixity)
+       -- Mini fixity env for the names we're about 
+       -- to bind, in a single binding group
+       --
+       -- We keep the location so that if we find
+       -- a duplicate, we can report it sensibly
+
 bindLocalFixities :: [FixitySig RdrName] -> (UniqFM (Located Fixity) -> RnM a) -> RnM a
 -- Used for nested fixity decls:
 --   bind the names that are in scope already;
@@ -558,7 +587,7 @@ bindLocalFixities fixes thing_inside
 -- the fixities are given as a UFM from an OccName's FastString to a fixity decl
 -- Also check for unused binders
 bindLocalNamesFV_WithFixities :: [Name]
-                             -> UniqFM (Located Fixity)
+                             -> MiniFixityEnv
                              -> RnM (a, FreeVars) -> RnM (a, FreeVars)
 bindLocalNamesFV_WithFixities names fixities thing_inside
   = bindLocalNamesFV names $
@@ -569,7 +598,7 @@ bindLocalNamesFV_WithFixities names fixities thing_inside
     boundFixities = foldr 
                         (\ name -> \ acc -> 
                          -- check whether this name has a fixity decl
-                          case lookupUFM fixities (occNameFS (nameOccName name)) of
+                          case lookupOccEnv fixities (nameOccName name) of
                                Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc
                                Nothing -> acc) [] names
     -- bind the names; extend the fixity env; do the thing inside
@@ -864,7 +893,7 @@ checkShadowedNames doc_str (global_env,local_env) loc_rdr_names
        ; mappM_ check_shadow loc_rdr_names }
   where
     check_shadow (loc, occ)
-       | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr loc]
+       | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)]
        | not (null gres)    = complain (map pprNameProvenance gres)
        | otherwise          = return ()
        where
@@ -927,19 +956,13 @@ warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
 warnUnusedImports gres  = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres)
 warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds   (warnUnusedGREs gres)
 
-warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM ()
 warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds
 warnUnusedMatches    = check_unused Opt_WarnUnusedMatches
 
-check_unused :: DynFlag -> [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-check_unused flag names thing_inside
- =  do { (res, res_fvs) <- thing_inside
-       
-       -- Warn about unused names
-       ; ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` res_fvs) names))
-
-       -- And return
-       ; return (res, res_fvs) }
+check_unused :: DynFlag -> [Name] -> FreeVars -> RnM ()
+check_unused flag bound_names used_names
+ = ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names))
 
 -------------------------
 --     Helpers
@@ -997,9 +1020,14 @@ shadowedNameWarn doc occ shadowed_locs
     $$ doc
 
 unknownNameErr rdr_name
-  = sep [ptext SLIT("Not in scope:"), 
-        nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
-                 <+> quotes (ppr rdr_name)]
+  = vcat [ hang (ptext SLIT("Not in scope:")) 
+             2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
+                         <+> quotes (ppr rdr_name))
+        , extra ]
+  where
+    extra | rdr_name == forall_tv_RDR 
+         = ptext SLIT("Perhaps you intended to use -XRankNTypes or similar flag")
+         | otherwise = empty
 
 unknownSubordinateErr doc op   -- Doc is "method of class" or 
                                -- "field of constructor"