fix(code-actions): offer destruct-line on inline matches

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Author: rgrinberg

CHANGES.md

@@ -11,6 +11,8 @@
   (#1851, @rgrinberg)
 - Advertise semantic-token support only to clients that support the relative
   token format. (#1853, @rgrinberg)
+- Offer the `destruct-line` code action on inline match expressions with
+  incomplete cases. (#1829, fixes #1595, @rgrinberg)
 - Replace a lone polymorphic-variant backtick when applying completions.
   (#1823, fixes #1427, @rgrinberg)
 - Advertise all code-action kinds that the server may return. (#1803, @rgrinberg)

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

@@ -166,21 +166,53 @@ let adjust_reply_location ~(statement : destructable_statement) (loc : Loc.t) :
   { loc with loc_start; loc_end }
 ;;
 
+let point_range ~line ~character =
+  let position = Position.create ~line ~character in
+  Range.create ~start:position ~end_:position
+;;
+
+let statement_of_code code range =
+  match get_statement_kind code range with
+  | None -> None
+  | Some kind ->
+    let query_range = get_query_range code kind range in
+    let reply_range = get_reply_range code kind query_range in
+    Some { code; kind; query_range; reply_range }
+;;
+
+let find_existing_case doc ~line ~match_start =
+  let source = Document.source doc in
+  let (`Offset line_start) = Msource.get_offset source (`Logical (line + 1, 0)) in
+  let match_offset = line_start + match_start in
+  let code = Base.String.drop_prefix (Document.text doc) match_offset in
+  match Destruct_line_search.find_case code ~match_start:0 with
+  | None -> None
+  | Some case_offset ->
+    let case_offset = match_offset + case_offset in
+    let (`Logical (line, character)) = Msource.get_logical source (`Offset case_offset) in
+    let range = point_range ~line:(line - 1) ~character in
+    let code = Destruct_line_search.mask_prefix (get_line doc range) character in
+    statement_of_code code range
+;;
+
 (** Tries to find a statement we know how to handle on the line where the range
-    starts. *)
+    starts. Inline matches are focused by masking their prefix, preserving all
+    character offsets used by the existing line-oriented processing. *)
 let extract_statement (doc : Document.t) (ca_range : Range.t)
   : destructable_statement option
   =
-  if ca_range.start.line <> ca_range.end_.line
-  then None
-  else (
-    let code = get_line doc ca_range in
-    match get_statement_kind code ca_range with
-    | None -> None
-    | Some kind ->
-      let query_range = get_query_range code kind ca_range in
-      let reply_range = get_reply_range code kind query_range in
-      Some { code; kind; query_range; reply_range })
+  let multiline = ca_range.start.line <> ca_range.end_.line in
+  let line_range : Range.t =
+    if multiline then { start = ca_range.start; end_ = ca_range.start } else ca_range
+  in
+  let code = get_line doc line_range in
+  match Destruct_line_search.find_match code ~position:line_range.start.character with
+  | None -> if multiline then None else statement_of_code code line_range
+  | Some match_start ->
+    (match find_existing_case doc ~match_start ~line:line_range.start.line with
+     | Some _ as statement -> statement
+     | None ->
+       statement_of_code (Destruct_line_search.mask_prefix code match_start) line_range)
 ;;
 
 (** Strips " -> _ " off the rhs and " | " off the lhs of a case-line if present. *)

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

@@ -1,11 +1,12 @@
 open Import
 
 (** This code action allows the user to invoke Merlin-destruct to enumerate
-    cases from various lines of a partial match statement. If the line is of any
-    of these forms: [match x] [match x with] [| x -> y] then the pre-processing
-    will extract [x] and invoke Merlin-destruct on it. Some post-processing is
-    applied to Merlin's response to make it more useful for adding subsequent
-    code: extraneous tokens are stripped and cases are split across lines. For
+    cases from various lines of a partial match statement. If a line contains
+    one of these forms: [match x] [match x with] [| x -> y] then the
+    pre-processing will extract [x] and invoke Merlin-destruct on it. Existing
+    cases are reused when the action is requested on [match]. Merlin's response
+    is post-processed to make it more useful for adding subsequent code:
+    extraneous tokens are stripped and cases are split across lines. For
     example, supposing [x] is a [bool], then the line [match x with] expands to
     [match x with
      | false -> _

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

@@ -0,0 +1,71 @@
+open Import
+module Lexer = Ocaml_preprocess.Lexer_raw
+module Parser = Ocaml_preprocess.Parser_raw
+
+type token =
+  { kind : Parser.token
+  ; start : int
+  ; end_ : int
+  }
+
+let lexer code =
+  let lexbuf = Lexing.from_string code in
+  let lexer = Lexer.make (Lexer.keywords []) in
+  let rec finish = function
+    | Lexer.Return token -> Some token
+    | Refill refill -> finish (refill ())
+    | Fail _ -> None
+  in
+  fun () ->
+    match finish (Lexer.token_without_comments lexer lexbuf) with
+    | None | Some Parser.EOF -> None
+    | Some kind ->
+      Some { kind; start = Lexing.lexeme_start lexbuf; end_ = Lexing.lexeme_end lexbuf }
+;;
+
+let find_match code ~position =
+  let next = lexer code in
+  match next () with
+  | None -> None
+  | Some first ->
+    let rec loop token =
+      match token.kind with
+      | Parser.MATCH
+        when token.start = first.start
+             || (token.start <= position && position <= token.end_) -> Some token.start
+      | Parser.MATCH | _ ->
+        (match next () with
+         | None -> None
+         | Some token -> loop token)
+    in
+    loop first
+;;
+
+let find_case code ~match_start =
+  let next = lexer code in
+  let rec after_match () =
+    match next () with
+    | None -> None
+    | Some { kind = Parser.MATCH; start; _ } when start = match_start -> loop 0 0
+    | Some _ -> after_match ()
+  and loop nested_branches braces =
+    match next () with
+    | None -> None
+    | Some { kind = Parser.MATCH | Parser.TRY; _ } -> loop (nested_branches + 1) braces
+    | Some { kind = Parser.LBRACE; _ } -> loop nested_branches (braces + 1)
+    | Some { kind = Parser.RBRACE; _ } -> loop nested_branches (max 0 (braces - 1))
+    | Some { kind = Parser.WITH; _ } when nested_branches > 0 ->
+      loop (nested_branches - 1) braces
+    | Some { kind = Parser.WITH; _ } when braces > 0 -> loop nested_branches braces
+    | Some { kind = Parser.WITH; _ } ->
+      (match next () with
+       | Some { kind = Parser.BAR; start; _ } -> Some start
+       | None | Some _ -> None)
+    | Some _ -> loop nested_branches braces
+  in
+  after_match ()
+;;
+
+let mask_prefix code prefix_len =
+  Stdlib.String.make prefix_len ' ' ^ Base.String.drop_prefix code prefix_len
+;;

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

@@ -0,0 +1,8 @@
+(** Locate a [match] token when it starts the line or contains [position]. *)
+val find_match : string -> position:int -> int option
+
+(** Locate the first case belonging to the [match] at [match_start]. *)
+val find_case : string -> match_start:int -> int option
+
+(** Replace the prefix with spaces without changing offsets. *)
+val mask_prefix : string -> int -> string

ocaml-lsp-server/src/dune

@@ -19,6 +19,7 @@
   merlin-lib.analysis
   merlin-lib.kernel
   merlin-lib.ocaml_parsing
+  merlin-lib.ocaml_preprocess
   merlin-lib.query_commands
   merlin-lib.query_protocol
   merlin-lib.ocaml_merlin_specific

ocaml-lsp-server/src/testing.ml

@@ -1,6 +1,7 @@
 (**WARNING: This is for internal use in testing only *)
 
 module Compl = Compl
+module Destruct_line = Destruct_line_search
 module Document_symbol = Document_symbol
 module Merlin_kernel = Merlin_kernel
 module Prefix_parser = Prefix_parser

ocaml-lsp-server/test/destruct_line_quickcheck_tests.ml

@@ -0,0 +1,173 @@
+open Base
+open Base_quickcheck
+module Destruct_line = Ocaml_lsp_server.Testing.Destruct_line
+
+let bounded value bound = Int.rem (value land Stdlib.max_int) bound
+
+let whitespace ?(allow_empty = false) selector =
+  let length = bounded selector 5 + if allow_empty then 0 else 1 in
+  let char = if selector land 1 = 0 then ' ' else '\t' in
+  Stdlib.String.make length char
+;;
+
+let identifier selector = Stdlib.String.make (bounded selector 8 + 1) 'x'
+let check label condition = if not condition then failwith label
+
+let check_equal label expected actual =
+  if not (Option.equal Int.equal expected actual)
+  then
+    failwith
+      (Printf.sprintf
+         "%s: expected %s"
+         label
+         (Option.value_map expected ~default:"none" ~f:Int.to_string))
+;;
+
+type context =
+  | Line_start
+  | Inline
+[@@deriving quickcheck, sexp_of]
+
+module Match_case = struct
+  type t =
+    { context : context
+    ; indentation : int
+    ; identifier_length : int
+    ; cursor : int
+    ; suffix : int
+    }
+  [@@deriving quickcheck, sexp_of]
+end
+
+let check_match { Match_case.context; indentation; identifier_length; cursor; suffix } =
+  let indentation = whitespace ~allow_empty:true indentation in
+  let prefix =
+    match context with
+    | Line_start -> indentation
+    | Inline -> indentation ^ "let " ^ identifier identifier_length ^ " = "
+  in
+  let match_start = String.length prefix in
+  let source = prefix ^ "match" ^ whitespace suffix ^ "value" in
+  let position =
+    match context with
+    | Line_start -> 0
+    | Inline -> match_start + bounded cursor (String.length "match" + 1)
+  in
+  check_equal
+    "match location"
+    (Some match_start)
+    (Destruct_line.find_match source ~position);
+  let focused = Destruct_line.mask_prefix source match_start in
+  check "focused length" (String.length focused = String.length source);
+  check
+    "focused suffix"
+    (String.equal
+       (Base.String.drop_prefix focused match_start)
+       (Base.String.drop_prefix source match_start));
+  match context with
+  | Line_start -> ()
+  | Inline ->
+    check_equal
+      "position outside inline match"
+      None
+      (Destruct_line.find_match source ~position:0)
+;;
+
+let%test_unit "find_match preserves offsets in line-leading and inline matches" =
+  Base_quickcheck.Test.run_exn (module Match_case) ~f:check_match
+;;
+
+type expression =
+  | Simple
+  | Record_update
+  | Nested_match
+  | Nested_try
+  | String_literal
+  | Comment
+[@@deriving quickcheck, sexp_of]
+
+module Existing_case = struct
+  type t =
+    { indentation : int
+    ; identifier_length : int
+    ; before_with : int
+    ; after_with : int
+    ; expression : expression
+    }
+  [@@deriving quickcheck, sexp_of]
+end
+
+let check_existing_case
+      { Existing_case.indentation
+      ; identifier_length
+      ; before_with
+      ; after_with
+      ; expression
+      }
+  =
+  let prefix =
+    whitespace ~allow_empty:true indentation
+    ^ "let "
+    ^ identifier identifier_length
+    ^ " = "
+  in
+  let expression =
+    match expression with
+    | Simple -> "A"
+    | Record_update -> "{ r with value = A }.value"
+    | Nested_match -> "(match A with | A -> B)"
+    | Nested_try -> "(try A with | _ -> A)"
+    | String_literal -> "f \"with |\""
+    | Comment -> "f (* with | *)"
+  in
+  let before_with = whitespace before_with in
+  let after_with = whitespace ~allow_empty:true after_with in
+  let before_case = prefix ^ "match " ^ expression ^ before_with ^ "with" ^ after_with in
+  let source = before_case ^ "| A -> _" in
+  let match_start = String.length prefix in
+  check_equal
+    "case location"
+    (Some (String.length before_case))
+    (Destruct_line.find_case source ~match_start)
+;;
+
+let%test_unit "find_case handles prefixes, whitespace, and nested syntax" =
+  Base_quickcheck.Test.run_exn (module Existing_case) ~f:check_existing_case
+;;
+
+let%test_unit "keywords embedded in identifiers are ignored" =
+  check_equal
+    "match identifier"
+    None
+    (Destruct_line.find_match "let matcher = 0" ~position:4);
+  check_equal
+    "match identifier with apostrophe"
+    None
+    (Destruct_line.find_match "let match' = 0" ~position:4);
+  check_equal
+    "with identifier"
+    None
+    (Destruct_line.find_case "match value somewith | A -> _" ~match_start:0)
+;;
+
+let%test_unit "find_case crosses comments and line breaks" =
+  let before_case = "match A with\n(* existing case *)\n  " in
+  check_equal
+    "case after comment"
+    (Some (String.length before_case))
+    (Destruct_line.find_case (before_case ^ "| A -> _") ~match_start:0)
+;;
+
+let%test_unit "matches without cases do not consume a later match" =
+  check_equal
+    "later match"
+    None
+    (Destruct_line.find_case "match A with\nlet y = match B with | B -> _" ~match_start:0)
+;;
+
+let%test_unit "record updates without a case are ignored" =
+  check_equal
+    "record update"
+    None
+    (Destruct_line.find_case "match { r with value = A } with" ~match_start:0)
+;;

ocaml-lsp-server/test/dune

@@ -1,5 +1,6 @@
 (library
  (modules
+  destruct_line_quickcheck_tests
   ocaml_lsp_tests
   position_prefix_tests
   range_relations_quickcheck_tests