Add bang patterns

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

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 0bf40e6..a128c35 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -30,13 +30,13 @@ import RnTypes              ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
                          dupFieldErr, checkTupSize )
 import DynFlags                ( DynFlag(..) )
 import BasicTypes      ( FixityDirection(..) )
-import PrelNames       ( hasKey, assertIdKey, assertErrorName,
+import PrelNames       ( thFAKE, hasKey, assertIdKey, assertErrorName,
                          loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
                          negateName, thenMName, bindMName, failMName )
-import Name            ( Name, nameOccName )
+import Name            ( Name, nameOccName, nameIsLocalOrFrom )
 import NameSet
 import RdrName         ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
-import UnicodeUtil     ( stringToUtf8 )
+import LoadIface       ( loadHomeInterface )
 import UniqFM          ( isNullUFM )
 import UniqSet         ( emptyUniqSet )
 import List            ( nub )
@@ -255,14 +255,9 @@ Since all the symbols are reservedops we can simply reject them.
 We return a (bogus) EWildPat in each case.
 
 \begin{code}
-rnExpr e@EWildPat = addErr (patSynErr e)       `thenM_`
-                   returnM (EWildPat, emptyFVs)
-
-rnExpr e@(EAsPat _ _) = addErr (patSynErr e)   `thenM_`
-                       returnM (EWildPat, emptyFVs)
-
-rnExpr e@(ELazyPat _) = addErr (patSynErr e)   `thenM_`
-                       returnM (EWildPat, emptyFVs)
+rnExpr e@EWildPat      = patSynErr e
+rnExpr e@(EAsPat {})   = patSynErr e
+rnExpr e@(ELazyPat {}) = patSynErr e
 \end{code}
 
 %************************************************************************
@@ -526,29 +521,51 @@ rnRbinds str rbinds
 %************************************************************************
 
 \begin{code}
-rnBracket (VarBr n) = lookupOccRn n            `thenM` \ name -> 
-                     returnM (VarBr name, unitFV name)
-rnBracket (ExpBr e) = rnLExpr e                `thenM` \ (e', fvs) ->
-                     returnM (ExpBr e', fvs)
-rnBracket (PatBr p) = rnLPat p         `thenM` \ (p', fvs) ->
-                     returnM (PatBr p', fvs)
-rnBracket (TypBr t) = rnHsTypeFVs doc t        `thenM` \ (t', fvs) ->
-                     returnM (TypBr t', fvs)
+rnBracket (VarBr n) = do { name <- lookupOccRn n
+                        ; this_mod <- getModule
+                        ; checkM (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
+                          do { loadHomeInterface msg name              -- home interface is loaded, and this is the
+                             ; return () }                             -- only way that is going to happen
+                        ; returnM (VarBr name, unitFV name) }
+                   where
+                     msg = ptext SLIT("Need interface for Template Haskell quoted Name")
+
+rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
+                        ; return (ExpBr e', fvs) }
+rnBracket (PatBr p) = do { (p', fvs) <- rnLPat p
+                        ; return (PatBr p', fvs) }
+rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
+                        ; return (TypBr t', fvs) }
                    where
                      doc = ptext SLIT("In a Template-Haskell quoted type")
 rnBracket (DecBr group) 
   = do         { gbl_env  <- getGblEnv
-       ; names    <- getLocalDeclBinders gbl_env group
-       ; rdr_env' <- extendRdrEnvRn (tcg_mod gbl_env) emptyGlobalRdrEnv names
 
-       ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env `plusOccEnv` rdr_env',
+       ; let gbl_env1 = gbl_env { tcg_mod = thFAKE }
+       -- Note the thFAKE.  The top-level names from the bracketed 
+       -- declarations will go into the name cache, and we don't want them to 
+       -- 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.
+       --      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',
                               tcg_dus = emptyDUs }) $ do
                -- Notice plusOccEnv, not plusGlobalRdrEnv.  In this situation we want
-               -- to *shadow* top-level bindings.  E.g.
-               --      foo = 1
-               --      bar = [d| foo = 1|]
-               -- So we drop down to plusOccEnv.  (Perhaps there should be a fn in RdrName.)
-               --      
+               -- 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
@@ -909,7 +926,7 @@ mkAssertErrorExpr
   = getSrcSpanM                        `thenM` \ sloc ->
     let
        expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
-       msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
+       msg  = HsStringPrim (mkFastString (showSDoc (ppr sloc)))
     in
     returnM (expr, emptyFVs)
 \end{code}
@@ -921,9 +938,9 @@ mkAssertErrorExpr
 %************************************************************************
 
 \begin{code}
-patSynErr e 
-  = sep [ptext SLIT("Pattern syntax in expression context:"),
-        nest 4 (ppr e)]
+patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"),
+                               nest 4 (ppr e)])
+                ; return (EWildPat, emptyFVs) }
 
 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))