melange-ppx: port melange.ppx to ppxlib 0.36 with OCaml 5.2 AST

.github/workflows/opam-build.yml

@@ -72,7 +72,8 @@ jobs:
       - name: Install all deps
         working-directory: melange-opam-template
         run: |
-          opam install -y reason-react
+          opam pin add reason-react-ppx.dev git+https://github.com/reasonml/reason-react.git#c97615d62311f32c2dbb1e5d159c06e147ca7545 -y
+          opam pin add reason-react.dev git+https://github.com/reasonml/reason-react.git#c97615d62311f32c2dbb1e5d159c06e147ca7545 -y
           npm install
 
       - name: Build basic template

dune-project

@@ -42,10 +42,7 @@
   (ounit :with-test)
   (reason
    (and :dev :with-test))
-  (ppxlib
-   (and
-     (>= "0.30.0")
-     (< "0.36.0")))
+  (ppxlib (>= "0.36.0"))
   (menhir
    (>= 20201214))
   (reason-react-ppx

flake.nix

@@ -16,7 +16,51 @@
       forAllSystems = f: nixpkgs.lib.genAttrs nixpkgs.lib.systems.flakeExposed (system:
         let
           pkgs = nixpkgs.legacyPackages.${system}.extend (self: super: {
-            ocamlPackages = super.ocaml-ng.ocamlPackages_5_3;
+            ocamlPackages = super.ocaml-ng.ocamlPackages_5_3.overrideScope (oself: osuper: {
+              js_of_ocaml-compiler = osuper.js_of_ocaml-compiler.overrideAttrs (_: {
+                src = super.fetchFromGitHub {
+                  owner = "ocsigen";
+                  repo = "js_of_ocaml";
+                  rev = "c76316cb4f07fc0b1ffc46805fd350d4be77e0dc";
+                  hash = "sha256-9aYCYQ+wt5INgm54COeUcbAAqUfpWruLh1TyRDy0Fp0=";
+                };
+              });
+              sedlex = osuper.sedlex.overrideAttrs (_: {
+                src = super.fetchFromGitHub {
+                  owner = "ocaml-community";
+                  repo = "sedlex";
+                  rev = "4dbaf572ed52281140be924a2c16fa4f287d88f0";
+                  hash = "sha256-pRZ/GRTpBIa8ZcKdmCo1pmAHR3tJrIfNqU4IreEhO7g=";
+                };
+              });
+              ppxlib = osuper.ppxlib.overrideAttrs (_: {
+                src = builtins.fetchurl {
+                  url = "https://github.com/ocaml-ppx/ppxlib/releases/download/0.36.0/ppxlib-0.36.0.tbz";
+                  sha256 = "0d54j19vi1khzmw0ffngs8xzjjq07n20q49h85hhhcf52k71pfjs";
+                };
+              });
+              reason = osuper.reason.overrideAttrs (_: {
+                src = super.fetchFromGitHub {
+                  owner = "reasonml";
+                  repo = "reason";
+                  rev = "0b2f1aa14f5722a07a63bedb608c381d218f24cf";
+                  hash = "sha256-rtFEhEdNwHgRFAk9S7xx9MKvn9/gtTrIcVZp6d45Fxk=";
+                };
+                patches = [ ];
+                doCheck = false;
+              });
+              reason-react-ppx = osuper.reason-react-ppx.overrideAttrs (_: {
+                src = super.fetchFromGitHub {
+                  owner = "reasonml";
+                  repo = "reason-react";
+                  rev = "c97615d62311f32c2dbb1e5d159c06e147ca7545";
+                  hash = "sha256-dZZyjc+G2erukLXsICExaKwWqs6eqGLrkHTouoe8k40=";
+                };
+              });
+              pp = osuper.pp.overrideAttrs (o: {
+                doCheck = false;
+              });
+            });
           });
         in
         f pkgs);

jscomp/core/gen/dune

@@ -1,6 +1,6 @@
 (executable
  (name gen_traversal)
- (libraries ppxlib.ast cmdliner)
+ (libraries ppxlib.ast ppxlib cmdliner)
  (flags :standard -open StdLabels -open Ppxlib_ast)
  (preprocess
   (pps ppxlib.metaquot)))

jscomp/melstd/gen/dune

@@ -2,4 +2,4 @@
  (name build_reserved)
  (preprocess
   (pps ppxlib.metaquot))
- (libraries ppxlib.ast))
+ (libraries ppxlib ppxlib.ast))

