perf(lsp): O(doc) semantic token encoding + delta + cancellation

bench/BASELINE.md

@@ -74,3 +74,16 @@ browser layout/paint.
 3. **Frontend full-doc scanners (Fase 4) — the real desktop win.** They
    scale linearly with doc size and dominate the keystroke cost. Early-out
    by sentinel + incrementalizing the fence scanner cut this directly.
+
+## Update — semantic tokens encoding fix + delta
+
+`semanticTokens/full [large]` went from **69.7ms → 1.77ms p95** (40x). The
+cost was never the token computation (`of_blocks` is 0.83ms) — it was the
+LSP delta-position encoding calling `Doc_position.of_offset` (O(offset),
+counts lines from the document start) once per token, i.e. O(n²) over the
+document. Replaced with a single forward cursor over the sorted tokens
+(O(doc)). `semanticTokens/full/delta` (LSP 3.17) and request cancellation
+also landed; with no request now exceeding ~2ms, the pre-process cancel
+check (reader thread + cancelled-id set, no mid-flight interruption) is
+sufficient for the budget. Fase 2 (analysis memo/cache) stays dropped —
+the analysis was never the bottleneck.

bin/httui-lsp/dune

@@ -11,4 +11,5 @@
   caqti.blocking
   caqti-driver-sqlite3
   toml
+  threads.posix
   uri))

bin/httui-lsp/httui_lsp.ml

@@ -208,7 +208,8 @@ let on_initialize (r : Jsonrpc.Request.t) =
               ~legend:
                 (T.SemanticTokensLegend.create ~tokenTypes:!legend_types
                    ~tokenModifiers:!legend_modifiers)
-              ~full:(`Bool true) ()))
+              ~full:(`Full (T.SemanticTokensOptions.create_full ~delta:true ()))
+              ()))
       ()
   in
   let serverInfo =
