Fix incorrect analysis report for optional function args

cknitt · cknitt · commit 57f9dd1a6512 · 2026-03-31T13:30:08.000+02:00
diff --git a/analysis/reanalyze/src/DeadCommon.ml b/analysis/reanalyze/src/DeadCommon.ml
@@ -123,11 +123,12 @@ let addDeclaration_ ~config ~decls ~(file : FileContext.t) ?posEnd ?posStart
     Declarations.add decls pos decl)
 
 let addValueDeclaration ~config ~decls ~file ?(isToplevel = true)
-    ~(loc : Location.t) ~moduleLoc ?(optionalArgs = OptionalArgs.empty) ~path
-    ~sideEffects name =
+    ?(ownsOptionalArgs = false) ~(loc : Location.t) ~moduleLoc
+    ?(optionalArgs = OptionalArgs.empty) ~path ~sideEffects name =
   name
   |> addDeclaration_ ~config ~decls ~file
-       ~declKind:(Value {isToplevel; optionalArgs; sideEffects})
+       ~declKind:
+         (Value {isToplevel; ownsOptionalArgs; optionalArgs; sideEffects})
        ~loc ~moduleLoc ~path
 
 (** Create a dead code issue. Pure - no side effects. *)
diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml
@@ -7,12 +7,34 @@ let addFunctionReference ~config ~decls ~cross_file ~(locFrom : Location.t)
   if active () then
     let posTo = locTo.loc_start in
     let posFrom = locFrom.loc_start in
-    (* Check if target has optional args - for filtering and debug logging *)
+    (* Only declarations that own optional args should participate in
+       optional-arg state merging. A function-valued alias like
+       [let f = useNotification()] can have an optional-arg type, but it is not
+       the declaration site that should receive warnings. *)
     let shouldAdd =
-      match Declarations.find_opt_builder decls posTo with
-      | Some {declKind = Value {optionalArgs}} ->
-        not (OptionalArgs.isEmpty optionalArgs)
-      | _ -> false
+      if posTo.pos_fname <> posFrom.pos_fname then
+        match Declarations.find_opt_builder decls posTo with
+        | Some {declKind = Value {ownsOptionalArgs; optionalArgs}} ->
+          ownsOptionalArgs && not (OptionalArgs.isEmpty optionalArgs)
+        | _ -> false
+      else
+        match
+          ( Declarations.find_opt_builder decls posFrom,
+            Declarations.find_opt_builder decls posTo )
+        with
+        | ( Some
+              {
+                declKind =
+                  Value {ownsOptionalArgs = true; optionalArgs = sourceArgs};
+              },
+            Some
+              {
+                declKind =
+                  Value {ownsOptionalArgs = true; optionalArgs = targetArgs};
+              } ) ->
+          (not (OptionalArgs.isEmpty sourceArgs))
+          && not (OptionalArgs.isEmpty targetArgs)
+        | _ -> false
     in
     if shouldAdd then (
       if config.DceConfig.cli.debug then
@@ -39,23 +61,44 @@ let rec fromTypeExpr (texpr : Types.type_expr) =
   | Tsubst t -> fromTypeExpr t
   | _ -> []
 
-let addReferences ~config ~cross_file ~(locFrom : Location.t)
+let rec fromTypeExprWithArity (texpr : Types.type_expr) arity =
+  if arity <= 0 then []
+  else
+    match texpr.desc with
+    | _ when not (active ()) -> []
+    | Tarrow ({lbl = Optional {txt = s}}, tTo, _, _) ->
+      s :: fromTypeExprWithArity tTo (arity - 1)
+    | Tarrow (_, tTo, _, _) -> fromTypeExprWithArity tTo (arity - 1)
+    | Tlink t -> fromTypeExprWithArity t arity
+    | Tsubst t -> fromTypeExprWithArity t arity
+    | _ -> []
+
+let addReferences ~config ~decls ~cross_file ~(locFrom : Location.t)
     ~(locTo : Location.t) ~(binding : Location.t) ~path (argNames, argNamesMaybe)
     =
-  if active () then (
+  if active () then
     let posTo = locTo.loc_start in
     let posFrom = binding.loc_start in
-    CrossFileItems.add_optional_arg_call cross_file ~pos_from:posFrom
-      ~pos_to:posTo ~arg_names:argNames ~arg_names_maybe:argNamesMaybe;
-    if config.DceConfig.cli.debug then
-      let callPos = locFrom.loc_start in
-      Log_.item
-        "DeadOptionalArgs.addReferences %s called with optional argNames:%s \
-         argNamesMaybe:%s %s@."
-        (path |> DcePath.fromPathT |> DcePath.toString)
-        (argNames |> String.concat ", ")
-        (argNamesMaybe |> String.concat ", ")
-        (callPos |> Pos.toString))
+    let callPos = locFrom.loc_start in
+    let shouldAdd =
+      if posTo.pos_fname <> callPos.pos_fname then true
+      else
+        match Declarations.find_opt_builder decls posTo with
+        | Some {declKind = Value {ownsOptionalArgs; optionalArgs}} ->
+          ownsOptionalArgs && not (OptionalArgs.isEmpty optionalArgs)
+        | _ -> false
+    in
+    if shouldAdd then (
+      CrossFileItems.add_optional_arg_call cross_file ~pos_from:posFrom
+        ~pos_to:posTo ~arg_names:argNames ~arg_names_maybe:argNamesMaybe;
+      if config.DceConfig.cli.debug then
+        Log_.item
+          "DeadOptionalArgs.addReferences %s called with optional argNames:%s \
+           argNamesMaybe:%s %s@."
+          (path |> DcePath.fromPathT |> DcePath.toString)
+          (argNames |> String.concat ", ")
+          (argNamesMaybe |> String.concat ", ")
+          (callPos |> Pos.toString))
 
 (** Check for optional args issues. Returns issues instead of logging.
     Uses optional_args_state map for final computed state. *)
diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml
@@ -27,12 +27,28 @@ let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t)
       when (not loc_ghost) && not vb.vb_loc.loc_ghost ->
       let name = Ident.name id |> Name.create ~isInterface:false in
       let optionalArgs =
