Completion edge cases (ocaml#1212)

* Tests passing

* Added support for whitespace in completion
The solution here is to change all whitespace to spaces for ease of regex matching(all whitespace is equivelent semantically) and then remove all spaces from the prefix that's passed to merlin.

Co-authored-by: faldor20 <[email protected]>
Co-authored-by: faldor20 <[email protected]>

CHANGES.md

@@ -15,6 +15,8 @@
 
 - Fix the encoding of URI's to match how vscode does it (#1197)
 
+- Fix parsing of completion prefixes (#1181)
+
 ## Features
 
 - Compatibility with Odoc 2.3.0, with support for the introduced syntax: tables,

Makefile

@@ -35,6 +35,11 @@ install: ## Install the packages on the system
 lock: ## Generate the lock files
 	opam lock -y .
 
+.PHONY: bench
+bench: ##
+	dune exec ocaml-lsp-server/bench/ocaml_lsp_bench.exe --profile bench
+
+
 .PHONY: test-ocaml
 test-ocaml: ## Run the unit tests
 	dune build @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest

ocaml-lsp-server/bench/documents.ml

@@ -0,0 +1,98 @@
+let document =
+  "let mem = ListLabels.mem\n\nlet _ = mem ~se" |> Merlin_kernel.Msource.make
+
+let long_document_text =
+  {|let prefix_of_position ~short_path source position =
+  let open Prefix_parser in
+  match Msource.text source with
+  | "" -> ""
+  | text ->
+    let end_of_prefix =
+      let (`Offset index) = Msource.get_offset source position in
+      min (String.length text - 1) (index - 1)
+    in
+    let prefix_text =
+      let pos =
+        (*clamp the length of a line to process at 500 chars, this is just a
+          reasonable limit for regex performance*)
+        max 0 (end_of_prefix - 500)
+      in
+      String.sub text ~pos ~len:(end_of_prefix + 1 - pos)
+      (*because all whitespace is semantically the same we convert it all to
+        spaces for easier regex matching*)
+      |> String.rev_map ~f:(fun x -> if x = '\n' || x = '\t' then ' ' else x)
+    in
+
+    let reconstructed_prefix =
+      try_parse_with_regex prefix_text
+      |> Option.value ~default:""
+      |> String.rev_filter ~f:(fun x -> x <> ' ')
+    in
+
+    if short_path then
+      match String.split_on_char reconstructed_prefix ~sep:'.' |> List.last with
+      | Some s -> s
+      | None -> reconstructed_prefix
+    else reconstructed_prefix
+
+let suffix_of_position source position =
+  match Msource.text source with
+  | "" -> ""
+  | text ->
+    let (`Offset index) = Msource.get_offset source position in
+    let len = String.length text in
+    if index >= len then ""
+    else
+      let from = index in
+      let len =
+        let ident_char = function
+          | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '\'' | '_' -> true
+          | _ -> false
+        in
+        let until =
+          String.findi ~from text ~f:(fun c -> not (ident_char c))
+          |> Option.value ~default:len
+        in
+        until - from
+      in
+      String.sub text ~pos:from ~len
+
+let reconstruct_ident source position =
+  let prefix = prefix_of_position ~short_path:false source position in
+  let suffix = suffix_of_position source position in
+  let ident = prefix ^ suffix in
+  Option.some_if (ident <> "") ident
+
+let range_prefix (lsp_position : Position.t) prefix : Range.t =
+  let start =
+    let len = String.length prefix in
+    let character = lsp_position.character - len in
+    { lsp_position with character }
+  in
+  { Range.start; end_ = lsp_position }
+
+let sortText_of_index idx = Printf.sprintf "%04d" idx
+
+module Complete_by_prefix = struct
+  let completionItem_of_completion_entry idx
+      (entry : Query_protocol.Compl.entry) ~compl_params ~range ~deprecated =
+    let kind = completion_kind entry.kind in
+    let textEdit = `TextEdit { TextEdit.range; newText = entry.name } in
+    CompletionItem.create
+      ~label:entry.name
+      ?kind
+      ~detail:entry.desc
+      ?deprecated:(Option.some_if deprecated entry.deprecated)
+        (* Without this field the client is not forced to respect the order
+           provided by merlin. *)
+      ~sortText:(sortText_of_index idx)
+      ?data:compl_params
+      ~textEdit
+      ()
+
+  let dispatch_cmd ~prefix position pipeline =
+    let complete =
+      Query_protocol.Complete_prefix (prefix, position, [], false, true)
+    in
+    Query_commands.dispatch pipeline comp
+    |}

ocaml-lsp-server/bench/dune

@@ -0,0 +1,13 @@
+(executables
+ (names ocaml_lsp_bench)
+ (enabled_if
+  (= %{profile} bench))
+ (libraries
+  ocaml_lsp_server
+  core_unix.command_unix
+  merlin-lib.kernel
+  base
+  core
+  core_bench)
+ (preprocess
+  (pps ppx_bench)))

ocaml-lsp-server/bench/ocaml_lsp_bench.ml

@@ -0,0 +1,27 @@
+open Ocaml_lsp_server
+open Core
+open Core_bench
+
+let () =
+  let open Documents in
+  let long_document = long_document_text |> Merlin_kernel.Msource.make in
+  let position = `Logical (3, 15) in
+  let long_position = `Logical (92, 41) in
+  Command_unix.run
+    (Bench.make_command
+       [ Bench.Test.create ~name:"get_prefix" (fun _ ->
+             Testing.Compl.prefix_of_position
+               ~short_path:false
+               document
+               position
+             |> ignore)
+       ; Bench.Test.create ~name:"get_prefix_long" (fun _ ->
+             Testing.Compl.prefix_of_position
+               ~short_path:false
+               long_document
+               long_position
+             |> ignore)
+       ; Bench.Test.create ~name:"get_offset_long" (fun _ ->
+             Merlin_kernel.Msource.get_offset long_document long_position
+             |> ignore)
+       ])

ocaml-lsp-server/src/compl.ml

@@ -26,77 +26,34 @@ let completion_kind kind : CompletionItemKind.t option =
   | `Constructor -> Some Constructor
   | `Type -> Some TypeParameter
 
-(** @see <https://ocaml.org/manual/lex.html> reference *)
 let prefix_of_position ~short_path source position =
   match Msource.text source with
   | "" -> ""
   | text ->
-    let from =
+    let end_of_prefix =
       let (`Offset index) = Msource.get_offset source position in
       min (String.length text - 1) (index - 1)
     in
     let pos =
-      let should_terminate = ref false in
-      let has_seen_dot = ref false in
-      let is_prefix_char c =
-        if !should_terminate then false
-        else
-          match c with
-          | 'a' .. 'z'
-          | 'A' .. 'Z'
-          | '0' .. '9'
-          | '\''
-          | '_'
-          (* Infix function characters *)
-          | '$'
-          | '&'
-          | '*'
-          | '+'
-          | '-'
-          | '/'
-          | '='
-          | '>'
-          | '@'
-          | '^'
-          | '!'
-          | '?'
-          | '%'
-          | '<'
-          | ':'
-          | '~'
-          | '#' -> true
-          | '`' ->
-            if !has_seen_dot then false
-            else (
-              should_terminate := true;
-              true)
-          | '.' ->
-            has_seen_dot := true;
-            not short_path
-          | _ -> false
-      in
-      String.rfindi text ~from ~f:(fun c -> not (is_prefix_char c))
+      (*clamp the length of a line to process at 500 chars, this is just a
+        reasonable limit for regex performance*)
+      max 0 (end_of_prefix - 500)
     in
-    let pos =
-      match pos with
-      | None -> 0
-      | Some pos -> pos + 1
+
+    let reconstructed_prefix =
+      Prefix_parser.parse ~pos ~len:(end_of_prefix + 1 - pos) text
+      |> Option.value ~default:""
+      (* We remove the whitespace because merlin expects no whitespace and it's
+         semantically meaningless *)
+      |> String.filter (fun x -> not (x = ' ' || x = '\n' || x = '\t'))
     in
-    let len = from - pos + 1 in
-    let reconstructed_prefix = String.sub text ~pos ~len in
-    (* if we reconstructed [~f:ignore] or [?f:ignore], we should take only
-       [ignore], so: *)
-    if
-      String.is_prefix reconstructed_prefix ~prefix:"~"
-      || String.is_prefix reconstructed_prefix ~prefix:"?"
-    then
-      match String.lsplit2 reconstructed_prefix ~on:':' with
-      | Some (_, s) -> s
+
+    if short_path then
+      match String.split_on_char reconstructed_prefix ~sep:'.' |> List.last with
+      | Some s -> s
       | None -> reconstructed_prefix
     else reconstructed_prefix
 
-(** [suffix_of_position source position] computes the suffix of the identifier
-    after [position]. *)
 let suffix_of_position source position =
   match Msource.text source with
   | "" -> ""

ocaml-lsp-server/src/compl.mli

@@ -27,7 +27,10 @@ val resolve :
   -> CompletionItem.t Fiber.t
 
 (** [prefix_of_position ~short_path source position] computes prefix before
-    given [position].
+    given [position]. A prefix is essentially a piece of code that refers to one
+    thing eg a single infix operator "|>", a single reference to a function or
+    variable: "List.map" a keyword "let" etc If there is semantically irrelivent
+    whitespace it is removed eg "List. map"->"List.map"
 
     @param short_path
       determines whether we want full prefix or cut at ["."], e.g.

ocaml-lsp-server/src/import.ml

@@ -34,6 +34,13 @@ include struct
   module String = struct
     include String
 
+    (**Filters a string keeping any chars for which f returns true and
+       discarding those for which it returns false*)
+    let filter f s =
+      let buf = Buffer.create (String.length s) in
+      iter ~f:(fun c -> if f c then Buffer.add_char buf c) s;
+      Buffer.contents buf
+
     let findi =
       let rec loop s len ~f i =
         if i >= len then None

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -3,6 +3,7 @@ module Version = Version
 module Diagnostics = Diagnostics
 module Doc_to_md = Doc_to_md
 module Diff = Diff
+module Testing = Testing
 open Fiber.O
 
 let make_error = Jsonrpc.Response.Error.make

ocaml-lsp-server/src/ocaml_lsp_server.mli

@@ -3,3 +3,4 @@ val run : Lsp.Cli.Channel.t -> read_dot_merlin:bool -> unit -> unit
 module Diagnostics = Diagnostics
 module Version = Version
 module Doc_to_md = Doc_to_md
+module Testing = Testing

ocaml-lsp-server/src/prefix_parser.ml

@@ -0,0 +1,50 @@
+open Import
+
+include struct
+  open Re
+
+  (* Regex based parser *)
+  let white_space = set "\n\t "
+
+  let name_char =
+    Re.alt [ rg 'a' 'z'; rg 'A' 'Z'; rg '0' '9'; char '_'; char '\'' ]
+
+  let name_with_dot =
+    Re.seq [ name_char; white_space |> rep; char '.'; white_space |> rep ]
+
+  let core_operator_str = {|$&*+-/=>@^||}
+
+  let operator = core_operator_str ^ {|~!?%<:.|}
+
+  let infix = set (operator ^ "#")
+
+  let name_or_label =
+    compile
+      (seq
+         [ alt [ set "~?``"; str "let%"; str "and%" ] |> opt
+         ; alt [ name_char; name_with_dot ] |> rep1
+         ; stop
+         ])
+
+  (** matches let%lwt and let* style expressions. See
+      here:https://v2.ocaml.org/manual/bindingops.html *)
+  let monadic_bind =
+    compile
+      (seq
+         [ alt [ str "let"; str "and" ]
+         ; alt [ infix |> rep1; seq [ name_char |> rep1; char '%' ] ]
+         ; stop
+         ])
+
+  let infix_operator = compile (seq [ infix |> rep1; stop ])
+end
+
+let parse ~pos ~len text =
+  (*Attempt to match each of our possible prefix types, the order is important
+    because there is some overlap between the regexs*)
+  let matched =
+    List.find_map
+      [ name_or_label; monadic_bind; infix_operator ]
+      ~f:(fun regex -> Re.exec_opt ~pos ~len regex text)
+  in
+  matched |> Option.map ~f:(fun x -> Re.Group.get x 0)

ocaml-lsp-server/src/prefix_parser.mli

@@ -0,0 +1,4 @@
+(** Tries the parse the incoming string for a prefix. The string should be the
+    source code ending at the prefix position. pos and len set the range for the
+    regex to operate on *)
+val parse : pos:int -> len:int -> string -> string option

ocaml-lsp-server/src/testing.ml

@@ -0,0 +1,5 @@
+(**WARNING: This is for internal use in testing only *)
+
+module Compl = Compl
+module Merlin_kernel = Merlin_kernel
+module Prefix_parser = Prefix_parser

ocaml-lsp-server/test/dune

@@ -1,14 +1,15 @@
 (dirs :standard \ e2e)
 
 (library
- (modules ocaml_lsp_tests)
+ (modules ocaml_lsp_tests position_prefix_tests)
  (name ocaml_lsp_tests)
  (enabled_if
   (>= %{ocaml_version} 4.08))
  (inline_tests)
  (libraries
   stdune
   ocaml_lsp_server
+  merlin-lib.kernel
   lsp
   yojson
   ;; This is because of the (implicit_transitive_deps false)