[WIP] Migrate command

CHANGELOG.md

@@ -15,6 +15,7 @@
 #### :nail_care: Polish
 
 - Apply heuristic to suggest using JSX fragments where we guess that might be what the user wanted. https://github.com/rescript-lang/rescript/pull/7714
+- `Int.Bitwise` functions have been deprecated. https://github.com/rescript-lang/rescript/pull/7705
 
 # 12.0.0-beta.3
 
@@ -27,6 +28,7 @@
 
 - Add optional `message` argument to `Result.getOrThrow` and improve default error message. https://github.com/rescript-lang/rescript/pull/7630
 - Add `RegExp.escape` binding. https://github.com/rescript-lang/rescript/pull/7695
+- Add `Array.fromString`. https://github.com/rescript-lang/rescript/pull/7693
 
 #### :bug: Bug fix
 
@@ -45,6 +47,7 @@
 - Suggest related functions with the expected arity in errors when it makes sense. https://github.com/rescript-lang/rescript/pull/7712
 - Improve error when a constructor expects an inline record. https://github.com/rescript-lang/rescript/pull/7713
 - Remove `@meth` attribute. https://github.com/rescript-lang/rescript/pull/7684
+  > > > > > > > 00815832f (changelog)
 
 #### :house: Internal
 

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

@@ -79,10 +79,58 @@ 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_piped_template =
+      fields
+      |> List.find_map (fun field ->
+             match field with
+             | {
+              lid = {txt = Lident "migratePiped"};
+              x = migration_piped_template;
+             } ->
+               Some migration_piped_template
+             | _ -> None)
+    in
+
+    (* TODO: Validate and error if expected shape mismatches *)
+    match reason with
+    | Some reason -> Some (reason, migration_template, migration_piped_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_piped_template) ->
+    !Cmt_utils.record_deprecated_used
+      ?deprecated_context ?migration_template ?migration_piped_template loc txt;
+    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/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,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 ?deprecated_context ?migration_template ?migration_piped_template source_loc deprecated_text =
+  deprecated_used := {Cmt_utils.source_loc; deprecated_text; migration_template; migration_piped_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,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,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_piped_template:Parsetree.expression ->
+  Location.t ->
+  string ->
+  unit
+
 (*
 
   val is_magic_number : string -> bool

compiler/ml/cmt_utils.ml

@@ -0,0 +1,26 @@
+type deprecated_used_context = FunctionCall | Reference
+
+type deprecated_used = {
+  source_loc: Location.t;
+  deprecated_text: string;
+  migration_template: Parsetree.expression option;
+  migration_piped_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_piped_template:Parsetree.expression ->
+    Location.t ->
+    string ->
+    unit)
+    ref =
+  ref
+    (fun
+      ?deprecated_context ?migration_template ?migration_piped_template _ _ ->
+      ignore deprecated_context;
+      ignore migration_template;
+      ignore migration_piped_template)

compiler/ml/typecore.ml

@@ -2244,28 +2244,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 =
@@ -2282,7 +2284,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 =
@@ -2420,7 +2429,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

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

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

lib/es6/Stdlib_Int.js

@@ -62,6 +62,14 @@ function clamp(min, max, value) {
   }
 }
 
+function lnot(x) {
+  return x ^ -1;
+}
+
+let Bitwise = {
+  lnot: lnot
+};
+
 let Ref = {};
 
 let Constants = {
@@ -75,6 +83,7 @@ export {
   range,
   rangeWithOptions,
   clamp,
+  Bitwise,
   Ref,
 }
 /* No side effect */

lib/js/Stdlib_Int.js

@@ -62,6 +62,14 @@ function clamp(min, max, value) {
   }
 }
 
+function lnot(x) {
+  return x ^ -1;
+}
+
+let Bitwise = {
+  lnot: lnot
+};
+
 let Ref = {};
 
 let Constants = {
@@ -74,5 +82,6 @@ exports.fromString = fromString;
 exports.range = range;
 exports.rangeWithOptions = rangeWithOptions;
 exports.clamp = clamp;
+exports.Bitwise = Bitwise;
 exports.Ref = Ref;
 /* No side effect */