Check that top-level binders are unqualified names

Not having this check led to strange error messages.
See test rnfail046.

3 files changed, 32 insertions, 29 deletions

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index d63c450b9e..91b1269a24 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -87,14 +87,14 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name)
 	--	data T = (,) Int Int
 	-- unless we are in GHC.Tup
     ASSERT2( isExternalName name,  ppr name )
-    do	checkErr (this_mod == nameModule name)
-	         (badOrigBinding rdr_name)
-	returnM name
+    do	{ checkM (this_mod == nameModule name)
+	         (addErrAt loc (badOrigBinding rdr_name))
+	; return name }
 
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = do	checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
-	         (badOrigBinding rdr_name)
+  = do	{ checkM (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
+	         (addErrAt loc (badOrigBinding rdr_name))
 	-- When reading External Core we get Orig names as binders, 
 	-- but they should agree with the module gotten from the monad
 	--
@@ -112,11 +112,15 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name)
 	-- the RdrName, not from the environment.  In principle, it'd be fine to 
 	-- have an arbitrary mixture of external core definitions in a single module,
 	-- (apart from module-initialisation issues, perhaps).
-	newGlobalBinder rdr_mod rdr_occ mb_parent 
-	    	        (srcSpanStart loc) --TODO, should pass the whole span
+	; newGlobalBinder rdr_mod rdr_occ mb_parent (srcSpanStart loc) }
+		--TODO, should pass the whole span
 
   | otherwise
-  = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc)
+  = do	{ checkM (not (isQual rdr_name))
+	         (addErrAt loc (badQualBndrErr rdr_name))
+	 	-- Binders should not be qualified; if they are, and with a different
+		-- module name, we we get a confusing "M.T is not in scope" error later
+	; newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) }
 \end{code}
 
 %*********************************************************
@@ -445,10 +449,9 @@ lookupFixityRn name
 ---------------
 lookupTyFixityRn :: Located Name -> RnM Fixity
 lookupTyFixityRn (L loc n)
-  = doptM Opt_GlasgowExts 			`thenM` \ glaExts ->
-    when (not glaExts) 
-    	 (setSrcSpan loc $ addWarn (infixTyConWarn n))	`thenM_`
-    lookupFixityRn n
+  = do	{ glaExts <- doptM Opt_GlasgowExts
+	; when (not glaExts) (addWarnAt loc (infixTyConWarn n))
+	; lookupFixityRn n }
 
 ---------------
 dataTcOccs :: RdrName -> [RdrName]
@@ -676,7 +679,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 ))
-	= setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name)
+	= addWarnAt loc (shadowedNameWarn doc_str rdr_name)
         | otherwise = returnM ()
     in
     mappM_ check_shadow loc_rdr_names
@@ -710,7 +713,7 @@ warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
 warnUnusedModules mods
   = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
   where
-    bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod)
+    bleat (mod,loc) = addWarnAt loc (mk_warn mod)
     mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m)
 			<+> text "is imported, but nothing from it is used,",
 		      nest 2 (ptext SLIT("except perhaps instances visible in") 
@@ -765,10 +768,11 @@ warnUnusedName (name, prov)
 \end{code}
 
 \begin{code}
-addNameClashErrRn rdr_name (np1:nps)
+addNameClashErrRn rdr_name names
   = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
 		  ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
   where
+    (np1:nps) = names
     msg1 = ptext  SLIT("either") <+> mk_ref np1
     msgs = [ptext SLIT("    or") <+> mk_ref np | np <- nps]
     mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre
@@ -793,10 +797,9 @@ badOrigBinding name
 
 dupNamesErr :: SDoc -> [Located RdrName] -> RnM ()
 dupNamesErr descriptor located_names
-  = setSrcSpan big_loc $
-    addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1),
-		  locations,
-		  descriptor])
+  = addErrAt big_loc $
+    vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1),
+	  locations, descriptor]
   where
     L _ name1 = head located_names
     locs      = map getLoc located_names
@@ -806,6 +809,9 @@ dupNamesErr descriptor located_names
 	      | otherwise = ptext SLIT("Bound at:") <+> 
 			    vcat (map ppr (sortLe (<=) locs))
 
+badQualBndrErr rdr_name
+  = ptext SLIT("Qualified name in binding position:") <+> ppr rdr_name
+
 infixTyConWarn op
   = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op),
 	  ftext FSLIT("Use -fglasgow-exts to avoid this warning")]
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index b1f3795378..d16e3d60f7 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -151,10 +151,9 @@ rnImportDecl' iface decl_spec (ImportDecl mod_name want_boot qual_only as_mod (J
          return $ ImportDecl mod_name want_boot qual_only as_mod (Just (want_hiding,rn_import_items))
     where
     srcSpanWrapper (L span ieRdr)
-        = setSrcSpan span $
-          case get_item ieRdr of
+        = case get_item ieRdr of
             Nothing
-                -> do addErr (badImportItemErr iface decl_spec ieRdr)
+                -> do addErrAt span (badImportItemErr iface decl_spec ieRdr)
                       return Nothing
             Just ieNames
                 -> return (Just [L span ie | ie <- ieNames])
@@ -753,8 +752,8 @@ reportDeprecations dflags tcg_env
     check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_)})
       | name `elemNameSet` used_names
       ,	Just deprec_txt <- lookupDeprec dflags hpt pit name
-      = setSrcSpan (importSpecLoc imp_spec) $
-	addWarn (sep [ptext SLIT("Deprecated use of") <+> 
+      = addWarnAt (importSpecLoc imp_spec)
+		  (sep [ptext SLIT("Deprecated use of") <+> 
 			pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> 
 		 	quotes (ppr name),
 		      (parens imp_msg) <> colon,
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index e209036e5e..055cd349ad 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -752,12 +752,10 @@ checkTupSize tup_size
 
 forAllWarn doc ty (L loc tyvar)
   = ifOptM Opt_WarnUnusedMatches 	$
-    setSrcSpan loc $
-    addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
-		   nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
+    addWarnAt loc (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+		 	nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
 		   $$
-		   doc
-                )
+		   doc)
 
 bogusCharError c
   = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''