Make HsRecordBinds a data type instead of a synonym.

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 2d967d2..603d721 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/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 (,) 

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 23db23f..eb93353 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/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

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index b41873f..3c526ec 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/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 }

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 76e51df..4ed7364 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/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') }
 

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 0b6095e..d4cb80e 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/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

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index ffc1f44..5ff8ca8 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/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] }
   

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ddff68f..c29f23a 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/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

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 17c7f97..bfd644f 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/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)

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 2100bba..4151e0d 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/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)

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 615a7a0..c6d428b 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/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 ->