X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=4b263e2a54bfb0e0697cdd5a93f32deb9c29621a;hb=1e436f2bb208a6c990743afaf17b7c2a93c31742;hp=32d4c4c379761918dcf32fc229db412ad5a0861b;hpb=389cca214f33a29646e08d57e3dca862140007b2;p=ghc-hetmet.git

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 32d4c4c..4b263e2 100644
--- 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