melange-playground.opam

@@ -30,3 +30,11 @@ build: [
   ]
 ]
 dev-repo: "git+https://github.com/melange-re/melange.git"
+pin-depends: [
+  [ "js_of_ocaml-compiler.dev" "git+https://github.com/ocsigen/js_of_ocaml.git#c76316cb4f07fc0b1ffc46805fd350d4be77e0dc" ]
+  [ "js_of_ocaml.dev" "git+https://github.com/ocsigen/js_of_ocaml.git#c76316cb4f07fc0b1ffc46805fd350d4be77e0dc" ]
+  [ "sedlex.dev" "git+https://github.com/ocaml-community/sedlex.git#4dbaf572ed52281140be924a2c16fa4f287d88f0"]
+  [ "reason.dev" "git+https://github.com/reasonml/reason.git" ]
+  [ "reason-react-ppx.dev" "git+https://github.com/reasonml/reason-react.git#c97615d62311f32c2dbb1e5d159c06e147ca7545"]
+]
+

melange-playground.opam.template

@@ -0,0 +1,8 @@
+pin-depends: [
+  [ "js_of_ocaml-compiler.dev" "git+https://github.com/ocsigen/js_of_ocaml.git#c76316cb4f07fc0b1ffc46805fd350d4be77e0dc" ]
+  [ "js_of_ocaml.dev" "git+https://github.com/ocsigen/js_of_ocaml.git#c76316cb4f07fc0b1ffc46805fd350d4be77e0dc" ]
+  [ "sedlex.dev" "git+https://github.com/ocaml-community/sedlex.git#4dbaf572ed52281140be924a2c16fa4f287d88f0"]
+  [ "reason.dev" "git+https://github.com/reasonml/reason.git" ]
+  [ "reason-react-ppx.dev" "git+https://github.com/reasonml/reason-react.git#c97615d62311f32c2dbb1e5d159c06e147ca7545"]
+]
+

melange.opam

@@ -14,7 +14,7 @@ depends: [
   "cppo" {build}
   "ounit" {with-test}
   "reason" {dev & with-test}
-  "ppxlib" {>= "0.30.0" & < "0.36.0"}
+  "ppxlib" {>= "0.36.0"}
   "menhir" {>= "20201214"}
   "reason-react-ppx" {with-test & post}
   "merlin" {with-test}
@@ -35,3 +35,7 @@ build: [
   ]
 ]
 dev-repo: "git+https://github.com/melange-re/melange.git"
+pin-depends: [
+  [ "reason.dev" "git+https://github.com/reasonml/reason.git" ]
+  [ "reason-react-ppx.dev" "git+https://github.com/reasonml/reason-react.git#c97615d62311f32c2dbb1e5d159c06e147ca7545"]
+]

melange.opam.template

@@ -0,0 +1,4 @@
+pin-depends: [
+  [ "reason.dev" "git+https://github.com/reasonml/reason.git" ]
+  [ "reason-react-ppx.dev" "git+https://github.com/reasonml/reason-react.git#c97615d62311f32c2dbb1e5d159c06e147ca7545"]
+]

ppx/ast_derive/ast_derive_projector.ml

@@ -99,7 +99,9 @@ let derive_structure tdcls =
                      in
                      List.fold_right
                        ~f:(fun var b ->
-                         Exp.fun_ Nolabel None (Pat.var { loc; txt = var }) b)
+                         Ast_builder.Default.pexp_fun ~loc Nolabel None
+                           (Pat.var { loc; txt = var })
+                           b)
                        vars ~init:exp);
               ])
           constructor_declarations

ppx/ast_object.ml

