Backport 5.3 changes to Parsetree.constant (#2610)

Author: Julow

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.

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); _}
                     ; _ }
                   , [] )
             ; _ } ] ) ->

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

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 =

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 = []; }

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 */

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]

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;