propagate context info for deprecated, and handle pipe without arguments

zth · zth · commit 3b5e873f1b3b · 2025-07-22T19:24:45.000+02:00
diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml
@@ -113,11 +113,12 @@ let rec deprecated_of_attrs_with_migrate = function
     Some (string_of_opt_payload p, None)
   | _ :: tl -> deprecated_of_attrs_with_migrate tl
 
-let check_deprecated loc attrs s =
+let check_deprecated ?deprecated_context loc attrs s =
   match deprecated_of_attrs_with_migrate attrs with
   | None -> ()
   | Some (txt, migration_template) ->
-    !Cmt_utils.record_deprecated_used loc txt migration_template;
+    !Cmt_utils.record_deprecated_used
+      ?deprecated_context loc txt migration_template;
     Location.deprecated loc (cat s txt)
 
 let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s =
diff --git a/compiler/ml/builtin_attributes.mli b/compiler/ml/builtin_attributes.mli
@@ -27,7 +27,12 @@
    ocaml.boxed / ocaml.unboxed
 *)
 
-val check_deprecated : Location.t -> Parsetree.attributes -> string -> unit
+val check_deprecated :
+  ?deprecated_context:Cmt_utils.deprecated_used_context ->
+  Location.t ->
+  Parsetree.attributes ->
+  string ->
+  unit
 val check_deprecated_inclusion :
   def:Location.t ->
   use:Location.t ->
diff --git a/compiler/ml/cmt_format.ml b/compiler/ml/cmt_format.ml
@@ -166,8 +166,8 @@ let add_saved_type b = saved_types := b :: !saved_types
 let get_saved_types () = !saved_types
 let set_saved_types l = saved_types := l
 
-let record_deprecated_used source_loc deprecated_text migration_template =
-  deprecated_used := {Cmt_utils.source_loc; deprecated_text; migration_template} :: !deprecated_used
+let record_deprecated_used ?deprecated_context source_loc deprecated_text migration_template =
+  deprecated_used := {Cmt_utils.source_loc; deprecated_text; migration_template; context = deprecated_context} :: !deprecated_used
 
 let _ = Cmt_utils.record_deprecated_used := record_deprecated_used
 
diff --git a/compiler/ml/cmt_format.mli b/compiler/ml/cmt_format.mli
@@ -113,7 +113,11 @@ val record_value_dependency :
   Types.value_description -> Types.value_description -> unit
 
 val record_deprecated_used :
