Stop warning 20 on calls of open JS object methods

changes/object-method-unused-argument.fix.md

@@ -0,0 +1 @@
+- Fix warning 20 ("this argument will not be used by the function") firing on calls of methods of open JS object types, such as `obj["getData"]("text/plain")`.

compiler/ml/typecore.ml

@@ -2467,6 +2467,15 @@ let should_unify_expected_result_before_typing_lowered_apply funct sargs =
 
 type targs = (Asttypes.arg_label * Typedtree.expression option) list
 
+(* The type of the most recent object field read if that read added the field
+   to an open object row ([obj["m"]] with [obj: {..}]), [None] after any other
+   read. Only the [Pexp_apply] case reads it: it resets it before typing the
+   callee and checks it right after, where it is only meaningful when the
+   callee itself is such a read. Request-local, so requests type-checked
+   concurrently on other domains cannot overwrite it in between. *)
+let open_row_field_read : type_expr option ref Request_local.key =
+  Request_local.new_key (fun () -> ref None)
+
 (* Eliminate an object-field scheme for a read. A declared field payload is
    wrapped in [Tpoly]: an empty binder list needs ordinary instantiation, while
    a nonempty list needs polymorphic instantiation. An inferred field whose
@@ -2715,9 +2724,19 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp
     assert (sargs <> []);
     begin_def ();
     (* one more level for non-returning functions *)
+    Request_local.get open_row_field_read := None;
     let funct =
       type_exp ~deprecated_context:FunctionCall ~context:None env sfunct
     in
+    (* Whether the callee is a JS object method that its read added to an open
+       object row ([obj["m"]] with [obj: {..}]). Its type is a fresh variable
+       like that of a callee that never returns, but the method receives its
+       arguments, so [type_application] must not report them as unused. *)
+    let open_row_method =
+      match (funct.exp_desc, !(Request_local.get open_row_field_read)) with
+      | Texp_object_get _, Some ty -> repr ty == repr funct.exp_type
+      | _ -> false
+    in
     (if should_unify_expected_result_before_typing_lowered_apply funct sargs
      then
        (* The async wrapper is lowered to a regular application, so thread the
@@ -2740,7 +2759,8 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp
     let args, ty_res, fully_applied =
       match translate_unified_ops env funct sargs with
       | Some (targs, result_type) -> (targs, result_type, true)
-      | None -> type_application ~context total_app env funct sargs
+      | None ->
+        type_application ~context ~open_row_method total_app env funct sargs
     in
     end_def ();
     if transformed_jsx then check_jsx_props ~loc env args;
@@ -3554,11 +3574,23 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp
       }
   | Pexp_object_get (e, ({txt = met} as met_loc)) -> (
     let obj = type_exp ~context:None env e in
+    (* An object type without the field gets it from its open row (or the
+       lookup fails). An object whose type is still a variable, such as
+       [failwith("x")], does not count. *)
+    let adds_field_to_row =
+      match (expand_head env obj.exp_type).desc with
+      | Tobject fields ->
+        let fields, _ = Ctype.flatten_fields fields in
+        not (List.exists (fun (f : Ctype.field_info) -> f.f_name = met) fields)
+      | _ -> false
+    in
     try
       (* Lookup constrains an open object row to contain the field, without
          requiring or adding write capability. *)
       let typ = filter_method env met obj.exp_type in
       let typ = object_field_use_type env typ in
+      Request_local.get open_row_field_read
+      := if adds_field_to_row then Some typ else None;
       rue
         {
           exp_desc = Texp_object_get (obj, met_loc);
@@ -4388,8 +4420,8 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression)
     | _ -> None)
   | _ -> None
 
-and type_application ~context total_app env funct (sargs : sargs) :
-    targs * Types.type_expr * bool =
+and type_application ~context ~open_row_method total_app env funct
+    (sargs : sargs) : targs * Types.type_expr * bool =
   match sargs with
   (* Special case for ignore: avoid discarding warning *)
   | [(Nolabel, sarg)] when is_ignore ~env funct ->
@@ -4418,9 +4450,16 @@ and type_application ~context total_app env funct (sargs : sargs) :
         List.map (fun (l1, _) -> {Types.lbl = l1; typ = newvar ()}) sargs
       in
       let ty_ret = newvar () in
+      (* A fresh type variable as function type usually means the function
+         never returns (e.g. [failwith("x")(1)]), so the arguments are
+         unused. A JS object method that the read added to an open object
+         row ([obj["m"]] with [obj: {..}]) also gets a fresh variable, but it
+         is an ordinary JS method that receives its arguments
+         ([open_row_method]). *)
       if
         ty_fun.level >= ty_ret.level
-        && not (is_identity_coercion funct.exp_desc)
+        && (not (is_identity_coercion funct.exp_desc))
+        && not open_row_method
       then
         List.iter
           (fun (_, sarg1) ->

tests/build_tests/super_errors/expected/unused_argument_object_method.res.expected

@@ -0,0 +1,36 @@
+
+  Warning number 20
+  /.../fixtures/unused_argument_object_method.res:28:51
+
+  26 │ 
+  27 │ // A function that never returns ignores its arguments: warning 20.
+  28 │ let ignored = () => throw(Failure("unreachable"))(1)
+  29 │ 
+  30 │ // A field read that cannot return ignores its arguments: warning 20.
+
+  this argument will not be used by the function.
+
+
+  Warning number 20
+  /.../fixtures/unused_argument_object_method.res:31:62-77
+
+  29 │ 
+  30 │ // A field read that cannot return ignores its arguments: warning 20.
+  31 │ let fromLiteral = () => ({"m": throw(Failure("boom"))})["m"](Console.lo
+     │ g("a"))
+  32 │ let fromThrow = () => throw(Failure("boom"))["m"](Console.log("b"))
+  33 │ 
+
+  this argument will not be used by the function.
+
+
+  Warning number 20
+  /.../fixtures/unused_argument_object_method.res:32:51-66
+
+  30 │ // A field read that cannot return ignores its arguments: warning 20.
+  31 │ let fromLiteral = () => ({"m": throw(Failure("boom"))})["m"](Console.lo
+     │ g("a"))
+  32 │ let fromThrow = () => throw(Failure("boom"))["m"](Console.log("b"))
+  33 │ 
+
+  this argument will not be used by the function.

tests/build_tests/super_errors/fixtures/unused_argument_object_method.res

@@ -0,0 +1,32 @@
+@get external clipboardData: string => {..} = "clipboardData"
+
+// A method of an open JS object type receives its arguments: no warning 20.
+let text = clipboardData("event")["getData"]("text/plain")
+
+// Arguments that read object fields do not change that.
+let closed: {"x": string} = {"x": "x"}
+let closedArg = clipboardData("e")["getData"](closed["x"])
+let openArg = clipboardData("e")["getData"](clipboardData("o")["x"])
+let closedLast = clipboardData("e")["m"]("a", closed["x"])
+let closedFirst = clipboardData("e")["m"](closed["x"], "a")
+let openLast = clipboardData("e")["m"]("a", clipboardData("o")["x"])
+let openFirst = clipboardData("e")["m"](clipboardData("o")["x"], "a")
+let nested = clipboardData("e")["m"](clipboardData("f")["n"]("y"))
+
+// Reading the method before calling it does not change that either.
+let retained = clipboardData("e")
+let first = retained["m"]
+let second = retained["m"]("used")
+let readElsewhere = () => {
+  let o = clipboardData("e")
+  let get = () => o["m"]
+  o["m"]("used")->ignore
+  get
+}
+
+// A function that never returns ignores its arguments: warning 20.
+let ignored = () => throw(Failure("unreachable"))(1)
+
+// A field read that cannot return ignores its arguments: warning 20.
+let fromLiteral = () => ({"m": throw(Failure("boom"))})["m"](Console.log("a"))
+let fromThrow = () => throw(Failure("boom"))["m"](Console.log("b"))

tests/ounit_tests/ounit_compiler_request_tests.ml

@@ -1398,6 +1398,38 @@ let concurrent_jsx_diagnostic_tests _context =
         assert_equal right_expected.stderr (Domain.join right).stderr
       done)
 
+(* Calls of open JS object methods mark their callee in request-local typing
+   state. Another request typing applications at the same time must not
+   overwrite that mark, which would report the method's arguments as unused
+   (warning 20, off by default and enabled here). *)
+let concurrent_open_object_method_tests _context =
+  with_temp_dir "rewatch-driver-open-method-" (fun root ->
+      let source =
+        "@get external obj: string => {..} = \"obj\"\n"
+        ^ String.concat ""
+            (List.init 200 (fun i ->
+                 Printf.sprintf "let v%d = obj(\"e\")[\"m\"](\"a\", \"b\")\n" i))
+      in
+      let setup name =
+        let directory = Filename.concat root name in
+        ensure_dir directory;
+        write directory "Calls.res" source;
+        fun () -> snd (run directory ~extra:["-w"; "+20"] "Calls.res")
+      in
+      let left_request = setup "left" in
+      let right_request = setup "right" in
+      let expect_clean result =
+        expect_code 0 result;
+        assert_equal ~printer:Fun.id "" result.Rescript_compiler_driver.stderr
+      in
+      expect_clean (left_request ());
+      for _ = 1 to 5 do
+        let left = Domain.spawn left_request in
+        let right = Domain.spawn right_request in
+        expect_clean (Domain.join left);
+        expect_clean (Domain.join right)
+      done)
+
 (* Exercise concurrent compiler requests without the process-worker boundary. *)
 let concurrent_request_isolation_tests _context =
   with_temp_dir "rewatch-driver-domains-" (fun root ->
@@ -1599,6 +1631,7 @@ let suites =
          "concurrent_diagnostic_recovery"
          >:: concurrent_diagnostic_recovery_tests;
          "concurrent_jsx_diagnostic" >:: concurrent_jsx_diagnostic_tests;
+         "concurrent_open_object_method" >:: concurrent_open_object_method_tests;
          "concurrent_request_isolation" >:: concurrent_request_isolation_tests;
          "concurrent_async_context" >:: concurrent_async_context_tests;
        ]