X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=34a3a202bcff2336507eb5311a07135b1b98e022;hp=dd433ec08c3627af65f60730de10e3028e7ad72c;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hpb=ff8e1d01524b48e028b09e2b04b2e5303cb6d95f

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index dd433ec..34a3a20 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
@@ -103,8 +104,9 @@ ds_val_bind (NonRecursive, hsbinds) body
 	--	 below.  Then pattern-match would fail.  Urk.)
     putSrcSpanDs loc	$
     case bind of
-      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick }
-	-> matchWrapper (FunRhs (idName fun)) matches 	 	`thenDs` \ (args, rhs) ->
+      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, 
+		fun_tick = tick, fun_infix = inf }
+	-> matchWrapper (FunRhs (idName fun ) inf) matches 	`thenDs` \ (args, rhs) ->
 	   ASSERT( null args )	-- Functions aren't lifted
 	   ASSERT( isIdHsWrapper co_fn )
            mkOptTickBox tick rhs 				`thenDs` \ rhs' ->
@@ -407,7 +409,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 +417,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 +457,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 +476,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 +546,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}
 
 %--------------------------------------------------------------------