@@ -128,11 +128,16 @@ let ocaml_object_as_js_object =
           match x.pcf_desc with
           | Pcf_method (label, public_flag, Cfk_concrete (Fresh, e)) -> (
               match e.pexp_desc with
-              | Pexp_poly ({ pexp_desc = Pexp_fun (lbl, _, pat, e); _ }, None)
-                ->
+              | Pexp_poly
+                  ( { pexp_desc = Pexp_function (_, _, Pfunction_cases _); _ },
+                    None ) ->
+                  assert false
+              | Pexp_poly
+                  ( { pexp_desc = Pexp_function (args, _, Pfunction_body e); _ },
+                    None ) ->
                   let method_type =
-                    Ast_typ_uncurry.generate_arg_type x.pcf_loc mapper label.txt
-                      lbl pat e
+                    Ast_typ_uncurry.generate_arg_type ~loc:x.pcf_loc mapper
+                      label.txt args e
                   in
                   ( Of.tag label method_type :: label_attr_types,
                     if public_flag = Public then
@@ -180,24 +185,55 @@ let ocaml_object_as_js_object =
           | Pcf_method (label, _public_flag, Cfk_concrete (Fresh, e)) -> (
               match e.pexp_desc with
               | Pexp_poly
-                  (({ pexp_desc = Pexp_fun (ll, None, pat, e); _ } as f), None)
-                ->
+                  ( { pexp_desc = Pexp_function (_, _, Pfunction_cases _); _ },
+                    None ) ->
+                  assert false
+              | Pexp_poly
+                  ( ({
+                       pexp_desc = Pexp_function (params, _, Pfunction_body e);
+                       _;
+                     } as f),
+                    None ) ->
                   let alias_type =
                     if aliased then None else Some internal_obj_type
                   in
                   let label_type =
                     Ast_typ_uncurry.generate_method_type ?alias_type x.pcf_loc
-                      mapper label.txt ll pat e
+                      mapper label.txt params e
                   in
                   ( label :: labels,
                     label_type :: label_types,
                     {
                       f with
                       pexp_desc =
-                        (let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in
-                         Ast_uncurry_gen.to_method_callback loc mapper Nolabel
-                           self_pat f)
-                        (* the first argument is this*);
+                        (let f =
+                           let first_arg =
+                             match
+                               List.find_opt
+                                 ~f:(function
+                                   | { pparam_desc = Pparam_val _; _ } -> true
+                                   | { pparam_desc = Pparam_newtype _; _ } ->
+                                       false)
+                                 params
+                             with
+                             | Some { pparam_desc = Pparam_val (_, _, pat); _ }
+                               ->
+                                 pat
+                             | Some { pparam_desc = Pparam_newtype _; _ } | None
+                               ->
+                                 assert false
+                           in
+                           if Ast_pat.is_unit first_arg then e else f
+                         in
+                         Ast_uncurry_gen.to_method_callback ~loc mapper
+                           [
+                             {
+                               pparam_desc = Pparam_val (Nolabel, None, self_pat);
+                               pparam_loc = x.pcf_loc;
+                             };
+                           ]
+                           f)
+                        (* the first argument is this *);
                     }
                     :: exprs,
                     true )

ppx/ast_pat.ml

@@ -24,25 +24,64 @@
 
 open Import
 
-let is_unit_cont ~yes ~no p =
+let is_unit p =
   match p with
-  | { ppat_desc = Ppat_construct ({ txt = Lident "()"; _ }, None); _ } -> yes
-  | _ -> no
+  | { ppat_desc = Ppat_construct ({ txt = Lident "()"; _ }, None); _ } -> true
+  | _ -> false
 
 (** [arity_of_fun pat e] tells the arity of
     expression [fun pat -> e] *)
-let arity_of_fun pat e =
-  let rec aux e =
-    match e.pexp_desc with
-    | Pexp_fun (_, _, _, e) -> 1 + aux e (*FIXME error on optional*)
-    | _ -> 0
+let arity_of_fun =
+  let rec arity_of_fun =
+    let arity_aux params ~init =
+      (* FIXME error on optional *)
+      List.fold_left ~init
+        ~f:(fun acc param ->
+          match param with
+          | { pparam_desc = Pparam_newtype _; _ } -> acc
+          | {
+           pparam_desc =
+             Pparam_val
+               ( _,
+                 _,
+                 {
+                   ppat_desc = Ppat_construct ({ txt = Lident "()"; _ }, None);
+                   _;
+                 } );
+           _;
+          }
+            when acc = 0 ->
+              acc
+          | { pparam_desc = Pparam_val (_, _, _); _ } -> acc + 1)
+        params
+    in
+    fun acc params body ->
+      let base = arity_aux params ~init:acc in
+      match body with
+      | { pexp_desc = Pexp_function (params', _, Pfunction_body body); _ } ->
+          arity_of_fun base params' body
+      | _ -> base
   in
-  is_unit_cont ~yes:0 ~no:1 pat + aux e
+  fun params body -> arity_of_fun 0 params body
 
-let rec labels_of_fun e =
-  match e.pexp_desc with
-  | Pexp_fun (l, _, _, e) -> l :: labels_of_fun e
-  | _ -> []
+let labels_of_fun =
+  let rec labels_of_fun =
+    let lbls_aux params ~init =
+      List.fold_left ~init
+        ~f:(fun acc param ->
+          match param with
+          | { pparam_desc = Pparam_newtype _; _ } -> acc
+          | { pparam_desc = Pparam_val (l, _, _); _ } -> l :: acc)
+        params
+    in
+    fun acc params body ->
+      let base = lbls_aux params ~init:acc in
+      match body with
+      | { pexp_desc = Pexp_function (params', _, Pfunction_body body); _ } ->
+          labels_of_fun base params' body
+      | _ -> List.rev base
+  in
+  fun params body -> labels_of_fun [] params body
 
 let rec is_single_variable_pattern_conservative p =
   match p.ppat_desc with

ppx/ast_pat.mli

@@ -24,11 +24,11 @@
 
 open Import
 
-val is_unit_cont : yes:'a -> no:'a -> pattern -> 'a
+val is_unit : pattern -> bool
 
-val arity_of_fun : pattern -> expression -> int
+val arity_of_fun : function_param list -> expression -> int
 (** [arity_of_fun pat e] tells the arity of
     expression [fun pat -> e]*)
 
-val labels_of_fun : expression -> Asttypes.arg_label list
+val labels_of_fun : function_param list -> expression -> Asttypes.arg_label list
 val is_single_variable_pattern_conservative : pattern -> bool

ppx/ast_tuple_pattern_flatten.ml

@@ -48,6 +48,7 @@ let flatten_tuple_pattern_vb (self : Ast_traverse.map) (vb : value_binding)
   let pvb_pat = self#pattern vb.pvb_pat in
   let pvb_expr = self#expression vb.pvb_expr in
   let pvb_attributes = self#attributes vb.pvb_attributes in
+  let pvb_constraint = Option.map self#value_constraint vb.pvb_constraint in
   match (pvb_pat.ppat_desc, pvb_expr.pexp_desc) with
   | Ppat_tuple xs, _ when List.for_all ~f:is_simple_pattern xs -> (
       match Ast_open_cxt.destruct_open_tuple pvb_expr [] with
@@ -62,10 +63,19 @@ let flatten_tuple_pattern_vb (self : Ast_traverse.map) (vb : value_binding)
                 pvb_expr = Ast_open_cxt.restore_exp exp wholes;
                 pvb_attributes;
                 pvb_loc = vb.pvb_loc;
+                pvb_constraint;
               }
               :: acc)
             xs es ~init:acc
-      | _ -> { pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes } :: acc)
+      | _ ->
+          {
+            pvb_pat;
+            pvb_expr;
+            pvb_loc = vb.pvb_loc;
+            pvb_attributes;
+            pvb_constraint;
+          }
+          :: acc)
   | Ppat_record (lid_pats, _), Pexp_pack { pmod_desc = Pmod_ident id; _ } ->
       List.map
         ~f:(fun (lid, pat) ->
@@ -78,13 +88,22 @@ let flatten_tuple_pattern_vb (self : Ast_traverse.map) (vb : value_binding)
                     { lid with txt = Ldot (id.txt, s) };
                 pvb_attributes = [];
                 pvb_loc = pat.ppat_loc;
+                pvb_constraint;
               }
           | _ ->
               Location.raise_errorf ~loc:lid.loc
                 "Pattern matching on modules requires simple labels")
         lid_pats
       @ acc
-  | _ -> { pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes } :: acc
+  | _ ->
+      {
+        pvb_pat;
+        pvb_expr;
+        pvb_loc = vb.pvb_loc;
+        pvb_attributes;
+        pvb_constraint;
+      }
+      :: acc
 
 (* XXX(anmonteiro): this one is a little brittle. Because it might introduce
    new value bindings, it must be called at every AST node that has a