Bump AST to OCaml 5.2.0

CHANGES.md

@@ -21,6 +21,10 @@ details.
   a `ppxlib-pp-ast` executable in a new separate `ppxlib-tools` package
   (#517, @NathanReb)
 
+- Change `-dparsetree` from a sexp output to a pretty printed AST, closer
+  to what the compiler's `-dparsetree` is.
+  (#530, @NathanReb)
+
 0.33.0 (2024-07-22)
 -------------------
 

ast/ast_helper_lite.ml

@@ -17,7 +17,7 @@
 open Stdlib0
 module Location = Astlib.Location
 module Longident = Astlib.Longident
-open Astlib.Ast_500
+open Astlib.Ast_502
 
 [@@@warning "-9"]
 
@@ -121,7 +121,7 @@ module Typ = struct
         | Ptyp_class (longident, lst) ->
             Ptyp_class (longident, List.map loop lst)
         | Ptyp_alias (core_type, string) ->
-            check_variable var_names t.ptyp_loc string;
+            check_variable var_names t.ptyp_loc string.txt;
             Ptyp_alias (loop core_type, string)
         | Ptyp_variant (row_field_list, flag, lbl_lst_option) ->
             Ptyp_variant
@@ -135,6 +135,7 @@ module Typ = struct
             Ptyp_package
               (longident, List.map (fun (n, typ) -> (n, loop typ)) lst)
         | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg)
+        | Ptyp_open (l, ct) -> Ptyp_open (l, loop ct)
       in
       { t with ptyp_desc = desc }
     and loop_row_field field =
@@ -201,8 +202,20 @@ module Exp = struct
   let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
   let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
   let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
-  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
-  let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
+
+  let function_ ?loc ?attrs ?loc_location cases =
+    let loc_locations =
+      match loc_location with Some l -> l | None -> !default_loc
+    in
+    mk ?loc ?attrs
+      (Pexp_function ([], None, Pfunction_cases (cases, loc_locations, [])))
+
+  let fun_ ?loc ?attrs a b c d =
+    let pparam_desc = Pparam_val (a, b, c) in
+    let body = Pfunction_body d in
+    let pparam_loc = match loc with Some loc -> loc | None -> Location.none in
+    mk ?loc ?attrs (Pexp_function ([ { pparam_loc; pparam_desc } ], None, body))
+
   let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
   let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
   let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b))
@@ -423,8 +436,14 @@ module Incl = struct
 end
 
 module Vb = struct
-  let mk ?(loc = !default_loc) ?(attrs = []) pat expr =
-    { pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; pvb_loc = loc }
+  let mk ?(loc = !default_loc) ?(attrs = []) ?value_constraint pat expr =
+    {
+      pvb_pat = pat;
+      pvb_expr = expr;
+      pvb_attributes = attrs;
+      pvb_loc = loc;
+      pvb_constraint = value_constraint;
+    }
 end
 
 module Ci = struct
@@ -440,6 +459,17 @@ module Ci = struct
     }
 end
 
+let constructor ?(loc = !default_loc) ?(attrs = []) ?(vars = [])
+    ?(args = Pcstr_tuple []) ?res name =
+  {
+    pcd_name = name;
+    pcd_vars = vars;
+    pcd_args = args;
+    pcd_res = res;
+    pcd_loc = loc;
+    pcd_attributes = attrs;
+  }
+
 module Type = struct
   let mk ?(loc = !default_loc) ?(attrs = []) ?(params = []) ?(cstrs = [])
       ?(kind = Ptype_abstract) ?(priv = Public) ?manifest name =

ast/ast_helper_lite.mli

@@ -15,7 +15,7 @@
 
 (** Copy of Ast_helper from OCaml 4.14 with docstring related stuff removed *)
 
-open Astlib.Ast_500
+open Astlib.Ast_502
 open Asttypes
 open Parsetree
 
@@ -72,7 +72,7 @@ module Typ : sig
     ?loc:loc -> ?attrs:attrs -> object_field list -> closed_flag -> core_type
 
   val class_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
-  val alias : ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
+  val alias : ?loc:loc -> ?attrs:attrs -> core_type -> str -> core_type
 
   val variant :
     ?loc:loc ->
