Make HsRecordBinds a data type instead of a synonym.

compiler/deSugar/Coverage.lhs

@@ -410,7 +410,7 @@ addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
 addTickDictBinds x = addTickLHsBinds x
 
 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
-addTickHsRecordBinds pairs = mapM process pairs
+addTickHsRecordBinds (HsRecordBinds pairs) = liftM HsRecordBinds (mapM process pairs)
     where
 	process (ids,expr) = 
 		liftM2 (,) 

compiler/deSugar/DsExpr.lhs

@@ -429,7 +429,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 rbinds)
+dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds))
   = dsExpr con_expr	`thenDs` \ con_expr' ->
     let
 	(arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -477,10 +477,10 @@ might do some argument-evaluation first; and may have to throw away some
 dictionaries.
 
 \begin{code}
-dsExpr (RecordUpd record_expr [] record_in_ty record_out_ty)
+dsExpr (RecordUpd record_expr (HsRecordBinds []) record_in_ty record_out_ty)
   = dsLExpr record_expr
 
-dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
+dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) record_in_ty record_out_ty)
   = dsLExpr record_expr	 	`thenDs` \ record_expr' ->
 
 	-- Desugar the rbinds, and generate let-bindings if

compiler/deSugar/DsMeta.hs

@@ -530,11 +530,11 @@ repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e)
 repE e@(ExplicitTuple es boxed) 
   | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
   | otherwise		  = notHandled "Unboxed tuples" (ppr e)
-repE (RecordCon c _ flds)
+repE (RecordCon c _ (HsRecordBinds flds))
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
         repRecCon x fs }
-repE (RecordUpd e flds _ _)
+repE (RecordUpd e (HsRecordBinds flds) _ _)
  = do { x <- repLE e;
         fs <- repFields flds;
         repRecUpd x fs }

compiler/hsSyn/Convert.lhs

@@ -364,10 +364,10 @@ cvtl e = wrapL (cvt e)
 			      ; return $ ExprWithTySig e' t' }
     cvt (RecConE c flds) = do { c' <- cNameL c
 			      ; flds' <- mapM cvtFld flds
-			      ; return $ RecordCon c' noPostTcExpr flds' }
+			      ; return $ RecordCon c' noPostTcExpr (HsRecordBinds flds') }
     cvt (RecUpdE e flds) = do { e' <- cvtl e
 			      ; flds' <- mapM cvtFld flds
-			      ; return $ RecordUpd e' flds' placeHolderType placeHolderType }
+			      ; return $ RecordUpd e' (HsRecordBinds flds') placeHolderType placeHolderType }
 
 cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') }
 

compiler/hsSyn/HsExpr.lhs

@@ -554,13 +554,13 @@ data HsCmdTop id
 %************************************************************************
 
 \begin{code}
-type HsRecordBinds id = [(Located id, LHsExpr id)]
+data HsRecordBinds id = HsRecordBinds [(Located id, LHsExpr id)]
 
 recBindFields :: HsRecordBinds id -> [id]
-recBindFields rbinds = [unLoc field | (field,_) <- rbinds]
+recBindFields (HsRecordBinds rbinds) = [unLoc field | (field,_) <- rbinds]
 
 pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
-pp_rbinds thing rbinds
+pp_rbinds thing (HsRecordBinds rbinds)
   = hang thing 
 	 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds))))
   where

compiler/parser/Parser.y.pp

@@ -1309,7 +1309,7 @@ aexp	:: { LHsExpr RdrName }
 
 aexp1	:: { LHsExpr RdrName }
         : aexp1 '{' fbinds '}' 	{% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) 
-							(reverse $3);
+							$3;
 				        return (LL r) }}
   	| aexp2			{ $1 }
 
@@ -1535,10 +1535,10 @@ qual  :: { LStmt RdrName }
 -- Record Field Update/Construction
 
 fbinds 	:: { HsRecordBinds RdrName }
-	: fbinds1			{ $1 }
-  	| {- empty -}			{ [] }
+	: fbinds1			{ HsRecordBinds (reverse $1) }
+  	| {- empty -}			{ HsRecordBinds [] }
 
-fbinds1	:: { HsRecordBinds RdrName }
+fbinds1	:: { [(Located id, LHsExpr id)] }
 	: fbinds1 ',' fbind		{ $3 : $1 }
 	| fbind				{ [$1] }
   

compiler/parser/RdrHsSyn.lhs

@@ -704,8 +704,8 @@ checkAPat loc e = case e of
    ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
    			 return (TuplePat ps b placeHolderType)
    
