Fix edge cases that prevent completion

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 release
+
+
 .PHONY: test-ocaml
 test-ocaml: ## Run the unit tests
 	dune build @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest

dune-project

@@ -59,6 +59,7 @@ possible and does not make any assumptions about IO.
   (odoc-parser (and (>= 2.0.0) (< 2.3.0)))
   (ppx_expect (and (>= v0.15.0) :with-test))
   (ocamlformat (and :with-test (= 0.24.1)))
+  (ppx_bench (and :with-test (>= 0.16.0)))
   (ocamlc-loc (>= 3.7.0))
   (uutf (>= 1.0.2))
   (pp (>= 1.1.2))

flake.nix

@@ -158,6 +158,9 @@
                 ocamlPackages.utop
                 ocamlPackages.cinaps
                 ocamlPackages.ppx_yojson_conv
+                #benchmarking
+                ocamlPackages.ppx_bench
+                ocamlPackages.core_bench
               ]);
             inputsFrom = [ fast.ocaml-lsp fast.jsonrpc fast.lsp ];
           };

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,11 @@
+(executables
+ (names ocaml_lsp_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,35 @@ 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 =
+  let open Prefix_parser in
   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 =
+      try_parse_with_regex ~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,48 @@
+open Re
+
+(*Regex based parser*)
+let whiteSpace = 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; whiteSpace |> rep; char '.'; whiteSpace |> 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 ])
+
+open Import
+
+let try_parse_with_regex ?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 -> Group.get x 0)

ocaml-lsp-server/src/prefix_parser.mli

@@ -0,0 +1,4 @@
+(**Try's 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 try_parse_with_regex : ?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)