Add code action combine cases (#1514)

* Add `combine_cases` code Action

* Add tests for `combine-cases`

* Add CHANGE entry

Author: xvw

CHANGES.md

@@ -4,6 +4,7 @@
 
 - Make `inlay-hint` for function parameters configurable (#1515)
 - Add custom `ocamllsp/jumpToTypedHole` to navigate through typed holes (#1516)
+- Add a code-action for combining pattern cases (just relaying on regex) (#1514)
 
 ## Fixes
 

ocaml-lsp-server/src/code_actions.ml

@@ -38,6 +38,7 @@ let compute_ocaml_code_actions (params : CodeActionParams.t) state doc =
       [ Action_destruct_line.t state
       ; Action_destruct.t state
       ; Action_update_signature.t state
+      ; Action_combine_cases.t
       ; Action_inferred_intf.t state
       ; Action_type_annotate.t
       ; Action_remove_type_annotation.t

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

@@ -0,0 +1,81 @@
+open Import
+
+let action_kind = "combine-cases"
+let kind = CodeActionKind.Other action_kind
+
+let select_complete_lines (range : Range.t) =
+  if range.start.line = range.end_.line
+  then None
+  else (
+    let start = { range.start with character = 0 } in
+    match range.end_.character with
+    | 0 -> Some { range with start }
+    | _ ->
+      let end_ = Position.{ line = range.end_.line + 1; character = 0 } in
+      Some (Range.create ~start ~end_))
+;;
+
+let split_cases code =
+  let lines = String.split code ~on:'\n' in
+  let case_regex = Re.Perl.re {|^\s*\|.*->|} |> Re.compile in
+  let drop_from_lines lines regex =
+    List.map lines ~f:(Re.replace_string (Re.compile regex) ~by:"")
+  in
+  match List.for_all ~f:(Re.execp case_regex) lines with
+  | false -> None
+  | true ->
+    let without_pipes = drop_from_lines lines (Re.Perl.re {|\s*\|\s*|}) in
+    let lhs_patterns = drop_from_lines without_pipes (Re.Perl.re {|\s*->.*$|}) in
+    let rhs_expressions = drop_from_lines without_pipes (Re.Perl.re {|^.*->\s*|}) in
+    Some (lhs_patterns, rhs_expressions)
+;;
+
+let pick_rhs rhs_expressions =
+  let distinct_nonempty =
+    List.map rhs_expressions ~f:String.strip
+    |> List.filter ~f:(fun s -> (not (String.is_empty s)) && not (String.equal s "_"))
+    |> Base.List.dedup_and_sort ~compare:Base.String.compare
+  in
+  match distinct_nonempty with
+  | [ expr ] -> expr
+  | _ -> "_"
+;;
+
+let make_text_edit ~range ~newText ~doc ~uri =
+  let text_edit = TextEdit.create ~range ~newText in
+  let version = Document.version doc in
+  let textDocument = OptionalVersionedTextDocumentIdentifier.create ~uri ~version () in
+  let edit = TextDocumentEdit.create ~textDocument ~edits:[ `TextEdit text_edit ] in
+  WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] ()
+;;
+
+let code_action doc params =
+  match Document.kind doc with
+  | `Other -> Fiber.return None
+  | `Merlin merlin ->
+    (match Document.Merlin.kind merlin with
+     | Intf -> Fiber.return None
+     | Impl ->
+       let result =
+         let open Option.O in
+         let* range = select_complete_lines params.CodeActionParams.range in
+         let* code = Document.substring doc range in
+         let code = String.strip ~drop:(fun c -> Char.equal c '\n') code in
+         let* lhs_patterns, rhs_expressions = split_cases code in
+         let+ i = Base.String.index code '|' in
+         let indent = String.sub code ~pos:0 ~len:i in
+         let lhs = String.concat ~sep:" | " lhs_patterns in
+         let rhs = pick_rhs rhs_expressions in
+         let newText = indent ^ "| " ^ lhs ^ " -> " ^ rhs ^ "\n" in
+         let edit = make_text_edit ~range ~newText ~doc ~uri:params.textDocument.uri in
+         CodeAction.create
+           ~title:(String.capitalize action_kind)
+           ~kind
+           ~edit
+           ~isPreferred:false
+           ()
+       in
+       Fiber.return result)
+;;
+
+let t = { Code_action.kind; run = `Non_batchable code_action }

ocaml-lsp-server/src/code_actions/action_combine_cases.mli

@@ -0,0 +1,4 @@
+open Import
+
+val kind : CodeActionKind.t
+val t : Code_action.t

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

@@ -1729,6 +1729,94 @@ let%expect_test "shouldn't find the jump target on the same line" =
       No code actions |}]
 ;;
 
+let%expect_test "can combine cases with multiple RHSes" =
+  let source =
+    {ocaml|
+    match card with
+    | Ace -> _
+    | King -> _
+    | Queen -> "Face card!"
+    | Jack -> "Face card?"
+    | Number _ -> _
+|ocaml}
+  in
+  let range =
+    let start = Position.create ~line:3 ~character:3 in
+    let end_ = Position.create ~line:6 ~character:6 in
+    Range.create ~start ~end_
+  in
+  print_code_actions source range ~filter:(find_action "combine-cases");
+  [%expect
+    {|
+    Code actions:
+    {
+      "edit": {
+        "documentChanges": [
+          {
+            "edits": [
+              {
+                "newText": "    | King | Queen | Jack | Number _ -> _\n",
+                "range": {
+                  "end": { "character": 0, "line": 7 },
+                  "start": { "character": 0, "line": 3 }
+                }
+              }
+            ],
+            "textDocument": { "uri": "file:///foo.ml", "version": 0 }
+          }
+        ]
+      },
+      "isPreferred": false,
+      "kind": "combine-cases",
+      "title": "Combine-cases"
+    }
+    |}]
+;;
+
+let%expect_test "can combine cases with one unique RHS" =
+  let source =
+    {ocaml|
+    match card with
+    | Ace -> _
+    | King -> _
+    | Queen -> "Face card!"
+    | Jack -> "Face card?"
+    | Number _ -> _
+|ocaml}
+  in
+  let range =
+    let start = Position.create ~line:3 ~character:3 in
+    let end_ = Position.create ~line:4 ~character:4 in
+    Range.create ~start ~end_
+  in
+  print_code_actions source range ~filter:(find_action "combine-cases");
+  [%expect
+    {|
+    Code actions:
+    {
+      "edit": {
+        "documentChanges": [
+          {
+            "edits": [
+              {
+                "newText": "    | King | Queen -> \"Face card!\"\n",
+                "range": {
+                  "end": { "character": 0, "line": 5 },
+                  "start": { "character": 0, "line": 3 }
+                }
+              }
+            ],
+            "textDocument": { "uri": "file:///foo.ml", "version": 0 }
+          }
+        ]
+      },
+      "isPreferred": false,
+      "kind": "combine-cases",
+      "title": "Combine-cases"
+    }
+    |}]
+;;
+
 let position_of_offset src x =
   assert (0 <= x && x < String.length src);
   let cnum = ref 0