Automatic migrations

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

compiler/ml/cmt_utils.ml

@@ -0,0 +1,31 @@
+type deprecated_used_context = FunctionCall | Reference
+
+type deprecated_used = {
+  source_loc: Location.t;
+  deprecated_text: string;
+  migration_template: Parsetree.expression option;
+  migration_in_pipe_chain_template: Parsetree.expression option;
+  context: deprecated_used_context option;
+}
+
+type cmt_extra_info = {deprecated_used: deprecated_used list}
+
+let record_deprecated_used :
+    (?deprecated_context:deprecated_used_context ->
+    ?migration_template:Parsetree.expression ->
+    ?migration_in_pipe_chain_template:Parsetree.expression ->
+    Location.t ->
+    string ->
+    unit)
+    ref =
+  ref
+    (fun
+      ?deprecated_context
+      ?migration_template
+      ?migration_in_pipe_chain_template
+      _
+      _
+    ->
+      ignore deprecated_context;
+      ignore migration_template;
+      ignore migration_in_pipe_chain_template)

compiler/ml/location.ml

@@ -298,7 +298,8 @@ let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
   pp_ksprintf ~before:print_phanton_error_prefix (fun msg ->
       raise (Error {loc; msg; sub; if_highlight}))
 
-let deprecated ?(def = none) ?(use = none) loc msg =
-  prerr_warning loc (Warnings.Deprecated (msg, def, use))
+let deprecated ?(can_be_automigrated = false) ?(def = none) ?(use = none) loc
+    msg =
+  prerr_warning loc (Warnings.Deprecated (msg, def, use, can_be_automigrated))
 
 let map_loc f {txt; loc} = {txt = f txt; loc}

compiler/ml/location.mli

@@ -130,6 +130,7 @@ val default_error_reporter :
 val report_exception : formatter -> exn -> unit
 (** Reraise the exception if it is unknown. *)
 
-val deprecated : ?def:t -> ?use:t -> t -> string -> unit
+val deprecated :
+  ?can_be_automigrated:bool -> ?def:t -> ?use:t -> t -> string -> unit
 
 val map_loc : ('a -> 'b) -> 'a loc -> 'b loc

compiler/ml/typecore.ml

@@ -2243,17 +2243,18 @@ type lazy_args =
   (Asttypes.arg_label * (unit -> Typedtree.expression) option) list
 
 type targs = (Asttypes.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 ~context ?deprecated_context ?in_function ?recarg env sexp
+    ty_expected =
   (* Special errors for braced identifiers passed to records *)
   let context =
     match sexp.pexp_desc with
@@ -2268,14 +2269,15 @@ and type_expect ~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 =
@@ -2292,7 +2294,14 @@ 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:
+          (match deprecated_context with
+          | None -> Some Reference
+          | v -> v)
+        env lid.loc lid.txt
+    in
     (if !Clflags.annotations then
        let dloc = desc.Types.val_loc in
        let annot =
@@ -2428,7 +2437,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;

compiler/ml/typetexp.ml

@@ -120,7 +120,8 @@ let find_type env loc lid =
       env loc lid
   in
   let decl = Env.find_type path env in
-  Builtin_attributes.check_deprecated loc decl.type_attributes (Path.name path);
+  Builtin_attributes.check_deprecated ~deprecated_context:Cmt_utils.Reference
+    loc decl.type_attributes (Path.name path);
   (path, decl)
 
 let find_constructor =
@@ -131,12 +132,13 @@ let find_all_constructors =
 let find_all_labels =
   find_component Env.lookup_all_labels (fun lid -> Unbound_label (lid, None))
 
-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 =