[project @ 2002-10-15 13:18:51 by simonmar]

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

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 66ec772..36bd94b 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -28,6 +28,7 @@ import RdrHsSyn
 import RnHsSyn
 import TcRnMonad
 import RnEnv
+import RnNames         ( importsFromLocalDecls )
 import RnTypes         ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
                          dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
 import CmdLineOpts     ( DynFlag(..), opt_IgnoreAsserts )
@@ -41,8 +42,10 @@ import PrelNames     ( hasKey, assertIdKey,
                          replicatePName, mapPName, filterPName,
                          crossPName, zipPName, toPName,
                          enumFromToPName, enumFromThenToPName, assertErrorName,
-                         negateName, qTyConName, monadNames, mfixName )
-import RdrName         ( RdrName )
+                         negateName, monadNames, mfixName )
+#ifdef GHCI
+import DsMeta          ( qTyConName )
+#endif
 import Name            ( Name, nameOccName )
 import NameSet
 import UnicodeUtil     ( stringToUtf8 )
@@ -224,19 +227,29 @@ rnExpr (HsPar e)
     returnM (HsPar e', fvs_e)
 
 -- Template Haskell extensions
-rnExpr (HsBracket br_body)
-  = checkGHCI (thErr "bracket")                `thenM_`
+#ifdef GHCI
+rnExpr (HsBracket br_body loc)
+  = addSrcLoc loc                      $
+    checkGHCI (thErr "bracket")                `thenM_`
     rnBracket br_body                  `thenM` \ (body', fvs_e) ->
-    returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
+    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)
-  = checkGHCI (thErr "splice")         `thenM_`
-    getSrcLocM                         `thenM` \ loc -> 
+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', fvs_e)    
+    returnM (HsSplice n' e' loc, fvs_e)    
+
+rnExpr (HsReify (Reify flavour name))
+  = checkGHCI (thErr "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
 
 rnExpr section@(SectionL expr op)
   = rnExpr expr                                        `thenM` \ (expr', fvs_expr) ->
@@ -286,7 +299,7 @@ rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
        -- Check the statement list ends in an expression
     case last stmts' of {
        ResultStmt _ _ -> returnM () ;
-       _              -> addErr (doStmtListErr (binder_name do_or_lc)  e)
+       _              -> addErr (doStmtListErr do_or_lc e)
     }                                  `thenM_`
 
        -- Generate the rebindable syntax for the monad
@@ -305,9 +318,6 @@ rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
     syntax_names MDoExpr = monadNames ++ [mfixName]
     syntax_names other   = []
 
-    binder_name MDoExpr  = "mdo"
-    binder_name other    = "do"
-
 rnExpr (ExplicitList _ exps)
   = rnExprs exps                       `thenM` \ (exps', fvs) ->
     returnM  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
@@ -461,10 +471,16 @@ rnBracket (TypBr t) = rnHsTypeFVs doc t   `thenM` \ (t', fvs) ->
                      returnM (TypBr t', fvs)
                    where
                      doc = ptext SLIT("In a Template-Haskell quoted type")
-rnBracket (DecBr ds) = rnSrcDecls ds   `thenM` \ (tcg_env, ds', fvs) ->
-                       -- Discard the tcg_env; it contains the extended global RdrEnv
-                       -- because there is no scope that these decls cover (yet!)
-                      returnM (DecBr ds', fvs)
+rnBracket (DecBr group) 
+  = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
+       -- Discard avails (not useful here)
+
+    updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
+
+    rnSrcDecls group   `thenM` \ (tcg_env, group', fvs) ->
+       -- Discard the tcg_env; it contains only extra info about fixity
+
+    returnM (DecBr group', fvs)
 \end{code}
 
 %************************************************************************
@@ -716,7 +732,7 @@ segsToStmts ((defs, uses, fwds, ss) : segs)
   where
     (later_stmts, later_uses) = segsToStmts segs
     new_stmt | non_rec  = head ss
-            | otherwise = RecStmt rec_names ss
+            | otherwise = RecStmt rec_names ss []
             where
               non_rec   = isSingleton ss && isEmptyNameSet fwds
               rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
@@ -906,9 +922,13 @@ patSynErr e
   = sep [ptext SLIT("Pattern syntax in expression context:"),
         nest 4 (ppr e)]
 
-doStmtListErr name e
-  = sep [quotes (text name) <+> ptext SLIT("statements must end in expression:"),
+doStmtListErr do_or_lc e
+  = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
         nest 4 (ppr e)]
+  where
+    binder_name = case do_or_lc of
+                       MDoExpr -> "mdo"
+                       other   -> "do"
 
 thErr what
   = ptext SLIT("Template Haskell") <+> text what <+>