From: simonpj@microsoft.com <unknown>
Date: Tue, 30 Dec 2008 15:04:45 +0000 (+0000)
Subject: Refactor RnEnv to fix Trac #2901
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=04c3bfc687db82659a7fe5a8b0fa4244c52560b7

Refactor RnEnv to fix Trac #2901

This tidy-up fixes Trac #2901, and eliminates 20 lines of code.
Mainly this is done by making a version of lookupGlobalOccRn that
returns (Maybe Name); this replaces lookupSrcOccRn but does more.
---

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 2a1ae6b..fa15136 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -1,4 +1,4 @@
-\%
+%
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2006
 %
 \section[RnEnv]{Environment manipulation for the renamer monad}
@@ -8,12 +8,12 @@ module RnEnv (
 	newTopSrcBinder, lookupFamInstDeclBndr,
 	lookupLocatedTopBndrRn, lookupTopBndrRn,
 	lookupLocatedOccRn, lookupOccRn, 
-	lookupLocatedGlobalOccRn, lookupGlobalOccRn,
-	lookupLocalDataTcNames, lookupSrcOcc_maybe,
-	lookupSigOccRn,
+	lookupLocatedGlobalOccRn, 
+	lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+	lookupLocalDataTcNames, lookupSigOccRn,
 	lookupFixityRn, lookupTyFixityRn, 
 	lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields,
-	lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
+	lookupSyntaxName, lookupSyntaxTable, 
 	lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
 	getLookupOccRn,
 
@@ -300,10 +300,9 @@ lookup_sub_bndr is_good doc rdr_name
 	}
 
   | otherwise	-- Occurs in derived instances, where we just
-		-- refer directly to the right method
-  = ASSERT2( not (isQual rdr_name), ppr rdr_name )
-	  -- NB: qualified names are rejected by the parser
-    lookupImportedName rdr_name
+		-- refer directly to the right method with an Orig
+		-- And record fields can be Quals: C { F.f = x }
+  = lookupGlobalOccRn rdr_name
 
 newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
 newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
@@ -350,54 +349,43 @@ lookupLocatedGlobalOccRn = wrapLocM lookupGlobalOccRn
 
 lookupGlobalOccRn :: RdrName -> RnM Name
 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global 
--- environment.  It's called directly only for
---	record field names
---	class op names in class and instance decls
--- 	names in export lists
+-- environment.  Adds an error message if the RdrName is not in scope.
+-- Also has a special case for GHCi.
 
 lookupGlobalOccRn rdr_name
-  | not (isSrcRdrName rdr_name)
-  = lookupImportedName rdr_name	
-
-  | otherwise
-  = do
-  	-- First look up the name in the normal environment.
-   mb_gre <- lookupGreRn_maybe rdr_name
-   case mb_gre of {
-	Just gre -> returnM (gre_name gre) ;
-	Nothing   -> do
-
-	-- We allow qualified names on the command line to refer to 
-	--  *any* name exported by any module in scope, just as if 
-	-- there was an "import qualified M" declaration for every 
-	-- module.
-   allow_qual <- doptM Opt_ImplicitImportQualified
-   mod <- getModule
+  = do { -- First look up the name in the normal environment.
+         mb_name <- lookupGlobalOccRn_maybe rdr_name
+       ; case mb_name of {
+		Just n  -> return n ;
+		Nothing -> do
+
+       { -- We allow qualified names on the command line to refer to 
+	 --  *any* name exported by any module in scope, just as if there
+	 -- was an "import qualified M" declaration for every module.
+	 allow_qual <- doptM Opt_ImplicitImportQualified
+       ; mod <- getModule
                -- This test is not expensive,
                -- and only happens for failed lookups
-   if isQual rdr_name && allow_qual && mod == iNTERACTIVE
-      then lookupQualifiedName rdr_name
-      else unboundName rdr_name
-  }
-
-lookupImportedName :: RdrName -> TcRnIf m n Name
--- Lookup the occurrence of an imported name
--- The RdrName is *always* qualified or Exact
--- Treat it as an original name, and conjure up the Name
--- Usually it's Exact or Orig, but it can be Qual if it
---	comes from an hi-boot file.  (This minor infelicity is 
---	just to reduce duplication in the parser.)
-lookupImportedName rdr_name
-  | Just n <- isExact_maybe rdr_name 
-	-- This happens in derived code
-  = returnM n
-
-	-- Always Orig, even when reading a .hi-boot file
+       ; if isQual rdr_name && allow_qual && mod == iNTERACTIVE
+         then lookupQualifiedName rdr_name
+         else unboundName rdr_name } } }
+
+lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
+-- No filter function; does not report an error on failure
+
+lookupGlobalOccRn_maybe rdr_name
+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+  = return (Just n)
+
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = lookupOrig rdr_mod rdr_occ
+  = do { n <- lookupOrig rdr_mod rdr_occ; return (Just n) }
 
   | otherwise
