[WIP] Actions

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/bsc/rescript_compiler_main.ml

@@ -462,4 +462,6 @@ 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/ext/warnings.ml

@@ -428,7 +428,9 @@ let message = function
   | Ambiguous_name (_slist, tl, true) ->
     "these field labels belong to several types: " ^ String.concat " " tl
     ^ "\nThe first one was selected. Please disambiguate if this is wrong."
-  | Nonoptional_label s -> "the label " ^ s ^ " is not optional."
+  | Nonoptional_label s ->
+    (* TODO(actions) When does this happen? *)
+    "the label " ^ s ^ " is not optional."
   | Open_shadow_identifier (kind, s) ->
     Printf.sprintf
       "this open statement shadows the %s identifier %s (which is later used)"
@@ -682,3 +684,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/ast_iterator.ml

@@ -44,6 +44,8 @@ type iterator = {
   open_description: iterator -> open_description -> unit;
   pat: iterator -> pattern -> unit;
   payload: iterator -> payload -> unit;
+  record_field: iterator -> expression record_element -> unit;
+  record_field_pat: iterator -> pattern record_element -> unit;
   signature: iterator -> signature -> unit;
   signature_item: iterator -> signature_item -> unit;
   structure: iterator -> structure -> unit;
@@ -53,6 +55,7 @@ type iterator = {
   type_extension: iterator -> type_extension -> unit;
   type_kind: iterator -> type_kind -> unit;
   value_binding: iterator -> value_binding -> unit;
+  value_bindings: iterator -> value_binding list -> unit;
   value_description: iterator -> value_description -> unit;
   with_constraint: iterator -> with_constraint -> unit;
 }
@@ -250,7 +253,7 @@ module M = struct
     | Pstr_eval (x, attrs) ->
       sub.expr sub x;
       sub.attributes sub attrs
-    | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
+    | Pstr_value (_r, vbs) -> sub.value_bindings sub vbs
     | Pstr_primitive vd -> sub.value_description sub vd
     | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
     | Pstr_typext te -> sub.type_extension sub te
@@ -289,7 +292,7 @@ module E = struct
     | Pexp_ident x -> iter_loc sub x
     | Pexp_constant _ -> ()
     | Pexp_let (_r, vbs, e) ->
-      List.iter (sub.value_binding sub) vbs;
+      sub.value_bindings sub vbs;
       sub.expr sub e
     | Pexp_fun {default = def; lhs = p; rhs = e} ->
       iter_opt (sub.expr sub) def;
@@ -310,11 +313,7 @@ module E = struct
       iter_opt (sub.expr sub) arg
     | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo
     | Pexp_record (l, eo) ->
-      List.iter
-        (fun {lid; x = exp} ->
-          iter_loc sub lid;
-          sub.expr sub exp)
-        l;
+      List.iter (sub.record_field sub) l;
       iter_opt (sub.expr sub) eo
     | Pexp_field (e, lid) ->
       sub.expr sub e;
@@ -400,12 +399,7 @@ module P = struct
       iter_loc sub l;
       iter_opt (sub.pat sub) p
     | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
-    | Ppat_record (lpl, _cf) ->
-      List.iter
-        (fun {lid; x = pat} ->
-          iter_loc sub lid;
-          sub.pat sub pat)
-        lpl
+    | Ppat_record (lpl, _cf) -> List.iter (sub.record_field_pat sub) lpl
     | Ppat_array pl -> List.iter (sub.pat sub) pl
     | Ppat_or (p1, p2) ->
       sub.pat sub p1;
@@ -489,6 +483,7 @@ let default_iterator =
         this.expr this pvb_expr;
         this.location this pvb_loc;
         this.attributes this pvb_attributes);
+    value_bindings = (fun this l -> List.iter (this.value_binding this) l);
     constructor_declaration =
       (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
         iter_loc this pcd_name;
@@ -528,4 +523,12 @@ let default_iterator =
         | PPat (x, g) ->
           this.pat this x;
           iter_opt (this.expr this) g);
+    record_field =
+      (fun this {lid; x; opt = _} ->
+        iter_loc this lid;
+        this.expr this x);
+    record_field_pat =
+      (fun this {lid; x; opt = _} ->
+        iter_loc this lid;
+        this.pat this x);
   }

compiler/ml/ast_iterator.mli

