ppx: improve inference of @mel.as in external param polyvars

Changes.md

@@ -8,6 +8,9 @@ Unreleased
   ([#1380](https://github.com/melange-re/melange/pull/1380))
 - Add `[@mel.spread]` in `external`s to spread polymorphic variants with
   payloads ([#1404](https://github.com/melange-re/melange/pull/1404))
+- melange.ppx: improve the inference of `@mel.as` in polymorphic variant
+  arguments to `external`s, allow to mix ints and strings in the different
+  variant branches ([#1418](https://github.com/melange-re/melange/pull/1418))
 
 5.1.0-53 2025-03-23
 ---------------

jscomp/core/js_of_lam_variant.ml

@@ -35,6 +35,32 @@ let eval (arg : J.expression)
   if arg == E.undefined then E.undefined
   else
     match arg.expression_desc with
+    | Caml_block
+        {
+          fields = { expression_desc = Str s; _ } :: payload;
+          tag_info = Blk_poly_var;
+          tag;
+          mutable_flag;
+        } ->
+        let v =
+          match dispatches with
+          | [] -> Melange_ffi.External_arg_spec.Arg_cst.Str s
+          | dispatches -> (
+              match List.assoc_opt s dispatches with
+              | Some r -> r
+              | None -> Str s)
+        in
+        {
+          arg with
+          expression_desc =
+            Caml_block
+              {
+                fields = Lam_compile_const.translate_arg_cst v :: payload;
+                tag_info = Blk_poly_var;
+                tag;
+                mutable_flag;
+              };
+        }
     | Str s -> Lam_compile_const.translate_arg_cst (List.assoc s dispatches)
     | _ ->
         E.of_block

jscomp/core/lam_compile_external_call.ml

@@ -130,7 +130,7 @@ let rec ocaml_to_js_eff ~(arg_label : External_arg_spec.Arg_label.t)
   | Int dispatches -> (Splice1 (Js_of_lam_variant.eval arg dispatches), [])
   | Unwrap polyvar -> (
       match (polyvar, raw_arg.expression_desc) with
-      | (Poly_var { spread = false; _ } | Int _), Caml_block _ ->
+      | (Poly_var { spread = false; descr = _ :: _ } | Int _), Caml_block _ ->
           Location.raise_errorf ?loc:raw_arg.loc
             "`[@mel.as ..]' can only be used with `[@mel.unwrap]' variants \
              without a payload."

ppx/ast_external_process.ml

@@ -43,38 +43,6 @@ let variant_unwrap =
     | [] -> false (* impossible syntax *)
     | xs -> variant_can_unwrap_aux xs
 
-let infer_mel_as ~loc row_fields ~allow_no_payload =
-  let mel_as_type =
-    (* No `@mel.string` / `@mel.int` present. Try to infer `@mel.as`, if
-       present, in polyvariants.
-
-       https://github.com/melange-re/melange/issues/578 *)
-    List.fold_left
-      ~f:(fun mel_as_type { prf_attributes; prf_loc; _ } ->
-        match List.filter ~f:Ast_attributes.is_mel_as prf_attributes with
-        | [] -> mel_as_type
-        | [ { attr_payload; attr_loc = loc; _ } ] -> (
-            match
-              ( mel_as_type,
-                Ast_payload.is_single_string attr_payload,
-                Ast_payload.is_single_int attr_payload )
-            with
-            | (`Nothing | `String), Some _, None -> `String
-            | (`Nothing | `Int), None, Some _ -> `Int
-            | (`Nothing | `String | `Int), None, None -> `Nothing
-            | `String, None, Some _ -> Error.err ~loc Expect_string_literal
-            | `Int, Some _, None -> Error.err ~loc Expect_int_literal
-            | _, Some _, Some _ -> assert false)
-        | _ :: _ -> Error.err ~loc:prf_loc Duplicated_mel_as)
-      ~init:`Nothing row_fields
-  in
-  match mel_as_type with
-  | `Nothing -> External_arg_spec.Nothing
-  | `String ->
-      Ast_polyvar.map_row_fields_into_strings row_fields ~loc ~allow_no_payload
-  | `Int ->
-      Ast_polyvar.map_row_fields_into_ints row_fields ~loc ~allow_no_payload
-
 (* TODO: [nolabel] is only used once turn Nothing into Unit, refactor later *)
 let spec_of_ptyp ~(nolabel : bool) (ptyp : core_type) : External_arg_spec.t =
   let ptyp_desc = ptyp.ptyp_desc in
@@ -87,13 +55,11 @@ let spec_of_ptyp ~(nolabel : bool) (ptyp : core_type) : External_arg_spec.t =
       match ptyp_desc with
       | Ptyp_variant (row_fields, Closed, None) ->
           Ast_polyvar.map_row_fields_into_strings row_fields ~loc:ptyp.ptyp_loc
-            ~allow_no_payload:false
       | _ -> Error.err ~loc:ptyp.ptyp_loc Invalid_mel_string_type)
   | Int -> (
       match ptyp_desc with
       | Ptyp_variant (row_fields, Closed, None) ->
           Ast_polyvar.map_row_fields_into_ints row_fields ~loc:ptyp.ptyp_loc
-            ~allow_no_payload:false
       | _ -> Error.err ~loc:ptyp.ptyp_loc Invalid_mel_int_type)
   | Spread -> (
       match ptyp_desc with
@@ -105,8 +71,7 @@ let spec_of_ptyp ~(nolabel : bool) (ptyp : core_type) : External_arg_spec.t =
       | Ptyp_variant (row_fields, Closed, _) when variant_unwrap row_fields ->
           (* Unwrap attribute can only be attached to things like
              `[a of a0 | b of b0]` *)
-          Unwrap
-            (infer_mel_as ~loc:ptyp.ptyp_loc row_fields ~allow_no_payload:true)
+          Unwrap (Ast_polyvar.infer_mel_as ~loc:ptyp.ptyp_loc row_fields)
       | _ -> Error.err ~loc:ptyp.ptyp_loc Invalid_mel_unwrap_type)
   | Uncurry opt_arity -> (
       let real_arity = Ast_core_type.get_uncurry_arity ptyp in
@@ -124,7 +89,7 @@ let spec_of_ptyp ~(nolabel : bool) (ptyp : core_type) : External_arg_spec.t =
       | Ptyp_constr ({ txt = Lident "unit"; _ }, []) ->
           if nolabel then Extern_unit else Nothing
       | Ptyp_variant (row_fields, Closed, None) ->
-          infer_mel_as ~loc:ptyp.ptyp_loc row_fields ~allow_no_payload:false
+          Ast_polyvar.infer_mel_as ~loc:ptyp.ptyp_loc row_fields
       | _ -> Nothing)
 
 (* is_optional = false *)

ppx/ast_polyvar.ml

@@ -41,8 +41,7 @@ let is_enum_polyvar =
         Some row_fields
     | Some _ | None -> None
 
-let map_row_fields_into_ints (row_fields : row_field list) ~loc
-    ~allow_no_payload =
+let map_row_fields_into_ints (row_fields : row_field list) ~loc =
   let _, acc =
     List.fold_left ~init:(0, []) row_fields ~f:(fun (i, acc) rtag ->
         match rtag.prf_desc with
@@ -53,13 +52,6 @@ let map_row_fields_into_ints (row_fields : row_field list) ~loc
                 ~default:i
             in
             (i + 1, (txt, External_arg_spec.Arg_cst.Int i) :: acc)
-        | Rtag ({ txt; _ }, _, _) when allow_no_payload ->
-            let i =
-              Option.value
-                (Ast_attributes.iter_process_mel_int_as rtag.prf_attributes)
-                ~default:i
-            in
-            (i + 1, (txt, External_arg_spec.Arg_cst.Int i) :: acc)
         | _ -> Error.err ~loc Invalid_mel_int_type)
   in
   External_arg_spec.Int (List.rev acc)
@@ -77,16 +69,14 @@ let map_row_fields_into_strings =
     in
     (txt, External_arg_spec.Arg_cst.Str name)
   in
-  fun (row_fields : row_field list) ~loc ~allow_no_payload ->
+  fun (row_fields : row_field list) ~loc ->
     let has_mel_as = ref false in
     let case, result =
       List.fold_right
         ~f:(fun tag (nullary, acc) ->
           match (nullary, tag.prf_desc) with
           | (`Nothing | `Null), Rtag ({ txt; _ }, true, []) ->
               (`Null, process_mel_as tag ~txt ~has_mel_as :: acc)
-          | `NonNull, Rtag ({ txt; _ }, true, []) when allow_no_payload ->
-              (`Null, process_mel_as tag ~txt ~has_mel_as :: acc)
           | (`Nothing | `NonNull), Rtag ({ txt; _ }, false, [ _ ]) ->
               (`NonNull, process_mel_as tag ~txt ~has_mel_as :: acc)
           | _ -> Error.err ~loc Invalid_mel_string_type)
@@ -113,3 +103,21 @@ let map_row_fields_into_spread (row_fields : row_field list) ~loc =
         | _ -> Error.err ~loc Invalid_mel_spread_type)
   in
   External_arg_spec.Poly_var { descr = result; spread = true }
+
+let infer_mel_as ~loc row_fields =
+  let has_mel_as = ref false in
+  let result =
+    List.map row_fields ~f:(fun { prf_desc; prf_attributes; _ } ->
+        match prf_desc with
+        | Rtag ({ txt; _ }, _, _) ->
+            ( txt,
+              match Ast_attributes.iter_process_mel_as_cst prf_attributes with
+              | Some x ->
+                  has_mel_as := true;
+                  x
+              | None -> Str txt )
+        | _ -> Error.err ~loc Invalid_mel_spread_type)
+  in
+  if !has_mel_as then
+    External_arg_spec.Poly_var { descr = result; spread = false }
+  else Nothing

ppx/ast_polyvar.mli

@@ -27,19 +27,14 @@ open Import
 val is_enum_polyvar : type_declaration -> row_field list option
 
 val map_row_fields_into_ints :
-  row_field list ->
-  loc:Location.t ->
-  (* allow `Foo [@mel.as "bar"] inside `@mel.unwrap` *)
-  allow_no_payload:bool ->
-  Melange_ffi.External_arg_spec.t
+  row_field list -> loc:Location.t -> Melange_ffi.External_arg_spec.t
 (** side effect: it will mark used attributes `mel.as`  *)
 
 val map_row_fields_into_strings :
-  row_field list ->
-  loc:Location.t ->
-  (* allow `Foo [@mel.as "bar"] inside `@mel.unwrap` *)
-  allow_no_payload:bool ->
-  Melange_ffi.External_arg_spec.t
+  row_field list -> loc:Location.t -> Melange_ffi.External_arg_spec.t
 
 val map_row_fields_into_spread :
   row_field list -> loc:Location.t -> Melange_ffi.External_arg_spec.t
+
+val infer_mel_as :
+  loc:Location.t -> row_field list -> Melange_ffi.External_arg_spec.t

test/blackbox-tests/as-without-mel-string.t

@@ -48,13 +48,17 @@ Test `@mel.as` without `@mel.string` / `@mel.int` in external polyvars
   >   ] ->
   >   unit = "transitionTimingFunction"
   > let () = transition_timing_function () \`easeIn
+  > let () = transition_timing_function () \`easeOut
   > EOF
   $ melc -ppx melppx x.ml
-  File "x.ml", line 6, characters 13-24:
-  6 |   | `easeOut [@mel.as 1]
-                   ^^^^^^^^^^^
-  Error: Expected a string literal
-  [2]
+  // Generated by Melange
+  'use strict';
+
+
+  transitionTimingFunction(undefined, "ease-in");
+
+  transitionTimingFunction(undefined, 1);
+  /*  Not a pure module */
 
   $ cat > x.ml <<EOF
   > type t = unit
@@ -68,9 +72,9 @@ Test `@mel.as` without `@mel.string` / `@mel.int` in external polyvars
   > let () = transition_timing_function () \`easeIn
   > EOF
   $ melc -ppx melppx x.ml
-  File "x.ml", line 5, characters 4-43:
+  File "x.ml", line 5, characters 26-32:
   5 |   | `easeIn [@mel.as 1] [@mel.as "ease-in"]
-          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+                                ^^^^^^
   Error: Duplicate `@mel.as'
   [2]
 

test/blackbox-tests/mel-as-string-warnings.t

@@ -74,5 +74,39 @@ This is wrong, just because there's `[@mel.as]` we shouldn't splice the payload
   'use strict';
 
 
-  foo("bar", 2);
+  foo({
+    NAME: "bar",
+    VAL: 2
+  });
   /*  Not a pure module */
+
+  $ cat > x.ml <<\EOF
+  > external foo : ([ `foo [@mel.as "bar"]][@mel.unwrap]) -> string = "foo"
+  > let _ = foo `foo
+  > EOF
+  $ melc -ppx melppx x.ml
+  // Generated by Melange
+  'use strict';
+
+
+  foo("bar");
+  /*  Not a pure module */
+
+  $ cat > x.ml <<EOF
+  > external join : ?foo:[ | \`foo of int [@mel.as "hi"] ] -> string = "join"
+  > let x = join ~foo:(\`foo 42)
+  > EOF
+  $ melc -ppx melppx x.ml
+  // Generated by Melange
+  'use strict';
+
+
+  const x = join({
+    NAME: "hi",
+    VAL: 42
+  });
+
+  module.exports = {
+    x,
+  }
+  /* x Not a pure module */

test/blackbox-tests/ppx-errors.t

@@ -410,12 +410,3 @@ Demonstrate PPX error messages
   Error: `[@mel.variadic]' cannot be applied to an optionally labelled argument
   [1]
 
-  $ cat > x.ml <<EOF
-  > external join : ?foo:[ | \`foo of int [@mel.as "hi"] ] -> string = "join"
-  > EOF
-  $ dune build @melange
-  File "x.ml", line 1, characters 21-53:
-  1 | external join : ?foo:[ | `foo of int [@mel.as "hi"] ] -> string = "join"
-                           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-  Error: `[@mel.as ..]' must not be used with an optionally labelled polymorphic variant
-  [1]