refactor(lsp): batch updates with a zipper (ocaml#1004)

CHANGES.md

@@ -1,3 +1,9 @@
+# Unreleased
+
+## Fixes
+
+- Fix a document syncing issue when utf-16 is the position encoding (#1004)
+
 # 1.15.1
 
 ## Fixes
@@ -7,8 +13,6 @@
   [#941](https://github.com/ocaml/ocaml-lsp/issues/941),
   [#1003](https://github.com/ocaml/ocaml-lsp/issues/1003))
 
-# 1.15.0
-
 ## Features
 
 - Enable [semantic highlighting](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocument_semanticTokens)

lsp/src/import.ml

@@ -1,6 +1,8 @@
 module List = Stdlib.ListLabels
 module Option = Stdlib.Option
 module Array = Stdlib.ArrayLabels
+module Bytes = Stdlib.BytesLabels
+module Map = Stdlib.MoreLabels.Map
 
 module Result = struct
   include Stdlib.Result

lsp/src/lsp.ml

@@ -15,4 +15,6 @@ module Diff = Diff
 
 module Private = struct
   module Array_view = Array_view
+  module Substring = Substring
+  module String_zipper = String_zipper
 end

lsp/src/position.ml

@@ -0,0 +1,5 @@
+include Types.Position
+
+let zero = create ~line:0 ~character:0
+
+let is_zero (t : t) = t.line = zero.line && t.character = zero.character

lsp/src/string_zipper.ml

@@ -0,0 +1,257 @@
+open! Import
+module Range = Types.Range
+
+module T = struct
+  type t =
+    { left : Substring.t list
+    ; rel_pos : int  (** the cursor's position *)
+    ; current : Substring.t
+          (** [current] needed to prevent fragmentation of the substring. E.g.
+              so that moving inside the substring doesn't create unnecessary
+              splits *)
+    ; line : int
+          (** the number of '\n' characters traversed past the current position *)
+    ; right : Substring.t list
+    }
+end
+
+include T
+
+let of_string s =
+  { left = []
+  ; rel_pos = 0
+  ; current = Substring.of_string s
+  ; right = []
+  ; line = 0
+  }
+
+let length =
+  let f acc sub = acc + Substring.length sub in
+  fun { current; left; right; rel_pos = _; line = _ } ->
+    let init = Substring.length current in
+    let init = List.fold_left ~init ~f left in
+    List.fold_left ~init ~f right
+
+let to_string t =
+  let dst = Bytes.make (length t) '\000' in
+  let dst_pos = ref 0 in
+  let f sub =
+    Substring.blit sub ~dst ~dst_pos:!dst_pos;
+    dst_pos := !dst_pos + Substring.length sub
+  in
+  List.iter (List.rev t.left) ~f;
+  f t.current;
+  List.iter t.right ~f;
+  Bytes.unsafe_to_string dst
+
+let empty = of_string ""
+
+let to_string_debug t =
+  let left, right = Substring.split_at t.current t.rel_pos in
+  List.rev_append t.left (left :: Substring.of_string "|" :: right :: t.right)
+  |> List.map ~f:Substring.to_string
+  |> String.concat ~sep:""
+
+let cons sub list = if Substring.length sub = 0 then list else sub :: list
+
+let is_end t =
+  let res = Substring.length t.current = t.rel_pos in
+  (if res then
+   match t.right with
+   | [] -> ()
+   | _ :: _ ->
+     invalid_arg
+       (sprintf "invalid state: current = %S" (Substring.to_string t.current)));
+  res
+
+let is_begin t =
+  match t.left with
+  | [] -> t.rel_pos = 0
+  | _ :: _ -> false
+
+let insert t (x : string) =
+  if String.length x = 0 then t
+  else
+    let current = Substring.of_string x in
+    let rel_pos = 0 in
+    if t.rel_pos = 0 then
+      { t with current; rel_pos; right = cons t.current t.right }
+    else if t.rel_pos = Substring.length t.current then
+      { t with current; rel_pos; left = cons t.current t.left }
+    else
+      let l, r = Substring.split_at t.current t.rel_pos in
+      { t with current; rel_pos; left = l :: t.left; right = r :: t.right }
+
+let advance_char t =
+  if is_end t then t
+  else
+    let line =
+      match Substring.get_exn t.current t.rel_pos with
+      | '\n' -> t.line + 1
+      | _ -> t.line
+    in
+    let rel_pos = t.rel_pos + 1 in
+    if rel_pos < Substring.length t.current then { t with rel_pos; line }
+    else
+      match t.right with
+      | [] -> { t with rel_pos; line }
+      | current :: right ->
+        { left = t.current :: t.left; current; line; right; rel_pos = 0 }
+
+let rec find_next_nl t =
+  if is_end t then t
+  else
+    match Substring.index_from t.current ~pos:t.rel_pos '\n' with
+    | Some rel_pos -> { t with rel_pos }
+    | None -> (
+      match t.right with
+      | [] -> { t with rel_pos = Substring.length t.current }
+      | current :: right ->
+        { t with left = t.current :: t.left; current; right; rel_pos = 0 }
+        |> find_next_nl)
+
+let rec goto_line_forward t n =
+  if n = 0 then t
+  else if is_end t then t
+  else
+    let t = find_next_nl t in
+    let t = advance_char t in
+    goto_line_forward t (n - 1)
+
+(* put the cursor left of the previous newline *)
+let rec prev_newline t =
+  if is_begin t then t
+  else
+    match Substring.rindex_from t.current ~pos:t.rel_pos '\n' with
+    | Some rel_pos -> { t with rel_pos; line = t.line - 1 }
+    | None -> (
+      match t.left with
+      | [] -> { t with rel_pos = 0 }
+      | current :: left ->
+        prev_newline
+          { t with
+            current
+          ; left
+          ; rel_pos = Substring.length current
+          ; right = t.current :: t.right
+          })
+
+let beginning_of_line t =
+  let t = prev_newline t in
+  if is_begin t then t else advance_char t
+
+let rec goto_line_backward t = function
+  | 0 -> beginning_of_line t
+  | n -> goto_line_backward (prev_newline t) (n - 1)
+
+let goto_line t n =
+  if t.line = n then beginning_of_line t
+  else if t.line > n then goto_line_backward t (t.line - n)
+  else goto_line_forward t (n - t.line)
+
+let newline = Uchar.of_char '\n'
+
+let nln = `ASCII newline
+
+module Advance (Char : sig
+  val units_of_char : Uchar.t -> int
+end) : sig
+  val advance : t -> code_units:int -> t
+end = struct
+  let feed_current_chunk dec t = Substring.Uutf.src t.current ~pos:t.rel_pos dec
+
+  let finish_chunk (t : t) consumed =
+    let rel_pos = t.rel_pos + consumed in
+    if rel_pos < Substring.length t.current then { t with rel_pos }
+    else (
+      assert (rel_pos = Substring.length t.current);
+      match t.right with
+      | [] -> { t with rel_pos }
+      | current :: right ->
+        { t with current; left = t.current :: t.left; right; rel_pos = 0 })
+
+  let rec loop dec (t : t) byte_count_ex_this_chunk (remaining : int) : t =
+    if remaining = 0 then
+      finish_chunk t (Uutf.decoder_byte_count dec - byte_count_ex_this_chunk)
+    else
+      match Uutf.decode dec with
+      | `Malformed _ -> assert false
+      | `End | `Await -> next_chunk dec t remaining
+      | `Uchar u ->
+        if Uchar.equal u newline then
+          finish_chunk
+            t
+            (Uutf.decoder_byte_count dec - byte_count_ex_this_chunk - 1)
+        else
+          let remaining = remaining - Char.units_of_char u in
+          loop dec t byte_count_ex_this_chunk remaining
+
+  and next_chunk dec (t : t) remaining =
+    match t.right with
+    | [] -> { t with rel_pos = Substring.length t.current }
+    | current :: right ->
+      let t =
+        { t with left = t.current :: t.left; current; right; rel_pos = 0 }
+      in
+      feed_current_chunk dec t;
+      loop dec t (Uutf.decoder_byte_count dec) remaining
+
+  let advance t ~code_units =
+    if code_units = 0 then t
+    else
+      let dec = Uutf.decoder ~nln ~encoding:`UTF_8 `Manual in
+      feed_current_chunk dec t;
+      loop dec t 0 code_units
+end
+
+let advance_utf16 =
+  let module Char = struct
+    let units_of_char u = Uchar.utf_16_byte_length u / 2
+  end in
+  let module F = Advance (Char) in
+  F.advance
+
+let advance_utf8 =
+  let module Char = struct
+    let units_of_char = Uchar.utf_8_byte_length
+  end in
+  let module F = Advance (Char) in
+  F.advance
+
+let drop_until from until =
+  if is_end from then from
+  else
+    let right = cons (Substring.drop until.current until.rel_pos) until.right in
+    let left = cons (Substring.take from.current from.rel_pos) from.left in
+    match right with
+    | current :: right -> { from with left; right; current; rel_pos = 0 }
+    | [] -> (
+      match left with
+      | [] -> empty
+      | current :: left ->
+        { from with left; right; current; rel_pos = Substring.length current })
+
+let apply_change t (range : Range.t) encoding ~replacement =
+  let advance =
+    match encoding with
+    | `UTF8 -> advance_utf8
+    | `UTF16 -> advance_utf16
+  in
+  let t = goto_line t range.start.line in
+  let t = advance t ~code_units:range.start.character in
+  let t' =
+    let delta_line = range.end_.line - range.start.line in
+    let delta_character =
+      if delta_line = 0 then range.end_.character - range.start.character
+      else range.end_.character
+    in
+    let t = if delta_line = 0 then t else goto_line t range.end_.line in
+    advance t ~code_units:delta_character
+  in
+  insert (drop_until t t') replacement
+
+module Private = struct
+  include T
+
+  let reflect x = x
+end

lsp/src/string_zipper.mli

@@ -0,0 +1,31 @@
+type t
+
+val of_string : string -> t
+
+val to_string : t -> string
+
+val to_string_debug : t -> string
+
+(* [insert t s] right of the current position *)
+val insert : t -> string -> t
+
+val goto_line : t -> int -> t
+
+val drop_until : t -> t -> t
+
+val apply_change :
+  t -> Types.Range.t -> [ `UTF16 | `UTF8 ] -> replacement:string -> t
+
+module Private : sig
+  type zipper := t
+
+  type nonrec t =
+    { left : Substring.t list
+    ; rel_pos : int
+    ; current : Substring.t
+    ; line : int
+    ; right : Substring.t list
+    }
+
+  val reflect : zipper -> t
+end