From 102b73a3f2a2f63d3835726be625dca8053dd88c Mon Sep 17 00:00:00 2001 From: "lennart@augustsson.net" Date: Sun, 4 Feb 2007 01:59:05 +0000 Subject: [PATCH 1/1] Make HsRecordBinds a data type instead of a synonym. --- compiler/deSugar/Coverage.lhs | 2 +- compiler/deSugar/DsExpr.lhs | 6 +++--- compiler/deSugar/DsMeta.hs | 4 ++-- compiler/hsSyn/Convert.lhs | 4 ++-- compiler/hsSyn/HsExpr.lhs | 6 +++--- compiler/parser/Parser.y.pp | 8 ++++---- compiler/parser/RdrHsSyn.lhs | 8 ++++---- compiler/rename/RnExpr.lhs | 8 ++++---- compiler/typecheck/TcExpr.lhs | 12 ++++++------ compiler/typecheck/TcHsSyn.lhs | 4 ++-- 10 files changed, 31 insertions(+), 31 deletions(-) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 2d967d2..603d721 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 -> -- 1.7.10.4