-  Location.t -> string -> Parsetree.expression option -> unit
+  ?deprecated_context:Cmt_utils.deprecated_used_context ->
+  Location.t ->
+  string ->
+  Parsetree.expression option ->
+  unit
 
 (*
 
diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml
@@ -1,11 +1,19 @@
+type deprecated_used_context = FunctionCall
+
 type deprecated_used = {
   source_loc: Location.t;
   deprecated_text: string;
   migration_template: Parsetree.expression option;
+  context: deprecated_used_context option;
 }
 
 type cmt_extra_info = {deprecated_used: deprecated_used list}
 
 let record_deprecated_used :
-    (Location.t -> string -> Parsetree.expression option -> unit) ref =
-  ref (fun _ _ _ -> ())
+    (?deprecated_context:deprecated_used_context ->
+    Location.t ->
+    string ->
+    Parsetree.expression option ->
+    unit)
+    ref =
+  ref (fun ?deprecated_context _ _ _ -> ignore deprecated_context)
diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml
@@ -2222,28 +2222,30 @@ type lazy_args =
   (Asttypes.Noloc.arg_label * (unit -> Typedtree.expression) option) list
 
 type targs = (Asttypes.Noloc.arg_label * Typedtree.expression option) list
-let rec type_exp ~context ?recarg env sexp =
+let rec type_exp ?deprecated_context ~context ?recarg env sexp =
   (* We now delegate everything to type_expect *)
-  type_expect ~context ?recarg env sexp (newvar ())
+  type_expect ?deprecated_context ~context ?recarg env sexp (newvar ())
 
 (* Typing of an expression with an expected type.
    This provide better error messages, and allows controlled
    propagation of return type information.
    In the principal case, [type_expected'] may be at generic_level.
 *)
 
-and type_expect ~context ?in_function ?recarg env sexp ty_expected =
+and type_expect ?deprecated_context ~context ?in_function ?recarg env sexp
+    ty_expected =
   let previous_saved_types = Cmt_format.get_saved_types () in
   let exp =
     Builtin_attributes.warning_scope sexp.pexp_attributes (fun () ->
-        type_expect_ ~context ?in_function ?recarg env sexp ty_expected)
+        type_expect_ ?deprecated_context ~context ?in_function ?recarg env sexp
+          ty_expected)
   in
   Cmt_format.set_saved_types
     (Cmt_format.Partial_expression exp :: previous_saved_types);
   exp
 
-and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
-    =
+and type_expect_ ?deprecated_context ~context ?in_function ?(recarg = Rejected)
+    env sexp ty_expected =
   let loc = sexp.pexp_loc in
   (* Record the expression type before unifying it with the expected type *)
   let rue exp =
@@ -2260,7 +2262,9 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
   in
   match sexp.pexp_desc with
   | Pexp_ident lid ->
-    let path, desc = Typetexp.find_value env lid.loc lid.txt in
+    let path, desc =
+      Typetexp.find_value ?deprecated_context env lid.loc lid.txt
+    in
     (if !Clflags.annotations then
        let dloc = desc.Types.val_loc in
        let annot =
@@ -2398,7 +2402,9 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
     assert (sargs <> []);
     begin_def ();
     (* one more level for non-returning functions *)
-    let funct = type_exp ~context:None env sfunct in
+    let funct =
+      type_exp ~deprecated_context:FunctionCall ~context:None env sfunct
+    in
     let ty = instance env funct.exp_type in
     end_def ();
     wrap_trace_gadt_instances env (lower_args env []) ty;
diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml
@@ -131,12 +131,13 @@ let find_all_constructors =
 let find_all_labels =
   find_component Env.lookup_all_labels (fun lid -> Unbound_label lid)
 
-let find_value env loc lid =
+let find_value ?deprecated_context env loc lid =
   Env.check_value_name (Longident.last lid) loc;
   let ((path, decl) as r) =
     find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid
   in
-  Builtin_attributes.check_deprecated loc decl.val_attributes (Path.name path);
+  Builtin_attributes.check_deprecated ?deprecated_context loc
+    decl.val_attributes (Path.name path);
   r
 
 let lookup_module ?(load = false) env loc lid =
diff --git a/compiler/ml/typetexp.mli b/compiler/ml/typetexp.mli
@@ -89,7 +89,11 @@ val find_all_labels :
   Longident.t ->
   (label_description * (unit -> unit)) list
 val find_value :
-  Env.t -> Location.t -> Longident.t -> Path.t * value_description
+  ?deprecated_context:Cmt_utils.deprecated_used_context ->
+  Env.t ->
+  Location.t ->
+  Longident.t ->
+  Path.t * value_description
 val find_module :
   Env.t -> Location.t -> Longident.t -> Path.t * module_declaration
 val lookup_module : ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t
diff --git a/tests/tools_tests/src/expected/FileToMigrate.res.expected b/tests/tools_tests/src/expected/FileToMigrate.res.expected
@@ -4,3 +4,6 @@ let someNiceString2 = String.slice(String.slice("abcdefg", ~start=0, ~end=1), ~s
 
 let someNiceString3 = "abcdefg"->String.slice(~start=2, ~end=5)
 
+let shift1 = Array.shift([1, 2, 3])
+let shift2 = [1, 2, 3]->Array.shift
+
diff --git a/tests/tools_tests/src/migrate/DeprecatedStuff.res b/tests/tools_tests/src/migrate/DeprecatedStuff.res
@@ -1,2 +1,5 @@
 @send
 external slice: (string, ~from: int, ~to_: int) => string = "slice"
+
+@send
+external shift: array<'a> => option<'a> = "shift"
diff --git a/tests/tools_tests/src/migrate/DeprecatedStuff.resi b/tests/tools_tests/src/migrate/DeprecatedStuff.resi
@@ -7,3 +7,10 @@
 })
 @send
 external slice: (string, ~from: int, ~to_: int) => string = "slice"
+
+@send
+@deprecated({
+  reason: "Use `Array.shift` instead.",
+  migrate: Array.shift(),
+})
+external shift: array<'a> => option<'a> = "shift"
diff --git a/tests/tools_tests/src/migrate/FileToMigrate.res b/tests/tools_tests/src/migrate/FileToMigrate.res
@@ -7,3 +7,6 @@ let someNiceString2 = DeprecatedStuff.slice(
 )
 
 let someNiceString3 = "abcdefg"->DeprecatedStuff.slice(~from=2, ~to_=5)
+
+let shift1 = DeprecatedStuff.shift([1, 2, 3])
+let shift2 = [1, 2, 3]->DeprecatedStuff.shift
diff --git a/tools/src/tools.ml b/tools/src/tools.ml
@@ -1297,10 +1297,19 @@ module StringMap = Map.Make (String)
 
 module Migrate = struct
   let makeMapper (deprecated_used : Cmt_utils.deprecated_used list) =
-    let loc_to_deprecated_use = Hashtbl.create (List.length deprecated_used) in
-    deprecated_used
+    let deprecated_function_calls =
+      deprecated_used
+      |> List.filter (fun (d : Cmt_utils.deprecated_used) ->
+             match d.context with
+             | Some FunctionCall -> true
+             | _ -> false)
+    in
+    let loc_to_deprecated_fn_call =
+      Hashtbl.create (List.length deprecated_function_calls)
+    in
+    deprecated_function_calls
     |> List.iter (fun ({Cmt_utils.source_loc} as d) ->
-           Hashtbl.replace loc_to_deprecated_use source_loc d);
+           Hashtbl.replace loc_to_deprecated_fn_call source_loc d);
     let mapper =
       {
         Ast_mapper.default_mapper with
@@ -1311,9 +1320,11 @@ module Migrate = struct
              pexp_desc =
                Pexp_apply {funct = {pexp_loc = fn_loc}; args = source_args};
             }
