From 02ad3cfa90c8117a6ebac05c122d5ce047338ff3 Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Fri, 24 Jan 2025 12:14:30 -0500 Subject: [PATCH 1/4] Add syntax, make compile Still needs parsing and tests --- lib/Ast.ml | 40 ++++++++++++++----------- lib/Exposed.ml | 5 +++- lib/Fmt_ast.ml | 45 ++++++++++++++++++++++------ lib/Params.ml | 34 ++++++++++++++------- lib/Params.mli | 11 +++++-- vendor/parser-extended/ast_helper.ml | 5 ++++ vendor/parser-extended/ast_mapper.ml | 24 +++++++++++++++ vendor/parser-extended/parsetree.mli | 25 ++++++++++++++++ vendor/parser-extended/printast.ml | 14 +++++++++ 9 files changed, 162 insertions(+), 41 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 9cdc3c83d7..4de99b565c 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -360,7 +360,8 @@ module Tyd = struct let is_simple x = match x.ptype_kind with | Ptype_abstract | Ptype_open -> true - | Ptype_variant _ | Ptype_record _ -> false + | Ptype_variant _ | Ptype_record _ | Ptype_record_unboxed_product _ -> + false end module Structure_item = struct @@ -1367,7 +1368,7 @@ end = struct assert (List.exists p1N ~f) | Ppat_tuple (p1N, _) | Ppat_unboxed_tuple (p1N, _) -> assert (List.exists p1N ~f:(fun (_, p) -> f p)) - | Ppat_record (p1N, _) -> + | Ppat_record (p1N, _) | Ppat_record_unboxed_product (p1N, _) -> assert (List.exists p1N ~f:(fun (_, _, x) -> Option.exists x ~f)) | Ppat_or l -> assert (List.exists ~f:(fun p -> p == pat) l) | Ppat_alias (p1, _) @@ -1390,15 +1391,17 @@ end = struct assert (check_comprehension comp (Pattern pat)) | Pexp_apply _ | Pexp_array _ | Pexp_list _ | Pexp_assert _ |Pexp_coerce _ | Pexp_constant _ | Pexp_constraint _ - |Pexp_construct _ | Pexp_field _ | Pexp_ident _ | Pexp_ifthenelse _ - |Pexp_lazy _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_new _ + |Pexp_construct _ | Pexp_field _ | Pexp_unboxed_field _ + |Pexp_ident _ | Pexp_ifthenelse _ | Pexp_lazy _ + |Pexp_letexception _ | Pexp_letmodule _ | Pexp_new _ |Pexp_newtype _ | Pexp_open _ | Pexp_override _ | Pexp_pack _ - |Pexp_poly _ | Pexp_record _ | Pexp_send _ | Pexp_sequence _ - |Pexp_setfield _ | Pexp_setinstvar _ | Pexp_tuple _ - |Pexp_unboxed_tuple _ | Pexp_unreachable | Pexp_variant _ - |Pexp_while _ | Pexp_hole | Pexp_beginend _ | Pexp_parens _ - |Pexp_cons _ | Pexp_letopen _ | Pexp_indexop_access _ - |Pexp_prefix _ | Pexp_infix _ | Pexp_stack _ -> + |Pexp_poly _ | Pexp_record _ | Pexp_record_unboxed_product _ + |Pexp_send _ | Pexp_sequence _ | Pexp_setfield _ | Pexp_setinstvar _ + |Pexp_tuple _ | Pexp_unboxed_tuple _ | Pexp_unreachable + |Pexp_variant _ | Pexp_while _ | Pexp_hole | Pexp_beginend _ + |Pexp_parens _ | Pexp_cons _ | Pexp_letopen _ + |Pexp_indexop_access _ | Pexp_prefix _ | Pexp_infix _ | Pexp_stack _ + -> assert false | Pexp_extension (_, ext) -> assert (check_extensions ext) | Pexp_object {pcstr_self; _} -> @@ -1521,7 +1524,7 @@ end = struct assert (List.exists e1N ~f) | Pexp_construct (_, e) | Pexp_variant (_, e) -> assert (Option.exists e ~f) - | Pexp_record (e1N, e0) -> + | Pexp_record (e1N, e0) | Pexp_record_unboxed_product (e1N, e0) -> assert ( Option.exists e0 ~f || List.exists e1N ~f:(fun (_, _, e) -> Option.exists e ~f) ) @@ -1532,6 +1535,7 @@ end = struct |Pexp_stack e |Pexp_coerce (e, _, _) |Pexp_field (e, _) + |Pexp_unboxed_field (e, _) |Pexp_lazy e |Pexp_letexception (_, e) |Pexp_letmodule (_, _, _, e) @@ -2249,9 +2253,10 @@ end = struct | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _ |Pexp_constraint _ |Pexp_construct (_, None) - |Pexp_extension _ | Pexp_field _ | Pexp_for _ | Pexp_ident _ - |Pexp_new _ | Pexp_object _ | Pexp_override _ | Pexp_pack _ - |Pexp_poly _ | Pexp_record _ | Pexp_send _ | Pexp_unreachable + |Pexp_extension _ | Pexp_field _ | Pexp_unboxed_field _ + |Pexp_for _ | Pexp_ident _ | Pexp_new _ | Pexp_object _ + |Pexp_override _ | Pexp_pack _ | Pexp_poly _ | Pexp_record _ + |Pexp_record_unboxed_product _ | Pexp_send _ | Pexp_unreachable |Pexp_variant (_, None) |Pexp_hole | Pexp_while _ | Pexp_beginend _ | Pexp_parens _ |Pexp_indexop_access _ | Pexp_list_comprehension _ @@ -2331,9 +2336,10 @@ end = struct | Pexp_array _ | Pexp_list _ | Pexp_coerce _ | Pexp_constant _ |Pexp_constraint _ |Pexp_construct (_, None) - |Pexp_extension _ | Pexp_field _ | Pexp_for _ | Pexp_ident _ - |Pexp_new _ | Pexp_object _ | Pexp_override _ | Pexp_pack _ - |Pexp_poly _ | Pexp_record _ | Pexp_send _ | Pexp_unreachable + |Pexp_extension _ | Pexp_field _ | Pexp_unboxed_field _ | Pexp_for _ + |Pexp_ident _ | Pexp_new _ | Pexp_object _ | Pexp_override _ + |Pexp_pack _ | Pexp_poly _ | Pexp_record _ + |Pexp_record_unboxed_product _ | Pexp_send _ | Pexp_unreachable |Pexp_variant (_, None) |Pexp_hole | Pexp_while _ | Pexp_beginend _ | Pexp_parens _ |Pexp_list_comprehension _ | Pexp_array_comprehension _ -> diff --git a/lib/Exposed.ml b/lib/Exposed.ml index b54d44adb6..3872c38261 100644 --- a/lib/Exposed.ml +++ b/lib/Exposed.ml @@ -81,7 +81,10 @@ module Right = struct | {ptype_cstrs= _ :: _ as cstrs; _} -> (* type a = ... constraint left = < ... > *) list ~elt:(fun (_left, right, _loc) -> core_type right) cstrs - | {ptype_kind= Ptype_open | Ptype_record _; _} -> false + | { ptype_kind= + Ptype_open | Ptype_record _ | Ptype_record_unboxed_product _ + ; _ } -> + false | {ptype_kind= Ptype_abstract; ptype_manifest= None; _} -> false | {ptype_kind= Ptype_abstract; ptype_manifest= Some manifest; _} -> (* type a = < ... > *) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 6fe894f00b..edf607af49 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1343,7 +1343,14 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) cbox 2 (Params.parens_if parens c.conf (variant_var c lbl $ fmt "@ " $ fmt_pattern c (sub_pat ~ctx pat)) ) - | Ppat_record (flds, closed_flag) -> + | Ppat_record (flds, closed_flag) + |Ppat_record_unboxed_product (flds, closed_flag) -> + let unboxed = + match ppat_desc with + | Ppat_record _ -> false + | Ppat_record_unboxed_product _ -> true + | _ -> assert false + in let fmt_field (lid, typ1, pat) = let typ1 = Option.map typ1 ~f:(sub_typ ~ctx) in let rhs = @@ -1351,7 +1358,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) in hvbox 0 @@ Cmts.fmt c ppat_loc @@ fmt_record_field c ?typ1 ?rhs lid in - let p1, p2 = Params.get_record_pat c.conf ~ctx:ctx0 in + let p1, p2 = Params.get_record_pat c.conf ~ctx:ctx0 ~unboxed in let last_sep, fmt_underscore = match closed_flag with | OClosed -> (true, noop) @@ -2572,12 +2579,19 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens ( variant_var c s $ opt arg (fmt "@ " >$ (sub_exp ~ctx >> fmt_expression c)) $ fmt_atrs ) ) - | Pexp_field (exp, lid) -> + | Pexp_field (exp, lid) | Pexp_unboxed_field (exp, lid) -> + let unboxed = + match pexp_desc with + | Pexp_field _ -> false + | Pexp_unboxed_field _ -> true + | _ -> assert false + in pro $ hvbox 2 (Params.parens_if parens c.conf ( fmt_expression c (sub_exp ~ctx exp) - $ fmt "@,." $ fmt_longident_loc c lid $ fmt_atrs ) ) + $ fmt (if unboxed then "@,.#" else "@,.") + $ fmt_longident_loc c lid $ fmt_atrs ) ) | Pexp_newtype _ | Pexp_fun _ -> let xargs, xbody = Sugar.fun_ c.cmts xexp in let fmt_cstr, xbody = type_constr_and_body c xbody in @@ -2880,7 +2894,14 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ hvbox 0 (Params.parens_if outer_parens c.conf (compose_module ~pro ~epi blk ~f:fmt_mod $ fmt_atrs) ) - | Pexp_record (flds, default) -> + | Pexp_record (flds, default) | Pexp_record_unboxed_product (flds, default) + -> + let unboxed = + match pexp_desc with + | Pexp_record _ -> false + | Pexp_record_unboxed_product _ -> true + | _ -> assert false + in let fmt_field (lid, tc, exp) = let typ1, typ2 = match tc with @@ -2895,7 +2916,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens in hvbox 0 @@ fmt_record_field c ?typ1 ?typ2 ?rhs lid in - let p1, p2 = Params.get_record_expr c.conf in + let p1, p2 = Params.get_record_expr c.conf ~unboxed in let last_loc (lid, tc, e) = match (tc, e) with | _, Some e -> e.pexp_loc @@ -3782,8 +3803,14 @@ and fmt_type_declaration c ?(pre = noop) ?name ?(eq = "=") {ast= decl; _} = box_manifest (fmt_manifest m) $ fmt "@ " $ list_fl ctor_decls (fmt_constructor_declaration c ctx) - | Ptype_record lbl_decls -> - let p = Params.get_record_type c.conf in + | Ptype_record lbl_decls | Ptype_record_unboxed_product lbl_decls -> + let unboxed = + match ptype_kind with + | Ptype_record _ -> false + | Ptype_record_unboxed_product _ -> true + | _ -> assert false + in + let p = Params.get_record_type c.conf ~unboxed in let fmt_decl ~first ~last x = fmt_if_k (not first) p.sep_before $ fmt_label_declaration c ctx x ~last @@ -3955,7 +3982,7 @@ and fmt_constructor_arguments ?vars c ctx ~pre = function let vars = match vars with Some vars -> fmt "@ " $ vars | None -> noop in - let p = Params.get_record_type c.conf in + let p = Params.get_record_type c.conf ~unboxed:false in let fmt_ld ~first ~last x = fmt_if_k (not first) p.sep_before $ fmt_label_declaration c ctx x ~last diff --git a/lib/Params.ml b/lib/Params.ml index 5cee57950a..e41248bbcb 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -297,8 +297,10 @@ let wrap_collec c ~space_around opn cls = if space_around then wrap_k (str opn $ char ' ') (break 1 0 $ str cls) else wrap_fits_breaks c opn cls -let wrap_record (c : Conf.t) = - wrap_collec c ~space_around:c.fmt_opts.space_around_records.v "{" "}" +let wrap_record (c : Conf.t) ~unboxed = + let left_brace = if unboxed then "#{" else "{" in + wrap_collec c ~space_around:c.fmt_opts.space_around_records.v left_brace + "}" let wrap_tuple (c : Conf.t) ~unboxed ~parens ~no_parens_if_break = if unboxed then wrap_fits_breaks c "#(" ")" @@ -316,7 +318,7 @@ type record_type = ; break_after: Fmt.t ; docked_after: Fmt.t } -let get_record_type (c : Conf.t) = +let get_record_type (c : Conf.t) ~unboxed = let sparse_type_decl = Poly.(c.fmt_opts.type_decl.v = `Sparse) in let space = if c.fmt_opts.space_around_records.v then 1 else 0 in let dock = c.fmt_opts.dock_collection_brackets.v in @@ -333,9 +335,12 @@ let get_record_type (c : Conf.t) = (fmt_or sparse_type_decl "@;<1000 0>" "@ ") (fmt_or sparse_type_decl "@;<1000 2>" "@;<1 2>") ) in - { docked_before= fmt_if dock " {" + let box_margin = if unboxed then 1 else 0 in + { docked_before= fmt_if dock (if unboxed then " #{" else " {") ; break_before - ; box_record= (fun k -> if dock then k else hvbox 0 (wrap_record c k)) + ; box_record= + (fun k -> + if dock then k else hvbox box_margin (wrap_record c ~unboxed k) ) ; box_spaced= c.fmt_opts.space_around_records.v ; sep_before ; sep_after @@ -352,12 +357,18 @@ type elements_collection_record_expr = {break_after_with: Fmt.t} type elements_collection_record_pat = {wildcard: Fmt.t} -let get_record_expr (c : Conf.t) = +let get_record_expr (c : Conf.t) ~unboxed = let space = if c.fmt_opts.space_around_records.v then 1 else 0 in let dock = c.fmt_opts.dock_collection_brackets.v in let box k = - if dock then hvbox 0 (wrap "{" "}" (break space 2 $ k $ break space 0)) - else hvbox 0 (wrap_record c k) + let margin = if unboxed then 1 else 0 in + if dock then + hvbox margin + (wrap + (if unboxed then "#{" else "{") + "}" + (break space 2 $ k $ break space 0) ) + else hvbox margin (wrap_record c ~unboxed k) in ( ( match c.fmt_opts.break_separators.v with | `Before -> @@ -441,12 +452,13 @@ let box_pattern_docked (c : Conf.t) ~ctx ~space_around opn cls k = hvbox indent_opn (wrap_k (str opn) (str cls) (break space 2 $ k $ break space indent_cls)) -let get_record_pat (c : Conf.t) ~ctx = - let params, _ = get_record_expr c in +let get_record_pat (c : Conf.t) ~ctx ~unboxed = + let params, _ = get_record_expr c ~unboxed in let box = if c.fmt_opts.dock_collection_brackets.v then + let left_brace = if unboxed then "#{" else "{" in box_pattern_docked c ~ctx - ~space_around:c.fmt_opts.space_around_records.v "{" "}" + ~space_around:c.fmt_opts.space_around_records.v left_brace "}" else params.box in ( {params with box} diff --git a/lib/Params.mli b/lib/Params.mli index df7d94dacf..ca64682e4a 100644 --- a/lib/Params.mli +++ b/lib/Params.mli @@ -109,7 +109,7 @@ type record_type = ; break_after: Fmt.t ; docked_after: Fmt.t } -val get_record_type : Conf.t -> record_type +val get_record_type : Conf.t -> unboxed:bool -> record_type type elements_collection = { box: Fmt.t -> Fmt.t @@ -122,7 +122,9 @@ type elements_collection_record_expr = {break_after_with: Fmt.t} type elements_collection_record_pat = {wildcard: Fmt.t} val get_record_expr : - Conf.t -> elements_collection * elements_collection_record_expr + Conf.t + -> unboxed:bool + -> elements_collection * elements_collection_record_expr val get_list_expr : Conf.t -> elements_collection @@ -134,7 +136,10 @@ val wrap_comprehension : Conf.t -> space_around:bool -> punctuation:string -> Fmt.t -> Fmt.t val get_record_pat : - Conf.t -> ctx:Ast.t -> elements_collection * elements_collection_record_pat + Conf.t + -> ctx:Ast.t + -> unboxed:bool + -> elements_collection * elements_collection_record_pat val get_list_pat : Conf.t -> ctx:Ast.t -> elements_collection diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index e431d62fe7..42b1c90d16 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -104,6 +104,8 @@ module Pat = struct let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + let record_unboxed_product ?loc ?attrs a b = + mk ?loc ?attrs (Ppat_record_unboxed_product (a, b)) let array ?loc ?attrs a b = mk ?loc ?attrs (Ppat_array (a, b)) let list ?loc ?attrs a = mk ?loc ?attrs (Ppat_list a) let or_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_or a) @@ -138,7 +140,10 @@ module Exp = struct let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) + let record_unboxed_product ?loc ?attrs a b = + mk ?loc ?attrs (Pexp_record_unboxed_product (a, b)) let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) + let unboxed_field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_unboxed_field (a, b)) let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) let array ?loc ?attrs a b = mk ?loc ?attrs (Pexp_array (a, b)) let list ?loc ?attrs a = mk ?loc ?attrs (Pexp_list a) diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 9008a855b4..41ae42cd3b 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -273,6 +273,8 @@ module T = struct | Ptype_variant l -> Ptype_variant (List.map (sub.constructor_declaration sub) l) | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_record_unboxed_product l -> + Ptype_record_unboxed_product (List.map (sub.label_declaration sub) l) | Ptype_open -> Ptype_open let map_constructor_argument sub x = @@ -611,8 +613,20 @@ module E = struct l in record ~loc ~attrs fields (map_opt (sub.expr sub) eo) + | Pexp_record_unboxed_product (l, eo) -> + let fields = + List.map + (map_tuple3 + (map_loc sub) + (map_opt (map_constraint sub)) + (map_opt (sub.expr sub))) + l + in + record_unboxed_product ~loc ~attrs fields (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_unboxed_field (e, lid) -> + unboxed_field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) | Pexp_setfield (e1, lid, e2) -> setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) @@ -744,6 +758,16 @@ module P = struct lpl in record ~loc ~attrs fields (Flag.map_obj_closed sub cf) + | Ppat_record_unboxed_product (lpl, cf) -> + let fields = + List.map + (map_tuple3 + (map_loc sub) + (map_opt (sub.typ sub)) + (map_opt (sub.pat sub))) + lpl + in + record_unboxed_product ~loc ~attrs fields (Flag.map_obj_closed sub cf) | Ppat_array (mf, pl) -> array ~loc ~attrs (Flag.map_mutable sub mf) (List.map (sub.pat sub) pl) | Ppat_list pl -> list ~loc ~attrs (List.map (sub.pat sub) pl) diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 16b25375e8..a92923f555 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -330,6 +330,17 @@ and pattern_desc = - [{ l1=P1; ...; ln=Pn; _}] when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + Invariant: [n > 0] + *) + | Ppat_record_unboxed_product of + (Longident.t loc * core_type option * pattern option) list + * obj_closed_flag + (** [Ppat_record_unboxed_product([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: + - [#{ l1=P1; ...; ln=Pn }] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} + - [#{ l1=P1; ...; ln=Pn; _}] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + Invariant: [n > 0] *) | Ppat_array of mutable_flag * pattern list @@ -443,9 +454,22 @@ and expression_desc = - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] + Invariant: [n > 0] + *) + | Pexp_record_unboxed_product of + ( Longident.t loc + * type_constraint option + * expression option) + list + * expression option + (** [Pexp_record_unboxed_product([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents + - [#{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [#{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] + Invariant: [n > 0] *) | Pexp_field of expression * Longident.t loc (** [E.l] *) + | Pexp_unboxed_field of expression * Longident.t loc (** [E.#l] *) | Pexp_setfield of expression * Longident.t loc * expression (** [E1.l <- E2] *) | Pexp_array of mutable_flag * expression list @@ -696,6 +720,7 @@ and type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list | Ptype_record of label_declaration list (** Invariant: non-empty list *) + | Ptype_record_unboxed_product of label_declaration list (** Invariant: non-empty list *) | Ptype_open and label_declaration = diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 0542bece9c..330c0bb9ab 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -352,6 +352,9 @@ and pattern i ppf x = | Ppat_record (l, c) -> line i ppf "Ppat_record %a\n" fmt_obj_closed_flag c; list i longident_x_pattern ppf l; + | Ppat_record_unboxed_product (l, c) -> + line i ppf "Ppat_record_unboxed_product %a\n" fmt_obj_closed_flag c; + list i longident_x_pattern ppf l; | Ppat_array (mf, l) -> line i ppf "Ppat_array %a\n" fmt_mutable_flag mf; list i pattern ppf l; @@ -446,10 +449,18 @@ and expression i ppf x = line i ppf "Pexp_record\n"; list i longident_x_expression ppf l; option i expression ppf eo; + | Pexp_record_unboxed_product (l, eo) -> + line i ppf "Pexp_record_unboxed_product\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; | Pexp_field (e, li) -> line i ppf "Pexp_field\n"; expression i ppf e; longident_loc i ppf li; + | Pexp_unboxed_field (e, li) -> + line i ppf "Pexp_unboxed_field\n"; + expression i ppf e; + longident_loc i ppf li; | Pexp_setfield (e1, li, e2) -> line i ppf "Pexp_setfield\n"; expression i ppf e1; @@ -745,6 +756,9 @@ and type_kind i ppf x = | Ptype_record l -> line i ppf "Ptype_record\n"; list (i+1) label_decl ppf l; + | Ptype_record_unboxed_product l -> + line i ppf "Ptype_record_unboxed_product\n"; + list (i+1) label_decl ppf l; | Ptype_open -> line i ppf "Ptype_open\n"; From dbc901cd23f09032ec213913213cbdde62ecf9ef Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Fri, 24 Jan 2025 12:21:51 -0500 Subject: [PATCH 2/4] parser changes --- vendor/parser-extended/lexer.mll | 2 ++ vendor/parser-extended/parser.mly | 18 ++++++++++++++++-- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/vendor/parser-extended/lexer.mll b/vendor/parser-extended/lexer.mll index f93f3e832d..b4e09a410d 100644 --- a/vendor/parser-extended/lexer.mll +++ b/vendor/parser-extended/lexer.mll @@ -756,11 +756,13 @@ rule token = parse | "(" { LPAREN } | ")" { RPAREN } | "#(" { HASHLPAREN } + | "#{" { HASHLBRACE } | "*" { STAR } | "," { COMMA } | "->" { MINUSGREATER } | "." { DOT } | ".." { DOTDOT } + | ".#" { DOTHASH } | "." (dotsymbolchar symbolchar* as op) { DOTOP op } | ":" { COLON } | "::" { COLONCOLON } diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 93bc3a414b..eaf13df89b 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -800,6 +800,7 @@ let transl_label ~pattern ~arg_label ~loc = %token DONE "done" %token DOT "." %token DOTDOT ".." +%token DOTHASH ".#" %token DOWNTO "downto" %token ELSE "else" %token END "end" @@ -819,6 +820,7 @@ let transl_label ~pattern ~arg_label ~loc = %token GREATERRBRACE ">}" %token GREATERRBRACKET ">]" %token HASHLPAREN "#(" +%token HASHLBRACE "#{" %token IF "if" %token IN "in" %token INCLUDE "include" @@ -987,12 +989,12 @@ The precedences must be listed from low to high. %nonassoc HASH HASH_SUFFIX /* simple_expr/toplevel_directive */ %left HASHOP %nonassoc below_DOT -%nonassoc DOT DOTOP +%nonassoc DOT DOTHASH DOTOP /* Finally, the first tokens of simple_expr are above everything else. */ %nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT HASH_FLOAT INT HASH_INT OBJECT LBRACE LBRACELESS LBRACKET LBRACKETBAR LBRACKETCOLON LIDENT LPAREN NEW PREFIXOP STRING TRUE UIDENT UNDERSCORE - LBRACKETPERCENT QUOTED_STRING_EXPR STACK HASHLPAREN + LBRACKETPERCENT QUOTED_STRING_EXPR STACK HASHLBRACE HASHLPAREN /* Entry points */ @@ -2810,6 +2812,8 @@ comprehension_clause: { Pexp_override [] } | simple_expr DOT mkrhs(label_longident) { Pexp_field($1, $3) } + | simple_expr DOTHASH mkrhs(label_longident) + { Pexp_unboxed_field($1, $3) } | od=open_dot_declaration DOT LPAREN seq_expr RPAREN { Pexp_open(od, $4) } | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE @@ -2843,6 +2847,9 @@ comprehension_clause: | LBRACE record_expr_content RBRACE { let (exten, fields) = $2 in Pexp_record(fields, exten) } + | HASHLBRACE record_expr_content RBRACE + { let (exten, fields) = $2 in + Pexp_record_unboxed_product(fields, exten) } | LBRACE record_expr_content error { unclosed "{" $loc($1) "}" $loc($3) } | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE @@ -3459,6 +3466,9 @@ simple_delimited_pattern: LBRACE record_pat_content RBRACE { let (fields, closed) = $2 in Ppat_record(fields, closed) } + | HASHLBRACE record_pat_content RBRACE + { let (fields, closed) = $2 in + Ppat_record_unboxed_product(fields, closed) } | LBRACE record_pat_content error { unclosed "{" $loc($1) "}" $loc($3) } | LBRACKET pattern_semi_list RBRACKET @@ -3641,6 +3651,10 @@ nonempty_type_kind: priv = inline_private_flag LBRACE ls = label_declarations RBRACE { (Ptype_record ls, priv, oty) } + | oty = type_synonym + priv = inline_private_flag + HASHLBRACE ls = label_declarations RBRACE + { (Ptype_record_unboxed_product ls, priv, oty) } ; %inline type_synonym: ioption(terminated(core_type, EQUAL)) From cbcbe8f22527f3e9cad82aa82b41d9398cfb077e Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Fri, 24 Jan 2025 13:50:00 -0500 Subject: [PATCH 3/4] Now my fingers hurt --- lib/Ast.ml | 66 +++-- lib/Extended_ast.ml | 9 + test/passing/dune.inc | 72 +++++ test/passing/tests/unboxed_record.ml | 219 ++++++++++++++ test/passing/tests/unboxed_record.ml.err | 9 + test/passing/tests/unboxed_record.ml.js-ref | 267 ++++++++++++++++++ test/passing/tests/unboxed_record.ml.ref | 224 +++++++++++++++ .../tests/unboxed_records_cmts_attrs.ml | 122 ++++++++ .../unboxed_records_cmts_attrs.ml.js-ref | 127 +++++++++ 9 files changed, 1099 insertions(+), 16 deletions(-) create mode 100644 test/passing/tests/unboxed_record.ml create mode 100644 test/passing/tests/unboxed_record.ml.err create mode 100644 test/passing/tests/unboxed_record.ml.js-ref create mode 100644 test/passing/tests/unboxed_record.ml.ref create mode 100644 test/passing/tests/unboxed_records_cmts_attrs.ml create mode 100644 test/passing/tests/unboxed_records_cmts_attrs.ml.js-ref diff --git a/lib/Ast.ml b/lib/Ast.ml index 4de99b565c..708546f8ff 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -202,8 +202,9 @@ module Exp = struct |Pexp_construct (_, None) |Pexp_variant (_, None) |Pexp_override _ | Pexp_open _ | Pexp_extension _ | Pexp_hole - |Pexp_record _ | Pexp_array _ | Pexp_list _ - |Pexp_list_comprehension _ | Pexp_array_comprehension _ -> + |Pexp_record _ | Pexp_record_unboxed_product _ | Pexp_array _ + |Pexp_list _ | Pexp_list_comprehension _ | Pexp_array_comprehension _ + |Pexp_unboxed_tuple _ -> true | Pexp_prefix (_, e) | Pexp_field (e, _) | Pexp_send (e, _) -> is_simple_in_parser e @@ -211,7 +212,18 @@ module Exp = struct String.length txt > 0 && Char.(String.get txt 0 = '#') && is_simple_in_parser e1 && is_simple_in_parser e2 - | _ -> false + | Pexp_indexop_access {pia_rhs= Some _; _} + |Pexp_construct (_, Some _) + |Pexp_variant (_, Some _) + |Pexp_unreachable | Pexp_let _ | Pexp_function _ | Pexp_fun _ + |Pexp_apply _ | Pexp_match _ | Pexp_try _ | Pexp_tuple _ + |Pexp_unboxed_field _ | Pexp_setfield _ | Pexp_ifthenelse _ + |Pexp_sequence _ | Pexp_while _ | Pexp_for _ | Pexp_constraint _ + |Pexp_coerce _ | Pexp_setinstvar _ | Pexp_letmodule _ + |Pexp_letexception _ | Pexp_assert _ | Pexp_lazy _ | Pexp_poly _ + |Pexp_newtype _ | Pexp_pack _ | Pexp_letopen _ | Pexp_letop _ + |Pexp_stack _ | Pexp_beginend _ | Pexp_parens _ | Pexp_cons _ -> + false end module Pat = struct @@ -240,22 +252,30 @@ module Pat = struct non-simple pattern. *) let rec is_simple_in_parser {ppat_desc; _} = match ppat_desc with - | Ppat_var _ | Ppat_record _ | Ppat_list _ | Ppat_array _ | Ppat_any - |Ppat_constant _ + | Ppat_var _ | Ppat_record _ | Ppat_record_unboxed_product _ + |Ppat_list _ | Ppat_array _ | Ppat_any | Ppat_constant _ |Ppat_construct (_, None) |Ppat_variant (_, None) - |Ppat_type _ | Ppat_extension _ -> + |Ppat_type _ | Ppat_extension _ | Ppat_unboxed_tuple _ -> true | Ppat_open (_, p) -> is_simple_in_parser p - | _ -> false + | Ppat_construct (_, Some _) + |Ppat_variant (_, Some _) + |Ppat_alias _ | Ppat_interval _ | Ppat_tuple _ | Ppat_or _ + |Ppat_constraint (_, _, _) + |Ppat_lazy _ + |Ppat_unpack (_, _) + |Ppat_exception _ | Ppat_cons _ -> + false let has_trailing_attributes {ppat_desc; ppat_attributes; _} = match ppat_desc with | Ppat_construct (_, None) |Ppat_constant _ | Ppat_any | Ppat_var _ |Ppat_variant (_, None) - |Ppat_record _ | Ppat_array _ | Ppat_list _ | Ppat_type _ - |Ppat_unpack _ | Ppat_extension _ | Ppat_open _ | Ppat_interval _ -> + |Ppat_record _ | Ppat_record_unboxed_product _ | Ppat_array _ + |Ppat_list _ | Ppat_type _ | Ppat_unpack _ | Ppat_extension _ + |Ppat_open _ | Ppat_interval _ -> false | _ -> List.exists ppat_attributes ~f:(Fn.non Attr.is_doc) end @@ -1018,7 +1038,7 @@ end = struct | Ptype_variant cd1N -> List.exists cd1N ~f:(fun {pcd_args; pcd_res; _} -> check_cstr pcd_args || Option.exists pcd_res ~f ) - | Ptype_record ld1N -> + | Ptype_record ld1N | Ptype_record_unboxed_product ld1N -> List.exists ld1N ~f:(fun {pld_type; _} -> typ == pld_type) | _ -> false ) || Option.exists ptype_manifest ~f ) @@ -1039,7 +1059,7 @@ end = struct | Ppat_extension (_, PTyp t) -> assert (typ == t) | Ppat_unpack (_, Some (_, l, _)) -> assert (List.exists l ~f:(fun (_, t) -> typ == t)) - | Ppat_record (l, _) -> + | Ppat_record (l, _) | Ppat_record_unboxed_product (l, _) -> assert (List.exists l ~f:(fun (_, t, _) -> Option.exists t ~f)) | _ -> assert false ) | Exp ctx -> ( @@ -1053,7 +1073,7 @@ end = struct | Pexp_coerce (_, Some t1, t2) -> assert (typ == t1 || typ == t2) | Pexp_letexception (ext, _) -> assert (check_ext ext) | Pexp_object _ -> assert false - | Pexp_record (en1, _) -> + | Pexp_record (en1, _) | Pexp_record_unboxed_product (en1, _) -> assert ( List.exists en1 ~f:(fun (_, c, _) -> Option.exists c ~f:(function @@ -1651,7 +1671,7 @@ end = struct | Pexp_tuple e1N | Pexp_unboxed_tuple e1N -> List.for_all e1N ~f:(fun (_, e) -> Exp.is_trivial e) && fit_margin c (width xexp) - | Pexp_record (e1N, e0) -> + | Pexp_record (e1N, e0) | Pexp_record_unboxed_product (e1N, e0) -> Option.for_all e0 ~f:Exp.is_trivial && List.for_all e1N ~f:(fun (_, c, eo) -> Option.is_none c && Option.for_all eo ~f:Exp.is_trivial ) @@ -2069,7 +2089,9 @@ end = struct | Pat {ppat_desc= Ppat_cons _; _}, inner -> ( match inner with | Ppat_cons _ -> true - | Ppat_construct _ | Ppat_record _ | Ppat_variant _ -> false + | Ppat_construct _ | Ppat_record _ | Ppat_record_unboxed_product _ + |Ppat_unboxed_tuple _ | Ppat_variant _ -> + false | _ -> true ) | Fp {pparam_desc= Pparam_val (_, _, _, _); _}, Ppat_cons _ -> true | Pat {ppat_desc= Ppat_construct _; _}, Ppat_cons _ -> true @@ -2635,12 +2657,14 @@ end = struct , _ ) when exp2 == exp -> false - | Pexp_record (flds, _) + | (Pexp_record (flds, _) | Pexp_record_unboxed_product (flds, _)) when List.exists flds ~f:(fun (_, _, e0) -> Option.exists e0 ~f:(fun x -> x == exp) ) -> exposed_right_exp Non_apply exp (* Non_apply is perhaps pessimistic *) | Pexp_record (_, Some ({pexp_desc= Pexp_prefix _; _} as e0)) + |Pexp_record_unboxed_product + (_, Some ({pexp_desc= Pexp_prefix _; _} as e0)) when e0 == exp -> (* don't put parens around [!e] in [{ !e with a; b }] *) false @@ -2651,9 +2675,19 @@ end = struct ( Pexp_ident _ | Pexp_constant _ | Pexp_record _ | Pexp_constraint _ | Pexp_field _ ) ; _ } as e0 ) ) + |Pexp_record_unboxed_product + ( _ + , Some + ( { pexp_desc= + ( Pexp_ident _ | Pexp_constant _ | Pexp_record _ + | Pexp_constraint _ | Pexp_field _ ) + ; _ } as e0 ) ) when e0 == exp -> false - | Pexp_record (_, Some e0) when e0 == exp -> true + | Pexp_record (_, Some e0) + |Pexp_record_unboxed_product (_, Some e0) + when e0 == exp -> + true | Pexp_override fields when List.exists fields ~f:(fun (_, e0) -> e0 == exp) -> exposed_right_exp Sequence exp diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml index ac4b659717..b8f15708a5 100644 --- a/lib/Extended_ast.ml +++ b/lib/Extended_ast.ml @@ -181,6 +181,9 @@ module Parse = struct | {ppat_desc= Ppat_record (fields, flag); _} as e -> let fields = List.map ~f:(pat_record_field m) fields in {e with ppat_desc= Ppat_record (fields, flag)} + | {ppat_desc= Ppat_record_unboxed_product (fields, flag); _} as e -> + let fields = List.map ~f:(pat_record_field m) fields in + {e with ppat_desc= Ppat_record_unboxed_product (fields, flag)} (* [(module M) : (module T)] -> [(module M : T)] *) | { ppat_desc= Ppat_constraint @@ -212,6 +215,12 @@ module Parse = struct { e with pexp_desc= Pexp_record (fields, Option.map ~f:(m.expr m) with_) } + | {pexp_desc= Pexp_record_unboxed_product (fields, with_); _} as e -> + let fields = List.map ~f:(record_field m) fields in + { e with + pexp_desc= + Pexp_record_unboxed_product + (fields, Option.map ~f:(m.expr m) with_) } (* [( + ) 1 2] -> [1 + 2] *) | { pexp_desc= Pexp_apply diff --git a/test/passing/dune.inc b/test/passing/dune.inc index f3a498f741..8e7f917cd3 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -11690,6 +11690,78 @@ (package ocamlformat) (action (diff tests/unary_hash.ml.js-err unary_hash.ml.js-stderr))) +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to unboxed_record.ml.stdout + (with-stderr-to unboxed_record.ml.stderr + (run %{bin:ocamlformat} --margin-check %{dep:tests/unboxed_record.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/unboxed_record.ml.ref unboxed_record.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/unboxed_record.ml.err unboxed_record.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to unboxed_record.ml.js-stdout + (with-stderr-to unboxed_record.ml.js-stderr + (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/unboxed_record.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/unboxed_record.ml.js-ref unboxed_record.ml.js-stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/unboxed_record.ml.js-err unboxed_record.ml.js-stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to unboxed_records_cmts_attrs.ml.stdout + (with-stderr-to unboxed_records_cmts_attrs.ml.stderr + (run %{bin:ocamlformat} --margin-check %{dep:tests/unboxed_records_cmts_attrs.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/unboxed_records_cmts_attrs.ml unboxed_records_cmts_attrs.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/unboxed_records_cmts_attrs.ml.err unboxed_records_cmts_attrs.ml.stderr))) + +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to unboxed_records_cmts_attrs.ml.js-stdout + (with-stderr-to unboxed_records_cmts_attrs.ml.js-stderr + (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/unboxed_records_cmts_attrs.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/unboxed_records_cmts_attrs.ml.js-ref unboxed_records_cmts_attrs.ml.js-stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/unboxed_records_cmts_attrs.ml.js-err unboxed_records_cmts_attrs.ml.js-stderr))) + (rule (deps tests/.ocamlformat ) (package ocamlformat) diff --git a/test/passing/tests/unboxed_record.ml b/test/passing/tests/unboxed_record.ml new file mode 100644 index 0000000000..00795a3e8f --- /dev/null +++ b/test/passing/tests/unboxed_record.ml @@ -0,0 +1,219 @@ +(* This test file is a copy of record.ml, updated to use unboxed records, and with some + additional tests at the end. *) + +type t = #{x: int; y: int} + +let _ = #{x= 1; y= 2} + +let _ = #{!e with a; b= c} + +let _ = #{!(f e) with a; b= c} + +let _ = + #{ !looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + with + a + ; b= c } + +let _ = + #{ !looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + with + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ; b= c } + +let _ = #{(a : t) with a; b; c} + +let _ = #{(f a) with a; b; c} + +let _ = #{(a ; a) with a; b; c} + +let _ = #{(if x then e else e) with e1; e2} + +let _ = #{(match x with x -> e) with e1; e2} + +let _ = #{(x : x) with e1; e2} + +let _ = #{(x :> x) with e1; e2} + +let _ = #{(x#x) with e1; e2} + +let f ~l:#{f; g} = e + +let f ?l:(#{f; g}) = e + +let _ = #{a; b = ((match b with `A -> A | `B -> B | `C -> C) : c); c} + +let a () = A #{A.a = (a : t)} + +let x = + #{ aaaaaaaaaa + (* b *); b} + +let x = + #{ aaaaaaaaaa + (* b *) + ; b} + +type t = #{ a : (module S); b : (module S) } + +let _ = #{ a = (module M : S); b = (module M : S) } + +let to_string #{x; _ (* we should print y *)} = string_of_int x + +let #{ x = (x : t) } = x + +(* Copy of record.ml ends here *) + +(* Basic field access. *) + +let _ = r.#x + +(* Tests adapted from unboxed_tuples.ml *) +let _ = + #{ u = abcdefghijklmnopqrstuvwxyz + ; w = bcdefghijklmnopqrstuvwxyz + ; x = abcdefghijklmnopqrstuvwxyz + ; y = abcdefghijklmnopqrstuvwxyz + ; z = abcdefghijklmnopqrstuvwxyz } + +let _ = + match () with + | #{ a = abcdefghijklmnopqrstuvwxyz + ; b = abcdefghijklmnopqrstuvwxyz + ; c = abcdefghijklmnopqrstuvwxyz + ; d = abcdefghijklmnopqrstuvwxyz + ; e = abcdefghijklmnopqrstuvwxyz } -> + () + +type t = + #{ a : abcdefghijklmnopqrstuvwxyz + ; b : abcdefghijklmnopqrstuvwxyz + ; c : abcdefghijklmnopqrstuvwxyz + ; d : abcdefghijklmnopqrstuvwxyz + ; e : abcdefghijklmnopqrstuvwxyz } + +type t = t' = + #{ a : abcdefghijklmnopqrstuvwxyz + ; b : abcdefghijklmnopqrstuvwxyz + ; c : abcdefghijklmnopqrstuvwxyz + ; d : abcdefghijklmnopqrstuvwxyz + ; e : abcdefghijklmnopqrstuvwxyz } + +let x = match foo with #{x = Some x; y = Some y} -> () + +let foo a = + match a with + | #{ l1 = None + ; l2 = Some _ + ; l3 = [1; 2] + ; l4 = 3 :: [] + ; l5 = {x: _; y: _} + ; l6 = 42 + ; l7 = _ + ; l8 = `Baz + ; l9 = `Bar _ + ; l10 = (1 | 2) + ; l11 = [|1; 2|] + ; l12 = (3 : int) + ; l13 = (lazy _) + ; l14 = ( module M ) + ; l15 = (exception _) + ; l16 = [%bar baz] + ; l17 = M.(A) + ; l18 = M.(A 42) } -> + false + +let bar = + #{ l1 = foo + ; l2 = 42 + ; l3 = (let x = 18 in + x ) + ; l4 = (function x -> x) + ; l5 = (fun x -> x) + ; l6 = foo 42 + ; l7 = (match () with () -> ()) + ; l8 = (try () with _ -> ()) + ; l9 = (1, 2) + ; l10 = (~x:1, ~y:2) + ; l11 = None + ; l12 = Some 42 + ; l13 = `A + ; l14 = `B 42 + ; l15 = {x= 42; z= false} + ; l16 = foo.lbl + ; l17 = (foo 42).lbl + ; l18 = (foo.lbl <- 42) + ; l19 = [|1; 2|] + ; l20 = [:1; 2:] + ; l21 = [1; 2] + ; l22 = [a for a = 1 to 10] + ; l23 = (if true then true else false) + ; l24 = (() ; ()) + ; l25 = while true do + () + done + ; l26 = for i = 1 to 2 do + () + done + ; l27 = (42 : int) + ; l28 = (42 :> int) + ; l29 = (42 : int :> bool) + ; l30 = foo#bar + ; l31 = foo #~# bar + ; l32 = new M.c + ; l33 = (x <- 2) + ; l34 = {} + ; l35 = (let module M = N in + () ) + ; l36 = (let exception Ex in + () ) + ; l37 = assert true } + +let _ = + match w with + | A -> #{a = []; b = A.(B (C (f x))); c = None; d = f x y; e = g y x} + | B -> #{a; b; c; d; e} + | C -> + #{ a = [] + ; b = A.(B (C (this is very looooooooooooooooooooooooooooooooooooong x))) + ; c = None + ; d = f x y + ; e = g y x } + +let _ = [%ext #{a = 1; b = 2; c = 3}] + +let _ = + [%ext + #{ loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; y = loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; z = 3 }] + +type t = int [@@deriving #{a = 1; b = 2; c = 3}] + +type t = int +[@@deriving + #{ sexp + ; compare + ; x = loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + }] + +let _ = + #{ a = 1 + ; b = 2 + ; c = looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + } + +let _ = #{a = 1; b = 2; c = 3; short} ;; + +#{ a = 1 + ; b = 2 + ; looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; d = looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + } +;; + +#{a = 1; b = 2; c = 3; short} + +(* make sure to not drop parens for local open. *) +let _ = A.(#{a = 1; b = 2}) diff --git a/test/passing/tests/unboxed_record.ml.err b/test/passing/tests/unboxed_record.ml.err new file mode 100644 index 0000000000..9a8b01fc4e --- /dev/null +++ b/test/passing/tests/unboxed_record.ml.err @@ -0,0 +1,9 @@ +Warning: tests/unboxed_record.ml:12 exceeds the margin +Warning: tests/unboxed_record.ml:18 exceeds the margin +Warning: tests/unboxed_record.ml:178 exceeds the margin +Warning: tests/unboxed_record.ml:187 exceeds the margin +Warning: tests/unboxed_record.ml:189 exceeds the margin +Warning: tests/unboxed_record.ml:199 exceeds the margin +Warning: tests/unboxed_record.ml:206 exceeds the margin +Warning: tests/unboxed_record.ml:207 exceeds the margin +Warning: tests/unboxed_record.ml:216 exceeds the margin diff --git a/test/passing/tests/unboxed_record.ml.js-ref b/test/passing/tests/unboxed_record.ml.js-ref new file mode 100644 index 0000000000..a716e96347 --- /dev/null +++ b/test/passing/tests/unboxed_record.ml.js-ref @@ -0,0 +1,267 @@ +(* This test file is a copy of record.ml, updated to use unboxed records, and with some + additional tests at the end. *) + +type t = + #{ x : int + ; y : int + } + +let _ = #{ x = 1; y = 2 } +let _ = #{ !e with a; b = c } +let _ = #{ !(f e) with a; b = c } + +let _ = + #{ !looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + with + a + ; b = c + } +;; + +let _ = + #{ !looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + with + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ; b = c + } +;; + +let _ = #{ (a : t) with a; b; c } +let _ = #{ (f a) with a; b; c } + +let _ = + #{ (a; + a) + with + a + ; b + ; c + } +;; + +let _ = #{ (if x then e else e) with e1; e2 } + +let _ = + #{ (match x with + | x -> e) + with + e1 + ; e2 + } +;; + +let _ = #{ (x : x) with e1; e2 } +let _ = #{ (x :> x) with e1; e2 } +let _ = #{ (x#x) with e1; e2 } +let f ~l:#{ f; g } = e +let f ?l:(#{ f; g }) = e + +let _ = + #{ a + ; b = + ((match b with + | `A -> A + | `B -> B + | `C -> C) + : c) + ; c + } +;; + +let a () = A #{ A.a : t } +let x = #{ aaaaaaaaaa (* b *); b } +let x = #{ aaaaaaaaaa (* b *); b } + +type t = + #{ a : (module S) + ; b : (module S) + } + +let _ = #{ a = (module M : S); b = (module M : S) } +let to_string #{ x; _ (* we should print y *) } = string_of_int x +let #{ x : t } = x + +(* Copy of record.ml ends here *) + +(* Basic field access. *) + +let _ = r.#x + +(* Tests adapted from unboxed_tuples.ml *) +let _ = + #{ u = abcdefghijklmnopqrstuvwxyz + ; w = bcdefghijklmnopqrstuvwxyz + ; x = abcdefghijklmnopqrstuvwxyz + ; y = abcdefghijklmnopqrstuvwxyz + ; z = abcdefghijklmnopqrstuvwxyz + } +;; + +let _ = + match () with + | #{ a = abcdefghijklmnopqrstuvwxyz + ; b = abcdefghijklmnopqrstuvwxyz + ; c = abcdefghijklmnopqrstuvwxyz + ; d = abcdefghijklmnopqrstuvwxyz + ; e = abcdefghijklmnopqrstuvwxyz + } -> () +;; + +type t = + #{ a : abcdefghijklmnopqrstuvwxyz + ; b : abcdefghijklmnopqrstuvwxyz + ; c : abcdefghijklmnopqrstuvwxyz + ; d : abcdefghijklmnopqrstuvwxyz + ; e : abcdefghijklmnopqrstuvwxyz + } + +type t = t' = + #{ a : abcdefghijklmnopqrstuvwxyz + ; b : abcdefghijklmnopqrstuvwxyz + ; c : abcdefghijklmnopqrstuvwxyz + ; d : abcdefghijklmnopqrstuvwxyz + ; e : abcdefghijklmnopqrstuvwxyz + } + +let x = + match foo with + | #{ x = Some x; y = Some y } -> () +;; + +let foo a = + match a with + | #{ l1 = None + ; l2 = Some _ + ; l3 = [ 1; 2 ] + ; l4 = 3 :: [] + ; l5 = { x : _; y : _ } + ; l6 = 42 + ; l7 = _ + ; l8 = `Baz + ; l9 = `Bar _ + ; l10 = 1 | 2 + ; l11 = [| 1; 2 |] + ; l12 = (3 : int) + ; l13 = (lazy _) + ; l14 = (module M) + ; l15 = (exception _) + ; l16 = [%bar baz] + ; l17 = M.(A) + ; l18 = M.(A 42) + } -> false +;; + +let bar = + #{ l1 = foo + ; l2 = 42 + ; l3 = + (let x = 18 in + x) + ; l4 = + (function + | x -> x) + ; l5 = (fun x -> x) + ; l6 = foo 42 + ; l7 = + (match () with + | () -> ()) + ; l8 = + (try () with + | _ -> ()) + ; l9 = 1, 2 + ; l10 = ~x:1, ~y:2 + ; l11 = None + ; l12 = Some 42 + ; l13 = `A + ; l14 = `B 42 + ; l15 = { x = 42; z = false } + ; l16 = foo.lbl + ; l17 = (foo 42).lbl + ; l18 = foo.lbl <- 42 + ; l19 = [| 1; 2 |] + ; l20 = [: 1; 2 :] + ; l21 = [ 1; 2 ] + ; l22 = [ a for a = 1 to 10 ] + ; l23 = (if true then true else false) + ; l24 = + ((); + ()) + ; l25 = + while true do + () + done + ; l26 = + for i = 1 to 2 do + () + done + ; l27 = (42 : int) + ; l28 = (42 :> int) + ; l29 = (42 : int :> bool) + ; l30 = foo#bar + ; l31 = foo #~# bar + ; l32 = new M.c + ; l33 = x <- 2 + ; l34 = {} + ; l35 = + (let module M = N in + ()) + ; l36 = + (let exception Ex in + ()) + ; l37 = assert true + } +;; + +let _ = + match w with + | A -> #{ a = []; b = A.(B (C (f x))); c = None; d = f x y; e = g y x } + | B -> #{ a; b; c; d; e } + | C -> + #{ a = [] + ; b = A.(B (C (this is very looooooooooooooooooooooooooooooooooooong x))) + ; c = None + ; d = f x y + ; e = g y x + } +;; + +let _ = [%ext #{ a = 1; b = 2; c = 3 }] + +let _ = + [%ext + #{ loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; y = loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; z = 3 + }] +;; + +type t = int [@@deriving #{ a = 1; b = 2; c = 3 }] + +type t = int +[@@deriving + #{ sexp + ; compare + ; x = loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + }] + +let _ = + #{ a = 1 + ; b = 2 + ; c = looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + } +;; + +let _ = #{ a = 1; b = 2; c = 3; short };; + +#{ a = 1 + ; b = 2 + ; looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; d = looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + } +;; + +#{ a = 1; b = 2; c = 3; short } + +(* make sure to not drop parens for local open. *) +let _ = A.(#{ a = 1; b = 2 }) diff --git a/test/passing/tests/unboxed_record.ml.ref b/test/passing/tests/unboxed_record.ml.ref new file mode 100644 index 0000000000..3812bc201a --- /dev/null +++ b/test/passing/tests/unboxed_record.ml.ref @@ -0,0 +1,224 @@ +(* This test file is a copy of record.ml, updated to use unboxed records, and + with some additional tests at the end. *) + +type t = #{x: int; y: int} + +let _ = #{x= 1; y= 2} + +let _ = #{!e with a; b= c} + +let _ = #{!(f e) with a; b= c} + +let _ = + #{ !looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + with + a + ; b= c } + +let _ = + #{ !looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo + with + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + ; b= c } + +let _ = #{(a : t) with a; b; c} + +let _ = #{(f a) with a; b; c} + +let _ = #{(a ; a) with a; b; c} + +let _ = #{(if x then e else e) with e1; e2} + +let _ = #{(match x with x -> e) with e1; e2} + +let _ = #{(x : x) with e1; e2} + +let _ = #{(x :> x) with e1; e2} + +let _ = #{(x#x) with e1; e2} + +let f ~l:#{f; g} = e + +let f ?l:(#{f; g}) = e + +let _ = #{a; b= (match b with `A -> A | `B -> B | `C -> C : c); c} + +let a () = A #{A.a: t} + +let x = #{aaaaaaaaaa (* b *); b} + +let x = #{aaaaaaaaaa (* b *); b} + +type t = #{a: (module S); b: (module S)} + +let _ = #{a= (module M : S); b= (module M : S)} + +let to_string #{x; _ (* we should print y *)} = string_of_int x + +let #{x: t} = x + +(* Copy of record.ml ends here *) + +(* Basic field access. *) + +let _ = r.#x + +(* Tests adapted from unboxed_tuples.ml *) +let _ = + #{ u= abcdefghijklmnopqrstuvwxyz + ; w= bcdefghijklmnopqrstuvwxyz + ; x= abcdefghijklmnopqrstuvwxyz + ; y= abcdefghijklmnopqrstuvwxyz + ; z= abcdefghijklmnopqrstuvwxyz } + +let _ = + match () with + | #{ a= abcdefghijklmnopqrstuvwxyz + ; b= abcdefghijklmnopqrstuvwxyz + ; c= abcdefghijklmnopqrstuvwxyz + ; d= abcdefghijklmnopqrstuvwxyz + ; e= abcdefghijklmnopqrstuvwxyz } -> + () + +type t = + #{ a: abcdefghijklmnopqrstuvwxyz + ; b: abcdefghijklmnopqrstuvwxyz + ; c: abcdefghijklmnopqrstuvwxyz + ; d: abcdefghijklmnopqrstuvwxyz + ; e: abcdefghijklmnopqrstuvwxyz } + +type t = t' = + #{ a: abcdefghijklmnopqrstuvwxyz + ; b: abcdefghijklmnopqrstuvwxyz + ; c: abcdefghijklmnopqrstuvwxyz + ; d: abcdefghijklmnopqrstuvwxyz + ; e: abcdefghijklmnopqrstuvwxyz } + +let x = match foo with #{x= Some x; y= Some y} -> () + +let foo a = + match a with + | #{ l1= None + ; l2= Some _ + ; l3= [1; 2] + ; l4= 3 :: [] + ; l5= {x: _; y: _} + ; l6= 42 + ; l7= _ + ; l8= `Baz + ; l9= `Bar _ + ; l10= 1 | 2 + ; l11= [|1; 2|] + ; l12= (3 : int) + ; l13= (lazy _) + ; l14= (module M) + ; l15= (exception _) + ; l16= [%bar baz] + ; l17= M.(A) + ; l18= M.(A 42) } -> + false + +let bar = + #{ l1= foo + ; l2= 42 + ; l3= + (let x = 18 in + x ) + ; l4= (function x -> x) + ; l5= (fun x -> x) + ; l6= foo 42 + ; l7= (match () with () -> ()) + ; l8= (try () with _ -> ()) + ; l9= (1, 2) + ; l10= (~x:1, ~y:2) + ; l11= None + ; l12= Some 42 + ; l13= `A + ; l14= `B 42 + ; l15= {x= 42; z= false} + ; l16= foo.lbl + ; l17= (foo 42).lbl + ; l18= foo.lbl <- 42 + ; l19= [|1; 2|] + ; l20= [:1; 2:] + ; l21= [1; 2] + ; l22= [a for a = 1 to 10] + ; l23= (if true then true else false) + ; l24= (() ; ()) + ; l25= + while true do + () + done + ; l26= + for i = 1 to 2 do + () + done + ; l27= (42 : int) + ; l28= (42 :> int) + ; l29= (42 : int :> bool) + ; l30= foo#bar + ; l31= foo #~# bar + ; l32= new M.c + ; l33= x <- 2 + ; l34= {} + ; l35= + (let module M = N in + () ) + ; l36= + (let exception Ex in + () ) + ; l37= assert true } + +let _ = + match w with + | A -> #{a= []; b= A.(B (C (f x))); c= None; d= f x y; e= g y x} + | B -> #{a; b; c; d; e} + | C -> + #{ a= [] + ; b= + A.(B (C (this is very looooooooooooooooooooooooooooooooooooong x))) + ; c= None + ; d= f x y + ; e= g y x } + +let _ = [%ext #{a= 1; b= 2; c= 3}] + +let _ = + [%ext + #{ loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; y= + loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; z= 3 }] + +type t = int [@@deriving #{a= 1; b= 2; c= 3}] + +type t = int +[@@deriving + #{ sexp + ; compare + ; x= + loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + }] + +let _ = + #{ a= 1 + ; b= 2 + ; c= + looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + } + +let _ = #{a= 1; b= 2; c= 3; short} ;; + +#{ a= 1 + ; b= 2 + ; looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + ; d= + looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong + } +;; + +#{a= 1; b= 2; c= 3; short} + +(* make sure to not drop parens for local open. *) +let _ = A.(#{a= 1; b= 2}) diff --git a/test/passing/tests/unboxed_records_cmts_attrs.ml b/test/passing/tests/unboxed_records_cmts_attrs.ml new file mode 100644 index 0000000000..431d966511 --- /dev/null +++ b/test/passing/tests/unboxed_records_cmts_attrs.ml @@ -0,0 +1,122 @@ +(* Tests making sure comments and attributes are handled reasonably by + unboxed record printing. *) + +(* Attrs around expressions *) +let y = #{a= z; b= z [@attr]} + +let y = #{a= z; b= z} [@@attr] + +let y = #{a= ((42 [@attr]) : int); b= 42} + +let y = #{a= a [@attr]; b= 42} + +(* Comments around expressions *) +let _ = (* baz *) #{x= 42; y} + +let _ = #{(* baz *) x= 42; y} + +let _ = #{x (* baz *)= 42; y} + +let _ = #{x= 42 (* baz *); y} + +let _ = #{x= 42; (* baz *) y} + +let _ = #{x= 42; y (* baz *)} + +let _ = #{x= 42; y} (* baz *) + +let _ = (* baz *) #{z; y: int} + +let _ = #{(* baz *) z; y: int} + +let _ = #{z (* baz *); y: int} + +let _ = #{z; (* baz *) y: int} + +let _ = #{z; y: (* baz *) int} + +let _ = #{z; y: (* baz *) int} + +let _ = #{z; y: int (* baz *)} + +let _ = #{z; y: int (* baz *)} + +let _ = #{z; y: int} (* baz *) + +(* Attrs around types *) +type t = #{x: (int[@attr]); y: bool} + +type t = #{x: int; y: (bool[@attr])} + +type t = #{x: int; y: bool [@attr]} + +type t = #{x: int; y: bool} [@@attr] + +(* Comments around types *) +type t = #{(* baz *) x: int; y: bool} + +type t = #{(* baz *) x: int; y: bool} + +type t = #{x (* baz *): int; y: bool} + +type t = #{x: (* baz *) int; y: bool} + +type t = #{x: int (* baz *); y: bool} + +type t = #{x: int; (* baz *) y: bool} + +type t = #{x: int; y (* baz *): bool} + +type t = #{x: int; y: (* baz *) bool} + +type t = #{x: int; y: bool (* baz *)} + +type t = #{x: int; y: bool} (* baz *) + +(* Attrs around patterns *) +let #{z= (z [@attr]); y} = () + +let #{z; y= (42 [@attr])} = () + +let (#{z; y= 42} [@attr]) = () + +(* Comments around patterns *) +let (* baz *) #{z; y= 42} = () + +let #{(* baz *) z; y= 42} = () + +let #{z (* baz *); y= 42} = () + +let #{z; (* baz *) y= 42} = () + +let #{z; y (* baz *)= 42} = () + +let #{z; y= (* baz *) 42} = () + +let #{z; y= 42 (* baz *)} = () + +let #{z; y= 42} (* baz *) = () + +let (* baz *) #{z= 42; y: int} = () + +let #{(* baz *) z= 42; y: int} = () + +let #{z (* baz *)= 42; y: int} = () + +let #{z= (* baz *) 42; y: int} = () + +let #{z= 42 (* baz *); y: int} = () + +let #{z= 42; (* baz *) y: int} = () + +let #{z= 42; y: (* baz *) int} = () + +let #{z= 42; y: (* baz *) int} = () + +let #{z= 42; y: (* baz *) int} = () + +let #{z= 42; y: int (* baz *)} = () + +let #{z= 42; y: int (* baz *)} = () + +let #{z= 42; y: int} (* baz *) = () diff --git a/test/passing/tests/unboxed_records_cmts_attrs.ml.js-ref b/test/passing/tests/unboxed_records_cmts_attrs.ml.js-ref new file mode 100644 index 0000000000..3f69939dfe --- /dev/null +++ b/test/passing/tests/unboxed_records_cmts_attrs.ml.js-ref @@ -0,0 +1,127 @@ +(* Tests making sure comments and attributes are handled reasonably by + unboxed record printing. *) + +(* Attrs around expressions *) +let y = #{ a = z; b = z [@attr] } +let y = #{ a = z; b = z } [@@attr] +let y = #{ a = ((42 [@attr]) : int); b = 42 } +let y = #{ a = a [@attr]; b = 42 } + +(* Comments around expressions *) +let _ = (* baz *) #{ x = 42; y } +let _ = #{ (* baz *) x = 42; y } +let _ = #{ x (* baz *) = 42; y } +let _ = #{ x = 42 (* baz *); y } +let _ = #{ x = 42; (* baz *) y } +let _ = #{ x = 42; y (* baz *) } +let _ = #{ x = 42; y } (* baz *) +let _ = (* baz *) #{ z; y : int } +let _ = #{ (* baz *) z; y : int } +let _ = #{ z (* baz *); y : int } +let _ = #{ z; (* baz *) y : int } +let _ = #{ z; y : (* baz *) int } +let _ = #{ z; y : (* baz *) int } +let _ = #{ z; y : int (* baz *) } +let _ = #{ z; y : int (* baz *) } +let _ = #{ z; y : int } (* baz *) + +(* Attrs around types *) +type t = + #{ x : (int[@attr]) + ; y : bool + } + +type t = + #{ x : int + ; y : (bool[@attr]) + } + +type t = + #{ x : int + ; y : bool [@attr] + } + +type t = + #{ x : int + ; y : bool + } +[@@attr] + +(* Comments around types *) +type t = + #{ (* baz *) x : int + ; y : bool + } + +type t = + #{ (* baz *) x : int + ; y : bool + } + +type t = + #{ x (* baz *) : int + ; y : bool + } + +type t = + #{ x : (* baz *) int + ; y : bool + } + +type t = + #{ x : int (* baz *) + ; y : bool + } + +type t = + #{ x : int + ; (* baz *) y : bool + } + +type t = + #{ x : int + ; y (* baz *) : bool + } + +type t = + #{ x : int + ; y : (* baz *) bool + } + +type t = + #{ x : int + ; y : bool (* baz *) + } + +type t = + #{ x : int + ; y : bool + } +(* baz *) + +(* Attrs around patterns *) +let #{ z = (z [@attr]); y } = () +let #{ z; y = (42 [@attr]) } = () +let (#{ z; y = 42 } [@attr]) = () + +(* Comments around patterns *) +let (* baz *) #{ z; y = 42 } = () +let #{ (* baz *) z; y = 42 } = () +let #{ z (* baz *); y = 42 } = () +let #{ z; (* baz *) y = 42 } = () +let #{ z; y (* baz *) = 42 } = () +let #{ z; y = (* baz *) 42 } = () +let #{ z; y = 42 (* baz *) } = () +let #{ z; y = 42 } (* baz *) = () +let (* baz *) #{ z = 42; y : int } = () +let #{ (* baz *) z = 42; y : int } = () +let #{ z (* baz *) = 42; y : int } = () +let #{ z = (* baz *) 42; y : int } = () +let #{ z = 42 (* baz *); y : int } = () +let #{ z = 42; (* baz *) y : int } = () +let #{ z = 42; y : (* baz *) int } = () +let #{ z = 42; y : (* baz *) int } = () +let #{ z = 42; y : (* baz *) int } = () +let #{ z = 42; y : int (* baz *) } = () +let #{ z = 42; y : int (* baz *) } = () +let #{ z = 42; y : int } (* baz *) = () From 4c55c63c9e7045e0fb308297f09658bf2b4611b7 Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Mon, 27 Jan 2025 16:21:30 -0500 Subject: [PATCH 4/4] Fix precedence of .# --- lib/Ast.ml | 37 ++++++++++++--------- test/passing/tests/unboxed_record.ml | 3 ++ test/passing/tests/unboxed_record.ml.js-ref | 3 ++ test/passing/tests/unboxed_record.ml.ref | 3 ++ 4 files changed, 31 insertions(+), 15 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 708546f8ff..64853c591e 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -149,7 +149,9 @@ module Exp = struct let rec is_trivial exp = match exp.pexp_desc with | Pexp_constant {pconst_desc= Pconst_string (_, _, None); _} -> true - | Pexp_constant _ | Pexp_field _ | Pexp_ident _ | Pexp_send _ -> true + | Pexp_constant _ | Pexp_field _ | Pexp_unboxed_field _ | Pexp_ident _ + |Pexp_send _ -> + true | Pexp_construct (_, exp) -> Option.for_all exp ~f:is_trivial | Pexp_prefix (_, e) -> is_trivial e | Pexp_apply @@ -164,7 +166,7 @@ module Exp = struct match e.pexp_desc with | Pexp_prefix _ -> true | Pexp_apply (op, _) -> exposed_left op - | Pexp_field (e, _) -> exposed_left e + | Pexp_field (e, _) | Pexp_unboxed_field (e, _) -> exposed_left e | _ -> false (** [mem_cls cls exp] holds if [exp] is in the named class of expressions @@ -206,7 +208,10 @@ module Exp = struct |Pexp_list _ | Pexp_list_comprehension _ | Pexp_array_comprehension _ |Pexp_unboxed_tuple _ -> true - | Pexp_prefix (_, e) | Pexp_field (e, _) | Pexp_send (e, _) -> + | Pexp_prefix (_, e) + |Pexp_field (e, _) + |Pexp_unboxed_field (e, _) + |Pexp_send (e, _) -> is_simple_in_parser e | Pexp_infix ({txt; _}, e1, e2) -> String.length txt > 0 @@ -217,12 +222,12 @@ module Exp = struct |Pexp_variant (_, Some _) |Pexp_unreachable | Pexp_let _ | Pexp_function _ | Pexp_fun _ |Pexp_apply _ | Pexp_match _ | Pexp_try _ | Pexp_tuple _ - |Pexp_unboxed_field _ | Pexp_setfield _ | Pexp_ifthenelse _ - |Pexp_sequence _ | Pexp_while _ | Pexp_for _ | Pexp_constraint _ - |Pexp_coerce _ | Pexp_setinstvar _ | Pexp_letmodule _ - |Pexp_letexception _ | Pexp_assert _ | Pexp_lazy _ | Pexp_poly _ - |Pexp_newtype _ | Pexp_pack _ | Pexp_letopen _ | Pexp_letop _ - |Pexp_stack _ | Pexp_beginend _ | Pexp_parens _ | Pexp_cons _ -> + |Pexp_setfield _ | Pexp_ifthenelse _ | Pexp_sequence _ | Pexp_while _ + |Pexp_for _ | Pexp_constraint _ | Pexp_coerce _ | Pexp_setinstvar _ + |Pexp_letmodule _ | Pexp_letexception _ | Pexp_assert _ | Pexp_lazy _ + |Pexp_poly _ | Pexp_newtype _ | Pexp_pack _ | Pexp_letopen _ + |Pexp_letop _ | Pexp_stack _ | Pexp_beginend _ | Pexp_parens _ + |Pexp_cons _ -> false end @@ -1657,7 +1662,7 @@ end = struct let ctx = Exp exp in match exp.pexp_desc with | Pexp_constant _ -> Exp.is_trivial exp - | Pexp_field _ | Pexp_ident _ | Pexp_send _ + | Pexp_field _ | Pexp_unboxed_field _ | Pexp_ident _ | Pexp_send _ |Pexp_construct (_, None) |Pexp_variant (_, None) -> true @@ -1838,7 +1843,7 @@ end = struct | Pexp_setfield (e0, _, _) when e0 == exp -> Some (Dot, Left) | Pexp_setfield (_, _, e0) when e0 == exp -> Some (LessMinus, Non) | Pexp_setinstvar _ -> Some (LessMinus, Non) - | Pexp_field _ -> Some (Dot, Left) + | Pexp_field _ | Pexp_unboxed_field _ -> Some (Dot, Left) (* We use [Dot] so [x#y] has the same precedence as [x.y], it is different to what is done in the parser, but it is intended. *) | Pexp_send _ -> Some (Dot, Left) @@ -1945,7 +1950,7 @@ end = struct prec_ast (Exp e) | Pexp_setfield _ -> Some LessMinus | Pexp_setinstvar _ -> Some LessMinus - | Pexp_field _ -> Some Dot + | Pexp_field _ | Pexp_unboxed_field _ -> Some Dot | Pexp_send _ -> Some Dot | _ -> None ) | Fp _ -> None @@ -2590,7 +2595,7 @@ end = struct ; _ } ) when exp == lhs -> true - | ( Exp {pexp_desc= Pexp_field (e, _); _} + | ( Exp {pexp_desc= Pexp_field (e, _) | Pexp_unboxed_field (e, _); _} , {pexp_desc= Pexp_construct _ | Pexp_cons _; _} ) when e == exp -> true @@ -2673,14 +2678,16 @@ end = struct , Some ( { pexp_desc= ( Pexp_ident _ | Pexp_constant _ | Pexp_record _ - | Pexp_constraint _ | Pexp_field _ ) + | Pexp_constraint _ | Pexp_unboxed_field _ + | Pexp_field _ ) ; _ } as e0 ) ) |Pexp_record_unboxed_product ( _ , Some ( { pexp_desc= ( Pexp_ident _ | Pexp_constant _ | Pexp_record _ - | Pexp_constraint _ | Pexp_field _ ) + | Pexp_constraint _ | Pexp_unboxed_field _ + | Pexp_field _ ) ; _ } as e0 ) ) when e0 == exp -> false diff --git a/test/passing/tests/unboxed_record.ml b/test/passing/tests/unboxed_record.ml index 00795a3e8f..546aa27f74 100644 --- a/test/passing/tests/unboxed_record.ml +++ b/test/passing/tests/unboxed_record.ml @@ -217,3 +217,6 @@ let _ = #{a = 1; b = 2; c = 3; short} ;; (* make sure to not drop parens for local open. *) let _ = A.(#{a = 1; b = 2}) + +(* make sure not to drop parens around thing being projected from. *) +let _ = (f x).#foo diff --git a/test/passing/tests/unboxed_record.ml.js-ref b/test/passing/tests/unboxed_record.ml.js-ref index a716e96347..d73b158d6f 100644 --- a/test/passing/tests/unboxed_record.ml.js-ref +++ b/test/passing/tests/unboxed_record.ml.js-ref @@ -265,3 +265,6 @@ let _ = #{ a = 1; b = 2; c = 3; short };; (* make sure to not drop parens for local open. *) let _ = A.(#{ a = 1; b = 2 }) + +(* make sure not to drop parens around thing being projected from. *) +let _ = (f x).#foo diff --git a/test/passing/tests/unboxed_record.ml.ref b/test/passing/tests/unboxed_record.ml.ref index 3812bc201a..c64fbb3573 100644 --- a/test/passing/tests/unboxed_record.ml.ref +++ b/test/passing/tests/unboxed_record.ml.ref @@ -222,3 +222,6 @@ let _ = #{a= 1; b= 2; c= 3; short} ;; (* make sure to not drop parens for local open. *) let _ = A.(#{a= 1; b= 2}) + +(* make sure not to drop parens around thing being projected from. *) +let _ = (f x).#foo