[project @ 2003-03-27 08:16:29 by simonpj]

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

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index b1481e3..5e18d67 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -43,9 +43,6 @@ import PrelNames      ( hasKey, assertIdKey,
                          crossPName, zipPName, toPName,
                          enumFromToPName, enumFromThenToPName, assertErrorName,
                          negateName, monadNames, mfixName )
-#ifdef GHCI
-import DsMeta          ( qTyConName )
-#endif
 import Name            ( Name, nameOccName )
 import NameSet
 import UnicodeUtil     ( stringToUtf8 )
@@ -72,7 +69,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
   = addSrcLoc (getMatchLoc match)      $
 
        -- Deal with the rhs type signature
-    bindPatSigTyVars rhs_sig_tys       $ 
+    bindPatSigTyVarsFV rhs_sig_tys     $ 
     doptM Opt_GlasgowExts              `thenM` \ opt_GlasgowExts ->
     (case maybe_rhs_sig of
        Nothing -> returnM (Nothing, emptyFVs)
@@ -87,7 +84,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
     rnGRHSs ctxt grhss         `thenM` \ (grhss', grhss_fvs) ->
 
     returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
-       -- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs
+       -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
   where
      rhs_sig_tys =  case maybe_rhs_sig of
                        Nothing -> []
@@ -227,30 +224,26 @@ rnExpr (HsPar e)
     returnM (HsPar e', fvs_e)
 
 -- Template Haskell extensions
-#ifdef GHCI
-rnExpr (HsBracket br_body loc)
-  = addSrcLoc loc                      $
-    checkGHCI (thErr "bracket")                `thenM_`
-    rnBracket br_body                  `thenM` \ (body', fvs_e) ->
-    returnM (HsBracket body' loc, fvs_e `addOneFV` qTyConName)
-       -- We use the Q tycon as a proxy to haul in all the smart
-       -- constructors; see the hack in RnIfaces
-
-rnExpr (HsSplice n e loc)
-  = addSrcLoc loc                      $
-    checkGHCI (thErr "splice")         `thenM_`
-    newLocalsRn [(n,loc)]              `thenM` \ [n'] ->
-    rnExpr e                           `thenM` \ (e', fvs_e) ->
-    returnM (HsSplice n' e' loc, fvs_e `addOneFV` qTyConName)
-       -- The qTyCon brutally pulls in all the meta stuff
-
-rnExpr (HsReify (Reify flavour name))
-  = checkGHCI (thErr "reify")          `thenM_`
-    lookupGlobalOccRn name             `thenM` \ name' ->
+-- Don't ifdef-GHCI them because we want to fail gracefully
+-- (not with an rnExpr crash) in a stage-1 compiler.
+rnExpr e@(HsBracket br_body loc)
+  = addSrcLoc loc              $
+    checkTH e "bracket"                `thenM_`
+    rnBracket br_body          `thenM` \ (body', fvs_e) ->
+    returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
+
+rnExpr e@(HsSplice n splice loc)
+  = addSrcLoc loc              $
+    checkTH e "splice"         `thenM_`
+    newLocalsRn [(n,loc)]      `thenM` \ [n'] ->
+    rnExpr splice              `thenM` \ (splice', fvs_e) ->
+    returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
+
+rnExpr e@(HsReify (Reify flavour name))
+  = checkTH e "reify"          `thenM_`
+    lookupGlobalOccRn name     `thenM` \ name' ->
        -- For now, we can only reify top-level things
-    returnM (HsReify (Reify flavour name'), mkFVs [name', qTyConName])
-       -- The qTyCon brutally pulls in all the meta stuff
-#endif
+    returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
 
 rnExpr section@(SectionL expr op)
   = rnExpr expr                                        `thenM` \ (expr', fvs_expr) ->
@@ -272,6 +265,10 @@ rnExpr (HsCCall fun args may_gc is_casm _)
                                       cReturnableClassName, 
                                       ioDataConName])
 
+rnExpr (HsCoreAnn ann expr)
+  = rnExpr expr `thenM` \ (expr', fvs_expr) ->
+    returnM (HsCoreAnn ann expr', fvs_expr)
+
 rnExpr (HsSCC lbl expr)
   = rnExpr expr                `thenM` \ (expr', fvs_expr) ->
     returnM (HsSCC lbl expr', fvs_expr)
@@ -458,10 +455,10 @@ rnBracket (DecBr group)
 
     updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
 
-    rnSrcDecls group   `thenM` \ (tcg_env, group', fvs) ->
+    rnSrcDecls group   `thenM` \ (tcg_env, group', dus) ->
        -- Discard the tcg_env; it contains only extra info about fixity
 
-    returnM (DecBr group', fvs)
+    returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
 \end{code}
 
 %************************************************************************
@@ -518,7 +515,9 @@ rnNormalStmts ctxt (LetStmt binds : stmts)
     ok _              _             = True
 
 rnNormalStmts ctxt (ParStmt stmtss : stmts)
-  = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss  `thenM` \ (stmtss', fv_stmtss) ->
+  = doptM Opt_GlasgowExts              `thenM` \ opt_GlasgowExts ->
+    checkM opt_GlasgowExts parStmtErr  `thenM_`
+    mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss  `thenM` \ (stmtss', fv_stmtss) ->
     let
        bndrss = map collectStmtsBinders stmtss'
     in
@@ -552,8 +551,6 @@ rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
 %************************************************************************
 
 \begin{code}
-type Defs    = NameSet
-type Uses    = NameSet -- Same as FreeVars really
 type FwdRefs = NameSet
 type Segment = (Defs,
                Uses,           -- May include defs
@@ -623,9 +620,9 @@ rn_mdo_stmt (BindStmt pat expr src_loc)
             [BindStmt pat' expr' src_loc])
 
 rn_mdo_stmt (LetStmt binds)
-  = rnBinds binds              `thenM` \ (binds', fv_binds) ->
-    returnM (mkNameSet (collectHsBinders binds'), 
-            fv_binds, emptyNameSet, [LetStmt binds'])
+  = rnBinds binds              `thenM` \ (binds', du_binds) ->
+    returnM (duDefs du_binds, duUses du_binds, 
+            emptyNameSet, [LetStmt binds'])
 
 rn_mdo_stmt stmt@(ParStmt _)   -- Syntactically illegal in mdo
   = pprPanic "rn_mdo_stmt" (ppr stmt)
@@ -917,9 +914,16 @@ doStmtListErr do_or_lc e
                        MDoExpr -> "mdo"
                        other   -> "do"
 
-thErr what
-  = ptext SLIT("Template Haskell") <+> text what <+>  
-    ptext SLIT("illegal in a stage-1 compiler") 
+#ifdef GHCI 
+checkTH e what = returnM ()    -- OK
+#else
+checkTH e what         -- Raise an error in a stage-1 compiler
+  = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>  
+                 ptext SLIT("illegal in a stage-1 compiler"),
+                 nest 2 (ppr e)])
+#endif   
+
+parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts"))
 
 badIpBinds binds
   = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4