-              when Hashtbl.mem loc_to_deprecated_use fn_loc -> (
-              let deprecated_info = Hashtbl.find loc_to_deprecated_use fn_loc in
-              Hashtbl.remove loc_to_deprecated_use fn_loc;
+              when Hashtbl.mem loc_to_deprecated_fn_call fn_loc -> (
+              let deprecated_info =
+                Hashtbl.find loc_to_deprecated_fn_call fn_loc
+              in
+              Hashtbl.remove loc_to_deprecated_fn_call fn_loc;
 
               let source_args =
                 source_args
@@ -1391,6 +1402,46 @@ module Migrate = struct
                 (* TODO: More elaborate warnings etc *)
                 (* Invalid config. *)
                 exp)
+            | {
+             pexp_desc =
+               Pexp_apply
+                 {
+                   funct = {pexp_desc = Pexp_ident {txt = Lident "->"}} as funct;
+                   args =
+                     (_ as lhs)
+                     :: (Nolabel, {pexp_loc = fn_loc; pexp_desc = Pexp_ident _})
+                     :: _;
+                 };
+            }
+              when Hashtbl.mem loc_to_deprecated_fn_call fn_loc -> (
+              (* Pipe with no arguments, [1, 2, 3]->someDeprecated *)
+              let deprecated_info =
+                Hashtbl.find loc_to_deprecated_fn_call fn_loc
+              in
+              Hashtbl.remove loc_to_deprecated_fn_call fn_loc;
+
+              match deprecated_info.migration_template with
+              | Some
+                  {
+                    pexp_desc =
+                      Pexp_apply
+                        {funct = template_funct; partial; transformed_jsx};
+                  } ->
+                {
+                  exp with
+                  pexp_desc =
+                    Pexp_apply
+                      {
+                        funct;
+                        args = [lhs; (Nolabel, template_funct)];
+                        partial;
+                        transformed_jsx;
+                      };
+                }
+              | _ ->
+                (* TODO: More elaborate warnings etc *)
+                (* Invalid config. *)
+                exp)
             | _ -> Ast_mapper.default_mapper.expr mapper exp);
       }
     in

-Original file line number
+Diff line change
@@ @@ -1,2 +1,5 @@ @@
 @send
 external slice: (string, ~from: int, ~to_: int) => string = "slice"
++
 +@send
 +external shift: array<'a> => option<'a> = "shift"