Three improvements to Template Haskell (fixes #3467)

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

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 32d4c4c..4b263e2 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -41,15 +41,13 @@ import NameSet
 import RdrName
 import LoadIface       ( loadInterfaceForName )
 import UniqSet
-import List            ( nub )
+import Data.List
 import Util            ( isSingleton )
 import ListSetOps      ( removeDups )
 import Maybes          ( expectJust )
 import Outputable
 import SrcLoc
 import FastString
-
-import List            ( unzip4 )
 import Control.Monad
 \end{code}
 
@@ -240,20 +238,24 @@ rnExpr (ExplicitPArr _ exps)
   = rnExprs exps                       `thenM` \ (exps', fvs) ->
     return  (ExplicitPArr placeHolderType exps', fvs)
 
-rnExpr (ExplicitTuple exps boxity)
-  = checkTupSize (length exps)                 `thenM_`
-    rnExprs exps                               `thenM` \ (exps', fvs) ->
-    return (ExplicitTuple exps' boxity, fvs)
+rnExpr (ExplicitTuple tup_args boxity)
+  = do { checkTupleSection tup_args
+       ; checkTupSize (length tup_args)
+       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
+       ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
+  where
+    rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
+    rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
 
 rnExpr (RecordCon con_id _ rbinds)
   = do { conname <- lookupLocatedOccRn con_id
-       ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
+       ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
        ; return (RecordCon conname noPostTcExpr rbinds', 
                  fvRbinds `addOneFV` unLoc conname) }
 
 rnExpr (RecordUpd expr rbinds _ _ _)
   = do { (expr', fvExpr) <- rnLExpr expr
-       ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
+       ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
        ; return (RecordUpd expr' rbinds' [] [] [], 
                  fvExpr `plusFV` fvRbinds) }
 
@@ -306,7 +308,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e
 \begin{code}
 rnExpr (HsProc pat body)
   = newArrowScope $
-    rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
+    rnPats ProcExpr [pat] $ \ [pat'] ->
     rnCmdTop body               `thenM` \ (body',fvBody) ->
     return (HsProc pat' body', fvBody)
 
@@ -363,6 +365,26 @@ rnSection other = pprPanic "rnSection" (ppr other)
 
 %************************************************************************
 %*                                                                     *
+       Records
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
+             -> RnM (HsRecordBinds Name, FreeVars)
+rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
+  = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
+       ; (flds', fvss) <- mapAndUnzipM rn_field flds
+       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, 
+                 fvs `plusFV` plusFVs fvss) }
+  where 
+    rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+                      ; return (fld { hsRecFieldArg = arg' }, fvs) }
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
        Arrow commands
 %*                                                                     *
 %************************************************************************
@@ -568,8 +590,8 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
 rnBracket (VarBr n) = do { name <- lookupOccRn n
                         ; this_mod <- getModule
-                        ; checkM (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
-                          do { loadInterfaceForName msg name           -- home interface is loaded, and this is the
+                        ; unless (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
+                          do { _ <- loadInterfaceForName msg name      -- home interface is loaded, and this is the
                              ; return () }                             -- only way that is going to happen
                         ; return (VarBr name, unitFV name) }
                    where
@@ -643,7 +665,7 @@ rnStmt ctxt (BindStmt pat expr _ _) thing_inside
                -- The binders do not scope over the expression
        ; (bind_op, fvs1) <- lookupSyntaxName bindMName
        ; (fail_op, fvs2) <- lookupSyntaxName failMName
-       ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
+       ; rnPats (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
        { (thing, fvs3) <- thing_inside
        ; return ((BindStmt pat' expr' bind_op fail_op, thing),
                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
@@ -792,9 +814,9 @@ rnParallelStmts ctxt segs thing_inside = do
     where
         go orig_lcl_env bndrs [] = do 
             let (bndrs', dups) = removeDups cmpByOcc bndrs
-                inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
+                inner_env = extendLocalRdrEnvList orig_lcl_env bndrs'
             
-            mapM dupErr dups
+            mapM_ dupErr dups
             (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
             return (([], thing), fvs)
 
@@ -1194,7 +1216,15 @@ checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt    -- Ok to n
 checkTransformStmt ctxt = addErr msg
   where
     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
-    
+
+---------
+checkTupleSection :: [HsTupArg RdrName] -> RnM ()
+checkTupleSection args
+  = do { tuple_section <- doptM Opt_TupleSections
+       ; checkErr (all tupArgPresent args || tuple_section) msg }
+  where
+    msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
+
 ---------
 sectionErr :: HsExpr RdrName -> SDoc
 sectionErr expr