From 8a664948b1a0c7d55079b897dbf4eaf6366870a3 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Thu, 19 Oct 2023 20:15:51 +0800 Subject: [PATCH] Define type 'type_constraint' --- lib/Ast.ml | 11 ++++++----- lib/Extended_ast.ml | 25 +++++++++++++++++++------ lib/Fmt_ast.ml | 20 +++++++++++++------- vendor/parser-extended/ast_mapper.ml | 7 ++++++- vendor/parser-extended/parser.mly | 28 ++++++++++++++-------------- vendor/parser-extended/parsetree.mli | 6 +++++- vendor/parser-extended/printast.ml | 15 ++++++++++++--- 7 files changed, 75 insertions(+), 37 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index c47beb25f2..a69165a7f2 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -981,8 +981,10 @@ end = struct | Pexp_object _ -> assert false | Pexp_record (en1, _) -> assert ( - List.exists en1 ~f:(fun (_, (t1, t2), _) -> - Option.exists t1 ~f || Option.exists t2 ~f ) ) + List.exists en1 ~f:(fun (_, c, _) -> + Option.exists c ~f:(function + | Pconstraint t -> f t + | Pcoerce (t1, t2) -> Option.exists t1 ~f || f t2 ) ) ) | Pexp_let (lbs, _) -> assert (check_let_bindings lbs) | _ -> assert false ) | Lb _ -> assert false @@ -1501,9 +1503,8 @@ end = struct List.for_all e1N ~f:Exp.is_trivial && fit_margin c (width xexp) | Pexp_record (e1N, e0) -> Option.for_all e0 ~f:Exp.is_trivial - && List.for_all e1N ~f:(fun (_, (ct1, ct2), eo) -> - Option.is_none ct1 && Option.is_none ct2 - && Option.for_all eo ~f:Exp.is_trivial ) + && List.for_all e1N ~f:(fun (_, c, eo) -> + Option.is_none c && Option.for_all eo ~f:Exp.is_trivial ) && fit_margin c (width xexp) | Pexp_indexop_access {pia_lhs; pia_kind; pia_rhs= None; _} -> Exp.is_trivial pia_lhs diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml index 34445fd11c..8e37fbc259 100644 --- a/lib/Extended_ast.ml +++ b/lib/Extended_ast.ml @@ -69,8 +69,21 @@ module Parse = struct when Std_longident.field_alias ~field:f.txt v_txt -> (f, t, None) (* [{ x = (x : t) }] -> [{ x : t }] *) + | ( None + , Some + { pexp_desc= + Pexp_constraint + ( { pexp_desc= Pexp_ident {txt= v_txt; _} + ; pexp_attributes= [] + ; _ } + , t1 ) + ; pexp_attributes= [] + ; _ } ) + when enable_short_field_annot + && Std_longident.field_alias ~field:f.txt v_txt -> + (f, Some (Pconstraint t1), None) (* [{ x :> t = (x : t) }] -> [{ x : t :> t }] *) - | ( (None, t2) + | ( Some (Pcoerce (None, t2)) , Some { pexp_desc= Pexp_constraint @@ -82,10 +95,10 @@ module Parse = struct ; _ } ) when enable_short_field_annot && Std_longident.field_alias ~field:f.txt v_txt -> - (f, (Some t1, t2), None) + (f, Some (Pcoerce (Some t1, t2)), None) (* [{ x = (x :> t) }] -> [{ x :> t }] *) (* [{ x = (x : t :> t) }] -> [{ x : t :> t }] *) - | ( (None, None) + | ( None , Some { pexp_desc= Pexp_coerce @@ -98,9 +111,9 @@ module Parse = struct ; _ } ) when enable_short_field_annot && Std_longident.field_alias ~field:f.txt v_txt -> - (f, (t1, Some t2), None) + (f, Some (Pcoerce (t1, t2)), None) (* [{ x : t = (x :> t) }] -> [{ x : t :> t }] *) - | ( (Some t1, None) + | ( Some (Pconstraint t1) , Some { pexp_desc= Pexp_coerce @@ -113,7 +126,7 @@ module Parse = struct ; _ } ) when enable_short_field_annot && Std_longident.field_alias ~field:f.txt v_txt -> - (f, (Some t1, Some t2), None) + (f, Some (Pcoerce (Some t1, t2)), None) | _ -> (f, t, Option.map ~f:(m.expr m) v) in let pat_record_field m (f, t, v) = diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 330dd29cdd..70910c9de7 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2469,7 +2469,13 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if outer_parens c.conf (compose_module ~pro ~epi blk ~f:fmt_mod $ fmt_atrs) ) | Pexp_record (flds, default) -> - let fmt_field (lid, (typ1, typ2), exp) = + let fmt_field (lid, tc, exp) = + let typ1, typ2 = + match tc with + | Some (Pconstraint t1) -> (Some t1, None) + | Some (Pcoerce (t1, t2)) -> (t1, Some t2) + | None -> (None, None) + in let typ1 = Option.map typ1 ~f:(sub_typ ~ctx) in let typ2 = Option.map typ2 ~f:(sub_typ ~ctx) in let rhs = @@ -2478,12 +2484,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens hvbox 0 @@ fmt_record_field c ?typ1 ?typ2 ?rhs lid in let p1, p2 = Params.get_record_expr c.conf in - let last_loc (lid, (t1, t2), e) = - match (t1, t2, e) with - | _, _, Some e -> e.pexp_loc - | _, Some t2, _ -> t2.ptyp_loc - | Some t1, _, _ -> t1.ptyp_loc - | _ -> lid.loc + let last_loc (lid, tc, e) = + match (tc, e) with + | _, Some e -> e.pexp_loc + | Some (Pcoerce (_, t2)), None -> t2.ptyp_loc + | Some (Pconstraint t1), None -> t1.ptyp_loc + | None, None -> lid.loc in let fmt_fields = fmt_elements_collection c p1 last_loc pexp_loc fmt_field flds diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index b1da740668..cbf8841c2f 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -467,6 +467,11 @@ end module E = struct (* Value expressions for the core language *) + let map_constraint sub c = + match c with + | Pconstraint ty -> Pconstraint (sub.typ sub ty) + | Pcoerce (ty1, ty2) -> Pcoerce (map_opt (sub.typ sub) ty1, sub.typ sub ty2) + let map_if_branch sub {if_cond; if_body; if_attrs} = let if_cond = sub.expr sub if_cond in let if_body = sub.expr sub if_body in @@ -507,7 +512,7 @@ module E = struct List.map (map_tuple3 (map_loc sub) - (map_tuple (map_opt (sub.typ sub)) (map_opt (sub.typ sub))) + (map_opt (map_constraint sub)) (map_opt (sub.expr sub))) l in diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 26673cdfae..dc65b85aa2 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -226,11 +226,13 @@ let rec mktailpat nilloc = let open Location in function let mkstrexp e attrs = { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } -let mkexp_constraint ~loc e (t1, t2) = - match t1, t2 with - | Some t, None -> mkexp ~loc (Pexp_constraint(e, t)) - | _, Some t -> mkexp ~loc (Pexp_coerce(e, t1, t)) - | None, None -> assert false +let mkexp_desc_constraint e t = + match t with + | Pconstraint t -> Pexp_constraint(e, t) + | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) + +let mkexp_constraint ~loc e t = + mkexp ~loc (mkexp_desc_constraint e t) (* let mkexp_opt_constraint ~loc e = function @@ -2484,10 +2486,9 @@ let_binding_body_no_punning: { let v = $1 in (* PR#7344 *) let t = match $2 with - Some t, None -> - Pvc_constraint { locally_abstract_univars = []; typ=t } - | ground, Some coercion -> Pvc_coercion { ground; coercion} - | _ -> assert false + | Pconstraint typ -> + Pvc_constraint { locally_abstract_univars = []; typ } + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion } in (v, $4, Some t) } @@ -2623,8 +2624,7 @@ record_expr_content: | label = mkrhs(label_longident) c = type_constraint? eo = preceded(EQUAL, expr)? - { let c = Option.value ~default:(None, None) c in - label, c, eo } + { label, c, eo } ; %inline object_expr_content: xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field) @@ -2648,9 +2648,9 @@ record_expr_content: { es } ; type_constraint: - COLON core_type { (Some $2, None) } - | COLON core_type COLONGREATER core_type { (Some $2, Some $4) } - | COLONGREATER core_type { (None, Some $2) } + | COLON core_type { Pconstraint $2 } + | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } + | COLONGREATER core_type { Pcoerce (None, $2) } | COLON error { syntax_error() } | COLONGREATER error { syntax_error() } ; diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index dea619a38b..8e3ebfd8a2 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -377,7 +377,7 @@ and expression_desc = *) | Pexp_record of ( Longident.t loc - * (core_type option * core_type option) + * type_constraint option * expression option ) list * expression option @@ -501,6 +501,10 @@ and binding_op = pbop_loc : Location.t; } +and type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type + (** {2 Value descriptions} *) and value_description = diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 51f196eecb..28ea03b656 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -514,6 +514,16 @@ and if_branch i ppf { if_cond; if_body } = expression i ppf if_cond; expression i ppf if_body +and type_constraint i ppf constraint_ = + match constraint_ with + | Pconstraint ty -> + line i ppf "Pconstraint\n"; + core_type (i+1) ppf ty + | Pcoerce (ty1, ty2) -> + line i ppf "Pcoerce\n"; + option (i+1) core_type ppf ty1; + core_type (i+1) ppf ty2 + and value_description i ppf x = line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc; @@ -1119,10 +1129,9 @@ and string_x_expression i ppf (s, e) = line i ppf " %a\n" fmt_string_loc s; expression (i+1) ppf e; -and longident_x_expression i ppf (li, (t1, t2), e) = +and longident_x_expression i ppf (li, c, e) = line i ppf "%a\n" fmt_longident_loc li; - option (i+1) core_type ppf t1; - option (i+1) core_type ppf t2; + option (i+1) type_constraint ppf c; option (i+1) expression ppf e; and label_x_expression i ppf (l,e) =