-        vb.vb_expr.exp_type |> DeadOptionalArgs.fromTypeExpr
-        |> OptionalArgs.fromList
+        match vb.vb_expr.exp_desc with
+        | Texp_function {arity = Some arity; _} ->
+          vb.vb_expr.exp_type
+          |> (fun texpr -> DeadOptionalArgs.fromTypeExprWithArity texpr arity)
+          |> OptionalArgs.fromList
+        | Texp_function _ ->
+          vb.vb_expr.exp_type |> DeadOptionalArgs.fromTypeExpr
+          |> OptionalArgs.fromList
+        | _ -> OptionalArgs.empty
+      in
+      (* Only actual function declarations own optional-arg diagnostics.
+         Aliases to function values can expose the same optional-arg type, but
+         warnings should stay attached to the declaration site. *)
+      let ownsOptionalArgs =
+        match vb.vb_expr.exp_desc with
+        | Texp_function _ -> true
+        | _ -> false
       in
       let exists =
         match Declarations.find_opt_builder decls loc_start with
         | Some {declKind = Value r} ->
+          r.ownsOptionalArgs <- ownsOptionalArgs;
           r.optionalArgs <- optionalArgs;
           true
         | _ -> false
@@ -48,8 +64,9 @@ let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t)
          let isToplevel = oldLastBinding = Location.none in
          let sideEffects = SideEffects.checkExpr vb.vb_expr in
          name
