Make HsRecordBinds a data type instead of a synonym.

parent bea2ece0
......@@ -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 (,)
......
......@@ -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
......
......@@ -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 }
......
......@@ -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') }
......
......@@ -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
......
......@@ -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] }
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
......@@ -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 ->
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment