[WIP] Migrate command

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/ml/builtin_attributes.ml

@@ -79,10 +79,46 @@ let rec deprecated_of_attrs = function
     Some (string_of_opt_payload p)
   | _ :: tl -> deprecated_of_attrs tl
 
+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
+
+    (* TODO: Validate and error if expected shape mismatches *)
+    match reason with
+    | Some reason -> Some (reason, migration_template)
+    | None -> None)
+  | ({txt = "ocaml.deprecated" | "deprecated"; _}, p) :: _ ->
+    Some (string_of_opt_payload p, None)
+  | _ :: tl -> deprecated_of_attrs_with_migrate tl
+
 let check_deprecated loc attrs s =
-  match deprecated_of_attrs attrs with
+  match deprecated_of_attrs_with_migrate attrs with
   | None -> ()
-  | Some txt -> Location.deprecated loc (cat s txt)
+  | Some (txt, migration_template) ->
+    !Cmt_utils.record_deprecated_used loc txt migration_template;
+    Location.deprecated 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/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,22 @@ 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 source_loc deprecated_text migration_template =
+  deprecated_used := {Cmt_utils.source_loc; deprecated_text; migration_template} :: !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,6 +205,7 @@ 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;

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,9 @@ val set_saved_types : binary_part list -> unit
 val record_value_dependency :
   Types.value_description -> Types.value_description -> unit
 