-         |> addValueDeclaration ~config ~decls ~file ~isToplevel ~loc
-              ~moduleLoc:modulePath.loc ~optionalArgs ~path ~sideEffects);
+         |> addValueDeclaration ~config ~decls ~file ~isToplevel
+              ~ownsOptionalArgs ~loc ~moduleLoc:modulePath.loc ~optionalArgs
+              ~path ~sideEffects);
       (match Declarations.find_opt_builder decls loc_start with
       | None -> ()
       | Some decl ->
@@ -74,8 +91,8 @@ let collectValueBinding ~config ~decls ~file ~(current_binding : Location.t)
   in
   loc
 
-let processOptionalArgs ~config ~cross_file ~expType ~(locFrom : Location.t)
-    ~(binding : Location.t) ~locTo ~path args =
+let processOptionalArgs ~config ~decls ~cross_file ~expType
+    ~(locFrom : Location.t) ~(binding : Location.t) ~locTo ~path args =
   if expType |> DeadOptionalArgs.hasOptionalArgs then (
     let supplied = ref [] in
     let suppliedMaybe = ref [] in
@@ -104,13 +121,36 @@ let processOptionalArgs ~config ~cross_file ~expType ~(locFrom : Location.t)
              if argIsSupplied = None then suppliedMaybe := s :: !suppliedMaybe
            | _ -> ());
     (!supplied, !suppliedMaybe)
-    |> DeadOptionalArgs.addReferences ~config ~cross_file ~locFrom ~locTo
+    |> DeadOptionalArgs.addReferences ~config ~decls ~cross_file ~locFrom ~locTo
          ~binding ~path)
 
-let rec collectExpr ~config ~refs ~file_deps ~cross_file
+let rec collectExpr ~config ~decls ~refs ~file_deps ~cross_file ~callee_locs
     ~(last_binding : Location.t) super self (e : Typedtree.expression) =
   let locFrom = e.exp_loc in
   let binding = last_binding in
+  let suppressOptionalArgs pos =
+    match Declarations.find_opt_builder decls pos with
+    | Some ({declKind = Value ({optionalArgs; _} as value_kind)} as decl)
+      when not (OptionalArgs.isEmpty optionalArgs) ->
+      Declarations.replace_builder decls pos
+        {
+          decl with
+          declKind = Value {value_kind with optionalArgs = OptionalArgs.empty};
+        }
+    | _ -> ()
+  in
+  let rec remove_first target = function
+    | [] -> []
+    | x :: xs when x = target -> xs
+    | x :: xs -> x :: remove_first target xs
+  in
+  let callee_loc_opt =
+    match e.exp_desc with
+    | Texp_apply {funct = {exp_desc = Texp_ident (_, _, _); exp_loc}; _} ->
+      Some exp_loc
+    | _ -> None
+  in
+  Option.iter (fun loc -> callee_locs := loc :: !callee_locs) callee_loc_opt;
   (match e.exp_desc with
   | Texp_ident (_path, _, {Types.val_loc = {loc_ghost = false; _} as locTo}) ->
     (* if Path.name _path = "rc" then assert false; *)
@@ -123,9 +163,11 @@ let rec collectExpr ~config ~refs ~file_deps ~cross_file
           (locTo.loc_start |> Pos.toString);
       References.add_value_ref refs ~posTo:locTo.loc_start
         ~posFrom:Location.none.loc_start)
-    else
+    else (
       addValueReference ~config ~refs ~file_deps ~binding ~addFileReference:true
-        ~locFrom ~locTo
+        ~locFrom ~locTo;
+      if not (List.mem locFrom !callee_locs) then
+        suppressOptionalArgs locTo.loc_start)
   | Texp_apply
       {
         funct =
@@ -138,7 +180,7 @@ let rec collectExpr ~config ~refs ~file_deps ~cross_file
         args;
       } ->
     args
-    |> processOptionalArgs ~config ~cross_file ~expType:exp_type
+    |> processOptionalArgs ~config ~decls ~cross_file ~expType:exp_type
          ~locFrom:(locFrom : Location.t)
          ~binding:last_binding ~locTo ~path
   | Texp_let
@@ -179,7 +221,7 @@ let rec collectExpr ~config ~refs ~file_deps ~cross_file
          && Ident.name etaArg = "eta"
          && Path.name idArg2 = "arg" ->
     args
-    |> processOptionalArgs ~config ~cross_file ~expType:exp_type
+    |> processOptionalArgs ~config ~decls ~cross_file ~expType:exp_type
          ~locFrom:(locFrom : Location.t)
          ~binding:last_binding ~locTo ~path
   | Texp_field
