From 5ecdbf3221d632a7e69f594fc4163e9465f22e85 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Fri, 3 Nov 2023 10:35:28 +0800 Subject: [PATCH 1/4] Add type constraint to binding_op --- lib/Ast.ml | 20 ++++++++--- lib/Ast.mli | 1 + lib/Fmt_ast.ml | 2 +- lib/Sugar.ml | 53 +++++----------------------- lib/Sugar.mli | 2 +- vendor/parser-extended/ast_helper.ml | 3 +- vendor/parser-extended/ast_mapper.ml | 29 ++++++++------- vendor/parser-extended/parser.mly | 25 +++++++------ vendor/parser-extended/parsetree.mli | 1 + vendor/parser-extended/printast.ml | 2 ++ 10 files changed, 58 insertions(+), 80 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index d4f3dfdf5b..7871ce2f70 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -641,6 +641,7 @@ module T = struct | Fp of function_param | Vc of value_constraint | Lb of value_binding + | Bo of binding_op | Mb of module_binding | Md of module_declaration | Cl of class_expr @@ -663,6 +664,7 @@ module T = struct | Fp p -> Format.fprintf fs "Fp:@\n%a" Printast.function_param p | Vc c -> Format.fprintf fs "Vc:@\n%a" Printast.value_constraint c | Lb b -> Format.fprintf fs "Lb:@\n%a" Printast.value_binding b + | Bo b -> Format.fprintf fs "Bo:@\n%a" Printast.binding_op b | Mb m -> Format.fprintf fs "Mb:@\n%a" Printast.module_binding m | Md m -> Format.fprintf fs "Md:@\n%a" Printast.module_declaration m | Cl cl -> Format.fprintf fs "Cl:@\n%a" Printast.class_expr cl @@ -697,6 +699,7 @@ let attributes = function | Fp _ -> [] | Vc _ -> [] | Lb x -> x.pvb_attributes + | Bo _ -> [] | Mb x -> attrs_of_ext_attrs x.pmb_ext_attrs | Md x -> attrs_of_ext_attrs x.pmd_ext_attrs | Cl x -> x.pcl_attributes @@ -720,6 +723,7 @@ let location = function | Fp x -> x.pparam_loc | Vc _ -> Location.none | Lb x -> x.pvb_loc + | Bo x -> x.pbop_loc | Mb x -> x.pmb_loc | Md x -> x.pmd_loc | Cl x -> x.pcl_loc @@ -999,6 +1003,7 @@ end = struct | Fp _ -> assert false | Vc c -> assert (check_value_constraint c) | Lb _ -> assert false + | Bo ctx -> assert (Option.exists ctx.pbop_typ ~f:check_value_constraint) | Mb _ -> assert false | Md _ -> assert false | Cl {pcl_desc; _} -> @@ -1108,6 +1113,7 @@ end = struct | Fp _ -> assert false | Vc _ -> assert false | Lb _ -> assert false + | Bo _ -> assert false | Mb _ -> assert false | Md _ -> assert false | Pld _ -> assert false @@ -1177,6 +1183,7 @@ end = struct | Fp _ -> assert false | Vc _ -> assert false | Lb _ -> assert false + | Bo _ -> assert false | Mb _ -> assert false | Md _ -> assert false | Pld _ -> assert false @@ -1303,6 +1310,7 @@ end = struct | Fp ctx -> assert (check_function_param ctx) | Vc _ -> assert false | Lb x -> assert (x.pvb_pat == pat) + | Bo x -> assert (x.pbop_pat == pat) | Mb _ -> assert false | Md _ -> assert false | Cl ctx -> @@ -1434,6 +1442,7 @@ end = struct | Fp ctx -> assert (check_function_param ctx) | Vc _ -> assert false | Lb x -> assert (x.pvb_expr == exp) + | Bo x -> assert (x.pbop_exp == exp) | Mb _ -> assert false | Md _ -> assert false | Str str -> ( @@ -1689,6 +1698,8 @@ end = struct |{ctx= _; ast= Vc _} |{ctx= Lb _; ast= _} |{ctx= _; ast= Lb _} + |{ctx= Bo _; ast= _} + |{ctx= _; ast= Bo _} |{ctx= Td _; ast= _} |{ctx= _; ast= Td _} |{ ctx= Cl _ @@ -1773,6 +1784,7 @@ end = struct | Fp _ -> None | Vc _ -> None | Lb _ -> None + | Bo _ -> None | Cl c -> ( match c.pcl_desc with | Pcl_apply _ -> Some Apply @@ -1893,14 +1905,14 @@ end = struct | Fp {pparam_desc= Pparam_val (_, _, _); _}, Ppat_cons _ -> true | Pat {ppat_desc= Ppat_construct _; _}, Ppat_cons _ -> true | _, Ppat_constraint (_, {ptyp_desc= Ptyp_poly _; _}) -> false - | ( Exp {pexp_desc= Pexp_letop _; _} + | ( (Exp {pexp_desc= Pexp_letop _; _} | Bo {pbop_typ= Some _; _}) , ( Ppat_construct (_, Some _) | Ppat_cons _ | Ppat_variant (_, Some _) - | Ppat_or _ | Ppat_alias _ + | Ppat_or _ | Ppat_alias _ | Ppat_tuple _ | Ppat_constraint ({ppat_desc= Ppat_any; _}, _) ) ) -> true - | ( Exp {pexp_desc= Pexp_letop _; _} + | ( (Exp {pexp_desc= Pexp_letop _; _} | Bo {pbop_typ= Some _; _}) , Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _) ) -> false | _, Ppat_constraint _ @@ -1938,7 +1950,7 @@ end = struct |Cl {pcl_desc= Pcl_fun _; _}, Ppat_construct _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_alias _ |Cl {pcl_desc= Pcl_fun _; _}, Ppat_lazy _ - |Exp {pexp_desc= Pexp_letop _; _}, Ppat_exception _ + |(Exp {pexp_desc= Pexp_letop _; _} | Bo _), Ppat_exception _ |( Exp {pexp_desc= Pexp_fun _; _} , ( Ppat_construct _ | Ppat_cons _ | Ppat_lazy _ | Ppat_tuple _ | Ppat_variant _ ) ) -> diff --git a/lib/Ast.mli b/lib/Ast.mli index 108907acf8..d2f87f4cd2 100644 --- a/lib/Ast.mli +++ b/lib/Ast.mli @@ -113,6 +113,7 @@ type t = | Fp of function_param | Vc of value_constraint | Lb of value_binding + | Bo of binding_op | Mb of module_binding | Md of module_declaration | Cl of class_expr diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 9e84300e59..7102aeaf2b 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2305,7 +2305,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt_let_bindings c ?ext ~parens ~fmt_atrs ~fmt_expr ~has_attr lbs.pvbs_rec bindings body | Pexp_letop {let_; ands; body} -> - let bd = Sugar.Let_binding.of_binding_ops c.cmts ~ctx (let_ :: ands) in + let bd = Sugar.Let_binding.of_binding_ops c.cmts (let_ :: ands) in let fmt_expr = fmt_expression c (sub_exp ~ctx body) in pro $ fmt_let_bindings c ?ext ~parens ~fmt_atrs ~fmt_expr ~has_attr diff --git a/lib/Sugar.ml b/lib/Sugar.ml index f96bbb3e61..b26fde03fa 100644 --- a/lib/Sugar.ml +++ b/lib/Sugar.ml @@ -236,43 +236,6 @@ module Let_binding = struct | Pexp_constraint _, Ppat_constraint _ -> (xargs, None, xbody) | _ -> split_annot cmts xargs xbody - let type_cstr cmts ~ctx lb_pat lb_exp = - let ({ast= pat; _} as xpat) = - match (lb_pat.ppat_desc, lb_exp.pexp_desc) with - (* recognize and undo the pattern of code introduced by - ocaml/ocaml@fd0dc6a0fbf73323c37a73ea7e8ffc150059d6ff to fix - https://caml.inria.fr/mantis/view.php?id=7344 *) - | ( Ppat_constraint - ( ({ppat_desc= Ppat_var _; _} as pat) - , {ptyp_desc= Ptyp_poly ([], typ1); _} ) - , Pexp_constraint (_, typ2) ) - when equal_core_type typ1 typ2 -> - Cmts.relocate cmts ~src:lb_pat.ppat_loc ~before:pat.ppat_loc - ~after:pat.ppat_loc ; - sub_pat ~ctx:(Pat lb_pat) pat - | ( Ppat_constraint (_, {ptyp_desc= Ptyp_poly (_, typ1); _}) - , Pexp_coerce (_, _, typ2) ) - when equal_core_type typ1 typ2 -> - sub_pat ~ctx lb_pat - | _ -> sub_pat ~ctx lb_pat - in - let pat_is_extension {ppat_desc; _} = - match ppat_desc with Ppat_extension _ -> true | _ -> false - in - let xbody = sub_exp ~ctx lb_exp in - if - (not (List.is_empty xbody.ast.pexp_attributes)) || pat_is_extension pat - then (xpat, [], None, xbody) - else - let xpat = - match xpat.ast.ppat_desc with - | Ppat_constraint (p, {ptyp_desc= Ptyp_poly ([], _); _}) -> - sub_pat ~ctx:xpat.ctx p - | _ -> xpat - in - let xargs, typ, xbody = split_fun_args cmts xpat xbody in - (xpat, xargs, typ, xbody) - let should_desugar_args pat typ = match (pat.ast, typ) with | {ppat_desc= Ppat_var _; ppat_attributes= []; _}, None -> true @@ -301,16 +264,16 @@ module Let_binding = struct let of_let_bindings cmts ~ctx = List.mapi ~f:(fun i -> of_let_binding cmts ~ctx ~first:(i = 0)) - let of_binding_ops cmts ~ctx bos = + let of_binding_ops cmts bos = List.map bos ~f:(fun bo -> - let lb_pat, lb_args, lb_typ, lb_exp = - type_cstr cmts ~ctx bo.pbop_pat bo.pbop_exp - in + let ctx = Bo bo in + let xbody = sub_exp ~ctx bo.pbop_exp in + let xargs, xbody = fun_ cmts ~will_keep_first_ast_node:false xbody in { lb_op= bo.pbop_op - ; lb_pat - ; lb_args - ; lb_typ - ; lb_exp + ; lb_pat= sub_pat ~ctx bo.pbop_pat + ; lb_args= xargs + ; lb_typ= bo.pbop_typ + ; lb_exp= xbody ; lb_pun= bo.pbop_is_pun ; lb_attrs= [] ; lb_loc= bo.pbop_loc } ) diff --git a/lib/Sugar.mli b/lib/Sugar.mli index ae2cc1e180..ae224cb870 100644 --- a/lib/Sugar.mli +++ b/lib/Sugar.mli @@ -70,5 +70,5 @@ module Let_binding : sig val of_let_bindings : Cmts.t -> ctx:Ast.t -> value_binding list -> t list - val of_binding_ops : Cmts.t -> ctx:Ast.t -> binding_op list -> t list + val of_binding_ops : Cmts.t -> binding_op list -> t list end diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 5394625dd5..fb2e886383 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -175,10 +175,11 @@ module Exp = struct pc_rhs = rhs; } - let binding_op op pat exp pun loc = + let binding_op op pat typ exp pun loc = { pbop_op = op; pbop_pat = pat; + pbop_typ = typ; pbop_exp = exp; pbop_is_pun = pun; pbop_loc = loc; diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 20f4f9ce86..34585b05f0 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -104,6 +104,16 @@ let map_arg_label sub = function | Labelled x -> Labelled (map_loc sub x) | Optional x -> Optional (map_loc sub x) +let map_value_constraint sub = function + | Pvc_constraint {locally_abstract_univars=vars; typ} -> + let locally_abstract_univars = List.map (map_loc sub) vars in + let typ = sub.typ sub typ in + Pvc_constraint { locally_abstract_univars; typ } + | Pvc_coercion { ground; coercion } -> + let ground = Option.map (sub.typ sub) ground in + let coercion = sub.typ sub coercion in + Pvc_coercion { ground; coercion } + module Flag = struct open Asttypes @@ -605,13 +615,14 @@ module E = struct | Pexp_infix (op, e1, e2) -> infix ~loc ~attrs (map_loc sub op) (sub.expr sub e1) (sub.expr sub e2) - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_is_pun; pbop_loc} = + let map_binding_op sub {pbop_op; pbop_pat; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} = let open Exp in let op = map_loc sub pbop_op in let pat = sub.pat sub pbop_pat in + let typ = map_opt (map_value_constraint sub) pbop_typ in let exp = sub.expr sub pbop_exp in let loc = sub.location sub pbop_loc in - binding_op op pat exp pbop_is_pun loc + binding_op op pat typ exp pbop_is_pun loc end @@ -859,22 +870,10 @@ let default_mapper = value_binding = (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_is_pun; pvb_attributes; pvb_loc} -> - let map_ct (ct:Parsetree.value_constraint) = match ct with - | Pvc_constraint {locally_abstract_univars=vars; typ} -> - Pvc_constraint - { locally_abstract_univars = List.map (map_loc this) vars; - typ = this.typ this typ - } - | Pvc_coercion { ground; coercion } -> - Pvc_coercion { - ground = Option.map (this.typ this) ground; - coercion = this.typ this coercion - } - in Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) - ?value_constraint:(Option.map map_ct pvb_constraint) + ?value_constraint:(Option.map (map_value_constraint this) pvb_constraint) ~is_pun:pvb_is_pun ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes) diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index b3f3de6719..38f3436b42 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -2231,10 +2231,10 @@ expr: | let_bindings(ext) IN seq_expr { expr_of_let_bindings ~loc:$sloc $1 $3 } | pbop_op = mkrhs(LETOP) bindings = letop_bindings IN body = seq_expr - { let (pbop_pat, pbop_exp, pbop_is_pun, rev_ands) = bindings in + { let (pbop_pat, pbop_typ, pbop_exp, pbop_is_pun, rev_ands) = bindings in let ands = List.rev rev_ands in let pbop_loc = make_loc $sloc in - let let_ = {pbop_op; pbop_pat; pbop_exp; pbop_is_pun; pbop_loc} in + let let_ = {pbop_op; pbop_pat; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} in mkexp ~loc:$sloc (Pexp_letop{ let_; ands; body}) } | expr COLONCOLON e = expr { match e.pexp_desc, e.pexp_attributes with @@ -2548,26 +2548,25 @@ and_let_binding: ; letop_binding_body: pat = let_ident exp = strict_binding - { (pat, exp, false) } + { (pat, None, exp, false) } | val_ident (* Let-punning *) - { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, true) } + { (mkpatvar ~loc:$loc $1, None, mkexpvar ~loc:$loc $1, true) } | pat = simple_pattern COLON typ = core_type EQUAL exp = seq_expr - { let loc = ($startpos(pat), $endpos(typ)) in - (ghpat ~loc (Ppat_constraint(pat, typ)), exp, false) } + { (pat, Some (Pvc_constraint { locally_abstract_univars = []; typ }), exp, false) } | pat = pattern_no_exn EQUAL exp = seq_expr - { (pat, exp, false) } + { (pat, None, exp, false) } ; letop_bindings: body = letop_binding_body - { let let_pat, let_exp, let_is_pun = body in - let_pat, let_exp, let_is_pun, [] } + { let let_pat, let_typ, let_exp, let_is_pun = body in + let_pat, let_typ, let_exp, let_is_pun, [] } | bindings = letop_bindings pbop_op = mkrhs(ANDOP) body = letop_binding_body - { let let_pat, let_exp, let_is_pun, rev_ands = bindings in - let pbop_pat, pbop_exp, pbop_is_pun = body in + { let let_pat, let_typ, let_exp, let_is_pun, rev_ands = bindings in + let pbop_pat, pbop_typ, pbop_exp, pbop_is_pun = body in let pbop_loc = make_loc $sloc in - let and_ = {pbop_op; pbop_pat; pbop_exp; pbop_is_pun; pbop_loc} in - let_pat, let_exp, let_is_pun, and_ :: rev_ands } + let and_ = {pbop_op; pbop_pat; pbop_typ; pbop_exp; pbop_is_pun; pbop_loc} in + let_pat, let_typ, let_exp, let_is_pun, and_ :: rev_ands } ; fun_binding: strict_binding diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index f1c8ed17fe..89580599a3 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -482,6 +482,7 @@ and binding_op = { pbop_op : string loc; pbop_pat : pattern; + pbop_typ : value_constraint option; pbop_exp : expression; pbop_is_pun: bool; pbop_loc : Location.t; diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index a17142f6f2..02e8be686a 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -1233,3 +1233,5 @@ let signature_item ppf x = signature_item 0 ppf x let function_param ppf x = function_param 0 ppf x let value_constraint ppf x = value_constraint 0 ppf x + +let binding_op ppf x = binding_op 0 ppf x From 9554854f56226897ea533c8e3ba86c514d374e7a Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Thu, 14 Dec 2023 17:30:44 +0800 Subject: [PATCH 2/4] Add test --- test/passing/tests/monadic_binding.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/passing/tests/monadic_binding.ml b/test/passing/tests/monadic_binding.ml index dd28d238e4..fcfbb82a69 100644 --- a/test/passing/tests/monadic_binding.ml +++ b/test/passing/tests/monadic_binding.ml @@ -32,4 +32,6 @@ let _ = let* (args, _) : bar = () in let* (arg : bar) = () in let* (_ : foo) = () in + let* _ as t = xxx in + let+ Ok x = xxx in () From 76fa5a42f06f2a06be79272cda40955fc48e4e48 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Thu, 14 Dec 2023 17:49:42 +0800 Subject: [PATCH 3/4] Not necessary --- lib/Ast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 7871ce2f70..6b54702a4d 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -1003,7 +1003,7 @@ end = struct | Fp _ -> assert false | Vc c -> assert (check_value_constraint c) | Lb _ -> assert false - | Bo ctx -> assert (Option.exists ctx.pbop_typ ~f:check_value_constraint) + | Bo _ -> assert false | Mb _ -> assert false | Md _ -> assert false | Cl {pcl_desc; _} -> From 6bbec630e38f9e65ec7d64287563c804054ce991 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Thu, 14 Dec 2023 18:10:36 +0800 Subject: [PATCH 4/4] Fix regressions --- lib/Ast.ml | 13 ++++++++++--- test/passing/tests/monadic_binding.ml | 4 ++-- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 6b54702a4d..868d19337c 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -1905,16 +1905,23 @@ end = struct | Fp {pparam_desc= Pparam_val (_, _, _); _}, Ppat_cons _ -> true | Pat {ppat_desc= Ppat_construct _; _}, Ppat_cons _ -> true | _, Ppat_constraint (_, {ptyp_desc= Ptyp_poly _; _}) -> false - | ( (Exp {pexp_desc= Pexp_letop _; _} | Bo {pbop_typ= Some _; _}) + | ( Exp {pexp_desc= Pexp_letop _; _} , ( Ppat_construct (_, Some _) | Ppat_cons _ | Ppat_variant (_, Some _) - | Ppat_or _ | Ppat_alias _ | Ppat_tuple _ + | Ppat_or _ | Ppat_alias _ | Ppat_constraint ({ppat_desc= Ppat_any; _}, _) ) ) -> true - | ( (Exp {pexp_desc= Pexp_letop _; _} | Bo {pbop_typ= Some _; _}) + | ( Exp {pexp_desc= Pexp_letop _; _} , Ppat_constraint ({ppat_desc= Ppat_tuple _; _}, _) ) -> false + | ( Bo {pbop_typ= None; _} + , ( Ppat_construct (_, Some _) + | Ppat_cons _ + | Ppat_variant (_, Some _) + | Ppat_or _ | Ppat_alias _ ) ) -> + true + | Bo {pbop_typ= Some _; _}, (Ppat_any | Ppat_tuple _) -> true | _, Ppat_constraint _ |_, Ppat_unpack _ |( Pat diff --git a/test/passing/tests/monadic_binding.ml b/test/passing/tests/monadic_binding.ml index fcfbb82a69..5b2036c92f 100644 --- a/test/passing/tests/monadic_binding.ml +++ b/test/passing/tests/monadic_binding.ml @@ -32,6 +32,6 @@ let _ = let* (args, _) : bar = () in let* (arg : bar) = () in let* (_ : foo) = () in - let* _ as t = xxx in - let+ Ok x = xxx in + let* (_ as t) = xxx in + let+ (Ok x) = xxx in ()