From 0e616216081ea0b10c1dbe6d0c0174c3db825f9b Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Fri, 3 Nov 2023 11:25:05 +0800 Subject: [PATCH] Reuse type 'value_constraint' instead of redefining constraint type for Let_binding.t --- lib/Ast.ml | 31 +++++++++------ lib/Ast.mli | 1 + lib/Fmt_ast.ml | 63 +++++++++++++++++------------- lib/Sugar.ml | 39 +++++++----------- lib/Sugar.mli | 6 +-- vendor/parser-extended/printast.ml | 2 + 6 files changed, 73 insertions(+), 69 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 0f8df8b54d..1f86607e04 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -639,6 +639,7 @@ module T = struct | Pat of pattern | Exp of expression | Fp of function_param + | Vc of value_constraint | Lb of value_binding | Mb of module_binding | Md of module_declaration @@ -660,6 +661,7 @@ module T = struct | Pat p -> Format.fprintf fs "Pat:@\n%a" Printast.pattern p | Exp e -> Format.fprintf fs "Exp:@\n%a" Printast.expression e | 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 | Mb m -> Format.fprintf fs "Mb:@\n%a" Printast.module_binding m | Md m -> Format.fprintf fs "Md:@\n%a" Printast.module_declaration m @@ -693,6 +695,7 @@ let attributes = function | Pat x -> x.ppat_attributes | Exp x -> x.pexp_attributes | Fp _ -> [] + | Vc _ -> [] | Lb x -> x.pvb_attributes | Mb x -> attrs_of_ext_attrs x.pmb_ext_attrs | Md x -> attrs_of_ext_attrs x.pmd_ext_attrs @@ -715,6 +718,7 @@ let location = function | Pat x -> x.ppat_loc | Exp x -> x.pexp_loc | Fp x -> x.pparam_loc + | Vc _ -> Location.none | Lb x -> x.pvb_loc | Mb x -> x.pmb_loc | Md x -> x.pmd_loc @@ -908,12 +912,13 @@ end = struct List.exists t ~f:(fun x -> x.pap_type == typ) | _ -> false ) in - let check_pvb pvb = - match pvb.pvb_constraint with - | Some (Pvc_constraint {typ= typ'; _}) -> typ' == typ - | Some (Pvc_coercion {ground; coercion}) -> + let check_value_constraint = function + | Pvc_constraint {typ= typ'; _} -> typ' == typ + | Pvc_coercion {ground; coercion} -> coercion == typ || Option.exists ground ~f:(fun x -> x == typ) - | None -> false + in + let check_pvb pvb = + Option.exists pvb.pvb_constraint ~f:check_value_constraint in let check_let_bindings lbs = List.exists lbs.pvbs_bindings ~f:check_pvb @@ -992,6 +997,7 @@ end = struct | Pexp_let (lbs, _) -> assert (check_let_bindings lbs) | _ -> assert false ) | Fp _ -> assert false + | Vc c -> assert (check_value_constraint c) | Lb _ -> assert false | Mb _ -> assert false | Md _ -> assert false @@ -1041,14 +1047,6 @@ end = struct | Pstr_extension ((_, PTyp t), _) -> assert (t == typ) | Pstr_extension (_, _) -> assert false | Pstr_value {pvbs_bindings; _} -> - let check_pvb pvb = - match pvb.pvb_constraint with - | Some (Pvc_constraint {typ= typ'; _}) -> typ' == typ - | Some (Pvc_coercion {ground; coercion}) -> - coercion == typ - || Option.exists ground ~f:(fun x -> x == typ) - | None -> false - in assert (List.exists pvbs_bindings ~f:check_pvb) | _ -> assert false ) | Clf {pcf_desc; _} -> @@ -1108,6 +1106,7 @@ end = struct match (ctx : t) with | Exp _ -> assert false | Fp _ -> assert false + | Vc _ -> assert false | Lb _ -> assert false | Mb _ -> assert false | Md _ -> assert false @@ -1176,6 +1175,7 @@ end = struct match (ctx : t) with | Exp _ -> assert false | Fp _ -> assert false + | Vc _ -> assert false | Lb _ -> assert false | Mb _ -> assert false | Md _ -> assert false @@ -1301,6 +1301,7 @@ end = struct | Pexp_for (p, _, _, _, _) -> assert (p == pat) | Pexp_fun (p, _) -> assert (check_function_param p) ) | Fp ctx -> assert (check_function_param ctx) + | Vc _ -> assert false | Lb x -> assert (x.pvb_pat == pat) | Mb _ -> assert false | Md _ -> assert false @@ -1431,6 +1432,7 @@ end = struct assert (e1 == exp || e2 == exp || e3 == exp) | Pexp_override e1N -> assert (List.exists e1N ~f:snd_f) ) | Fp ctx -> assert (check_function_param ctx) + | Vc _ -> assert false | Lb x -> assert (x.pvb_expr == exp) | Mb _ -> assert false | Md _ -> assert false @@ -1683,6 +1685,8 @@ end = struct | Str _ | Clf _ | Ctf _ | Rep | Mb _ | Md _ ) } |{ctx= Fp _; ast= _} |{ctx= _; ast= Fp _} + |{ctx= Vc _; ast= _} + |{ctx= _; ast= Vc _} |{ctx= Lb _; ast= _} |{ctx= _; ast= Lb _} |{ctx= Td _; ast= _} @@ -1767,6 +1771,7 @@ end = struct | Pexp_send _ -> Some Dot | _ -> None ) | Fp _ -> None + | Vc _ -> None | Lb _ -> None | Cl c -> ( match c.pcl_desc with diff --git a/lib/Ast.mli b/lib/Ast.mli index 4897031cc3..108907acf8 100644 --- a/lib/Ast.mli +++ b/lib/Ast.mli @@ -111,6 +111,7 @@ type t = | Pat of pattern | Exp of expression | Fp of function_param + | Vc of value_constraint | Lb of value_binding | Mb of module_binding | Md of module_declaration diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 1dae4955b3..6028010f44 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -4360,6 +4360,41 @@ and fmt_let c ~ext ~rec_flag ~bindings ~parens ~fmt_atrs ~fmt_expr ~body_loc $ hvbox 0 fmt_expr ) ) $ fmt_atrs +and fmt_value_constraint c vc_opt = + let fmt_sep x = + match c.conf.fmt_opts.break_colon.v with + | `Before -> fmt "@ " $ str x $ char ' ' + | `After -> char ' ' $ str x $ fmt "@ " + in + match vc_opt with + | Some vc -> ( + let ctx = Vc vc in + match vc with + | Pvc_constraint {locally_abstract_univars= []; typ} -> + (noop, fmt_type_cstr c (sub_typ ~ctx typ)) + | Pvc_constraint {locally_abstract_univars= pvars; typ} -> ( + match c.conf.fmt_opts.break_colon.v with + | `Before -> + ( noop + , fmt_sep ":" + $ hvbox 0 + ( str "type " + $ list pvars " " (fmt_str_loc c) + $ fmt ".@ " + $ fmt_core_type c (sub_typ ~ctx typ) ) ) + | `After -> + ( fmt_sep ":" + $ hvbox 0 + (str "type " $ list pvars " " (fmt_str_loc c) $ str ".") + , fmt "@ " $ fmt_core_type c (sub_typ ~ctx typ) ) ) + | Pvc_coercion {ground; coercion} -> + ( noop + , opt ground (fun ty -> + fmt_sep ":" $ fmt_core_type c (sub_typ ~ctx ty) ) + $ fmt_sep ":>" + $ fmt_core_type c (sub_typ ~ctx coercion) ) ) + | None -> (noop, noop) + and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi {lb_op; lb_pat; lb_args; lb_typ; lb_exp; lb_attrs; lb_loc; lb_pun} = update_config_maybe_disabled c lb_loc lb_attrs @@ -4371,33 +4406,7 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi in let doc1, atrs = doc_atrs lb_attrs in let doc2, atrs = doc_atrs atrs in - let fmt_newtypes, fmt_cstr = - let fmt_sep x = - match c.conf.fmt_opts.break_colon.v with - | `Before -> fmt "@ " $ str x $ char ' ' - | `After -> char ' ' $ str x $ fmt "@ " - in - match lb_typ with - | `Polynewtype (pvars, xtyp) -> ( - match c.conf.fmt_opts.break_colon.v with - | `Before -> - ( noop - , fmt_sep ":" - $ hvbox 0 - ( str "type " - $ list pvars " " (fmt_str_loc c) - $ fmt ".@ " $ fmt_core_type c xtyp ) ) - | `After -> - ( fmt_sep ":" - $ hvbox 0 (str "type " $ list pvars " " (fmt_str_loc c) $ str ".") - , fmt "@ " $ fmt_core_type c xtyp ) ) - | `Coerce (xtyp1, xtyp2) -> - ( noop - , opt xtyp1 (fun xtyp1 -> fmt_sep ":" $ fmt_core_type c xtyp1) - $ fmt_sep ":>" $ fmt_core_type c xtyp2 ) - | `Other xtyp -> (noop, fmt_type_cstr c xtyp) - | `None -> (noop, noop) - in + let fmt_newtypes, fmt_cstr = fmt_value_constraint c lb_typ in let indent = match lb_exp.ast.pexp_desc with | Pexp_function _ -> c.conf.fmt_opts.function_indent.v diff --git a/lib/Sugar.ml b/lib/Sugar.ml index f692d4eb7d..a8a160e973 100644 --- a/lib/Sugar.ml +++ b/lib/Sugar.ml @@ -180,11 +180,7 @@ module Let_binding = struct { lb_op: string loc ; lb_pat: pattern xt ; lb_args: function_param list - ; lb_typ: - [ `Polynewtype of label loc list * core_type xt - | `Coerce of core_type xt option * core_type xt - | `Other of core_type xt - | `None ] + ; lb_typ: value_constraint option ; lb_exp: expression xt ; lb_pun: bool ; lb_attrs: attribute list @@ -197,7 +193,6 @@ module Let_binding = struct when Source.type_constraint_is_first typ exp.pexp_loc -> Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; - let typ_ctx = ctx in let exp_ctx = (* The type constraint is moved to the pattern, so we need to replace the context from [Pexp_constraint] to [Pexp_fun]. This @@ -210,20 +205,25 @@ module Let_binding = struct in Exp (Ast_helper.Exp.fun_ param exp) in - (xargs, `Other (sub_typ ~ctx:typ_ctx typ), sub_exp ~ctx:exp_ctx exp) + ( xargs + , Some (Pvc_constraint {locally_abstract_univars= []; typ}) + , sub_exp ~ctx:exp_ctx exp ) (* The type constraint is always printed before the declaration for functions, for other value bindings we preserve its position. *) | Pexp_constraint (exp, typ) when not (List.is_empty xargs) -> Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; - (xargs, `Other (sub_typ ~ctx typ), sub_exp ~ctx exp) + ( xargs + , Some (Pvc_constraint {locally_abstract_univars= []; typ}) + , sub_exp ~ctx exp ) | Pexp_coerce (exp, typ1, typ2) when Source.type_constraint_is_first typ2 exp.pexp_loc -> Cmts.relocate cmts ~src:body.pexp_loc ~before:exp.pexp_loc ~after:exp.pexp_loc ; - let typ1 = Option.map typ1 ~f:(sub_typ ~ctx) in - (xargs, `Coerce (typ1, sub_typ ~ctx typ2), sub_exp ~ctx exp) - | _ -> (xargs, `None, xbody) + ( xargs + , Some (Pvc_coercion {ground= typ1; coercion= typ2}) + , sub_exp ~ctx exp ) + | _ -> (xargs, None, xbody) let split_fun_args cmts xpat xbody = let xargs, xbody = @@ -233,7 +233,7 @@ module Let_binding = struct | _ -> ([], xbody) in match (xbody.ast.pexp_desc, xpat.ast.ppat_desc) with - | Pexp_constraint _, Ppat_constraint _ -> (xargs, `None, xbody) + | Pexp_constraint _, Ppat_constraint _ -> (xargs, None, xbody) | _ -> split_annot cmts xargs xbody let type_cstr cmts ~ctx lb_pat lb_exp = @@ -262,7 +262,7 @@ module Let_binding = struct 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) + then (xpat, [], None, xbody) else let xpat = match xpat.ast.ppat_desc with @@ -273,18 +273,9 @@ module Let_binding = struct let xargs, typ, xbody = split_fun_args cmts xpat xbody in (xpat, xargs, typ, xbody) - let typ_of_pvb_constraint ~ctx = function - | Some (Pvc_constraint {locally_abstract_univars= []; typ}) -> - `Other (sub_typ ~ctx typ) - | Some (Pvc_constraint {locally_abstract_univars; typ}) -> - `Polynewtype (locally_abstract_univars, sub_typ ~ctx typ) - | Some (Pvc_coercion {ground; coercion}) -> - `Coerce (Option.map ground ~f:(sub_typ ~ctx), sub_typ ~ctx coercion) - | None -> `None - let should_desugar_args pat typ = match (pat.ast, typ) with - | {ppat_desc= Ppat_var _; ppat_attributes= []; _}, `None -> true + | {ppat_desc= Ppat_var _; ppat_attributes= []; _}, None -> true | _ -> false let of_let_binding cmts ~ctx ~first @@ -292,7 +283,7 @@ module Let_binding = struct = let lb_exp = sub_exp ~ctx pvb_expr and lb_pat = sub_pat ~ctx pvb_pat - and lb_typ = typ_of_pvb_constraint ~ctx pvb_constraint in + and lb_typ = pvb_constraint in let lb_args, lb_typ, lb_exp = if should_desugar_args lb_pat lb_typ then split_fun_args cmts lb_pat lb_exp diff --git a/lib/Sugar.mli b/lib/Sugar.mli index f1f5296529..ae2cc1e180 100644 --- a/lib/Sugar.mli +++ b/lib/Sugar.mli @@ -59,11 +59,7 @@ module Let_binding : sig { lb_op: string loc ; lb_pat: pattern Ast.xt ; lb_args: function_param list - ; lb_typ: - [ `Polynewtype of label loc list * core_type Ast.xt - | `Coerce of core_type Ast.xt option * core_type Ast.xt - | `Other of core_type Ast.xt - | `None ] + ; lb_typ: value_constraint option ; lb_exp: expression Ast.xt ; lb_pun: bool ; lb_attrs: attribute list diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index f6f1404514..a17142f6f2 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -1231,3 +1231,5 @@ let structure_item ppf x = structure_item 0 ppf x 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