[WIP] Actions

.gitignore

@@ -12,6 +12,7 @@ _build_playground
 *.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;

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/ext/warnings.ml

@@ -690,3 +690,6 @@ let loc_to_string (loc : loc) : string =
     (loc.loc_start.pos_cnum - loc.loc_start.pos_bol)
     loc.loc_end.pos_lnum
     (loc.loc_end.pos_cnum - loc.loc_end.pos_bol)
+
+let emit_possible_actions_from_warning : (loc -> t -> unit) ref =
+  ref (fun _ _ -> ())

compiler/ext/warnings.mli

@@ -131,3 +131,5 @@ val loc_to_string : loc -> string
 (**
 Turn the location into a string with (line,column--line,column) format.
 *)
+
+val emit_possible_actions_from_warning : (loc -> t -> unit) ref

compiler/ml/actions.ml

@@ -0,0 +1,182 @@
+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)
+type action_type =
+  | ApplyFunction of {function_name: Longident.t}
+  | ApplyCoercion of {coerce_to_name: Longident.t}
+  | RemoveSwitchCase
+  | RemoveOpen
+  | RemoveAwait
+  | AddAwait
+  | ReplaceWithVariantConstructor of {constructor_name: Longident.t}
+  | ReplaceWithPolymorphicVariantConstructor of {constructor_name: string}
+  | RewriteObjectToRecord
+  | RewriteArrayToTuple
+  | RewriteIdentToModule of {module_name: string}
+  | RewriteIdent of {new_ident: Longident.t}
+  | RewriteArgType of {to_type: [`Labelled | `Optional | `Unlabelled]}
+  | PrefixVariableWithUnderscore
+  | RemoveUnusedVariable
+  | RemoveUnusedType
+  | RemoveUnusedModule
+  | RemoveRecFlag
+  | RemoveRecordSpread
+  | ForceOpen
+  | AssignToUnderscore
+  | PipeToIgnore
+  | PartiallyApplyFunction
+  | InsertMissingArguments of {missing_args: Asttypes.Noloc.arg_label list}
+  | ChangeRecordFieldOptional of {optional: bool}
+  | UnwrapOptionMapRecordField of {field_name: Longident.t}
+
+(* TODO: 
+- Unused var in patterns (and aliases )*)
+
+type action = {loc: Location.t; action: action_type; description: string}
+
+let action_to_string = function
+  | ApplyFunction {function_name} ->
+    Printf.sprintf "ApplyFunction(%s)"
+      (Longident.flatten function_name |> String.concat ".")
+  | ApplyCoercion {coerce_to_name} ->
+    Printf.sprintf "ApplyCoercion(%s)"
+      (Longident.flatten coerce_to_name |> String.concat ".")
+  | RemoveSwitchCase -> "RemoveSwitchCase"
+  | RemoveOpen -> "RemoveOpen"
+  | RemoveAwait -> "RemoveAwait"
+  | AddAwait -> "AddAwait"
+  | RewriteObjectToRecord -> "RewriteObjectToRecord"
+  | RewriteArrayToTuple -> "RewriteArrayToTuple"
+  | RewriteIdentToModule {module_name} ->
+    Printf.sprintf "RewriteIdentToModule(%s)" module_name
+  | PrefixVariableWithUnderscore -> "PrefixVariableWithUnderscore"
+  | RemoveUnusedVariable -> "RemoveUnusedVariable"
+  | RemoveUnusedType -> "RemoveUnusedType"
+  | RemoveUnusedModule -> "RemoveUnusedModule"
+  | ReplaceWithVariantConstructor {constructor_name} ->
+    Printf.sprintf "ReplaceWithVariantConstructor(%s)"
+      (constructor_name |> Longident.flatten |> String.concat ".")
+  | ReplaceWithPolymorphicVariantConstructor {constructor_name} ->
+    Printf.sprintf "ReplaceWithPolymorphicVariantConstructor(%s)"
+      constructor_name
+  | RewriteIdent {new_ident} ->
+    Printf.sprintf "RewriteIdent(%s)"
+      (Longident.flatten new_ident |> String.concat ".")
+  | RemoveRecFlag -> "RemoveRecFlag"
+  | ForceOpen -> "ForceOpen"
+  | RemoveRecordSpread -> "RemoveRecordSpread"
+  | AssignToUnderscore -> "AssignToUnderscore"
+  | PipeToIgnore -> "PipeToIgnore"
+  | RewriteArgType {to_type} -> (
+    match to_type with
+    | `Labelled -> "RewriteArgType(Labelled)"
+    | `Optional -> "RewriteArgType(Optional)"
+    | `Unlabelled -> "RewriteArgType(Unlabelled)")
+  | PartiallyApplyFunction -> "PartiallyApplyFunction"
+  | InsertMissingArguments {missing_args} ->
+    Printf.sprintf "InsertMissingArguments(%s)"
+      (missing_args
+      |> List.map (fun arg ->
+             match arg with
+             | Asttypes.Noloc.Labelled txt -> "~" ^ txt
+             | Asttypes.Noloc.Optional txt -> "?" ^ txt
+             | Asttypes.Noloc.Nolabel -> "<unlabelled>")
+      |> String.concat ", ")
+  | ChangeRecordFieldOptional {optional} ->
+    Printf.sprintf "ChangeRecordFieldOptional(%s)"
+      (if optional then "true" else "false")
+  | UnwrapOptionMapRecordField {field_name} ->
+    Printf.sprintf "UnwrapOptionMapRecordField(%s)"
+      (Longident.flatten field_name |> String.concat ".")
+
+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 =
+  match w with
+  | Warnings.Unused_open _ ->
+    add_possible_action {loc; action = RemoveOpen; description = "Remove open"}
+  | Unused_match | Unreachable_case ->
+    add_possible_action
+      {loc; action = RemoveSwitchCase; description = "Remove switch case"}
+  | Unused_var _ | Unused_var_strict _ | Unused_value_declaration _ ->
+    add_possible_action
+      {
+        loc;
+        action = PrefixVariableWithUnderscore;
+        description = "Prefix with `_`";
+      };
+    add_possible_action
+      {
+        loc;
+        action = RemoveUnusedVariable;
+        description = "Remove unused variable";
+      }
+  | Unused_type_declaration _ ->
+    add_possible_action
+      {loc; action = RemoveUnusedType; description = "Remove unused type"}
+  | Unused_module _ ->
+    add_possible_action
+      {loc; action = RemoveUnusedModule; description = "Remove unused module"}
+  | Unused_rec_flag ->
+    add_possible_action
+      {loc; action = RemoveRecFlag; description = "Remove rec flag"}
+  | Open_shadow_identifier _ | Open_shadow_label_constructor _ ->
+    add_possible_action {loc; action = ForceOpen; description = "Force open"}
+  | Useless_record_with ->
+    add_possible_action
+      {loc; action = RemoveRecordSpread; description = "Remove `...` spread"}
+  | Bs_toplevel_expression_unit _ ->
+    add_possible_action
+      {loc; action = PipeToIgnore; description = "Pipe to ignore()"};
+    add_possible_action
+      {loc; action = AssignToUnderscore; description = "Assign to let _ ="}
+  | Nonoptional_label _ ->
+    add_possible_action
+      {
+        loc;
+        action = RewriteArgType {to_type = `Labelled};
+        description = "Make argument optional";
+      }
+    (* 
+
+    === TODO === 
+
+    *)
+  | Unused_pat -> (* Remove pattern *) ()
+  | Unused_argument -> (* Remove unused argument or prefix with underscore *) ()
+  | Unused_constructor _ -> (* Remove unused constructor *) ()
+  | Bs_unused_attribute _ -> (* Remove unused attribute *) ()
+  | _ -> ()
+
+let _ =
+  Warnings.emit_possible_actions_from_warning :=
+    emit_possible_actions_from_warning