Automatic migrations (#7829)

* migrate wip

* wip migrate

* pipe chain example

* migrations for Js_option

* migrations for Js_null

* rename migration template for pipe chains

* migrations for Js_null_undefined

* js_float migrations

* Js_int migrations

* format

* dict migrations

* migrations for Js_date

* migrations for Js_re

* migrations for Js_math

* one more test

* migrations for js_undefined

* deprecate Js_OO

* migrations for Js_extern

* migrations for Js_global

* migrations for Js_obj

* make parsing of @deprecated with migration info an experimental feature

* Revert "make parsing of @deprecated with migration info an experimental feature"

This reverts commit 59c902c.

* typed array migrations

* format

* support replacing types

* more type replacement migrations

* support @apply.transforms for applying transforms, and add migrations for Js_promise and Js_promise2

* refactor a bit and add transform for dropping unit args in apply

* refactor

* finish js_json migration

* more migrations

* remove unused Match template

* more migrations

* update test fixtures

* update test fixtures

* more fixtures

* remove

* more

* more

* migrate .resi files as well

* fix resi

* migrate-all command

* more migrations

* migrations for Exn

* change migrate summary

* oops, test file

* proper interfaces for Js Promise modules, so they can have migrations

* format

* more migration fixes

* more migration fix

* get rid of some warning output

* update artifacts list

* spec

* more migrations

* more migrations

* analysis output

* remove redundant stuff in migration templates

* bool migration

* more migrations

* fix changelog

* remove changelog entry

* updates after merge

* message about automatic migrations

* updated analysis output

* tweak message

* fix subcommand

Author: zth

analysis/src/Cmt.ml

@@ -51,3 +51,17 @@ let fullsFromModule ~package ~moduleName =
 let loadFullCmtFromPath ~path =
   let uri = Uri.fromPath path in
   fullFromUri ~uri
+
+let loadCmtInfosFromPath ~path =
+  let uri = Uri.fromPath path in
+  match Packages.getPackage ~uri with
+  | None -> None
+  | Some package -> (
+    let moduleName =
+      BuildSystem.namespacedName package.namespace (FindFiles.getName path)
+    in
+    match Hashtbl.find_opt package.pathsForModule moduleName with
+    | Some paths ->
+      let cmt = getCmtPath ~uri paths in
+      Shared.tryReadCmt cmt
+    | None -> None)

compiler/bsb/bsb_package_specs.ml

@@ -50,7 +50,7 @@ let supported_format (x : string) loc : Ext_module_system.t =
         {loc with Lexing.pos_cnum = loc.Lexing.pos_cnum + String.length x}
       in
       let loc = {Warnings.loc_start = loc; loc_end; loc_ghost = false} in
-      Location.deprecated loc
+      Location.deprecated ~can_be_automigrated:false loc
         (Printf.sprintf "Option \"%s\" is deprecated. Use \"%s\" instead." x
            Literals.esmodule)
   in

compiler/ext/ext_list.ml

@@ -774,3 +774,7 @@ let filter lst p =
     | x :: l -> if p x then find (x :: accu) l ~p else find accu l ~p
   in
   find [] lst ~p
+
+let is_empty = function
+  | [] -> true
+  | _ :: _ -> false

compiler/ext/ext_list.mli

@@ -231,3 +231,5 @@ val filter : 'a list -> ('a -> bool) -> 'a list
 
 val array_list_filter_map :
   'a array -> 'b list -> ('a -> 'b -> 'c option) -> 'c list
+
+val is_empty : 'a list -> bool

compiler/ext/warnings.ml

@@ -31,7 +31,7 @@ type top_level_unit_help = FunctionCall | Other
 type t =
   | Comment_start (*  1 *)
   | Comment_not_end (*  2 *)
-  | Deprecated of string * loc * loc (*  3 *)
+  | Deprecated of string * loc * loc * bool (*  3 *)
   | Fragile_match of string (*  4 *)
   | Partial_application (*  5 *)
   | Method_override of string list (*  7 *)
@@ -299,14 +299,22 @@ let () = reset ()
 let message = function
   | Comment_start -> "this is the start of a comment."
   | Comment_not_end -> "this is not the end of a comment."
-  | Deprecated (s, _, _) ->
+  | Deprecated (s, _, _, can_be_automigrated) ->
     (* Reduce \r\n to \n:
          - Prevents any \r characters being printed on Unix when processing
            Windows sources
          - Prevents \r\r\n being generated on Windows, which affects the
            testsuite
     *)
     "deprecated: " ^ Misc.normalise_eol s
+    ^
+    if can_be_automigrated then
+      "\n\n\
+      \  This can be automatically migrated by the ReScript migration tool. \
+       Run `rescript-tools migrate-all <project-root>` to run all automatic \
+       migrations available in your project, or `rescript-tools migrate \
+       <file>` to migrate a single file."
+    else ""
   | Fragile_match "" -> "this pattern-matching is fragile."
   | Fragile_match s ->
     "this pattern-matching is fragile.\n\
@@ -533,7 +541,7 @@ let message = function
        you implement this before running the code."
 
 let sub_locs = function
-  | Deprecated (_, def, use) ->
+  | Deprecated (_, def, use, _) ->
     [(def, "Definition"); (use, "Expected signature")]
   | _ -> []
 

compiler/ext/warnings.mli

@@ -24,7 +24,7 @@ type top_level_unit_help = FunctionCall | Other
 type t =
   | Comment_start (*  1 *)
   | Comment_not_end (*  2 *)
-  | Deprecated of string * loc * loc (*  3 *)
+  | Deprecated of string * loc * loc * bool (*  3 *)
   | Fragile_match of string (*  4 *)
   | Partial_application (*  5 *)
   | Method_override of string list (*  7 *)

compiler/ml/builtin_attributes.ml

@@ -79,10 +79,64 @@ let rec deprecated_of_attrs = function
     Some (string_of_opt_payload p)
   | _ :: tl -> deprecated_of_attrs tl
 
-let check_deprecated loc attrs s =
-  match deprecated_of_attrs attrs with
+let rec deprecated_of_attrs_with_migrate = function
+  | [] -> None
+  | ( {txt = "deprecated"; _},
+      PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (fields, _)}, _)}]
+    )
+    :: _ -> (
+    let reason =
+      fields
+      |> List.find_map (fun field ->
+             match field with
+             | {
+              lid = {txt = Lident "reason"};
+              x = {pexp_desc = Pexp_constant (Pconst_string (reason, _))};
+             } ->
+               Some reason
+             | _ -> None)
+    in
+    let migration_template =
+      fields
+      |> List.find_map (fun field ->
+             match field with
+             | {lid = {txt = Lident "migrate"}; x = migration_template} ->
+               Some migration_template
+             | _ -> None)
+    in
+    let migration_in_pipe_chain_template =
+      fields
+      |> List.find_map (fun field ->
+             match field with
+             | {
+              lid = {txt = Lident "migrateInPipeChain"};
+              x = migration_in_pipe_chain_template;
+             } ->
+               Some migration_in_pipe_chain_template
+             | _ -> None)
+    in
+
+    (* TODO: Validate and error if expected shape mismatches *)
+    match reason with
+    | Some reason ->
+      Some (reason, migration_template, migration_in_pipe_chain_template)
+    | None -> None)
+  | ({txt = "ocaml.deprecated" | "deprecated"; _}, p) :: _ ->
+    Some (string_of_opt_payload p, None, None)
+  | _ :: tl -> deprecated_of_attrs_with_migrate tl
+
+let check_deprecated ?deprecated_context loc attrs s =
+  match deprecated_of_attrs_with_migrate attrs with
   | None -> ()
