X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=261969b399664441ce3cec4e030399ba364f23d2;hp=e9685908126cb86cd7bc3b015c3a911717eeaca3;hb=b00b5bc04ff36a551552470060064f0b7d84ca30;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index e968590..261969b 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -23,6 +23,7 @@ import HsSyn
 import RnHsSyn
 import TcRnMonad
 import RnEnv
+import HscTypes         ( availNames )
 import OccName		( plusOccEnv )
 import RnNames		( getLocalDeclBinders, extendRdrEnvRn )
 import RnTypes		( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
@@ -30,6 +31,7 @@ import RnTypes		( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
 			  dupFieldErr, checkTupSize )
 import DynFlags		( DynFlag(..) )
 import BasicTypes	( FixityDirection(..) )
+import SrcLoc           ( SrcSpan )
 import PrelNames	( thFAKE, hasKey, assertIdKey, assertErrorName,
 			  loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
 			  negateName, thenMName, bindMName, failMName )
@@ -38,12 +40,11 @@ import PrelNames        ( breakpointJumpName, breakpointCondJumpName
                         , undefined_RDR, breakpointIdKey, breakpointCondIdKey )
 import UniqFM           ( eltsUFM )
 import DynFlags         ( GhcMode(..) )
-import SrcLoc           ( srcSpanFile, srcSpanStartLine )
 import Name             ( isTyVarName )
 #endif
 import Name		( Name, nameOccName, nameIsLocalOrFrom )
 import NameSet
-import RdrName		( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
+import RdrName		( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals )
 import LoadIface	( loadInterfaceForName )
 import UniqFM		( isNullUFM )
 import UniqSet		( emptyUniqSet )
@@ -249,9 +250,10 @@ rnExpr (RecordUpd expr rbinds _ _)
 	     fvExpr `plusFV` fvRbinds)
 
 rnExpr (ExprWithTySig expr pty)
-  = rnLExpr expr		`thenM` \ (expr', fvExpr) ->
-    rnHsTypeFVs doc pty		`thenM` \ (pty', fvTy) ->
-    returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
+  = do	{ (pty', fvTy) <- rnHsTypeFVs doc pty
+	; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
+		  	     rnLExpr expr
+	; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
   where 
     doc = text "In an expression type signature"
 
@@ -330,7 +332,7 @@ rnExpr (HsArrForm op fixity cmds)
     returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
 
 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-	-- DictApp, DictLam, TyApp, TyLam
+	-- HsWrap
 \end{code}
 
 
@@ -459,7 +461,7 @@ methodNamesCmd other = emptyFVs
    -- The type checker will complain later
 
 ---------------------------------------------------
-methodNamesMatch (MatchGroup ms ty)
+methodNamesMatch (MatchGroup ms _)
   = plusFVs (map do_one ms)
  where 
     do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
@@ -573,25 +575,27 @@ rnBracket (DecBr group)
 	-- confuse the Names for the current module.  
 	-- By using a pretend module, thFAKE, we keep them safely out of the way.
 
-	; names    <- getLocalDeclBinders gbl_env1 group
-	; rdr_env' <- extendRdrEnvRn emptyGlobalRdrEnv names
-	-- Furthermore, the names in the bracket shouldn't conflict with
-	-- existing top-level names E.g.
+	; avails <- getLocalDeclBinders gbl_env1 group
+        ; let names = concatMap availNames avails
+
+	; let new_occs = map nameOccName names
+	      trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs
+
+	; rdr_env' <- extendRdrEnvRn trimmed_rdr_env names
+	-- In this situation we want to *shadow* top-level bindings.
 	--	foo = 1
 	--	bar = [d| foo = 1|]
-	-- But both 'foo's get a LocalDef provenance, so we'd get a complaint unless
-	-- we start with an emptyGlobalRdrEnv
-
-	; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env1 `plusOccEnv` rdr_env',
+	-- If we don't shadow, we'll get an ambiguity complaint when we do 
+	-- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
+	--
+	-- Furthermore, arguably if the splice does define foo, that should hide
+	-- any foo's further out
+	--
+	-- The shadowing is acheived by the call to hideSomeUnquals, which removes
+	-- the unqualified bindings of things defined by the bracket
+
+	; setGblEnv (gbl_env { tcg_rdr_env = rdr_env',
 			       tcg_dus = emptyDUs }) $ do
-		-- Notice plusOccEnv, not plusGlobalRdrEnv.  In this situation we want
-		-- to *shadow* top-level bindings.  (See the 'foo' example above.)
-		-- If we don't shadow, we'll get an ambiguity complaint when we do 
-		-- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo'
-		--
-		-- Furthermore, arguably if the splice does define foo, that should hide
-		-- any foo's further out
-		--
 		-- The emptyDUs is so that we just collect uses for this group alone
 
 	{ (tcg_env, group') <- rnSrcDecls group
@@ -963,12 +967,17 @@ mkBreakpointExpr' breakpointFunc scope
              mkExpr' fnName [] = inLoc (HsVar fnName)
              mkExpr' fnName (arg:args)
                  = lHsApp (mkExpr' fnName args) (inLoc arg)
-             expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, HsLit msg]
-             mkScopeArg args
-                 = unLoc $ mkExpr undef (map HsVar args)
-             msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc)))
+             expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, msg]
+             mkScopeArg args = unLoc $ mkExpr undef (map HsVar args)
+             msg = srcSpanLit sloc
          return (expr, emptyFVs)
+
+srcSpanLit :: SrcSpan -> HsExpr Name
+srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
 #endif
+
+srcSpanPrimLit :: SrcSpan -> HsExpr Name
+srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
 \end{code}
 
 %************************************************************************
@@ -983,8 +992,8 @@ mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
 mkAssertErrorExpr
   = getSrcSpanM    			`thenM` \ sloc ->
     let
-	expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
-	msg  = HsStringPrim (mkFastString (showSDoc (ppr sloc)))
+	expr = HsApp (L sloc (HsVar assertErrorName)) 
+		     (L sloc (srcSpanPrimLit sloc))
     in
     returnM (expr, emptyFVs)
 \end{code}