Extend mark/remove unused actions

CHANGES.md

@@ -8,6 +8,8 @@
 ## Features
 
 - Display text of references in doc strings (#1166)
+- Add mark/remove unused actions for open, types, for loop indexes, modules,
+  match cases, rec, and constructors (#1141)
 
 # 1.16.2
 

ocaml-lsp-server/src/code_actions/action_mark_remove_unused.ml

@@ -1,6 +1,48 @@
 open Import
 open Option.O
 
+let diagnostic_regex, diagnostic_regex_marks =
+  let msgs =
+    ( Re.mark
+        (Re.alt
+           [ Re.str "Error (warning 26)"
+           ; Re.str "Error (warning 27)"
+           ; Re.str "unused value"
+           ])
+    , `Value )
+    :: ([ ("unused open", `Open)
+        ; ("unused open!", `Open_bang)
+        ; ("unused type", `Type)
+        ; ("unused constructor", `Constructor)
+        ; ("unused extension constructor", `Extension)
+        ; ("this match case is unused", `Case)
+        ; ("unused for-loop index", `For_loop_index)
+        ; ("unused rec flag", `Rec)
+        ; ("unused module", `Module)
+        ]
+       |> List.map ~f:(fun (msg, kind) -> (Re.mark (Re.str msg), kind)))
+  in
+  let regex =
+    Re.compile
+      (Re.seq [ Re.bol; Re.alt (List.map ~f:(fun ((_, r), _) -> r) msgs) ])
+  in
+  let marks = List.map ~f:(fun ((m, _), k) -> (m, k)) msgs in
+  (regex, marks)
+
+let find_unused_diagnostic pos ds =
+  let open Option.O in
+  List.filter ds ~f:(fun (d : Diagnostic.t) ->
+      match Position.compare_inclusion pos d.range with
+      | `Outside _ -> false
+      | `Inside -> true)
+  |> List.find_map ~f:(fun (d : Diagnostic.t) ->
+         let* group = Re.exec_opt diagnostic_regex d.message in
+         let+ kind =
+           List.find_map diagnostic_regex_marks ~f:(fun (m, k) ->
+               if Re.Mark.test group m then Some k else None)
+         in
+         (kind, d))
+
 (* Return contexts enclosing `pos` in order from most specific to most
    general. *)
 let enclosing_pos pipeline pos =
@@ -14,7 +56,6 @@ let enclosing_pos pipeline pos =
 
 (* `name` is an unused binding. `contexts` is a list of Mbrowse.t enclosing an
    unused definition of `name`, in order from most general to most specific.
-
    Returns an edit that silences the 'unused value' warning. *)
 let rec mark_value_unused_edit name contexts =
   match contexts with
@@ -64,11 +105,11 @@ let rec mark_value_unused_edit name contexts =
   | _ -> None
 
 let code_action_mark_value_unused pipeline doc (diagnostic : Diagnostic.t) =
+  let open Option.O in
   let* var_name = Document.substring doc diagnostic.range in
   let pos = diagnostic.range.start in
   let+ text_edit =
-    enclosing_pos pipeline pos
-    |> List.rev_map ~f:(fun (_, x) -> x)
+    enclosing_pos pipeline pos |> List.rev_map ~f:snd
     |> mark_value_unused_edit var_name
   in
   let edit = Document.edit doc [ text_edit ] in
@@ -93,22 +134,23 @@ let enclosing_value_binding_range name =
                     ; _
                     }
                   ]
-                , body )
-          ; exp_loc
+                , { exp_loc = { loc_start = let_end; _ }; _ } )
+          ; exp_loc = { loc_start = let_start; _ }
           ; _
           }
         when name = name' ->
-        let* start = Position.of_lexical_position exp_loc.loc_start in
-        let+ end_ = Position.of_lexical_position body.exp_loc.loc_start in
+        let* start = Position.of_lexical_position let_start in
+        let+ end_ = Position.of_lexical_position let_end in
         Range.create ~start ~end_
       | _ -> None)
 
 (* Create a code action that removes [range] and refers to [diagnostic]. *)
-let code_action_remove_range doc (diagnostic : Diagnostic.t) range =
+let code_action_remove_range ?(title = "Remove unused") doc
+    (diagnostic : Diagnostic.t) range =
   let edit = Document.edit doc [ { range; newText = "" } ] in
   CodeAction.create
     ~diagnostics:[ diagnostic ]
-    ~title:"Remove unused"
+    ~title
     ~kind:CodeActionKind.QuickFix
     ~edit
     ~isPreferred:false
@@ -121,25 +163,222 @@ let code_action_remove_value pipeline doc pos (diagnostic : Diagnostic.t) =
   |> enclosing_value_binding_range var_name
   |> Option.map ~f:(fun range -> code_action_remove_range doc diagnostic range)
 
