X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=f9219ba94b8055e0cb856bf9ce2dd051e62f1ea1;hp=dd433ec08c3627af65f60730de10e3028e7ad72c;hb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;hpb=74b27e20425336403d80e942ee3faf00f8c36ef8

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index dd433ec..f9219ba 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -19,6 +19,7 @@ import DsListComp
 import DsUtils
 import DsArrows
 import DsMonad
+import Name
 
 #ifdef GHCI
 import PrelNames
@@ -407,7 +408,7 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
 constructor @C@, setting all of @C@'s fields to bottom.
 
 \begin{code}
-dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds))
+dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
   = dsExpr con_expr	`thenDs` \ con_expr' ->
     let
 	(arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -415,7 +416,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds))
 	-- hence TcType.tcSplitFunTys
 
 	mk_arg (arg_ty, lbl)	-- Selector id has the field label as its name
-	  = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
+	  = case findField (rec_flds rbinds) lbl of
 	      (rhs:rhss) -> ASSERT( null rhss )
 		 	    dsLExpr rhs
 	      []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
@@ -455,10 +456,11 @@ might do some argument-evaluation first; and may have to throw away some
 dictionaries.
 
 \begin{code}
-dsExpr (RecordUpd record_expr (HsRecordBinds []) _ _ _)
+dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
+		       cons_to_upd in_inst_tys out_inst_tys)
+  | null fields
   = dsLExpr record_expr
-
-dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) cons_to_upd in_inst_tys out_inst_tys)
+  | otherwise
   =	-- Record stuff doesn't work for existentials
 	-- The type checker checks for this, but we need 
 	-- worry only about the constructors that are to be updated
@@ -473,7 +475,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) cons_to_upd in_inst_ty
 				    (mkFamilyTyConApp tycon out_inst_tys)
 
 		mk_val_arg field old_arg_id 
-		  = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
+		  = case findField fields field  of
 		      (rhs:rest) -> ASSERT(null rest) rhs
 		      []	 -> nlHsVar old_arg_id
 
@@ -543,6 +545,11 @@ dsExpr (HsBinTick ixT ixF e) = do
 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 #endif
 
+
+findField :: [HsRecField Id arg] -> Name -> [arg]
+findField rbinds lbl 
+  = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds 
+	 , lbl == idName (unLoc id) ]
 \end{code}
 
 %--------------------------------------------------------------------