move away from cmt to an explicit sidecar extras file

Author: zth

.gitignore

@@ -11,6 +11,7 @@ _build
 *.cmx
 *.cmt
 *.cmti
+*.resextra
 *.cma
 *.a
 *.cmxa

analysis/src/Cmt.ml

@@ -38,7 +38,8 @@ let fullFromUri ~uri =
         let cmt = getCmtPath ~uri paths in
         fullForCmt ~moduleName ~package ~uri cmt
       | None ->
-        prerr_endline ("can't find module " ^ moduleName);
+        if not (Uri.isInterface uri) then
+          prerr_endline ("can't find module " ^ moduleName);
         None))
 
 let fullsFromModule ~package ~moduleName =

analysis/src/Resextra.ml

@@ -0,0 +1,30 @@
+let extrasPathFromCmtPath cmtPath =
+  if Filename.check_suffix cmtPath ".cmti" then
+    Filename.chop_extension cmtPath ^ ".resiextra"
+  else if Filename.check_suffix cmtPath ".cmt" then
+    Filename.chop_extension cmtPath ^ ".resextra"
+  else cmtPath ^ ".resextra"
+
+let loadActionsFromPackage ~path ~package =
+  let uri = Uri.fromPath path in
+  let moduleName =
+    BuildSystem.namespacedName package.SharedTypes.namespace
+      (FindFiles.getName path)
+  in
+  match Hashtbl.find_opt package.SharedTypes.pathsForModule moduleName with
+  | None -> None
+  | Some paths ->
+    let cmtPath = SharedTypes.getCmtPath ~uri paths in
+    let extrasPath = extrasPathFromCmtPath cmtPath in
+
+    let tryLoad path =
+      if Sys.file_exists path then
+        try
+          let ic = open_in_bin path in
+          let v = (input_value ic : Actions.action list) in
+          close_in ic;
+          Some v
+        with _ -> None
+      else None
+    in
+    tryLoad extrasPath

analysis/src/Xform.ml

@@ -897,6 +897,28 @@ let parseInterface ~filename =
 let extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug =
   let pos = startPos in
   let codeActions = ref [] in
+  let add_actions_from_extras ~path ~pos ~package ~codeActions =
+    let map_extra_action (a : Actions.action) =
+      match a.action with
+      | Actions.RemoveOpen ->
+        let range = Loc.rangeOfLoc a.loc in
+        let newText = "" in
+        Some
+          (CodeActions.make ~title:a.description ~kind:RefactorRewrite ~uri:path
+             ~newText ~range)
+      | _ -> None
+    in
+    match Resextra.loadActionsFromPackage ~path ~package with
+    | None -> ()
+    | Some actions ->
+      let relevant =
+        actions
+        |> List.filter (fun (a : Actions.action) -> Loc.hasPos ~pos a.loc)
+      in
+      relevant
+      |> List.filter_map map_extra_action
+      |> List.iter (fun ca -> codeActions := ca :: !codeActions)
+  in
   match Files.classifySourceFile currentFile with
   | Res ->
     let structure, printExpr, printStructureItem, printStandaloneStructure =
@@ -920,7 +942,8 @@ let extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug =
           ~pos:
             (if startPos = endPos then Single startPos
              else Range (startPos, endPos))
-          ~full ~structure ~codeActions ~debug ~currentFile
+          ~full ~structure ~codeActions ~debug ~currentFile;
+        add_actions_from_extras ~path ~pos ~package:full.package ~codeActions
       | None -> ()
     in
 
@@ -929,5 +952,8 @@ let extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug =
     let signature, printSignatureItem = parseInterface ~filename:currentFile in
     AddDocTemplate.Interface.xform ~pos ~codeActions ~path ~signature
       ~printSignatureItem;
+    (match Packages.getPackage ~uri:(Uri.fromPath path) with
+    | Some package -> add_actions_from_extras ~path ~pos ~package ~codeActions
+    | None -> ());
     !codeActions
   | Other -> []

compiler/bsc/rescript_compiler_main.ml

@@ -437,6 +437,9 @@ let _ : unit =
   Bs_conditional_initial.setup_env ();
   Clflags.color := Some Always;
 
+  (* Save extras (e.g., actions) once before exit, after all reporting. *)
+  at_exit (fun () -> Res_extra.save ());
+
   let flags = "flags" in
   Ast_config.add_structure flags file_level_flags_handler;
   Ast_config.add_signature flags file_level_flags_handler;
@@ -446,6 +449,4 @@ let _ : unit =
     exit 2
   | x ->
     Location.report_exception ppf x;
