Ppx: add support for ppxlib.0.36

hhugo · hhugo · commit cbc9044aae64 · 2025-04-03T13:56:22.000+02:00
diff --git a/compiler/ppx/ppx_optcomp_light.ml b/compiler/ppx/ppx_optcomp_light.ml
@@ -158,6 +158,8 @@ let keep loc (attrs : attributes) =
           let rec eval = function
             | { pexp_desc = Pexp_ident { txt = Lident "ocaml_version"; _ }; _ } ->
                 Version Version.current
+            | { pexp_desc = Pexp_ident { txt = Lident "ast_version"; _ }; _ } ->
+                Int Ppxlib.Selected_ast.version
             | { pexp_desc = Pexp_construct ({ txt = Lident "true"; _ }, None); _ } ->
                 Bool true
             | { pexp_desc = Pexp_construct ({ txt = Lident "false"; _ }, None); _ } ->
@@ -275,11 +277,14 @@ let traverse =
       in
       super#structure items
 
-    method! cases =
-      filter_map ~f:(fun case ->
-          match filter_pattern case.pc_lhs with
-          | None -> None
-          | Some pattern -> Some { case with pc_lhs = pattern })
+    method! cases cases =
+      let cases =
+        filter_map cases ~f:(fun case ->
+            match filter_pattern case.pc_lhs with
+            | None -> None
+            | Some pattern -> Some { case with pc_lhs = pattern })
+      in
+      super#cases cases
   end
 
 let () =
