Tests passing

ocaml-lsp-server/bench/dune

@@ -0,0 +1,16 @@
+
+(executables
+ (names ocaml_lsp_bench)
+
+  (libraries
+  ocaml_lsp_server
+ core_unix.command_unix
+  merlin-lib.kernel
+
+  base
+  core
+  core_bench
+  )
+
+ (preprocess(pps ppx_jane ppx_bench))
+  )

ocaml-lsp-server/bench/ocaml_lsp_bench.ml

@@ -0,0 +1,22 @@
+open Core
+open Core_bench
+open Ocaml_lsp_server.Testing
+
+let () =
+  let document =
+    "let mem = ListLabels.mem\n\nlet _ = mem ~se" |> Merlin_kernel.Msource.make
+  in
+
+  let position = `Logical (3, 15) in
+  Command_unix.run
+    (Bench.make_command
+       [ Bench.Test.create ~name:"non-regex" (fun _ ->
+             Compl.prefix_of_position ~short_path:false document position
+             |> ignore)
+       ; Bench.Test.create ~name:"regex" (fun _ ->
+             Compl.prefix_of_position_regex ~short_path:false document position
+             |> ignore)
+       ; Bench.Test.create ~name:"old" (fun _ ->
+             Compl.prefix_of_position_old ~short_path:false document position
+             |> ignore)
+       ])

ocaml-lsp-server/bench/run_bench.ml

@@ -0,0 +1,23 @@
+open Core
+open Core_bench
+open Ocaml_lsp_server.Testing
+
+let () =
+  let document =
+    "let mem = ListLabels.mem\n\nlet _ = mem ~se" |> Merlin_kernel.Msource.make
+  in
+
+  let position = `Logical (3, 15) in
+  Command.summary
+    (Bench.make_command
+       [ Bench.Test.create ~name:"non-regex" (fun _ ->
+             Compl.prefix_of_position ~short_path:false document position
+             |> ignore)
+       ; Bench.Test.create ~name:"regex" (fun _ ->
+             Compl.prefix_of_position_regex ~short_path:false document position
+             |> ignore)
+       ; Bench.Test.create ~name:"old" (fun _ ->
+             Compl.prefix_of_position_old ~short_path:false document position
+             |> ignore)
+       ])
+  |> ignore

ocaml-lsp-server/src/compl.ml

@@ -26,8 +26,16 @@ 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 =
+(* I should just rewrite all of this so that it uses a nice for loop. This
+   current soluction is a nice try but overall crap we need to be able to look
+   ahead and behind
+
+   Split it into name and infix name is obvious infix can be either a dot, a
+   label or an I could possibly do a regex based parser.
+
+   Name regex: ((\w)|\w.)*$ *)
+
+let prefix_of_position_old ~short_path source position =
   match Msource.text source with
   | "" -> ""
   | text ->
@@ -95,6 +103,80 @@ let prefix_of_position ~short_path source position =
       | None -> reconstructed_prefix
     else reconstructed_prefix
 
+let prefix_of_position_parser ~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
+    (*TODO this is a mess and could be a lot faster*)
+    let prefix_text =
+      String.sub text ~pos:0 ~len:(end_of_prefix + 1)
+      |> String.to_seq |> List.of_seq |> List.rev
+    in
+
+    (*Printf.printf "trying to parse text `%s`\n"
+      (prefix_text|>String.of_list);*)
+    let prefix_length =
+      match prefix_text with
+      | c :: next_char :: _ when c |> is_name_char ~next_char ->
+        (*Printf.printf "trying to parse as name or label";*)
+        prefix_text |> try_parse [ name_prefix ]
+      | x ->
+        (*Printf.printf "trying to parse as infix";*)
+        x |> try_parse [ infix_prefix ]
+    in
+
+    let len =
+      match prefix_length with
+      | None -> 0
+      | Some len -> len
+    in
+    let pos = end_of_prefix - len + 1 in
+    let reconstructed_prefix = String.sub text ~pos ~len 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 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 =
+      (*We do prevent completion from working across multiple lines here. But
+        this is probably an okay aproximation. We could add the the regex or
+        parser the fact that whitespace doesn't really matter in certain cases
+        like "List. map"*)
+      let pos =
+        text
+        |> String.rfindi ~from:end_of_prefix ~f:(( = ) '\n')
+        |> Option.value ~default:0
+      in
+      String.sub text ~pos ~len:(end_of_prefix + 1 - pos)
+    in
+
+    (*Printf.printf "trying to parse text `%s`\n"
+      (prefix_text|>String.of_list);*)
+    let reconstructed_prefix =
+      try_parse_regex prefix_text |> Option.value ~default:""
+    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
+
 (** [suffix_of_position source position] computes the suffix of the identifier
     after [position]. *)
 let suffix_of_position source position =
@@ -260,8 +342,12 @@ module Complete_with_construct = struct
       List.mapi constructed_exprs ~f:completionItem_of_constructed_expr
 end
 
+let logCompletion log =
+  Log.log ~section:"resolveCompletion" (fun () -> Log.msg log [])
+
 let complete (state : State.t)
     ({ textDocument = { uri }; position = pos; _ } : CompletionParams.t) =
+  logCompletion "ho1";
   Fiber.of_thunk (fun () ->
       let doc = Document_store.get state.store uri in
       match Document.kind doc with
@@ -296,6 +382,12 @@ let complete (state : State.t)
               let* item = completion_item_capability in
               item.deprecatedSupport)
           in
+          logCompletion
+            (Printf.sprintf
+               "prefix: %s; position %i:%i"
+               prefix
+               pos.line
+               pos.character);
           if not (Typed_hole.can_be_hole prefix) then
             Complete_by_prefix.complete merlin prefix pos ~resolve ~deprecated
           else
@@ -365,10 +457,12 @@ let format_doc ~markdown doc =
 
 let resolve doc (compl : CompletionItem.t) (resolve : Resolve.t) query_doc
     ~markdown =
+  logCompletion "Starting  completion";
   Fiber.of_thunk (fun () ->
       (* Due to merlin's API, we create a version of the given document with the
          applied completion item and pass it to merlin to get the docs for the
          [compl.label] *)
+      logCompletion "Starting  completion";
       let position : Position.t = resolve.position in
       let logical_position = Position.logical position in
       let doc =
@@ -380,6 +474,7 @@ let resolve doc (compl : CompletionItem.t) (resolve : Resolve.t) query_doc
                 (Document.Merlin.source doc)
                 logical_position
             in
+            logCompletion @@ "completion prefix is:" ^ prefix;
             { position with
               character = position.character - String.length prefix
             }
@@ -392,7 +487,9 @@ let resolve doc (compl : CompletionItem.t) (resolve : Resolve.t) query_doc
               character = position.character + String.length suffix
             }
           in
+
           let range = Range.create ~start ~end_ in
+
           TextDocumentContentChangeEvent.create ~range ~text:compl.label ()
         in
         Document.update_text (Document.Merlin.to_doc doc) [ complete ]

ocaml-lsp-server/src/compl.mli

@@ -34,6 +34,10 @@ val resolve :
       [List.m<cursor>] returns ["m"] when [short_path] is set vs ["List.m"] when
       not.
     @return prefix of [position] in [source] and its length *)