-    (* Re-save cmt so we can get the possible actions *)
-    Cmt_format.resave_cmt_with_possible_actions ();
     exit 2

compiler/core/js_implementation.ml

@@ -49,6 +49,8 @@ let after_parsing_sig ppf outputprefix ast =
     if !Js_config.syntax_only then Warnings.check_fatal ()
     else
       let modulename = module_of_filename outputprefix in
+      Res_extra.set_is_interface true;
+      Res_extra.set_current_outputprefix (Some outputprefix);
       Lam_compile_env.reset ();
       let initial_env = Res_compmisc.initial_env ~modulename () in
       Env.set_unit_name modulename;
@@ -65,7 +67,9 @@ let after_parsing_sig ppf outputprefix ast =
       in
       Typemod.save_signature modulename tsg outputprefix !Location.input_name
         initial_env sg;
-      process_with_gentype (outputprefix ^ ".cmti"))
+      process_with_gentype (outputprefix ^ ".cmti");
+      (* Persist any collected code actions to .resextra sidecar *)
+      Res_extra.save ())
 
 let interface ~parser ppf ?outputprefix fname =
   let outputprefix =
@@ -130,6 +134,8 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) =
     if !Js_config.syntax_only then Warnings.check_fatal ()
     else
       let modulename = Ext_filename.module_name outputprefix in
+      Res_extra.set_is_interface false;
+      Res_extra.set_current_outputprefix (Some outputprefix);
       Lam_compile_env.reset ();
       let env = Res_compmisc.initial_env ~modulename () in
       Env.set_unit_name modulename;
@@ -152,7 +158,9 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) =
          in
          if not !Js_config.cmj_only then
            Lam_compile_main.lambda_as_module js_program outputprefix);
-      process_with_gentype (outputprefix ^ ".cmt"))
+      process_with_gentype (outputprefix ^ ".cmt");
+      (* Persist any collected code actions to .resextra sidecar *)
+      Res_extra.save ())
 
 let implementation ~parser ppf ?outputprefix fname =
   let outputprefix =

compiler/ml/cmt_utils.ml renamed to compiler/ml/actions.ml

@@ -29,7 +29,7 @@ type action_type =
 (* TODO: 
 - Unused var in patterns (and aliases )*)
 
-type cmt_action = {loc: Location.t; action: action_type; description: string}
+type action = {loc: Location.t; action: action_type; description: string}
 
 let action_to_string = function
   | ApplyFunction {function_name} ->
@@ -86,7 +86,7 @@ let action_to_string = function
     Printf.sprintf "UnwrapOptionMapRecordField(%s)"
       (Longident.flatten field_name |> String.concat ".")
 
-let _add_possible_action : (cmt_action -> unit) ref = ref (fun _ -> ())
+let _add_possible_action : (action -> unit) ref = ref (fun _ -> ())
 let add_possible_action action = !_add_possible_action action
 
 let emit_possible_actions_from_warning loc w =

compiler/ml/cmt_format.ml

@@ -63,7 +63,6 @@ type cmt_infos = {
   cmt_imports : (string * Digest.t option) list;
   cmt_interface_digest : Digest.t option;
   cmt_use_summaries : bool;
-  cmt_possible_actions : Cmt_utils.cmt_action list;
 }
 
 type error =
@@ -155,22 +154,15 @@ let read_cmi filename =
 
 let saved_types = ref []
 let value_deps = ref []
-let possible_actions = ref []
 
 let clear () =
   saved_types := [];
-  value_deps := [];
-  possible_actions := []
+  value_deps := []
 
 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 add_possible_action action =
-  possible_actions := action :: !possible_actions
-
-let _ = Cmt_utils._add_possible_action := add_possible_action
-
 let record_value_dependency vd1 vd2 =
   if vd1.Types.val_loc <> vd2.Types.val_loc then
     value_deps := (vd1, vd2) :: !value_deps
@@ -180,30 +172,8 @@ let save_cmt _filename _modname _binary_annots _sourcefile _initial_env _cmi = (
 #else
 open Cmi_format
 
-let current_cmt_filename = ref None
-
-(* TODO: Terrible hack. Figure out way to do this without saving the cmt file twice. 
-  Probably change how/where we save the cmt, and delay it to after writing errors, if possible.
-*)
-let resave_cmt_with_possible_actions () =
-  if List.length !possible_actions > 0 then begin
-    match !current_cmt_filename with
-    | None -> ()
-    | Some filename ->
-      let current_cmt = read_cmt filename in
-      Misc.output_to_bin_file_directly filename
-       (fun _temp_file_name oc ->
-         let cmt = {
-          current_cmt with
-           cmt_possible_actions = current_cmt.cmt_possible_actions @ !possible_actions;
-         } in
-         output_cmt oc cmt)
-  end;
-  clear ()
-
 let save_cmt filename modname binary_annots sourcefile initial_env cmi =
   if !Clflags.binary_annotations then begin
-    current_cmt_filename := Some filename;
     Misc.output_to_bin_file_directly filename
        (fun temp_file_name oc ->
          let this_crc =
@@ -227,7 +197,6 @@ 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_possible_actions = !possible_actions;
          } in
          output_cmt oc cmt)
   end;