diff --git a/ppx/ppx_js/as-lib/dune b/ppx/ppx_js/as-lib/dune
@@ -4,7 +4,7 @@
  (synopsis "Js_of_ocaml ppx")
  (libraries compiler-libs.common ppxlib)
  (preprocess
-  (pps ppxlib.metaquot)))
+  (pps ppx_optcomp_light ppxlib.metaquot)))
 
 (rule
  (targets ppx_js_internal.ml)
diff --git a/ppx/ppx_js/lib_internal/dune b/ppx/ppx_js/lib_internal/dune
@@ -3,4 +3,4 @@
  (libraries compiler-libs.common ppxlib)
  (kind ppx_rewriter)
  (preprocess
-  (pps ppxlib.metaquot)))
+  (pps ppx_optcomp_light ppxlib.metaquot)))
diff --git a/ppx/ppx_js/lib_internal/ppx_js_internal.ml b/ppx/ppx_js/lib_internal/ppx_js_internal.ml
@@ -250,7 +250,24 @@ let invoker ?(extra_types = []) uplift downlift body arguments =
   in
   let make_fun (label, pat) (label', typ) expr =
     assert (label' = label);
-    Exp.fun_ label None (Pat.constraint_ pat typ) expr
+    match expr.pexp_desc with
+    | ((Pexp_function (params, c, b)) [@if ast_version >= 502]) ->
+        let params =
+          { pparam_desc = Pparam_val (nolabel, None, Pat.constraint_ pat typ)
+          ; pparam_loc = { expr.pexp_loc with loc_ghost = true }
+          }
+          :: params
+        in
+        let c, b =
+          match c, b with
+          | ( None
+            , Pfunction_body
+                { pexp_desc = Pexp_constraint (e, ty); pexp_attributes = []; _ } ) ->
+              Some (Pconstraint ty), Pfunction_body e
+          | _ -> c, b
+        in
+        { expr with pexp_desc = Pexp_function (params, c, b) }
+    | _ -> Exp.fun_ label None (Pat.constraint_ pat typ) expr
   in
   let invoker =
     List.fold_right2
@@ -504,7 +521,7 @@ type field_desc =
       string Asttypes.loc
       * Asttypes.private_flag
       * Asttypes.override_flag
-      * Parsetree.expression
+      * (Parsetree.expression * Parsetree.core_type option)
       * Arg.t list
   | Val of
       string Asttypes.loc * Prop_kind.t * Asttypes.override_flag * Parsetree.expression
@@ -518,6 +535,29 @@ let filter_map f l =
   in
   List.rev l
 
+let rec create_meth_ty exp =
+  match exp.pexp_desc with
+  | Pexp_fun (label, _, _, body) -> label :: create_meth_ty body
+  | Pexp_function _ -> [ nolabel ]
+  | Pexp_newtype (_, body) -> create_meth_ty body
+  | _ -> []
+[@@if ast_version < 502]
+
+let rec create_meth_ty exp =
+  match exp.pexp_desc with
+  | Pexp_function (params, _, body) -> (
+      List.filter_map params ~f:(function
+        | { pparam_desc = Pparam_newtype _; _ } -> None
+        | { pparam_desc = Pparam_val (label, _, _arg); _ } -> Some label)
+      @
+      match body with
+      | Pfunction_cases _ -> [ nolabel ]
+      | Pfunction_body e ->
+          (* TODO: should we recurse or not ? *)
+          create_meth_ty e)
+  | _ -> []
+[@@if ast_version >= 502]
+
 let preprocess_literal_object mappper fields :
     [ `Fields of field_desc list | `Error of _ ] =
   let check_name id names =
@@ -581,22 +621,16 @@ let preprocess_literal_object mappper fields :
     | Pcf_method (id, priv, Cfk_concrete (bang, body)) ->
         let names = check_name id names in
         let body, body_ty = drop_pexp_poly (mappper body) in
-        let rec create_meth_ty exp =
-          match exp.pexp_desc with
-          | Pexp_fun (label, _, _, body) -> label :: create_meth_ty body
-          | Pexp_function _ -> [ nolabel ]
-          | Pexp_newtype (_, body) -> create_meth_ty body
-          | _ -> []
-        in
         let fun_ty =
           List.map ~f:(fun label -> Arg.make ~label ()) (create_meth_ty body)
         in
+
         let body =
           match body_ty with
-          | None -> body
+          | None -> body, None
           | Some { ptyp_desc = Ptyp_poly _; _ } ->
               raise_errorf ~loc:exp.pcf_loc "Polymorphic method not supported."
-          | Some ty -> Exp.constraint_ body ty
+          | Some ty -> body, Some ty
         in
         names, Meth (id, priv, bang, body, fun_ty) :: fields
     | _ ->
@@ -649,8 +683,43 @@ let literal_object self_id (fields : field_desc list) =
   in
   let body = function
     | Val (_, _, _, body) -> body
-    | Meth (_, _, _, body, _) ->
-        Exp.fun_ ~loc:{ body.pexp_loc with loc_ghost = true } Nolabel None self_id body
+    | Meth (_, _, _, (body, ty), _) -> (
+        match body.pexp_desc, ty with
+        | ((Pexp_function (params, c, b), None) [@if ast_version >= 502]) ->
+            let params =
+              { pparam_desc = Pparam_val (nolabel, None, self_id)
+              ; pparam_loc = { body.pexp_loc with loc_ghost = true }
+              }
+              :: params
+            in
+            { body with pexp_desc = Pexp_function (params, c, b) }
+        | ((_, Some ty) [@if ast_version >= 502]) -> (
+            let e =
+              Exp.fun_
+                ~loc:{ body.pexp_loc with loc_ghost = true }
+                Nolabel
+                None
+                self_id
+                body
+            in
+            match e.pexp_desc with
+            | Pexp_function (params, None, b) ->
+                { e with pexp_desc = Pexp_function (params, Some (Pconstraint ty), b) }
+            | _ -> assert false)
+        | ((_, Some ty) [@if ast_version < 502]) ->
+            Exp.fun_
+              ~loc:{ body.pexp_loc with loc_ghost = true }
+              Nolabel
+              None
+              self_id
+              (Exp.constraint_ body ty)
+        | _, None ->
+            Exp.fun_
+              ~loc:{ body.pexp_loc with loc_ghost = true }
+              Nolabel
+              None
+              self_id
+              body)
   in
   let extra_types =
     List.concat
@@ -738,7 +807,23 @@ let literal_object self_id (fields : field_desc list) =
                (self :: List.map fields ~f:(fun f -> (name f).txt))
                ~init:fake_object
                ~f:(fun name fun_ ->
-                 Exp.fun_ ~loc:gloc nolabel None (Pat.var ~loc:gloc (mknoloc name)) fun_))
+                 match fun_.pexp_desc with
+                 | ((Pexp_function (params, c, b)) [@if ast_version >= 502]) ->
+                     let params =
+                       { pparam_desc =
+                           Pparam_val (nolabel, None, Pat.var ~loc:gloc (mknoloc name))
+                       ; pparam_loc = { fun_.pexp_loc with loc_ghost = true }
+                       }
+                       :: params
+                     in
+                     { fun_ with pexp_desc = Pexp_function (params, c, b) }
+                 | _ ->
+                     Exp.fun_
+                       ~loc:gloc
+                       nolabel
+                       None
+                       (Pat.var ~loc:gloc (mknoloc name))
+                       fun_))
             with
             pexp_attributes = [ merlin_hide ]
           }
diff --git a/ppx/ppx_js/tests/gen.mlt b/ppx/ppx_js/tests/gen.mlt
@@ -369,7 +369,7 @@ Error: Polymorphic method not supported.
 
 
 let o () =
-  object%js
+  object%js 
     method m1 : 'a  -> unit = fun (type a) (a : a) -> ignore a
     method m2 : int -> unit = fun (type a) (a : a) -> ignore a
     method m3 : 'b -> unit = fun (a : 'b) -> ignore a
@@ -409,8 +409,8 @@ let o () =
                        ("m3",
                          (Js_of_ocaml.Js.Unsafe.inject
                             (Js_of_ocaml.Js.wrap_meth_callback t31)))|])
-    (fun _ : 'a -> unit-> fun (type a) -> fun (a : a) -> ignore a)
-    (fun _ : int -> unit-> fun (type a) -> fun (a : a) -> ignore a)
+    (fun _ : 'a -> unit-> fun (type a) (a : a) -> ignore a)
+    (fun _ : int -> unit-> fun (type a) (a : a) -> ignore a)
     (fun _ : 'b -> unit-> fun (a : 'b) -> ignore a)
     ((fun self m1 m2 m3 ->
         object method m1 = m1 self method m2 = m2 self method m3 = m3 self