@@ -151,7 +151,8 @@ module Exp : sig
     expression ->
     expression
 
-  val function_ : ?loc:loc -> ?attrs:attrs -> case list -> expression
+  val function_ :
+    ?loc:loc -> ?attrs:attrs -> ?loc_location:loc -> case list -> expression
 
   val apply :
     ?loc:loc ->
@@ -466,7 +467,13 @@ end
 
 (** Value bindings *)
 module Vb : sig
-  val mk : ?loc:loc -> ?attrs:attrs -> pattern -> expression -> value_binding
+  val mk :
+    ?loc:loc ->
+    ?attrs:attrs ->
+    ?value_constraint:value_constraint ->
+    pattern ->
+    expression ->
+    value_binding
 end
 
 (** {1 Class language} *)

ast/import.ml

@@ -6,7 +6,7 @@
 
 (*$ open Ast_cinaps_helpers $*)
 
-module Js = Versions.OCaml_500
+module Js = Versions.OCaml_502
 module Ocaml = Versions.OCaml_current
 
 module Select_ast (Ocaml : Versions.OCaml_version) = struct

astlib/pprintast.ml

@@ -21,7 +21,7 @@
 (* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *)
 (* TODO more fine-grained precedence pretty-printing *)
 
-open Ast_414
+open Ast_502
 open Asttypes
 open Format
 open Location
@@ -56,7 +56,7 @@ let varify_type_constructors var_names t =
       | Ptyp_object (lst, o) -> Ptyp_object (List.map loop_object_field lst, o)
       | Ptyp_class (longident, lst) -> Ptyp_class (longident, List.map loop lst)
       | Ptyp_alias (core_type, string) ->
-          check_variable var_names t.ptyp_loc string;
+          check_variable var_names t.ptyp_loc string.txt;
           Ptyp_alias (loop core_type, string)
       | Ptyp_variant (row_field_list, flag, lbl_lst_option) ->
           Ptyp_variant
@@ -69,6 +69,7 @@ let varify_type_constructors var_names t =
       | Ptyp_package (longident, lst) ->
           Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst)
       | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg)
+      | Ptyp_open (s, ct) -> Ptyp_open (s, loop ct)
     in
     { t with ptyp_desc = desc }
   and loop_row_field field =
@@ -220,12 +221,15 @@ let is_simple_construct : construct -> bool = function
 
 let pp = fprintf
 
-type ctxt = { pipe : bool; semi : bool; ifthenelse : bool }
+type ctxt = { pipe : bool; semi : bool; ifthenelse : bool; functionrhs : bool }
+
+let reset_ctxt =
+  { pipe = false; semi = false; ifthenelse = false; functionrhs = false }
 
-let reset_ctxt = { pipe = false; semi = false; ifthenelse = false }
 let under_pipe ctxt = { ctxt with pipe = true }
 let under_semi ctxt = { ctxt with semi = true }
 let under_ifthenelse ctxt = { ctxt with ifthenelse = true }