+val record_deprecated_used :
+  Location.t -> string -> Parsetree.expression option -> unit
+
 (*
 
   val is_magic_number : string -> bool

compiler/ml/cmt_utils.ml

@@ -0,0 +1,11 @@
+type deprecated_used = {
+  source_loc: Location.t;
+  deprecated_text: string;
+  migration_template: Parsetree.expression option;
+}
+
+type cmt_extra_info = {deprecated_used: deprecated_used list}
+
+let record_deprecated_used :
+    (Location.t -> string -> Parsetree.expression option -> unit) ref =
+  ref (fun _ _ _ -> ())

tests/tools_tests/src/expected/DeprecatedStuff.res.expected

@@ -0,0 +1 @@
+DeprecatedStuff.res: File did not need migration

tests/tools_tests/src/expected/DeprecatedStuff.resi.expected

@@ -0,0 +1 @@
+DeprecatedStuff.resi: File did not need migration

tests/tools_tests/src/expected/FileToMigrate.res.expected

@@ -0,0 +1,6 @@
+let someNiceString = String.slice("abcdefg", ~start=2, ~end=5)
+
+let someNiceString2 = String.slice(String.slice("abcdefg", ~start=0, ~end=1), ~start=2, ~end=5)
+
+let someNiceString3 = "abcdefg"->String.slice(~start=2, ~end=5)
+

tests/tools_tests/src/migrate/DeprecatedStuff.res

@@ -0,0 +1,2 @@
+@send
+external slice: (string, ~from: int, ~to_: int) => string = "slice"

tests/tools_tests/src/migrate/DeprecatedStuff.resi

@@ -0,0 +1,9 @@
+@deprecated({
+  reason: "Use `String.slice` instead",
+  migrate: String.slice(
+    ~start=%insert.labelledArgument("from"),
+    ~end=%insert.labelledArgument("to_"),
+  ),
+})
+@send
+external slice: (string, ~from: int, ~to_: int) => string = "slice"

tests/tools_tests/src/migrate/FileToMigrate.res

@@ -0,0 +1,9 @@
+let someNiceString = DeprecatedStuff.slice("abcdefg", ~from=2, ~to_=5)
+
+let someNiceString2 = DeprecatedStuff.slice(
+  DeprecatedStuff.slice("abcdefg", ~from=0, ~to_=1),
+  ~from=2,
+  ~to_=5,
+)
+
+let someNiceString3 = "abcdefg"->DeprecatedStuff.slice(~from=2, ~to_=5)

tests/tools_tests/test.sh

@@ -33,6 +33,15 @@ for file in src/docstrings-format/*.{res,resi,md}; do
   fi
 done
 
+# Test migrate command
+for file in src/migrate/*.{res,resi}; do
+  output="src/expected/$(basename $file).expected"
+  ../../_build/install/default/bin/rescript-tools migrate "$file" --stdout > $output
+  if [ "$RUNNER_OS" == "Windows" ]; then
+    perl -pi -e 's/\r\n/\n/g' -- $output
+  fi
+done
+
 warningYellow='\033[0;33m'
 successGreen='\033[0;32m'
 reset='\033[0m'

tools/bin/main.ml

@@ -32,6 +32,7 @@ Usage: rescript-tools [command]
 
 Commands:
 
+migrate <file> [--stdout]               Runs the migration tool on the given file
 doc <file>                              Generate documentation
 format-codeblocks <file>                Format ReScript code blocks
   [--stdout]                              Output to stdout
@@ -66,6 +67,15 @@ let main () =
       in
       logAndExit (Tools.extractDocs ~entryPointFile:path ~debug:false)
     | _ -> logAndExit (Error docHelp))
+  | "migrate" :: file :: opts -> (
+    let isStdout = List.mem "--stdout" opts in
+    let outputMode = if isStdout then `Stdout else `File in
+    match
+      (Tools.Migrate.migrate ~entryPointFile:file ~outputMode, outputMode)
+    with
+    | Ok content, `Stdout -> print_endline content
+    | result, `File -> logAndExit result
+    | Error e, _ -> logAndExit (Error e))
   | "format-codeblocks" :: rest -> (
     match rest with
     | ["-h"] | ["--help"] -> logAndExit (Ok formatCodeblocksHelp)

tools/src/tools.ml

@@ -1292,3 +1292,164 @@ module ExtractCodeblocks = struct
                    ])
           |> Protocol.array)
 end
+
+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
+    |> List.iter (fun ({Cmt_utils.source_loc} as d) ->
+           Hashtbl.replace loc_to_deprecated_use source_loc d);
+    let mapper =
+      {
+        Ast_mapper.default_mapper with
+        expr =
+          (fun mapper exp ->
+            match exp with
+            | {
+             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;
+
+              let source_args =
+                source_args
+                |> List.map (fun (label, arg) ->
+                       (label, mapper.expr mapper arg))
+              in
+
+              (* TODO: Here we could add strict and partial mode, to control if args are merged or not. *)
+              match deprecated_info.migration_template with
+              | Some
+                  {
+                    pexp_desc =
+                      Pexp_apply
+                        {
+                          funct = template_funct;
+                          args = template_args;
+                          partial;
+                          transformed_jsx;
+                        };
+                  } ->
+                let labelled_args_map =
+                  template_args
+                  |> List.filter_map (fun (label, arg) ->
+                         match (label, arg) with
+                         | ( ( Asttypes.Labelled {txt = label}
+                             | Optional {txt = label} ),
+                             {
+                               Parsetree.pexp_desc =
+                                 Pexp_extension
+                                   ( {txt = "insert.labelledArgument"},
+                                     PStr
+                                       [
+                                         {
+                                           pstr_desc =
+                                             Pstr_eval
+                                               ( {
+                                                   pexp_desc =
+                                                     Pexp_constant
+                                                       (Pconst_string
+                                                          (arg_name, _));
+                                                 },
+                                                 _ );
+                                         };
+                                       ] );
+                             } ) ->
+                           Some (arg_name, label)
+                         | _ -> None)
+                  |> StringMap.of_list
+                in
+                {
+                  exp with
+                  pexp_desc =
+                    Pexp_apply
+                      {
+                        funct = template_funct;
+                        args =
+                          source_args
+                          |> List.map (fun (label, arg) ->
+                                 match label with
+                                 | Asttypes.Labelled {loc; txt = label}
+                                 | Asttypes.Optional {loc; txt = label}
+                                   when StringMap.mem label labelled_args_map ->
+                                   let mapped_label_name =
+                                     StringMap.find label labelled_args_map
+                                   in
+                                   ( Asttypes.Labelled
+                                       {loc; txt = mapped_label_name},
+                                     arg )
+                                 | label -> (label, arg));
+                        partial;
+                        transformed_jsx;
+                      };
+                }
+              | _ ->
+                (* TODO: More elaborate warnings etc *)
+                (* Invalid config. *)
+                exp)
+            | _ -> Ast_mapper.default_mapper.expr mapper exp);
+      }
+    in
+    mapper
+
+  let migrate ~entryPointFile ~outputMode =
+    let path =
+      match Filename.is_relative entryPointFile with
+      | true -> Unix.realpath entryPointFile
+      | false -> entryPointFile
+    in
+    let result =
+      if Filename.check_suffix path ".res" then
+        let parser =
+          Res_driver.parsing_engine.parse_implementation ~for_printer:true
+        in
+        let {Res_driver.parsetree; comments; source} = parser ~filename:path in
+        match Cmt.loadCmtInfosFromPath ~path with
+        | None ->
+          Error
+            (Printf.sprintf
+               "error: failed to run migration for %s because build artifacts \
+                could not be found. try to build the project"
+               path)
+        | Some {cmt_extra_info = {deprecated_used}} ->
+          let mapper = makeMapper deprecated_used in
+          let astMapped = mapper.structure mapper parsetree in
+          Ok
+            ( Res_printer.print_implementation
+                ~width:Res_printer.default_print_width astMapped ~comments,
+              source )
+      else if Filename.check_suffix path ".resi" then
+        let parser =
+          Res_driver.parsing_engine.parse_interface ~for_printer:true
+        in
+        let {Res_driver.parsetree = signature; comments; source} =
+          parser ~filename:path
+        in
+        let mapper = makeMapper [] in
+        let astMapped = mapper.signature mapper signature in
+        Ok
+          ( Res_printer.print_interface ~width:Res_printer.default_print_width
+              astMapped ~comments,
+            source )
+      else
+        Error
+          (Printf.sprintf
+             "File extension not supported. This command accepts .res, .resi \
+              files")
+    in
+    match result with
+    | Error e -> Error e
+    | Ok (contents, source) when contents <> source -> (
+      match outputMode with
+      | `Stdout -> Ok contents
+      | `File ->
+        let oc = open_out path in
+        Printf.fprintf oc "%s" contents;
+        close_out oc;
+        Ok (Filename.basename path ^ ": File migrated successfully"))
+    | Ok _ -> Ok (Filename.basename path ^ ": File did not need migration")
+end