Ppx_js: more tests

CHANGES.md

@@ -16,6 +16,8 @@
 * Runtime: less conversion during un-marshalling (#1889)
 * Compiler: improve performance of Javascript linking
 * Runtime/wasm: support unmarshaling compressed data (#1898)
+* Ppx: explicitly disallow polymorphic method (#1897)
+* Ppx: allow "function" in object literals (#1897)
 
 ## Bug fixes
 * Runtime: fix path normalization (#1848)

ppx/ppx_js/lib_internal/ppx_js_internal.ml

@@ -465,12 +465,10 @@ let new_object constr args =
 
 module S = Map.Make (String)
 
-(** We remove Pexp_poly as it should never be in the parsetree except after a method call.
-*)
-let format_meth body =
+let drop_pexp_poly body =
   match body.pexp_desc with
-  | Pexp_poly (e, _) -> e
-  | _ -> body
+  | Pexp_poly (e, ty) -> e, ty
+  | _ -> body, None
 
 (** Ensure basic sanity rules about fields of a literal object:
     - No duplicated declaration
@@ -582,13 +580,22 @@ let preprocess_literal_object mappper fields :
         names, Val (id, kind, bang, body) :: fields
     | Pcf_method (id, priv, Cfk_concrete (bang, body)) ->
         let names = check_name id names in
-        let body = format_meth (mappper body) 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) -> Arg.make ~label () :: create_meth_ty body
+          | Pexp_function _ -> [ Arg.make () ]
+          | Pexp_newtype (_, body) -> create_meth_ty body
           | _ -> []
         in
         let fun_ty = create_meth_ty body in
+        let body =
+          match body_ty with
+          | None -> body
+          | Some { ptyp_desc = Ptyp_poly _; _ } ->
+              raise_errorf ~loc:exp.pcf_loc "Polymorphic method not supported."
+          | Some ty -> Exp.constraint_ body ty
+        in
         names, Meth (id, priv, bang, body, fun_ty) :: fields
     | _ ->
         raise_errorf

ppx/ppx_js/tests/dune

@@ -13,6 +13,15 @@
  (action
   (run %{exe:main.bc} %{dep:ppx.mlt})))
 
+(rule
+ (targets gen.mlt.corrected)
+ (enabled_if
+  (and
+   (>= %{ocaml_version} 5.3)
+   (< %{ocaml_version} 5.4)))
+ (action
+  (run %{exe:main.bc} %{dep:gen.mlt})))
+
 (rule
  (alias runtest)
  (package js_of_ocaml-ppx)
@@ -22,3 +31,13 @@
    (< %{ocaml_version} 5.4)))
  (action
   (diff ppx.mlt ppx.mlt.corrected)))
+
+(rule
+ (alias runtest)
+ (package js_of_ocaml-ppx)
+ (enabled_if
+  (and
+   (>= %{ocaml_version} 5.3)
+   (< %{ocaml_version} 5.4)))
+ (action
+  (diff gen.mlt gen.mlt.corrected)))