@@ -206,12 +248,16 @@ let rec collectExpr ~config ~refs ~file_deps ~cross_file
              ->
              (* Punned field in OCaml projects has ghost location in expression *)
              let e = {e with exp_loc = {exp_loc with loc_ghost = false}} in
-             collectExpr ~config ~refs ~file_deps ~cross_file ~last_binding
-               super self e
+             collectExpr ~config ~decls ~refs ~file_deps ~cross_file
+               ~callee_locs ~last_binding super self e
              |> ignore
            | _ -> ())
   | _ -> ());
-  super.Tast_mapper.expr self e
+  let result = super.Tast_mapper.expr self e in
+  Option.iter
+    (fun loc -> callee_locs := remove_first loc !callee_locs)
+    callee_loc_opt;
+  result
 
 (*
   type k. is a locally abstract type
@@ -279,13 +325,17 @@ let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc
         let optionalArgs =
           val_type |> DeadOptionalArgs.fromTypeExpr |> OptionalArgs.fromList
         in
+        (* Signature items only expose the function type, so we conservatively
+           seed ownership from the presence of optional args. The implementation
+           pass above refines this for aliases that should not own warnings. *)
+        let ownsOptionalArgs = not (OptionalArgs.isEmpty optionalArgs) in
 
         (* if Ident.name id = "someValue" then
            Printf.printf "XXX %s\n" (Ident.name id); *)
         Ident.name id
         |> Name.create ~isInterface:false
         |> addValueDeclaration ~config ~decls ~file ~loc ~moduleLoc
-             ~optionalArgs ~path ~sideEffects:false
+             ~ownsOptionalArgs ~optionalArgs ~path ~sideEffects:false
   | Sig_module (id, {Types.md_type = moduleType; md_loc = moduleLoc}, _)
   | Sig_modtype (id, {Types.mtd_type = Some moduleType; mtd_loc = moduleLoc}) ->
     let modulePath' =
@@ -309,6 +359,7 @@ let rec processSignatureItem ~config ~decls ~file ~doTypes ~doValues ~moduleLoc
 (* Traverse the AST *)
 let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes
     ~doExternals (structure : Typedtree.structure) : unit =
+  let callee_locs = ref [] in
   let rec create_mapper (last_binding : Location.t) (modulePath : ModulePath.t)
       =
     let super = Tast_mapper.default in
@@ -317,9 +368,8 @@ let traverseStructure ~config ~decls ~refs ~file_deps ~cross_file ~file ~doTypes
         super with
         expr =
           (fun _self e ->
-            e
-            |> collectExpr ~config ~refs ~file_deps ~cross_file ~last_binding
-                 super mapper);
+            collectExpr ~config ~decls ~refs ~file_deps ~cross_file ~callee_locs
+              ~last_binding super mapper e);
         pat = (fun _self p -> p |> collectPattern ~config ~refs super mapper);
         structure_item =
           (fun _self (structureItem : Typedtree.structure_item) ->
diff --git a/analysis/reanalyze/src/Decl.ml b/analysis/reanalyze/src/Decl.ml
@@ -7,6 +7,7 @@ module Kind = struct
     | VariantCase
     | Value of {
         isToplevel: bool;
+        mutable ownsOptionalArgs: bool;
         mutable optionalArgs: OptionalArgs.t;
         sideEffects: bool;
       }
diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt
diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/src/ContextOptionalArgs.res b/tests/analysis_tests/tests-reanalyze/deadcode/src/ContextOptionalArgs.res

Original file line number	Diff line number	Diff line change
`@@ -7,6 +7,7 @@ module Kind = struct`
`7`	`7`	`\| VariantCase`
`8`	`8`	`\| Value of {`
`9`	`9`	`isToplevel: bool;`
	`10`	`+ mutable ownsOptionalArgs: bool;`
`10`	`11`	`mutable optionalArgs: OptionalArgs.t;`
`11`	`12`	`sideEffects: bool;`
`12`	`13`	`}`