@@ -42,6 +42,8 @@ type iterator = {
   open_description: iterator -> open_description -> unit;
   pat: iterator -> pattern -> unit;
   payload: iterator -> payload -> unit;
+  record_field: iterator -> expression record_element -> unit;
+  record_field_pat: iterator -> pattern record_element -> unit;
   signature: iterator -> signature -> unit;
   signature_item: iterator -> signature_item -> unit;
   structure: iterator -> structure -> unit;
@@ -51,6 +53,7 @@ type iterator = {
   type_extension: iterator -> type_extension -> unit;
   type_kind: iterator -> type_kind -> unit;
   value_binding: iterator -> value_binding -> unit;
+  value_bindings: iterator -> value_binding list -> unit;
   value_description: iterator -> value_description -> unit;
   with_constraint: iterator -> with_constraint -> unit;
 }

compiler/ml/ast_mapper.ml

@@ -48,6 +48,9 @@ type mapper = {
   open_description: mapper -> open_description -> open_description;
   pat: mapper -> pattern -> pattern;
   payload: mapper -> payload -> payload;
+  record_field:
+    mapper -> expression record_element -> expression record_element;
+  record_field_pat: mapper -> pattern record_element -> pattern record_element;
   signature: mapper -> signature -> signature;
   signature_item: mapper -> signature_item -> signature_item;
   structure: mapper -> structure -> structure;
@@ -57,6 +60,7 @@ type mapper = {
   type_extension: mapper -> type_extension -> type_extension;
   type_kind: mapper -> type_kind -> type_kind;
   value_binding: mapper -> value_binding -> value_binding;
+  value_bindings: mapper -> value_binding list -> value_binding list;
   value_description: mapper -> value_description -> value_description;
   with_constraint: mapper -> with_constraint -> with_constraint;
 }
@@ -247,7 +251,7 @@ module M = struct
     match desc with
     | Pstr_eval (x, attrs) ->
       eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x)
-    | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs)
+    | Pstr_value (r, vbs) -> value ~loc r (sub.value_bindings sub vbs)
     | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
     | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l)
     | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te)
@@ -287,7 +291,7 @@ module E = struct
     | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
     | Pexp_constant x -> constant ~loc ~attrs x
     | Pexp_let (r, vbs, e) ->
-      let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
+      let_ ~loc ~attrs r (sub.value_bindings sub vbs) (sub.expr sub e)
     | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async}
       ->
       fun_ ~loc ~attrs ~arity ~async lab
@@ -306,10 +310,7 @@ module E = struct
       variant ~loc ~attrs lab (map_opt (sub.expr sub) eo)
     | Pexp_record (l, eo) ->
       record ~loc ~attrs
-        (List.map
-           (fun {lid; x = exp; opt} ->
-             {lid = map_loc sub lid; x = sub.expr sub exp; opt})
-           l)
+        (List.map (sub.record_field sub) l)
         (map_opt (sub.expr sub) eo)
     | Pexp_field (e, lid) ->
       field ~loc ~attrs (sub.expr sub e) (map_loc sub lid)
@@ -392,12 +393,7 @@ module P = struct
       construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
     | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
     | Ppat_record (lpl, cf) ->
-      record ~loc ~attrs
-        (List.map
-           (fun {lid; x = pat; opt} ->
-             {lid = map_loc sub lid; x = sub.pat sub pat; opt})
-           lpl)
-        cf
+      record ~loc ~attrs (List.map (sub.record_field_pat sub) lpl) cf
     | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl)
     | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2)
     | Ppat_constraint (p, t) ->
@@ -475,6 +471,7 @@ let default_mapper =
         Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr)
           ~loc:(this.location this pvb_loc)
           ~attrs:(this.attributes this pvb_attributes));
+    value_bindings = (fun this l -> List.map (this.value_binding this) l);
     constructor_declaration =
       (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} ->
         Type.constructor (map_loc this pcd_name)
@@ -509,6 +506,12 @@ let default_mapper =
         | PSig x -> PSig (this.signature this x)
         | PTyp x -> PTyp (this.typ this x)
         | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g));
+    record_field =
+      (fun this {lid; x; opt} ->
+        {lid = map_loc this lid; x = this.expr this x; opt});
+    record_field_pat =
+      (fun this {lid; x; opt} ->
+        {lid = map_loc this lid; x = this.pat this x; opt});
   }
 
 let rec extension_of_error {loc; msg; if_highlight; sub} =

compiler/ml/ast_mapper.mli

@@ -76,6 +76,9 @@ type mapper = {
   open_description: mapper -> open_description -> open_description;
   pat: mapper -> pattern -> pattern;
   payload: mapper -> payload -> payload;
+  record_field:
+    mapper -> expression record_element -> expression record_element;
+  record_field_pat: mapper -> pattern record_element -> pattern record_element;
   signature: mapper -> signature -> signature;
   signature_item: mapper -> signature_item -> signature_item;
   structure: mapper -> structure -> structure;
@@ -85,6 +88,7 @@ type mapper = {
   type_extension: mapper -> type_extension -> type_extension;
   type_kind: mapper -> type_kind -> type_kind;
   value_binding: mapper -> value_binding -> value_binding;
+  value_bindings: mapper -> value_binding list -> value_binding list;
   value_description: mapper -> value_description -> value_description;
   with_constraint: mapper -> with_constraint -> with_constraint;
 }

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_possible_actions : Cmt_utils.cmt_action list;
 }
 
 type error =
@@ -154,15 +155,22 @@ let read_cmi filename =
 
 let saved_types = ref []
 let value_deps = ref []
+let possible_actions = ref []
 
 let clear () =
   saved_types := [];
-  value_deps := []
+  value_deps := [];
+  possible_actions := []
 
 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
@@ -172,8 +180,30 @@ 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 =
@@ -197,6 +227,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_possible_actions = !possible_actions;
          } 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_possible_actions: Cmt_utils.cmt_action list;
 }
 
 type error = Not_a_typedtree of string
@@ -111,6 +112,8 @@ 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