-let find_unused_diagnostic pos (ds : Diagnostic.t list) =
-  List.find ds ~f:(fun d ->
-      let in_range =
-        match Position.compare_inclusion pos d.range with
-        | `Outside _ -> false
-        | `Inside -> true
-      in
-      in_range && Diagnostic_util.is_unused_var_warning d.message)
+(** [create_mark_action ~title doc pos d] creates a code action that resolves
+    the diagnostic [d] by inserting an underscore at [pos] in [doc]. *)
+let create_mark_action ~title doc pos d =
+  let edit =
+    Document.edit
+      doc
+      [ { range = Range.create ~start:pos ~end_:pos; newText = "_" } ]
+  in
+  CodeAction.create
+    ~diagnostics:[ d ]
+    ~title
+    ~kind:CodeActionKind.QuickFix
+    ~edit
+    ~isPreferred:true
+    ()
+
+let action_mark_type pipeline doc pos (d : Diagnostic.t) =
+  let open Option.O in
+  let m_name_loc_start =
+    enclosing_pos pipeline pos
+    |> List.find_map ~f:(fun (_, node) ->
+           match node with
+           | Browse_raw.Type_declaration
+               { typ_name = { loc = { loc_start; _ }; _ }; _ } -> Some loc_start
+           | _ -> None)
+  in
+  let* name_loc_start = m_name_loc_start in
+  let+ start = Position.of_lexical_position name_loc_start in
+  create_mark_action ~title:"Mark type as unused" doc start d
 
-let code_action_mark pipeline doc (params : CodeActionParams.t) =
-  let pos = params.range.start in
-  let* d = find_unused_diagnostic pos params.context.diagnostics in
-  code_action_mark_value_unused pipeline doc d
+let contains loc pos =
+  match Position.compare_inclusion pos (Range.of_loc loc) with
+  | `Outside _ -> false
+  | `Inside -> true
+
+let action_mark_for_loop_index pipeline doc pos (d : Diagnostic.t) =
+  let open Option.O in
+  let module I = Ocaml_parsing.Ast_iterator in
+  let exception Found of Warnings.loc in
+  let iterator =
+    let expr iter (e : Parsetree.expression) =
+      if contains e.pexp_loc pos then
+        match e.pexp_desc with
+        | Pexp_for ({ ppat_loc; _ }, _, _, _, _) when contains ppat_loc pos ->
+          raise_notrace (Found ppat_loc)
+        | _ -> I.default_iterator.expr iter e
+    in
+    let structure_item iter (item : Parsetree.structure_item) =
+      if contains item.pstr_loc pos then
+        I.default_iterator.structure_item iter item
+    in
+    { I.default_iterator with expr; structure_item }
+  in
+  let m_index_loc =
+    match Mpipeline.reader_parsetree pipeline with
+    | `Implementation parsetree -> (
+      try
+        iterator.structure iterator parsetree;
+        None
+      with Found task -> Some task)
+    | `Interface _ -> None
+  in
+  let* (index_loc : Warnings.loc) = m_index_loc in
+  let+ start = Position.of_lexical_position index_loc.loc_start in
+  create_mark_action ~title:"Mark for-loop index as unused" doc start d
 
-let code_action_remove pipeline doc (params : CodeActionParams.t) =
-  let pos = params.range.start in
-  let* d = find_unused_diagnostic pos params.context.diagnostics in
-  code_action_remove_value pipeline doc pos d
+let action_mark_open doc (d : Diagnostic.t) =
+  let edit =
+    let pos = { d.range.start with character = d.range.start.character + 4 } in
+    let range = Range.create ~start:pos ~end_:pos in
+    Document.edit doc [ { range; newText = "!" } ]
+  in
+  CodeAction.create
+    ~diagnostics:[ d ]
+    ~title:"Replace with open!"
+    ~kind:CodeActionKind.QuickFix
+    ~edit
+    ~isPreferred:true
+    ()
 
-let mark = Code_action.batchable QuickFix code_action_mark
+let rec_regex =
+  Re.compile
+    (Re.seq
+       [ Re.bos
+       ; Re.rep Re.any
+       ; Re.group (Re.str "rec")
+       ; Re.rep Re.space
+       ; Re.stop
+       ])
 
