Massive patch for the first months work adding System FC to GHC #29

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

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index c14909e..be0970c 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -30,6 +30,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 +39,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, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals )
 import LoadIface       ( loadInterfaceForName )
 import UniqFM          ( isNullUFM )
 import UniqSet         ( emptyUniqSet )
@@ -330,7 +330,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
+       -- HsCoerce
 \end{code}
 
 
@@ -573,25 +573,26 @@ 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.
+       ; names <- getLocalDeclBinders gbl_env1 group
+
+       ; 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 +964,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)
 #endif
+
+srcSpanLit :: SrcSpan -> HsExpr Name
+srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
+
+srcSpanPrimLit :: SrcSpan -> HsExpr Name
+srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
 \end{code}
 
 %************************************************************************
@@ -983,8 +989,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}