-  | Some txt -> Location.deprecated loc (cat s txt)
+  | Some (txt, migration_template, migration_in_pipe_chain_template) ->
+    !Cmt_utils.record_deprecated_used
+      ?deprecated_context ?migration_template ?migration_in_pipe_chain_template
+      loc txt;
+    Location.deprecated
+      ~can_be_automigrated:
+        (Option.is_some migration_template
+        || Option.is_some migration_in_pipe_chain_template)
+      loc (cat s txt)
 
 let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s =
   match (deprecated_of_attrs attrs1, deprecated_of_attrs attrs2) with

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 ->

compiler/ml/cmt_format.ml

@@ -63,6 +63,7 @@ type cmt_infos = {
   cmt_imports : (string * Digest.t option) list;
   cmt_interface_digest : Digest.t option;
   cmt_use_summaries : bool;
+  cmt_extra_info: Cmt_utils.cmt_extra_info;
 }
 
 type error =
@@ -154,15 +155,30 @@ let read_cmi filename =
 
 let saved_types = ref []
 let value_deps = ref []
+let deprecated_used = ref []
 
 let clear () =
   saved_types := [];
-  value_deps := []
+  value_deps := [];
+  deprecated_used := []
 
 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 ?deprecated_context ?migration_template ?migration_in_pipe_chain_template source_loc deprecated_text =
+  deprecated_used :=
+    {
+      Cmt_utils.source_loc;
+      deprecated_text;
+      migration_template;
+      migration_in_pipe_chain_template;
+      context = deprecated_context;
+    }
+    :: !deprecated_used
+
+let _ = Cmt_utils.record_deprecated_used := record_deprecated_used
+
 let record_value_dependency vd1 vd2 =
   if vd1.Types.val_loc <> vd2.Types.val_loc then
     value_deps := (vd1, vd2) :: !value_deps
@@ -197,8 +213,9 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi =
            cmt_imports = List.sort compare (Env.imports ());
            cmt_interface_digest = this_crc;
            cmt_use_summaries = need_to_clear_env;
+           cmt_extra_info = {deprecated_used = !deprecated_used};
          } in
          output_cmt oc cmt)
   end;
   clear ()
-#endif
+#endif

compiler/ml/cmt_format.mli

@@ -63,6 +63,7 @@ type cmt_infos = {
   cmt_imports: (string * Digest.t option) list;
   cmt_interface_digest: Digest.t option;
   cmt_use_summaries: bool;
+  cmt_extra_info: Cmt_utils.cmt_extra_info;
 }
 
 type error = Not_a_typedtree of string
@@ -111,6 +112,14 @@ val set_saved_types : binary_part list -> unit
 val record_value_dependency :
   Types.value_description -> Types.value_description -> unit
 
+val record_deprecated_used :
+  ?deprecated_context:Cmt_utils.deprecated_used_context ->
+  ?migration_template:Parsetree.expression ->
+  ?migration_in_pipe_chain_template:Parsetree.expression ->
+  Location.t ->
+  string ->
+  unit
+
 (*
 
   val is_magic_number : string -> bool