+val prefix_of_position_parser :
+  short_path:bool -> Msource.t -> [< Msource.position ] -> string
+val prefix_of_position_old :
+  short_path:bool -> Msource.t -> [< Msource.position ] -> string
 val prefix_of_position :
   short_path:bool -> Msource.t -> [< Msource.position ] -> string
 

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,5 @@ 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,115 @@
+type parse_state =
+  | Continue
+  | End
+  | IncludeAndEnd
+  | Fail
+
+let next continue = if continue then Continue else End
+
+let is_name_body_char char =
+  match char with
+  | '0' .. '9' | '\'' | '_' | 'a' .. 'z' | 'A' .. 'Z' -> true
+  | _ -> false
+
+let parse_name_char ~next_char currentChar =
+  match currentChar with
+  | '.' -> next_char |> is_name_body_char |> next
+  | '`' -> IncludeAndEnd
+  | '~' | '?' ->
+    if next_char |> is_name_body_char || next_char = ' ' then IncludeAndEnd
+    else End
+  | c -> c |> is_name_body_char |> next
+
+let is_name_char ~next_char currentChar =
+  match parse_name_char ~next_char currentChar with
+  | IncludeAndEnd | Continue -> true
+  | Fail | End -> false
+
+let is_infix_char' char =
+  match char with
+  | '~'
+  | '?'
+  | ':'
+  | '!'
+  | '$'
+  | '&'
+  | '*'
+  | '+'
+  | '-'
+  | '/'
+  | '='
+  | '>'
+  | '@'
+  | '^'
+  | '|'
+  | '%'
+  | '<'
+  | '.'
+  | '#' -> true
+  | _ -> false
+
+let parse_infix_char ~next_char:_ char = is_infix_char' char |> next
+
+let parse_char is_correct_char text =
+  let rec loop text length =
+    match text with
+    | char :: (next_char :: _ as tail) -> (
+      match is_correct_char ~next_char char with
+      | Continue -> loop tail (length + 1)
+      | IncludeAndEnd -> Some (length + 1)
+      | End -> Some length
+      | Fail -> None)
+    (*This is ugly but i'm not sure how else to deal with reaching the start of
+      the string*)
+    | [ char ] -> (
+      match is_correct_char ~next_char:' ' char with
+      | Continue -> Some (length + 1)
+      | IncludeAndEnd -> Some (length + 1)
+      | End -> Some length
+      | Fail -> None)
+    | _ -> Some length
+  in
+  let len = loop text 0 in
+  Option.bind len (fun x -> if x = 0 then None else Some x)
+
+let infix_prefix text =
+  if text |> List.hd |> is_infix_char' && List.nth text 1 |> is_infix_char' then
+    None
+  else parse_char parse_infix_char text
+
+let name_prefix = parse_char parse_name_char
+
+let rec try_parse parsers str =
+  match parsers with
+  | head :: tail -> (
+    match head str with
+    | Some l -> Some l
+    | None -> str |> try_parse tail)
+  | [] -> None
+open Re
+
+(*Regex based parser*)
+
+let name_or_label_regex =
+   Re.compile @@ Re.Posix.re {|([~?`])?([a-zA-Z0-9_']|[a-zA-Z0-9_']\.)+$|}
+
+let infixRegex =Re.compile @@ Re.Posix.re {|[~?:!$&*+\-\/=><@^|%<.#]+$|}
+
+open Import
+
+module Option = struct
+  include Option
+
+  let none_bind func option =
+    match option with
+    | None -> func ()
+    | Some x -> Some x
+end
+
+let try_parse_regex text =
+
+  let matched =
+    Re.exec_opt name_or_label_regex text
+    |> Option.none_bind (fun () -> Re.exec_opt infixRegex text)
+  in
+  matched |>Option.map ~f:(fun x->Group.get x 0)

ocaml-lsp-server/src/testing.ml

@@ -0,0 +1,5 @@
+module Compl=Compl
+module Document =Document
+module Import =Import
+module Merlin_kernel =Merlin_kernel
+module Position =Position

ocaml-lsp-server/src/testing.mli

@@ -0,0 +1,5 @@
+module Compl=Compl
+module Document =Document
+module Import =Import
+module Merlin_kernel =Merlin_kernel
+module Position =Position

ocaml-lsp-server/test/dune

@@ -1,14 +1,17 @@
 (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)