-  = pprPanic "RnEnv.lookupImportedName" (ppr rdr_name)
+  = do	{ mb_gre <- lookupGreRn_maybe rdr_name
+	; case mb_gre of
+		Nothing  -> return Nothing
+		Just gre -> return (Just (gre_name gre)) }
+
 
 unboundName :: RdrName -> RnM Name
 unboundName rdr_name 
@@ -412,15 +400,6 @@ unboundName rdr_name
 --	Lookup in the Global RdrEnv of the module
 --------------------------------------------------
 
-lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name)
--- No filter function; does not report an error on failure
-lookupSrcOcc_maybe rdr_name
-  = do	{ mb_gre <- lookupGreRn_maybe rdr_name
-	; case mb_gre of
-		Nothing  -> returnM Nothing
-		Just gre -> returnM (Just (gre_name gre)) }
-	
--------------------------
 lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
 -- Just look up the RdrName in the GlobalRdrEnv
 lookupGreRn_maybe rdr_name 
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 2b3e9c0..14c96ae 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -21,7 +21,7 @@ import FamInst
 import FamInstEnv
 import TcDeriv
 import TcEnv
-import RnEnv	( lookupImportedName )
+import RnEnv	( lookupGlobalOccRn )
 import TcHsType
 import TcUnify
 import TcSimplify
@@ -863,7 +863,7 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys
 			{   -- Build the typechecked version directly, 
 			    -- without calling typecheck_method; 
 			    -- see Note [Default methods in instances]
-			  dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
+			  dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
 					-- Might not be imported, but will be an OrigName
 			; dm_id   <- tcLookupId dm_name
 			; return (wrapId dm_wrapper dm_id, emptyBag) } }
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index e0d8632..7739e0e 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -877,7 +877,7 @@ check_main dflags tcg_env
    return tcg_env
 
  | otherwise
- = do	{ mb_main <- lookupSrcOcc_maybe main_fn
+ = do	{ mb_main <- lookupGlobalOccRn_maybe main_fn
 		-- Check that 'main' is in scope
 		-- It might be imported from another module!
 	; case mb_main of {
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index f025ac2..9a03acb 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -825,11 +825,7 @@ lookupThName_maybe th_name
 	     ; rdr_env <- getLocalRdrEnv
   	     ; case lookupLocalRdrEnv rdr_env rdr_name of
 		 Just name -> return (Just name)
-	         Nothing | not (isSrcRdrName rdr_name)	-- Exact, Orig
-		         -> do { name <- lookupImportedName rdr_name
-			       ; return (Just name) }
-		    	 | otherwise			-- Unqual, Qual
-		    	 -> lookupSrcOcc_maybe rdr_name }
+	         Nothing   -> lookupGlobalOccRn_maybe rdr_name }
 
 tcLookupTh :: Name -> TcM TcTyThing
 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that