-   RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
-			 return (ConPatIn c (RecCon (map (uncurry mkRecField) fs))) 
+   RecordCon c _ (HsRecordBinds fs)   -> mapM checkPatField fs >>= \fs ->
+			 return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
 -- Generics 
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
@@ -872,9 +872,9 @@ mkRecConstrOrUpdate
 
 mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
   = return (RecordCon (L l c) noPostTcExpr fs)
-mkRecConstrOrUpdate exp loc fs@(_:_)
+mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
   = return (RecordUpd exp fs placeHolderType placeHolderType)
-mkRecConstrOrUpdate _ loc []
+mkRecConstrOrUpdate _ loc (HsRecordBinds [])
   = parseError loc "Empty record update"
 
 mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec

compiler/rename/RnExpr.lhs

@@ -228,16 +228,16 @@ rnExpr e@(ExplicitTuple exps boxity)
     tup_size   = length exps
     tycon_name = tupleTyCon_name boxity tup_size
 
-rnExpr (RecordCon con_id _ rbinds)
+rnExpr (RecordCon con_id _ (HsRecordBinds rbinds))
   = lookupLocatedOccRn con_id		`thenM` \ conname ->
     rnRbinds "construction" rbinds	`thenM` \ (rbinds', fvRbinds) ->
-    returnM (RecordCon conname noPostTcExpr rbinds', 
+    returnM (RecordCon conname noPostTcExpr (HsRecordBinds rbinds'), 
 	     fvRbinds `addOneFV` unLoc conname)
 
-rnExpr (RecordUpd expr rbinds _ _)
+rnExpr (RecordUpd expr (HsRecordBinds rbinds) _ _)
   = rnLExpr expr		`thenM` \ (expr', fvExpr) ->
     rnRbinds "update" rbinds	`thenM` \ (rbinds', fvRbinds) ->
-    returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType, 
+    returnM (RecordUpd expr' (HsRecordBinds rbinds') placeHolderType placeHolderType, 
 	     fvExpr `plusFV` fvRbinds)
 
 rnExpr (ExprWithTySig expr pty)

compiler/typecheck/TcExpr.lhs

@@ -382,7 +382,7 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
 -- don't know how to do the update otherwise.
 
 
-tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
+tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _) res_ty
   = 	-- STEP 0
 	-- Check that the field names are really field names
     ASSERT( notNull rbinds )
@@ -404,7 +404,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 	-- Figure out the tycon and data cons from the first field name
     let
 		-- It's OK to use the non-tc splitters here (for a selector)
-	upd_field_lbls  = recBindFields rbinds
+	upd_field_lbls  = recBindFields hrbinds
 	sel_id : _   	= sel_ids
 	(tycon, _)   	= recordSelectorFieldLabel sel_id	-- We've failed already if
 	data_cons    	= tyConDataCons tycon		-- it's not a field label
@@ -416,7 +416,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 	-- Check that at least one constructor has all the named fields
 	-- i.e. has an empty set of bad fields returned by badFields
     checkTc (not (null relevant_cons))
-	    (badFieldsUpd rbinds)	`thenM_`
+	    (badFieldsUpd hrbinds)	`thenM_`
 
 	-- Check that all relevant data cons are vanilla.  Doing record updates on 
 	-- GADTs and/or existentials is more than my tiny brain can cope with today
@@ -457,7 +457,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 	con1_arg_tys'    = map (substTy inst_env) con1_arg_tys
     in
     tcSubExp result_record_ty res_ty		`thenM` \ co_fn ->
-    tcRecordBinds con1 con1_arg_tys' rbinds	`thenM` \ rbinds' ->
+    tcRecordBinds con1 con1_arg_tys' hrbinds	`thenM` \ rbinds' ->
 
 	-- STEP 5
 	-- Typecheck the expression to be updated
@@ -1049,9 +1049,9 @@ tcRecordBinds
 	-> HsRecordBinds Name
 	-> TcM (HsRecordBinds TcId)
 
-tcRecordBinds data_con arg_tys rbinds
+tcRecordBinds data_con arg_tys (HsRecordBinds rbinds)
   = do	{ mb_binds <- mappM do_bind rbinds
-	; return (catMaybes mb_binds) }
+	; return (HsRecordBinds (catMaybes mb_binds)) }
   where
     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
     do_bind (L loc field_lbl, rhs)

compiler/typecheck/TcHsSyn.lhs

@@ -647,8 +647,8 @@ zonkStmt env (BindStmt pat expr bind_op fail_op)
 -------------------------------------------------------------------------
 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
 
-zonkRbinds env rbinds
-  = mappM zonk_rbind rbinds
+zonkRbinds env (HsRecordBinds rbinds)
+  = mappM zonk_rbind rbinds >>= return . HsRecordBinds
   where
     zonk_rbind (field, expr)
       = zonkLExpr env expr	`thenM` \ new_expr ->