compiler/ml/cmt_format.mli

@@ -63,7 +63,6 @@ type cmt_infos = {
   cmt_imports: (string * Digest.t option) list;
   cmt_interface_digest: Digest.t option;
   cmt_use_summaries: bool;
-  cmt_possible_actions: Cmt_utils.cmt_action list;
 }
 
 type error = Not_a_typedtree of string
@@ -112,8 +111,6 @@ val set_saved_types : binary_part list -> unit
 val record_value_dependency :
   Types.value_description -> Types.value_description -> unit
 
-val resave_cmt_with_possible_actions : unit -> unit
-
 (*
 
   val is_magic_number : string -> bool

compiler/ml/error_message_utils.ml

@@ -389,7 +389,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
       \  To fix this, change the highlighted code so it evaluates to a \
        @{<info>bool@}."
   | Some Await, _ ->
-    Cmt_utils.add_possible_action
+    Actions.add_possible_action
       {loc; action = RemoveAwait; description = "Remove await"};
     fprintf ppf
       "\n\n\
@@ -417,7 +417,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
   | Some ComparisonOperator, _ ->
     fprintf ppf "\n\n  You can only compare things of the same type."
   | Some ArrayValue, _ ->
-    Cmt_utils.add_possible_action
+    Actions.add_possible_action
       {loc; action = RewriteArrayToTuple; description = "Rewrite to tuple"};
     fprintf ppf
       "\n\n\
@@ -478,7 +478,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
             Some record
           | _ -> None)
     in
-    Cmt_utils.add_possible_action
+    Actions.add_possible_action
       {
         loc;
         action = RewriteObjectToRecord;
@@ -498,7 +498,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
   | _, Some ({Types.desc = Tconstr (p1, _, _)}, _)
     when Path.same p1 Predef.path_promise ->
     (* TODO: This should be aware of if we're in an async context or not? *)
-    Cmt_utils.add_possible_action
+    Actions.add_possible_action
       {loc; action = AddAwait; description = "Await promise"};
     fprintf ppf "\n\n  - Did you mean to await this promise before using it?\n"
   | _, Some ({Types.desc = Tconstr (p1, _, _)}, {Types.desc = Ttuple _})
@@ -507,7 +507,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
       Parser.reprint_expr_at_loc loc ~mapper:(fun exp ->
           match exp.Parsetree.pexp_desc with
           | Pexp_array items ->
-            Cmt_utils.add_possible_action
+            Actions.add_possible_action
               {
                 loc;
                 action = RewriteArrayToTuple;
@@ -538,7 +538,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
     in
 
     let print_jsx_msg ?(extra = "") name target_fn =
-      Cmt_utils.add_possible_action
+      Actions.add_possible_action
         {
           loc;
           action = ApplyFunction {function_name = Longident.parse target_fn};
@@ -589,7 +589,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
   | ( Some (RecordField {optional = true; field_name; jsx = None}),
       Some ({desc = Tconstr (p, _, _)}, _) )
     when Path.same Predef.path_option p ->
-    Cmt_utils.add_possible_action
+    Actions.add_possible_action
       {
         loc;
         action = ChangeRecordFieldOptional {optional = true};
@@ -632,7 +632,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
   | ( Some (FunctionArgument {optional = true}),
       Some ({desc = Tconstr (p, _, _)}, _) )
     when Path.same Predef.path_option p ->
-    Cmt_utils.add_possible_action
+    Actions.add_possible_action
       {
         loc;
         action = RewriteArgType {to_type = `Optional};
@@ -696,7 +696,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
       in
       match (reprinted, List.mem string_value variant_constructors) with
       | Some reprinted, true ->
-        Cmt_utils.add_possible_action
+        Actions.add_possible_action
           {
             loc;
             action =
@@ -763,7 +763,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
         in
         match reprinted with
         | Some reprinted ->
-          Cmt_utils.add_possible_action
+          Actions.add_possible_action
             {
               loc;
               action =
@@ -829,7 +829,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf
     in
 
     if can_show_coercion_message && not is_constant then (
-      Cmt_utils.add_possible_action
+      Actions.add_possible_action
         {
           loc;
           action =