@@ -281,31 +282,112 @@ let on_completion (r : Jsonrpc.Request.t) =
       in
       respond r.id (`List (List.map T.CompletionItem.yojson_of_t items)))
 
+(* Encode tokens to the LSP delta-position int stream. Tokens arrive
+   sorted by start offset, so a single forward cursor over the document
+   converts every offset to (line, char) in O(doc) total — the previous
+   per-token [Doc_position.of_offset] was O(offset) each, i.e. O(n^2)
+   over the whole document and the dominant cost on large files. *)
+let encode_tokens text tokens =
+  let n = String.length text in
+  let cur = ref 0 and line = ref 0 and line_start = ref 0 in
+  let advance_to off =
+    while !cur < off && !cur < n do
+      if text.[!cur] = '\n' then begin
+        incr line;
+        line_start := !cur + 1
+      end;
+      incr cur
+    done
+  in
+  let prev_line = ref 0 and prev_char = ref 0 in
+  let data =
+    List.concat_map
+      (fun (t : Httui_lang.Semantic_tokens.t) ->
+        advance_to t.t_start;
+        let char =
+          Httui_lang.Doc_position.utf16_units text ~from:!line_start
+            ~until:t.t_start
+        in
+        let length =
+          Httui_lang.Doc_position.utf16_units text ~from:t.t_start
+            ~until:t.t_stop
+        in
+        let dl = !line - !prev_line in
+        let dc = if dl = 0 then char - !prev_char else char in
+        prev_line := !line;
+        prev_char := char;
+        [ dl; dc; length; type_index t.kind; modifier_bits t ])
+      tokens
+  in
+  Array.of_list data
+
+let compute_token_data text =
+  encode_tokens text
+    (Httui_lang.Semantic_tokens.of_blocks (Httui_lang.Fence_scanner.scan text))
+
+(* Last full result per document, for delta requests: uri -> (resultId,
+   data). Monotonic ids keep delta bookkeeping trivial. *)
+let token_results : (string, string * int array) Hashtbl.t = Hashtbl.create 16
+let result_id_counter = ref 0
+
+let next_result_id () =
+  incr result_id_counter;
+  string_of_int !result_id_counter
+
+let store_tokens uri data =
+  let id = next_result_id () in
+  Hashtbl.replace token_results (T.DocumentUri.to_string uri) (id, data);
+  id
+
+(* Minimal prefix/suffix diff of two int streams into a single LSP edit
+   (the encoding rust-analyzer uses). Empty list when identical. *)
+let diff_tokens old_ new_ =
+  let lo = Array.length old_ and ln = Array.length new_ in
+  let p = ref 0 in
+  while !p < lo && !p < ln && old_.(!p) = new_.(!p) do
+    incr p
+  done;
+  let s = ref 0 in
+  while
+    !s < lo - !p && !s < ln - !p && old_.(lo - 1 - !s) = new_.(ln - 1 - !s)
+  do
+    incr s
+  done;
+  let delete_count = lo - !p - !s in
+  let new_len = ln - !p - !s in
+  if delete_count = 0 && new_len = 0 then []
+  else
+    let data = if new_len = 0 then None else Some (Array.sub new_ !p new_len) in
+    [ T.SemanticTokensEdit.create ~deleteCount:delete_count ?data ~start:!p () ]
+
 let on_semantic_tokens (r : Jsonrpc.Request.t) =
   let p = T.SemanticTokensParams.t_of_yojson (params_json r.params) in
   with_doc r.id p.textDocument.uri (fun text ->
-      let blocks = Httui_lang.Fence_scanner.scan text in
-      let tokens = Httui_lang.Semantic_tokens.of_blocks blocks in
-      let data =
-        let prev_line = ref 0 and prev_char = ref 0 in
-        List.concat_map
-          (fun (t : Httui_lang.Semantic_tokens.t) ->
-            let pos = Httui_lang.Doc_position.of_offset text t.t_start in
-            let length =
-              Httui_lang.Doc_position.utf16_units text ~from:t.t_start
-                ~until:t.t_stop
-            in
-            let dl = pos.line - !prev_line in
-            let dc =
-              if dl = 0 then pos.character - !prev_char else pos.character
-            in
-            prev_line := pos.line;
-            prev_char := pos.character;
-            [ dl; dc; length; type_index t.kind; modifier_bits t ])
-          tokens
-      in
-      let result = T.SemanticTokens.create ~data:(Array.of_list data) () in
-      respond r.id (T.SemanticTokens.yojson_of_t result))
+      let data = compute_token_data text in
+      let result_id = store_tokens p.textDocument.uri data in
+      respond r.id
+        (T.SemanticTokens.yojson_of_t
+           (T.SemanticTokens.create ~data ~resultId:result_id ())))
+
+let on_semantic_tokens_delta (r : Jsonrpc.Request.t) =
+  let p = T.SemanticTokensDeltaParams.t_of_yojson (params_json r.params) in
+  with_doc r.id p.textDocument.uri (fun text ->
+      let data = compute_token_data text in
+      let uri_s = T.DocumentUri.to_string p.textDocument.uri in
+      match Hashtbl.find_opt token_results uri_s with
+      | Some (prev_id, old_data) when prev_id = p.previousResultId ->
+          let edits = diff_tokens old_data data in
+          let result_id = store_tokens p.textDocument.uri data in
+          respond r.id
+            (T.SemanticTokensDelta.yojson_of_t
+               (T.SemanticTokensDelta.create ~edits ~resultId:result_id ()))
+      | _ ->
+          (* unknown/stale previousResultId — the spec allows replying
+             with a full result instead of a delta *)
+          let result_id = store_tokens p.textDocument.uri data in
+          respond r.id
+            (T.SemanticTokens.yojson_of_t
+               (T.SemanticTokens.create ~data ~resultId:result_id ())))
 
 let shutdown_received = ref false
 
@@ -315,6 +397,7 @@ let handle_request (r : Jsonrpc.Request.t) =
   | "textDocument/hover" -> on_hover r
   | "textDocument/completion" -> on_completion r
   | "textDocument/semanticTokens/full" -> on_semantic_tokens r
+  | "textDocument/semanticTokens/full/delta" -> on_semantic_tokens_delta r
   | "shutdown" ->
       shutdown_received := true;
       respond r.id `Null
@@ -344,7 +427,71 @@ let handle_notification (n : Jsonrpc.Notification.t) =
       Hashtbl.iter (fun _ (uri, text) -> publish_diagnostics uri text) docs
   | _ -> ()
 
-(* --- main loop ---------------------------------------------------------- *)
+(* --- cancellation + main loop ------------------------------------------- *)
+
+(* A dedicated reader thread parses incoming messages and enqueues them;
+   [$/cancelRequest] ids are recorded as they arrive so the main loop can
+   skip a stale request before doing its work. Processing stays
+   single-threaded (only the main loop touches docs/stores/stdout), so
+   the only shared state is the queue and the cancelled-id set. *)
+let queue : Jsonrpc.Packet.t Queue.t = Queue.create ()
+let queue_mutex = Mutex.create ()
+let queue_cond = Condition.create ()
+let eof = ref false
+let cancelled : (Jsonrpc.Id.t, unit) Hashtbl.t = Hashtbl.create 16
+
+let record_cancel id =
+  Mutex.lock queue_mutex;
+  (* cancels for already-completed requests would otherwise leak; the set
+     is advisory, so dropping it wholesale past a cap is safe *)
+  if Hashtbl.length cancelled > 256 then Hashtbl.clear cancelled;
+  Hashtbl.replace cancelled id ();
+  Mutex.unlock queue_mutex
+
+let take_cancelled id =
+  Mutex.lock queue_mutex;
+  let c = Hashtbl.mem cancelled id in
+  if c then Hashtbl.remove cancelled id;
+  Mutex.unlock queue_mutex;
+  c
+
+let reader_thread () =
+  (try
+     while true do
+       let body = read_message () in
+       match
+         try Some (Jsonrpc.Packet.t_of_yojson (Yojson.Safe.from_string body))
+         with _ -> None
+       with
+       | Some (Jsonrpc.Packet.Notification n) when n.method_ = "$/cancelRequest"
+         -> (
+           match
+             try Some (T.CancelParams.t_of_yojson (params_json n.params))
+             with _ -> None
+           with
+           | Some cp -> record_cancel cp.id
+           | None -> ())
+       | Some pkt ->
+           Mutex.lock queue_mutex;
+           Queue.push pkt queue;
+           Condition.signal queue_cond;
+           Mutex.unlock queue_mutex
+       | None -> ()
+     done
+   with End_of_file -> ());
+  Mutex.lock queue_mutex;
+  eof := true;
+  Condition.signal queue_cond;
+  Mutex.unlock queue_mutex
+
+let next_packet () =
+  Mutex.lock queue_mutex;
+  while Queue.is_empty queue && not !eof do
+    Condition.wait queue_cond queue_mutex
+  done;
+  let r = if Queue.is_empty queue then None else Some (Queue.pop queue) in
+  Mutex.unlock queue_mutex;
+  r
 
 let () =
   (* --db <path>: app database for environment variable NAMES (read-only
@@ -359,19 +506,22 @@ let () =
    parse (Array.to_list Sys.argv));
   set_binary_mode_in stdin true;
   set_binary_mode_out stdout true;
-  try
-    while true do
-      let body = read_message () in
-      (* one malformed message must not kill the session — skip it and
-         keep serving (EOF still ends the loop) *)
-      try
-        let json = Yojson.Safe.from_string body in
-        match Jsonrpc.Packet.t_of_yojson json with
-        | Jsonrpc.Packet.Request r -> handle_request r
-        | Jsonrpc.Packet.Notification n -> handle_notification n
-        | _ -> ()
-      with
-      | End_of_file -> raise End_of_file
-      | _ -> ()
-    done
-  with End_of_file -> ()
+  let _ : Thread.t = Thread.create reader_thread () in
+  let rec loop () =
+    match next_packet () with
+    | None -> () (* stdin closed and queue drained *)
+    | Some pkt ->
+        (* one malformed handler must not kill the session *)
+        (try
+           match pkt with
+           | Jsonrpc.Packet.Request r ->
+               if take_cancelled r.id then
+                 respond_error r.id Jsonrpc.Response.Error.Code.RequestCancelled
+                   "request cancelled"
+               else handle_request r
+           | Jsonrpc.Packet.Notification n -> handle_notification n
+           | _ -> ()
+         with _ -> ());
+        loop ()
+  in
+  loop ()

test/test_lsp.ml

@@ -601,8 +601,102 @@ let () =
     | Some (`String v) -> contains v "last value: `42`"
     | _ -> false);
 
-  send_to c3 (req 9 "shutdown");
+  (* --- semantic tokens: full + delta --- *)
+  (* drain notifications (e.g. publishDiagnostics) until the response for
+     [rid] arrives *)
+  let rec recv_result client rid =
+    let m = recv_from client in
+    if member "id" m = Some (`Int rid) then m else recv_result client rid
+  in
+  let result_id_of m = Option.bind (member "result" m) (member "resultId") in
+  send_to c3
+    (req 6 "textDocument/semanticTokens/full"
+       ~params:(`Assoc [ ("textDocument", vault_doc) ]));
+  let full = recv_result c3 6 in
+  let full_data =
+    match Option.bind (member "result" full) (member "data") with
+    | Some (`List l) -> l
+    | _ -> []
+  in
+  check "semanticTokens/full returns a resultId and data"
+    (result_id_of full <> None && List.length full_data > 0);
+  let rid_full =
+    match result_id_of full with Some (`String s) -> s | _ -> ""
+  in
+
+  (* delta with no document change since the full → empty edit list *)
+  send_to c3
+    (req 7 "textDocument/semanticTokens/full/delta"
+       ~params:
+         (`Assoc
+            [
+              ("textDocument", vault_doc); ("previousResultId", `String rid_full);
+            ]));
+  let delta_same = recv_result c3 7 in
+  check "delta with no change returns empty edits"
+    (match Option.bind (member "result" delta_same) (member "edits") with
+    | Some (`List []) -> true
+    | _ -> false);
+  let rid_same =
+    match result_id_of delta_same with Some (`String s) -> s | _ -> ""
+  in
+
+  (* edit the doc, then delta against the last resultId → a real edit list
+     (the delta path, not the full fallback) *)
+  (* the new Authorization header adds header-name/value + env-ref tokens,
+     so the token stream genuinely differs (a URL-only edit would not —
+     the URL is not a semantic token) *)
+  let edited =
+    "# nota\n\n\
+     ```http alias=req1\n\
+     GET https://api.example.com/users\n\
+     Authorization: Bearer {{TOKEN}}\n\
+     ```\n\n\
+     ```http alias=req2\n\
+     GET https://x.dev/{{req1.response.body.id}}\n\
+     ```\n"
+  in
+  send_to c3
+    (notif "textDocument/didChange"
+       ~params:
+         (`Assoc
+            [
+              ( "textDocument",
+                `Assoc [ ("uri", `String vault_uri); ("version", `Int 3) ] );
+              ("contentChanges", `List [ `Assoc [ ("text", `String edited) ] ]);
+            ]));
   let _ = recv_from c3 in
+  send_to c3
+    (req 8 "textDocument/semanticTokens/full/delta"
+       ~params:
+         (`Assoc
+            [
+              ("textDocument", vault_doc); ("previousResultId", `String rid_same);
+            ]));
+  let delta_edit = recv_result c3 8 in
+  check "delta after an edit returns a non-empty edit list"
+    (match Option.bind (member "result" delta_edit) (member "edits") with
+    | Some (`List (_ :: _)) -> true
+    | _ -> false);
+
+  (* --- cancellation: a cancel observed before the request is honored --- *)
+  send_to c3 (notif "$/cancelRequest" ~params:(`Assoc [ ("id", `Int 77) ]));
+  send_to c3
+    (req 77 "textDocument/semanticTokens/full"
+       ~params:(`Assoc [ ("textDocument", vault_doc) ]));
+  let cancelled = recv_result c3 77 in
+  check "cancelled request answers with an error, no result"
+    (member "result" cancelled = None && member "error" cancelled <> None);
+  (* a normal request afterwards is unaffected (no cancel bleed) *)
+  send_to c3
+    (req 78 "textDocument/semanticTokens/full"
+       ~params:(`Assoc [ ("textDocument", vault_doc) ]));
+  let after_cancel = recv_result c3 78 in
+  check "request after a cancel still succeeds"
+    (member "result" after_cancel <> None);
+
+  send_to c3 (req 9 "shutdown");
+  let _ = recv_result c3 9 in
   send_to c3 (notif "exit");
   (* best effort: on Windows the server may still hold the file *)
   (try Sys.remove db_path with Sys_error _ -> ());