-let remove = Code_action.batchable QuickFix code_action_remove
+let find_preceding doc pos regex =
+  let open Option.O in
+  let src = Document.source doc in
+  let (`Offset end_) = Msource.get_offset src @@ Position.logical pos in
+  let* groups = Re.exec_opt ~len:end_ regex (Msource.text src) in
+  let match_start, match_end = Re.Group.offset groups 1 in
+  let filename = Uri.to_path (Document.uri doc) in
+  let* start =
+    Msource.get_lexing_pos ~filename src (`Offset match_start)
+    |> Position.of_lexical_position
+  in
+  let+ end_ =
+    Msource.get_lexing_pos ~filename src (`Offset match_end)
+    |> Position.of_lexical_position
+  in
+  Range.create ~start ~end_
+
+let action_remove_rec doc (d : Diagnostic.t) =
+  let open Option.O in
+  let+ rec_range = find_preceding doc d.range.start rec_regex in
+  code_action_remove_range ~title:"Remove unused rec" doc d rec_range
+
+let bar_regex =
+  Re.compile
+    (Re.seq
+       [ Re.bos
+       ; Re.rep Re.any
+       ; Re.group (Re.str "|")
+       ; Re.rep Re.space
+       ; Re.stop
+       ])
+
+let action_remove_case pipeline doc (d : Diagnostic.t) =
+  let open Option.O in
+  let case_range =
+    enclosing_pos pipeline d.range.start
+    |> List.find_map ~f:(fun (_, node) ->
+           match node with
+           | Browse_raw.Case
+               { c_lhs = { pat_loc = { loc_start; _ }; _ }
+               ; c_rhs = { exp_loc = { loc_end; _ }; _ }
+               ; _
+               } -> Some (loc_start, loc_end)
+           | _ -> None)
+  in
+  let* case_start, case_end = case_range in
+  let* start = Position.of_lexical_position case_start in
+  let* end_ = Position.of_lexical_position case_end in
+  let+ preceding_bar = find_preceding doc start bar_regex in
+  let edit =
+    Document.edit
+      doc
+      [ { range = Range.create ~start:preceding_bar.start ~end_; newText = "" }
+      ]
+  in
+  CodeAction.create
+    ~diagnostics:[ d ]
+    ~title:"Remove unused case"
+    ~kind:CodeActionKind.QuickFix
+    ~edit
+    ~isPreferred:true
+    ()
+
+let action_remove_constructor pipeline doc (d : Diagnostic.t) =
+  let open Option.O in
+  let case_range =
+    enclosing_pos pipeline d.range.start
+    |> List.find_map ~f:(fun (_, node) ->
+           match node with
+           | Browse_raw.Constructor_declaration
+               { cd_loc = { loc_start; loc_end; _ }; _ } ->
+             Some (loc_start, loc_end)
+           | _ -> None)
+  in
+  let* case_start, case_end = case_range in
+  let* start = Position.of_lexical_position case_start in
+  let+ end_ = Position.of_lexical_position case_end in
+  let edit =
+    Document.edit doc [ { range = Range.create ~start ~end_; newText = "" } ]
+  in
+  CodeAction.create
+    ~diagnostics:[ d ]
+    ~title:"Remove unused constructor"
+    ~kind:CodeActionKind.QuickFix
+    ~edit
+    ~isPreferred:true
+    ()
+
+let action_remove_simple kind doc (d : Diagnostic.t) =
+  code_action_remove_range ~title:("Remove unused " ^ kind) doc d d.range
+
+let mark =
+  let run pipeline doc (params : CodeActionParams.t) =
+    let open Option.O in
+    let pos = params.range.start in
+    let* diagnostic = find_unused_diagnostic pos params.context.diagnostics in
+    match diagnostic with
+    | `Value, d -> code_action_mark_value_unused pipeline doc d
+    | `Open, d -> Some (action_mark_open doc d)
+    | `Type, d -> action_mark_type pipeline doc pos d
+    | `For_loop_index, d -> action_mark_for_loop_index pipeline doc pos d
+    | (`Open_bang | `Constructor | `Extension | `Case | `Rec | `Module), _ ->
+      (* these diagnostics don't have a reasonable "mark as unused" action *)
+      None
+  in
+  Code_action.batchable QuickFix run
+
+let remove =
+  let run pipeline doc (params : CodeActionParams.t) =
+    let open Option.O in
+    let pos = params.range.start in
+    let* diagnostic = find_unused_diagnostic pos params.context.diagnostics in
+    match diagnostic with
+    | `Value, d -> code_action_remove_value pipeline doc pos d
+    | `Open, d -> Some (action_remove_simple "open" doc d)
+    | `Open_bang, d -> Some (action_remove_simple "open!" doc d)
+    | `Type, d -> Some (action_remove_simple "type" doc d)
+    | `Module, d -> Some (action_remove_simple "module" doc d)
+    | `Case, d -> action_remove_case pipeline doc d
+    | `Rec, d -> action_remove_rec doc d
+    | `Constructor, d -> action_remove_constructor pipeline doc d
+    | `Extension, _ ->
+      (* todo *)
+      None
+    | `For_loop_index, _ ->
+      (* these diagnostics don't have a reasonable "remove unused" action *)
+      None
+  in
+  Code_action.batchable QuickFix run

ocaml-lsp-server/test/e2e-new/action_extract.ml

@@ -1,8 +1,7 @@
-let extract_local_test src =
-  Code_actions.code_action_test ~title:"Extract local" ~source:src
+let extract_local_test = Code_actions.code_action_test ~title:"Extract local"
 
-let extract_function_test src =
-  Code_actions.code_action_test ~title:"Extract function" ~source:src
+let extract_function_test =
+  Code_actions.code_action_test ~title:"Extract function"
 
 let%expect_test "extract local constant" =
   extract_local_test {|

ocaml-lsp-server/test/e2e-new/action_inline.ml

@@ -1,5 +1,4 @@
-let inline_test src =
-  Code_actions.code_action_test ~title:"Inline into uses" ~source:src
+let inline_test = Code_actions.code_action_test ~title:"Inline into uses"
 
 let%expect_test "" =
   inline_test {|