fix: turn off warning 20 (ignored-extra-arguments) for mel.raw

Changes.md

@@ -50,6 +50,8 @@ Unreleased
 - Add `Js.Obj.assign` to merge 2 JS objects immutably
   ([#900](https://github.com/melange-re/melange/pull/900),
   [#795](https://github.com/melange-re/melange/pull/795))
+- Turn off warning 20 (`ignored-extra-argument`) for `%mel.raw` application
+  ([#915](https://github.com/melange-re/melange/pull/915))
 
 2.1.0 2023-10-22
 ---------------

bin/melc.ml

@@ -278,17 +278,8 @@ let main: Melc_cli.t -> _ Cmdliner.Term.ret
       List.rev_append include_dirs !Clflags.include_dirs;
     List.iter ~f:Warnings.parse_alert_option alerts;
 
-    begin match warnings with
-    | [] -> ()
-    | first :: rest ->
-      (* If more than one `-w` arguments are present, we insert `"-20"` between
-         them to give a chance for the last one to turn it off. This also
-         happens to cover the common case of Dune, which explicitly passes
-         "+20" (so we override it). *)
-      Melc_warnings.parse_warnings ~warn_error:false first;
-      Melc_warnings.parse_warnings ~warn_error:false "-20";
-      List.iter ~f:(Melc_warnings.parse_warnings ~warn_error:false) rest;
-    end;
+    List.iter warnings ~f:(fun w ->
+      Melc_warnings.parse_warnings ~warn_error:false w);
 
     Option.iter
       (fun output_name -> Clflags.output_name := Some output_name)

jscomp/core/melc_warnings.ml

@@ -69,7 +69,7 @@
 
   - 102 Mel_polymorphic_comparison
 *)
-let defaults_w = "+a-4-20-29-40-41-42-44-45-48-58-59-60-61-63..70-102"
+let defaults_w = "+a-4-29-40-41-42-44-45-48-58-59-60-61-63..70-102"
 let defaults_warn_error = "-a+5+6+101+109"
 (*TODO: add +10*)
 

ppx/ast_attributes.ml

@@ -181,13 +181,20 @@ let mel_set : attr =
     attr_loc = Location.none;
   }
 
+let internal_expansive_label = "internal.expansive"
+
 let internal_expansive : attr =
   {
-    attr_name = { txt = "internal.expansive"; loc = Location.none };
+    attr_name = { txt = internal_expansive_label; loc = Location.none };
     attr_payload = PStr [];
     attr_loc = Location.none;
   }
 
+let has_internal_expansive attrs =
+  List.exists
+    (fun { attr_name = { txt; _ }; _ } -> txt = "internal.expansive")
+    attrs
+
 let mel_return_undefined : attr =
   {
     attr_name = { txt = "mel.return"; loc = Location.none };
@@ -418,20 +425,18 @@ let has_mel_as_payload (attrs : t) =
             "Duplicate `%@mel.as' attribute found")
     ([], None) attrs
 
-(* We disable warning 61 in Melange externals since they're substantially
-   different from OCaml externals. This warning doesn't make sense for a JS
-   runtime *)
-let unboxable_type_in_prim_decl : Parsetree.attribute =
-  let open Ast_helper in
+let ocaml_warning w =
   {
     attr_name = { txt = "ocaml.warning"; loc = Location.none };
     attr_payload =
       PStr
-        [
-          Str.eval
-            (Exp.constant
-               (Pconst_string
-                  ("-unboxable-type-in-prim-decl", Location.none, None)));
-        ];
+        Ast_helper.
+          [ Str.eval (Exp.constant (Pconst_string (w, Location.none, None))) ];
     attr_loc = Location.none;
   }
+
+(* We disable warning 61 in Melange externals since they're substantially
+   different from OCaml externals. This warning doesn't make sense for a JS
+   runtime *)
+let unboxable_type_in_prim_decl = ocaml_warning "-unboxable-type-in-prim-decl"
+let ignored_extra_argument = ocaml_warning "-ignored-extra-argument"

ppx/ast_attributes.mli

@@ -46,6 +46,7 @@ val mel_get_index : attr
 val mel_get_arity : attr
 val mel_set : attr
 val internal_expansive : attr
+val has_internal_expansive : t -> bool
 val mel_return_undefined : attr
 
 val iter_process_mel_string_int_unwrap_uncurry :
@@ -61,5 +62,6 @@ type as_const_payload = Int of int | Str of string | Js_literal_str of string
 
 val iter_process_mel_string_or_int_as : t -> as_const_payload option
 val unboxable_type_in_prim_decl : attr
+val ignored_extra_argument : attr
 val is_mel_as : attr -> bool
 val has_mel_as_payload : t -> attr list * attr option

ppx/ast_exp_apply.ml

@@ -119,12 +119,12 @@ let app_exp_mapper (e : exp)
       | Some { op = "|."; args = [ a_; f_ ]; loc } -> (
           (*
         a |. f
-        a |. f b c [@bs]  --> f a b c [@bs]
+        a |. f b c [@u]  --> f a b c [@u]
         a |. M.(f b c) --> M.f a M.b M.c
         a |. (g |. b)
         a |. M.Some
         a |. `Variant
-        a |. (b |. f c [@bs])
+        a |. (b |. f c [@u])
       *)
           let a = self#expression a_ in
           let f = self#expression f_ in
@@ -220,7 +220,7 @@ let app_exp_mapper (e : exp)
                       f_.pexp_desc )
                   with
                   | Some other_attributes, Pexp_apply (fn1, args) ->
-                      (* a |. f b c [@bs]
+                      (* a |. f b c [@u]
                          Cannot process uncurried application early as the arity is wip *)
                       let fn1 = self#expression fn1 in
                       let args =
@@ -246,7 +246,7 @@ let app_exp_mapper (e : exp)
              gpr#1063 foo##(bar##baz) we should rewrite (bar##baz)
                  first  before pattern match.
                  currently the pattern match is written in a top down style.
-                 Another corner case: f##(g a b [@bs])
+                 Another corner case: f##(g a b [@u])
           *)
           match rest with
           | {
@@ -330,15 +330,22 @@ let app_exp_mapper (e : exp)
           Location.raise_errorf ~loc
             "Js object ## expect syntax like obj##(paint (a,b)) "
       | Some { op; _ } -> Location.raise_errorf "invalid %s syntax" op
-      | None -> (
-          match
-            exclude_with_val e.pexp_attributes Ast_attributes.is_uncurried
-          with
-          | None -> super e
-          | Some pexp_attributes ->
-              {
-                e with
-                pexp_desc =
-                  Ast_uncurry_apply.uncurry_fn_apply e.pexp_loc self fn args;
-                pexp_attributes;
-              }))
+      | None ->
+          let e =
+            match
+              exclude_with_val e.pexp_attributes Ast_attributes.is_uncurried
+            with
+            | None -> super e
+            | Some pexp_attributes ->
+                {
+                  e with
+                  pexp_desc =
+                    Ast_uncurry_apply.uncurry_fn_apply e.pexp_loc self fn args;
+                  pexp_attributes;
+                }
+          in
+          {
+            e with
+            pexp_attributes =
+              Ast_attributes.ignored_extra_argument :: e.pexp_attributes;
+          })

ppx/ast_external_mk.ml

@@ -25,7 +25,7 @@
 open Import
 open Ast_helper
 
-let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string list)
+let local_external_apply loc ~(pval_prim : string list)
     ~(pval_type : Parsetree.core_type) ?(local_module_name = "J")
     ?(local_fun_name = "unsafe_expr") (args : Parsetree.expression list) :
     Parsetree.expression_desc =
@@ -43,7 +43,7 @@ let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string list)
                       pval_type;
                       pval_loc = loc;
                       pval_prim;
-                      pval_attributes;
+                      pval_attributes = [];
                     };
                 pstr_loc = loc;
               };

ppx/ast_external_mk.mli

@@ -26,7 +26,6 @@ open Import
 
 val local_external_apply :
   Location.t ->
-  ?pval_attributes:Parsetree.attributes ->
   pval_prim:string list ->
   pval_type:Parsetree.core_type ->
   ?local_module_name:string ->

ppx/ast_uncurry_apply.ml

@@ -33,19 +33,6 @@ type exp = Parsetree.expression
 *)
 let jsInternal = Ast_literal.js_internal
 
-let ignored_extra_argument : Parsetree.attribute =
-  {
-    attr_name = { txt = "ocaml.warning"; loc = Location.none };
-    attr_payload =
-      PStr
-        [
-          Str.eval
-            (Exp.constant
-               (Pconst_string ("-ignored-extra-argument", Location.none, None)));
-        ];
-    attr_loc = Location.none;
-  }
-
 (* we use the trick
    [( opaque e : _) ] to avoid it being inspected,
    the type constraint is avoid some syntactic transformation, e.g ` e |. (f g [@bs])`
@@ -65,7 +52,7 @@ let opaque_full_apply ~loc (e : exp) : Parsetree.expression_desc =
              * OCaml thinks the extra argument is unused because we're
              * producing * an uncurried call to a JS function whose arity isn't
              * known at compile time. *)
-            ignored_extra_argument;
+            Ast_attributes.ignored_extra_argument;
           ]
         (Exp.ident { txt = Ast_literal.js_internal_full_apply; loc })
         [ (Nolabel, e) ],

test/blackbox-tests/warning-20.t

@@ -1,4 +1,5 @@
-Melange turns off warning 20 by default ([ignored-extra-argument])
+Melange turns off warning 20 by default for applications
+([ignored-extra-argument])
 
   $ . ./setup.sh
   $ cat > dune-project <<EOF
@@ -23,47 +24,3 @@ Melange turns off warning 20 by default ([ignored-extra-argument])
 
   $ dune build @melange
 
-But it remains possible to turn it on via `-w`:
-
-  $ cat > dune << EOF
-  > (melange.emit
-  >  (target out)
-  >  (emit_stdlib false)
-  >  (preprocess (pps melange.ppx))
-  >  (compile_flags :standard -w +20))
-  > EOF
-
-  $ dune build @melange
-  File "foo.ml", line 6, characters 15-16:
-  6 | let x = addOne 2
-                     ^
-  Error (warning 20 [ignored-extra-argument]): this argument will not be used by the function.
-  [1]
-
-Turned off by default with `melc`
-
-  $ melc -ppx melppx foo.ml
-  // Generated by Melange
-  'use strict';
-
-
-  var addOne = (function (a) {
-      return a + 1;
-    });
-
-  var x = addOne(2);
-
-  exports.addOne = addOne;
-  exports.x = x;
-  /* x Not a pure module */
-
-Possible to turn on with `melc`, but `-w -20` gets inserted in between `-w`
-arguments so we need to pass `-w` twice. Better than not being able to turn it
-off at all...
-
-  $ melc -ppx melppx -w +20 -w +20 -warn-error +20 foo.ml
-  File "foo.ml", line 6, characters 15-16:
-  6 | let x = addOne 2
-                     ^
-  Error (warning 20 [ignored-extra-argument]): this argument will not be used by the function.
-  [2]