+let under_functionrhs ctxt = { ctxt with functionrhs = true }
 (*
 let reset_semi ctxt = { ctxt with semi=false }
 let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
@@ -368,7 +372,7 @@ and core_type ctxt f x =
         pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
           (type_with_label ctxt) (l, ct1) (core_type ctxt) ct2
     | Ptyp_alias (ct, s) ->
-        pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s
+        pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar_loc s
     | Ptyp_poly ([], ct) -> core_type ctxt f ct
     | Ptyp_poly (sl, ct) ->
         pp f "@[<2>%a%a@]"
@@ -456,6 +460,8 @@ and core_type1 ctxt f x =
         pp f "@[<hov2>%a#%a@]"
           (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
           l longident_loc li
+    | Ptyp_open (li, ct) ->
+        pp f "@[<hov2>%a.(%a)@]" longident_loc li (core_type ctxt) ct
     | Ptyp_package (lid, cstrs) -> (
         let aux f (s, ct) =
           pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct
@@ -688,7 +694,7 @@ and expression ctxt f x =
       (attributes ctxt) x.pexp_attributes
   else
     match x.pexp_desc with
-    | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+    | Pexp_function _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
     | Pexp_newtype _
       when ctxt.pipe || ctxt.semi ->
         paren true (expression reset_ctxt) f x
@@ -698,12 +704,30 @@ and expression ctxt f x =
     | Pexp_letop _
       when ctxt.semi ->
         paren true (expression reset_ctxt) f x
-    | Pexp_fun (l, e0, p, e) ->
-        pp f "@[<2>fun@;%a->@;%a@]" (label_exp ctxt) (l, e0, p)
-          (expression ctxt) e
     | Pexp_newtype (lid, e) ->
         pp f "@[<2>fun@;(type@;%s)@;->@;%a@]" lid.txt (expression ctxt) e
-    | Pexp_function l -> pp f "@[<hv>function%a@]" (case_list ctxt) l
+    | Pexp_function (params, c, body) -> (
+        match (params, c) with
+        (* Omit [fun] if there are no params. *)
+        | [], None ->
+            (* If function cases are a direct body of a function,
+               the function node should be wrapped in parens so
+               it doesn't become part of the enclosing function. *)
+            let should_paren =
+              match body with
+              | Pfunction_cases _ -> ctxt.functionrhs
+              | Pfunction_body _ -> false
+            in
+            let ctxt' = if should_paren then reset_ctxt else ctxt in
+            pp f "@[<2>%a@]" (paren should_paren (function_body ctxt')) body
+        | [], Some c ->
+            pp f "@[<2>(%a@;%a)@]" (function_body ctxt) body
+              (type_constraint ctxt) c
+        | _ :: _, _ ->
+            pp f "@[<2>fun@;%a@]"
+              (fun f () ->
+                function_params_then_body ctxt f params c body ~delimiter:"->")
+              ())
     | Pexp_match (e, l) ->
         pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt)
           e (case_list ctxt) l
@@ -832,6 +856,35 @@ and expression ctxt f x =
     | Pexp_unreachable -> pp f "."
     | _ -> expression1 ctxt f x
 
+and function_param ctxt f param =
+  match param.pparam_desc with
+  | Pparam_val (a, b, c) -> label_exp ctxt f (a, b, c)
+  | Pparam_newtype ty -> pp f "(type %a)@;" protect_ident ty.txt
+
+and function_body ctxt f function_body =
+  match function_body with
+  | Pfunction_body body -> expression ctxt f body
+  | Pfunction_cases (cases, _, attrs) ->
+      pp f "@[<hv>function%a%a@]" (item_attributes ctxt) attrs (case_list ctxt)
+        cases
+
+and type_constraint ctxt f constraint_ =
+  match constraint_ with
+  | Pconstraint ty -> pp f ":@;%a" (core_type ctxt) ty
+  | Pcoerce (ty1, ty2) ->
+      pp f "%a:>@;%a"
+        (option ~first:":@;" (core_type ctxt))
+        ty1 (core_type ctxt) ty2
+
+and function_params_then_body ctxt f params constraint_ body ~delimiter =
+  pp f "%a%a%s@;%a"
+    (list (function_param ctxt) ~sep:"")
+    params
+    (option (type_constraint ctxt))
+    constraint_ delimiter
+    (function_body (under_functionrhs ctxt))
+    body
+
 and expression1 ctxt f x =
   if x.pexp_attributes <> [] then expression ctxt f x
   else
@@ -1041,6 +1094,7 @@ and class_field ctxt f x =
             pvb_expr = e;
             pvb_attributes = [];
             pvb_loc = Location.none;
+            pvb_constraint = None;
           }
       in
       pp f "@[<2>method%s %a%a@]%a" (override ovf) private_flag pf
@@ -1281,6 +1335,7 @@ and module_expr ctxt f x =
     | Pmod_apply (me1, me2) ->
         pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
         (* Cf: #7200 *)
+    | Pmod_apply_unit me1 -> pp f "(%a)()" (module_expr ctxt) me1
     | Pmod_unpack e -> pp f "(val@ %a)" (expression ctxt) e
     | Pmod_extension e -> extension ctxt f e
 
@@ -1312,12 +1367,8 @@ and binding ctxt f { pvb_pat = p; pvb_expr = x; _ } =
     if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
     else
       match x.pexp_desc with
-      | Pexp_fun (label, eo, p, e) ->
-          if label = Nolabel then
-            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
-          else
-            pp f "%a@ %a" (label_exp ctxt) (label, eo, p) pp_print_pexp_function
-              e
+      | Pexp_function (params, c, body) ->
+          function_params_then_body ctxt f params c body ~delimiter:"="
       | Pexp_newtype (str, e) ->
           pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e
       | _ -> pp f "=@;%a" (expression ctxt) x

astlib/pprintast.mli

@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Ast_414
+open Ast_502
 
 type space_formatter = (unit, Format.formatter, unit) format
 

bench/vendored/ppx_sexp_conv.v0.15.1/expander/conversion.ml

@@ -49,7 +49,7 @@ module Lambda = struct
   let maybe_apply_generic ~loc ~binds maybe_arg cases =
     let expr =
       match maybe_arg with
-      | None -> pexp_function ~loc cases
+      | None -> pexp_function_cases ~loc cases
       | Some arg -> pexp_match ~loc arg cases
     in
     with_let ~loc ~binds expr

bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_of_sexp.ml

@@ -186,6 +186,7 @@ module Str_generate_of_sexp = struct
     | { ptyp_desc = Ptyp_class (_, _); _ }
     | { ptyp_desc = Ptyp_alias (_, _); _ }
     | { ptyp_desc = Ptyp_package _; _ }
+    | { ptyp_desc = Ptyp_open _; _ }
     | { ptyp_desc = Ptyp_extension _; _ } ->
       Location.raise_errorf ~loc "Type unsupported for ppx [of_sexp] conversion"
 
@@ -841,7 +842,7 @@ module Str_generate_of_sexp = struct
       [%expr
         let rec [%p Fresh_name.pattern fresh_iter] =
           [%e
-            pexp_function
+            pexp_function_cases
               ~loc
               [ [%pat?
                        Sexplib0.Sexp.List

bench/vendored/ppx_sexp_conv.v0.15.1/expander/expand_sexp_of.ml

@@ -82,6 +82,7 @@ module Str_generate_sexp_of = struct
     | { ptyp_desc = Ptyp_class (_, _); _ }
     | { ptyp_desc = Ptyp_alias (_, _); _ }
     | { ptyp_desc = Ptyp_package _; _ }
+    | { ptyp_desc = Ptyp_open _; _ }
     | { ptyp_desc = Ptyp_extension _; _ } ->
       Location.raise_errorf ~loc "Type unsupported for ppx [sexp_of] conversion"
 

bench/vendored/ppx_sexp_conv.v0.15.1/expander/helpers.ml

@@ -139,7 +139,7 @@ let fresh_lambda ~loc apply =
 let rec is_value_expression expr =
   match expr.pexp_desc with
   (* Syntactic values. *)
-  | Pexp_ident _ | Pexp_constant _ | Pexp_function _ | Pexp_fun _ | Pexp_lazy _ -> true
+  | Pexp_ident _ | Pexp_constant _ | Pexp_function _ | Pexp_lazy _ -> true
   (* Type-only wrappers; we check their contents. *)
   | Pexp_constraint (expr, (_ : core_type))
   | Pexp_coerce (expr, (_ : core_type option), (_ : core_type))

bench/vendored/ppx_sexp_conv.v0.15.1/expander/ppx_sexp_conv_grammar.ml

@@ -218,6 +218,7 @@ let rec grammar_of_type core_type ~rec_flag ~tags_of_doc_comments =
             grammar_of_polymorphic_variant ~loc ~rec_flag ~tags_of_doc_comments rows)
        | Ptyp_poly _ -> unsupported ~loc "explicitly polymorphic types"
        | Ptyp_package _ -> unsupported ~loc "first-class module types"
+       | Ptyp_open _ -> unsupported ~loc "locally opened modules"
        | Ptyp_extension _ -> unsupported ~loc "unexpanded ppx extensions")
   in
   grammar_of_type_tags core_type grammar ~tags_of_doc_comments

examples/simple-deriver/ppx_deriving_accessors.ml

@@ -16,6 +16,7 @@ let accessor_impl (ld : label_declaration) =
                { loc; txt = lident ld.pld_name.txt });
         pvb_attributes = [];
         pvb_loc = loc;
+        pvb_constraint = None;
       };
     ]