From f35d593acbb63389b938393602b945f668ff595d Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 4 Nov 2024 14:31:43 +0100 Subject: [PATCH 1/3] Backport 5.3 changes to Parsetree.constant --- lib/Normalize_std_ast.ml | 13 +++- .../parser-shims/ocamlformat_parser_shims.ml | 25 ++++---- vendor/parser-standard/ast_helper.ml | 21 ++++--- vendor/parser-standard/ast_mapper.ml | 23 ++++--- vendor/parser-standard/docstrings.ml | 6 +- vendor/parser-standard/parser.mly | 62 ++++++++++++------- vendor/parser-standard/parsetree.mli | 9 ++- vendor/parser-standard/printast.ml | 34 ++++++---- 8 files changed, 123 insertions(+), 70 deletions(-) diff --git a/lib/Normalize_std_ast.ml b/lib/Normalize_std_ast.ml index da02eb5e1d..c20d44bef9 100644 --- a/lib/Normalize_std_ast.ml +++ b/lib/Normalize_std_ast.ml @@ -39,7 +39,10 @@ let make_mapper conf ~ignore_doc_comments = [ ( { pstr_desc= Pstr_eval ( ( { pexp_desc= - Pexp_constant (Pconst_string (doc, str_loc, None)) + Pexp_constant + ( { pconst_desc= + Pconst_string (doc, str_loc, None) + ; _ } as const ) ; _ } as exp ) , [] ) ; _ } as pstr ) ] @@ -56,7 +59,9 @@ let make_mapper conf ~ignore_doc_comments = ( { exp with pexp_desc= Pexp_constant - (Pconst_string (doc', str_loc, None)) + { const with + pconst_desc= + Pconst_string (doc', str_loc, None) } ; pexp_loc_stack= [] } , [] ) } ] } | _ -> Ast_mapper.default_mapper.attribute m attr @@ -179,7 +184,9 @@ let make_docstring_mapper docstrings = , PStr [ { pstr_desc= Pstr_eval - ( { pexp_desc= Pexp_constant (Pconst_string (doc, _, None)) + ( { pexp_desc= + Pexp_constant + {pconst_desc= Pconst_string (doc, _, None); _} ; _ } , [] ) ; _ } ] ) -> diff --git a/vendor/parser-shims/ocamlformat_parser_shims.ml b/vendor/parser-shims/ocamlformat_parser_shims.ml index b9d3f34885..b8cb90ff23 100644 --- a/vendor/parser-shims/ocamlformat_parser_shims.ml +++ b/vendor/parser-shims/ocamlformat_parser_shims.ml @@ -70,6 +70,7 @@ module Misc = struct in "\x1b[" ^ s ^ "m" + type Format.stag += Style of style list type tag_style ={ @@ -89,19 +90,19 @@ module Misc = struct let no_markup stl = { ansi = stl; text_close = ""; text_open = "" } let default_styles = { - warning = no_markup [Bold; FG Magenta]; - error = no_markup [Bold; FG Red]; - loc = no_markup [Bold]; - hint = no_markup [Bold; FG Blue]; - inline_code= { ansi=[Bold]; text_open = {|"|}; text_close = {|"|} } - } + warning = no_markup [Bold; FG Magenta]; + error = no_markup [Bold; FG Red]; + loc = no_markup [Bold]; + hint = no_markup [Bold; FG Blue]; + inline_code= { ansi=[Bold]; text_open = {|"|}; text_close = {|"|} } + } let cur_styles = ref default_styles let get_styles () = !cur_styles let set_styles s = cur_styles := s (* map a tag to a style, if the tag is known. - @raise Not_found otherwise *) + @raise Not_found otherwise *) let style_of_tag s = match s with | Format.String_tag "error" -> (!cur_styles).error | Format.String_tag "warning" ->(!cur_styles).warning @@ -138,9 +139,9 @@ module Misc = struct let open Format in let functions = pp_get_formatter_stag_functions ppf () in let functions' = {functions with - mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag); - mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag); - } in + mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag); + mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag); + } in pp_set_mark_tags ppf true; (* enable tags *) pp_set_formatter_stag_functions ppf functions'; () @@ -161,8 +162,8 @@ module Misc = struct Format.set_mark_tags true; List.iter set_tag_handling formatter_l; Color.enabled := (match o with - | Some s -> enable_color s - | None -> enable_color Color.default_setting) + | Some s -> enable_color s + | None -> enable_color Color.default_setting) ); () end diff --git a/vendor/parser-standard/ast_helper.ml b/vendor/parser-standard/ast_helper.ml index 184049f0cb..444bfab585 100644 --- a/vendor/parser-standard/ast_helper.ml +++ b/vendor/parser-standard/ast_helper.ml @@ -33,15 +33,20 @@ let with_default_loc l f = Misc.protect_refs [Misc.R (default_loc, l)] f module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c + let mk ?(loc = !default_loc) d = + {pconst_desc = d; + pconst_loc = loc} + + let integer ?loc ?suffix i = mk ?loc (Pconst_integer (i, suffix)) + let int ?loc ?suffix i = integer ?loc ?suffix (Int.to_string i) + let int32 ?loc ?(suffix='l') i = integer ?loc ~suffix (Int32.to_string i) + let int64 ?loc ?(suffix='L') i = integer ?loc ~suffix (Int64.to_string i) + let nativeint ?loc ?(suffix='n') i = + integer ?loc ~suffix (Nativeint.to_string i) + let float ?loc ?suffix f = mk ?loc (Pconst_float (f, suffix)) + let char ?loc c = mk ?loc (Pconst_char c) let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) + mk ~loc (Pconst_string (s, loc, quotation_delimiter)) end module Attr = struct diff --git a/vendor/parser-standard/ast_mapper.ml b/vendor/parser-standard/ast_mapper.ml index d729cfdc1d..82b7a892ff 100644 --- a/vendor/parser-standard/ast_mapper.ml +++ b/vendor/parser-standard/ast_mapper.ml @@ -95,14 +95,18 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} module C = struct (* Constants *) - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s + let map sub { pconst_desc; pconst_loc } = + let loc = sub.location sub pconst_loc in + let desc = + match pconst_desc with + | Pconst_integer _ + | Pconst_char _ + | Pconst_float _ -> + pconst_desc + | Pconst_string (s, loc, quotation_delimiter) -> + Pconst_string (s, sub.location sub loc, quotation_delimiter) + in + Const.mk ~loc desc end module T = struct @@ -941,7 +945,8 @@ module PpxContext = struct let restore fields = let field name payload = let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str + | {pexp_desc = Pexp_constant + {pconst_desc = Pconst_string (str, _, None); _}} -> str | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ { %s }] string syntax" name and get_bool pexp = diff --git a/vendor/parser-standard/docstrings.ml b/vendor/parser-standard/docstrings.ml index a39f75d259..32b8e8c468 100644 --- a/vendor/parser-standard/docstrings.ml +++ b/vendor/parser-standard/docstrings.ml @@ -91,8 +91,9 @@ let docs_attr ds = let open Parsetree in let body = ds.ds_body in let loc = ds.ds_loc in + let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); + { pexp_desc = Pexp_constant const; pexp_loc = loc; pexp_loc_stack = []; pexp_attributes = []; } @@ -143,8 +144,9 @@ let text_attr ds = let open Parsetree in let body = ds.ds_body in let loc = ds.ds_loc in + let const = { pconst_desc= Pconst_string(body,loc,None); pconst_loc= loc } in let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); + { pexp_desc = Pexp_constant const; pexp_loc = loc; pexp_loc_stack = []; pexp_attributes = []; } diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly index ba160f09c6..891028702b 100644 --- a/vendor/parser-standard/parser.mly +++ b/vendor/parser-standard/parser.mly @@ -58,6 +58,7 @@ let mkmod ~loc ?attrs d = Mod.mk ~loc:(make_loc loc) ?attrs d let mkstr ~loc d = Str.mk ~loc:(make_loc loc) d let mkclass ~loc ?attrs d = Cl.mk ~loc:(make_loc loc) ?attrs d let mkcty ~loc ?attrs d = Cty.mk ~loc:(make_loc loc) ?attrs d +let mkconst ~loc c = Const.mk ~loc:(make_loc loc) c let pstr_typext (te, ext) = (Pstr_typext te, ext) @@ -150,20 +151,31 @@ let neg_string f = then String.sub f 1 (String.length f - 1) else "-" ^ f -let mkuminus ~oploc name arg = - match name, arg.pexp_desc with - | "-", Pexp_constant(Pconst_integer (n,m)) -> - Pexp_constant(Pconst_integer(neg_string n,m)) - | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) -> - Pexp_constant(Pconst_float(neg_string f, m)) +(* Pre-apply the special [-], [-.], [+] and [+.] prefix operators into + constants if possible, otherwise turn them into the corresponding prefix + operators [~-], [~-.], etc.. *) +let mkuminus ~sloc ~oploc name arg = + match name, arg.pexp_desc, arg.pexp_attributes with + | "-", + Pexp_constant({pconst_desc = Pconst_integer (n,m); pconst_loc=_}), + [] -> + Pexp_constant(mkconst ~loc:sloc (Pconst_integer(neg_string n, m))) + | ("-" | "-."), + Pexp_constant({pconst_desc = Pconst_float (f, m); pconst_loc=_}), [] -> + Pexp_constant(mkconst ~loc:sloc (Pconst_float(neg_string f, m))) | _ -> Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) -let mkuplus ~oploc name arg = +let mkuplus ~sloc ~oploc name arg = let desc = arg.pexp_desc in - match name, desc with - | "+", Pexp_constant(Pconst_integer _) - | ("+" | "+."), Pexp_constant(Pconst_float _) -> desc + match name, desc, arg.pexp_attributes with + | "+", + Pexp_constant({pconst_desc = Pconst_integer _ as desc; pconst_loc=_}), + [] + | ("+" | "+."), + Pexp_constant({pconst_desc = Pconst_float _ as desc; pconst_loc=_}), + [] -> + Pexp_constant(mkconst ~loc:sloc desc) | _ -> Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) @@ -481,7 +493,8 @@ let wrap_mksig_ext ~loc (item, ext) = let mk_quotedext ~loc (id, idloc, str, strloc, delim) = let exp_id = mkloc id idloc in - let e = ghexp ~loc (Pexp_constant (Pconst_string (str, strloc, delim))) in + let const = Const.mk ~loc:strloc (Pconst_string (str, strloc, delim)) in + let e = ghexp ~loc (Pexp_constant const) in (exp_id, PStr [mkstrexp e []]) let text_str pos = Str.text (rhs_text pos) @@ -2494,9 +2507,9 @@ fun_expr: | e1 = fun_expr op = op(infix_operator) e2 = expr { mkinfix e1 op e2 } | subtractive expr %prec prec_unary_minus - { mkuminus ~oploc:$loc($1) $1 $2 } + { mkuminus ~sloc:$sloc ~oploc:$loc($1) $1 $2 } | additive expr %prec prec_unary_plus - { mkuplus ~oploc:$loc($1) $1 $2 } + { mkuplus ~sloc:$sloc ~oploc:$loc($1) $1 $2 } ; simple_expr: @@ -3736,17 +3749,24 @@ meth_list: /* Constants */ constant: - | INT { let (n, m) = $1 in Pconst_integer (n, m) } - | CHAR { Pconst_char $1 } - | STRING { let (s, strloc, d) = $1 in Pconst_string (s, strloc, d) } - | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } + | INT { let (n, m) = $1 in + mkconst ~loc:$sloc (Pconst_integer (n, m)) } + | CHAR { mkconst ~loc:$sloc (Pconst_char $1) } + | STRING { let (s, strloc, d) = $1 in + mkconst ~loc:$sloc (Pconst_string (s,strloc,d)) } + | FLOAT { let (f, m) = $1 in + mkconst ~loc:$sloc (Pconst_float (f, m)) } ; signed_constant: constant { $1 } - | MINUS INT { let (n, m) = $2 in Pconst_integer("-" ^ n, m) } - | MINUS FLOAT { let (f, m) = $2 in Pconst_float("-" ^ f, m) } - | PLUS INT { let (n, m) = $2 in Pconst_integer (n, m) } - | PLUS FLOAT { let (f, m) = $2 in Pconst_float(f, m) } + | MINUS INT { let (n, m) = $2 in + mkconst ~loc:$sloc (Pconst_integer("-" ^ n, m)) } + | MINUS FLOAT { let (f, m) = $2 in + mkconst ~loc:$sloc (Pconst_float("-" ^ f, m)) } + | PLUS INT { let (n, m) = $2 in + mkconst ~loc:$sloc (Pconst_integer (n, m)) } + | PLUS FLOAT { let (f, m) = $2 in + mkconst ~loc:$sloc (Pconst_float(f, m)) } ; /* Identifiers and long identifiers */ diff --git a/vendor/parser-standard/parsetree.mli b/vendor/parser-standard/parsetree.mli index b50162c330..72596fabcf 100644 --- a/vendor/parser-standard/parsetree.mli +++ b/vendor/parser-standard/parsetree.mli @@ -22,7 +22,12 @@ open Asttypes -type constant = +type constant = { + pconst_desc : constant_desc; + pconst_loc : Location.t; +} + +and constant_desc = | Pconst_integer of string * char option (** Integer constants such as [3] [3l] [3L] [3n]. @@ -311,7 +316,7 @@ and expression_desc = A function must have parameters. [Pexp_function (params, _, body)] must have non-empty [params] or a [Pfunction_cases _] body. - *) + *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] represents [E0 ~l1:E1 ... ~ln:En] diff --git a/vendor/parser-standard/printast.ml b/vendor/parser-standard/printast.ml index 7718d7d77b..535563e923 100644 --- a/vendor/parser-standard/printast.ml +++ b/vendor/parser-standard/printast.ml @@ -57,16 +57,6 @@ let fmt_char_option f = function | None -> fprintf f "None" | Some c -> fprintf f "Some %c" c -let fmt_constant f x = - match x with - | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m - | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c) - | Pconst_string (s, strloc, None) -> - fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc - | Pconst_string (s, strloc, Some delim) -> - fprintf f "PConst_string (%S,%a,Some %S)" s fmt_location strloc delim - | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m - let fmt_mutable_flag f x = match x with | Immutable -> fprintf f "Immutable" @@ -106,6 +96,18 @@ let line i f s (*...*) = fprintf f "%s" (String.make ((2*i) mod 72) ' '); fprintf f s (*...*) +let fmt_constant i f x = + line i f "constant %a\n" fmt_location x.pconst_loc; + let i = i+1 in + match x.pconst_desc with + | Pconst_integer (j,m) -> line i f "PConst_int (%s,%a)\n" j fmt_char_option m + | Pconst_char c -> line i f "PConst_char %02x\n" (Char.code c) + | Pconst_string (s, strloc, None) -> + line i f "PConst_string(%S,%a,None)\n" s fmt_location strloc + | Pconst_string (s, strloc, Some delim) -> + line i f "PConst_string (%S,%a,Some %S)\n" s fmt_location strloc delim + | Pconst_float (s,m) -> line i f "PConst_float (%s,%a)\n" s fmt_char_option m + let list i f ppf l = match l with | [] -> line i ppf "[]\n" @@ -201,9 +203,13 @@ and pattern i ppf x = | Ppat_alias (p, s) -> line i ppf "Ppat_alias %a\n" fmt_string_loc s; pattern i ppf p; - | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Ppat_constant (c) -> + line i ppf "Ppat_constant\n"; + fmt_constant i ppf c; | Ppat_interval (c1, c2) -> - line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; + line i ppf "Ppat_interval\n"; + fmt_constant i ppf c1; + fmt_constant i ppf c2; | Ppat_tuple (l) -> line i ppf "Ppat_tuple\n"; list i pattern ppf l; @@ -255,7 +261,9 @@ and expression i ppf x = let i = i+1 in match x.pexp_desc with | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; - | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Pexp_constant (c) -> + line i ppf "Pexp_constant\n"; + fmt_constant i ppf c; | Pexp_let (rf, l, e) -> line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; From 8d10bdff1fb13a62e7b0c9407b16f34fe5b40787 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 4 Nov 2024 16:12:10 +0100 Subject: [PATCH 2/3] Reduce diffs --- .../parser-shims/ocamlformat_parser_shims.ml | 25 +++++++++---------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/vendor/parser-shims/ocamlformat_parser_shims.ml b/vendor/parser-shims/ocamlformat_parser_shims.ml index b8cb90ff23..b9d3f34885 100644 --- a/vendor/parser-shims/ocamlformat_parser_shims.ml +++ b/vendor/parser-shims/ocamlformat_parser_shims.ml @@ -70,7 +70,6 @@ module Misc = struct in "\x1b[" ^ s ^ "m" - type Format.stag += Style of style list type tag_style ={ @@ -90,19 +89,19 @@ module Misc = struct let no_markup stl = { ansi = stl; text_close = ""; text_open = "" } let default_styles = { - warning = no_markup [Bold; FG Magenta]; - error = no_markup [Bold; FG Red]; - loc = no_markup [Bold]; - hint = no_markup [Bold; FG Blue]; - inline_code= { ansi=[Bold]; text_open = {|"|}; text_close = {|"|} } - } + warning = no_markup [Bold; FG Magenta]; + error = no_markup [Bold; FG Red]; + loc = no_markup [Bold]; + hint = no_markup [Bold; FG Blue]; + inline_code= { ansi=[Bold]; text_open = {|"|}; text_close = {|"|} } + } let cur_styles = ref default_styles let get_styles () = !cur_styles let set_styles s = cur_styles := s (* map a tag to a style, if the tag is known. - @raise Not_found otherwise *) + @raise Not_found otherwise *) let style_of_tag s = match s with | Format.String_tag "error" -> (!cur_styles).error | Format.String_tag "warning" ->(!cur_styles).warning @@ -139,9 +138,9 @@ module Misc = struct let open Format in let functions = pp_get_formatter_stag_functions ppf () in let functions' = {functions with - mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag); - mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag); - } in + mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag); + mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag); + } in pp_set_mark_tags ppf true; (* enable tags *) pp_set_formatter_stag_functions ppf functions'; () @@ -162,8 +161,8 @@ module Misc = struct Format.set_mark_tags true; List.iter set_tag_handling formatter_l; Color.enabled := (match o with - | Some s -> enable_color s - | None -> enable_color Color.default_setting) + | Some s -> enable_color s + | None -> enable_color Color.default_setting) ); () end From e465353671eb70be0b4ee1b714471418897cb5fb Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 4 Nov 2024 16:15:49 +0100 Subject: [PATCH 3/3] Update changes --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 65992b1b57..2eac4f4ef3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -13,7 +13,7 @@ profile. This started with version 0.26.0. This might change the formatting of some functions due to the formatting code being completely rewritten. -- Support OCaml 5.3 syntax (#2609, @Julow) +- Support OCaml 5.3 syntax (#2609, #2610, @Julow) - Documentation comments are now formatted by default (#2390, @Julow) Use the option `parse-docstrings = false` to restore the previous behavior.