X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=6f347da286ce764f60a641cd7cd8ef58acc8e74a;hb=d0ea71ec5000050ec22487029a9fcf6da76ee422;hp=16c1b0b962f2213801e6d530cd83d0cc72a9d327;hpb=f39ff24bc78da5ba09db8864ecbd7d1055b332db;p=ghc-hetmet.git

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 16c1b0b..6f347da 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -15,6 +15,7 @@ module RnEnv (
 	lookupLocatedInstDeclBndr,
 	lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
 	lookupGreRn, lookupGreRn_maybe,
+	getLookupOccRn,
 
 	newLocalsRn, newIPNameRn,
 	bindLocalNames, bindLocalNamesFV,
@@ -114,7 +115,7 @@ newTopSrcBinder this_mod (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 (srcSpanStart loc) }
+	; newGlobalBinder rdr_mod rdr_occ loc }
 		--TODO, should pass the whole span
 
   | otherwise
@@ -122,7 +123,7 @@ newTopSrcBinder this_mod (L loc 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) (srcSpanStart loc) }
+	; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
 \end{code}
 
 %*********************************************************
@@ -174,7 +175,7 @@ lookupTopBndrRn rdr_name
 	-- we don't bother to call newTopSrcBinder first
 	-- We assume there is no "parent" name
   = do	{ loc <- getSrcSpanM
-	; newGlobalBinder rdr_mod rdr_occ (srcSpanStart loc) }
+	; newGlobalBinder rdr_mod rdr_occ loc }
 
   | otherwise
   = do	{ mb_gre <- lookupGreLocalRn rdr_name
@@ -194,8 +195,25 @@ lookupTopBndrRn rdr_name
 -- The Haskell98 report does not stipulate this, but it will!
 -- So we must treat the 'f' in the signature in the same way
 -- as the binding occurrence of 'f', using lookupBndrRn
+--
+-- However, consider this case:
+--	import M( f )
+--	f :: Int -> Int
+--	g x = x
+-- We don't want to say 'f' is out of scope; instead, we want to
+-- return the imported 'f', so that later on the reanamer will
+-- correctly report "misplaced type sig".
 lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name)
-lookupLocatedSigOccRn = lookupLocatedBndrRn
+lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do
+	{ local_env <- getLocalRdrEnv
+	; case lookupLocalRdrEnv local_env rdr_name of {
+		Just n  -> return n ;
+		Nothing -> do
+	{ mb_gre <- lookupGreLocalRn rdr_name
+	; case mb_gre of 
+		Just gre -> return (gre_name gre) 
+		Nothing  -> lookupGlobalOccRn rdr_name
+	}}}
 
 -- lookupInstDeclBndr is used for the binders in an 
 -- instance declaration.   Here we use the class name to
@@ -255,6 +273,11 @@ lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name)
 --		Occurrences
 --------------------------------------------------
 
+getLookupOccRn :: RnM (Name -> Maybe Name)
+getLookupOccRn
+  = getLocalRdrEnv			`thenM` \ local_env ->
+    return (lookupLocalRdrEnv local_env . mkRdrUnqual . nameOccName)
+
 lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedOccRn = wrapLocM lookupOccRn
 
@@ -546,7 +569,7 @@ At the moment this just happens for
   * "do" notation
 
 We store the relevant Name in the HsSyn tree, in 
-  * HsIntegral/HsFractional	
+  * HsIntegral/HsFractional/HsIsString
   * NegApp
   * NPlusKPat
   * HsDo
@@ -603,7 +626,7 @@ newLocalsRn rdr_names_w_loc
 	| otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name )
 			-- We only bind unqualified names here
 			-- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
-		      mkInternalName uniq (rdrNameOcc rdr_name) (srcSpanStart loc)
+		      mkInternalName uniq (rdrNameOcc rdr_name) loc
 
 bindLocatedLocalsRn :: SDoc	-- Documentation string for error message
 	   	    -> [Located RdrName]
@@ -775,12 +798,12 @@ warnUnusedMatches    names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals name
 -------------------------
 --	Helpers
 warnUnusedGREs gres 
- = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres]
+ = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres]
 
 warnUnusedLocals names
- = warnUnusedBinds [(n,Nothing) | n<-names]
+ = warnUnusedBinds [(n,LocalDef) | n<-names]
 
-warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM ()
+warnUnusedBinds :: [(Name,Provenance)] -> RnM ()
 warnUnusedBinds names  = mappM_ warnUnusedName (filter reportable names)
  where reportable (name,_) 
 	| isWiredInName name = False	-- Don't report unused wired-in names
@@ -790,23 +813,25 @@ warnUnusedBinds names  = mappM_ warnUnusedName (filter reportable names)
 
 -------------------------
 
-warnUnusedName :: (Name, Maybe Provenance) -> RnM ()
-warnUnusedName (name, prov)
-  = addWarnAt loc $
+warnUnusedName :: (Name, Provenance) -> RnM ()
+warnUnusedName (name, LocalDef)
+  = addUnusedWarning name (srcLocSpan (nameSrcLoc name)) 
+		     (ptext SLIT("Defined but not used"))
+
+warnUnusedName (name, Imported is)
+  = mapM_ warn is
+  where
+    warn spec = addUnusedWarning name span msg
+	where
+	   span = importSpecLoc spec
+	   pp_mod = quotes (ppr (importSpecModule spec))
+	   msg = ptext SLIT("Imported from") <+> pp_mod <+> ptext SLIT("but not used")
+
+addUnusedWarning name span msg
+  = addWarnAt span $
     sep [msg <> colon, 
 	 nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
 			<+> quotes (ppr name)]
-	-- TODO should be a proper span
-  where
-    (loc,msg) = case prov of
-		  Just (Imported is)
-		        -> (importSpecLoc imp_spec, imp_from (importSpecModule imp_spec))
-		        where
-			  imp_spec = head is
-		  other -> (srcLocSpan (nameSrcLoc name), unused_msg)
-
-    unused_msg   = text "Defined but not used"
-    imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used"
 \end{code}
 
 \begin{code}