Semantic tokens with per-client legend downgrade

bin/httui-lsp/httui_lsp.ml

@@ -99,7 +99,73 @@ let doc_updated uri text =
 let params_json (params : Jsonrpc.Structured.t option) =
   match params with Some p -> Jsonrpc.Structured.yojson_of_t p | None -> `Null
 
+(* --- semantic tokens legend (per-client, server-side downgrade) --------- *)
+
+(* Token types are unique per range and clients silently ignore types
+   outside their announced capabilities, so the legend is computed at
+   initialize: an httui.* kind is registered only when the client
+   announced it; otherwise its LSP-standard fallback takes the slot. *)
+
+let legend_types = ref [ "variable"; "property" ]
+let legend_modifiers = ref ([] : string list)
+
+let compute_legend ~announced_types ~announced_modifiers =
+  let pick preferred fallback =
+    if List.mem preferred announced_types then preferred else fallback
+  in
+  let names =
+    [
+      pick "httui.alias" "variable";
+      pick "httui.env_var" "variable";
+      pick "httui.ref_path" "property";
+    ]
+  in
+  legend_types := List.sort_uniq compare names;
+  legend_modifiers :=
+    List.filter
+      (fun m -> List.mem m announced_modifiers)
+      [ "declaration"; "unresolved" ]
+
+let type_index (kind : Httui_lang.Semantic_tokens.kind) =
+  let name =
+    let mem n = List.mem n !legend_types in
+    match kind with
+    | Httui_lang.Semantic_tokens.Alias ->
+        if mem "httui.alias" then "httui.alias" else "variable"
+    | Httui_lang.Semantic_tokens.Env_var ->
+        if mem "httui.env_var" then "httui.env_var" else "variable"
+    | Httui_lang.Semantic_tokens.Ref_path ->
+        if mem "httui.ref_path" then "httui.ref_path" else "property"
+  in
+  let rec idx i = function
+    | [] -> 0
+    | x :: rest -> if x = name then i else idx (i + 1) rest
+  in
+  idx 0 !legend_types
+
+let modifier_bits (t : Httui_lang.Semantic_tokens.t) =
+  List.fold_left
+    (fun bits (i, m) ->
+      let active =
+        (m = "declaration" && t.declaration)
+        || (m = "unresolved" && t.unresolved)
+      in
+      if active then bits lor (1 lsl i) else bits)
+    0
+    (List.mapi (fun i m -> (i, m)) !legend_modifiers)
+
 let on_initialize (r : Jsonrpc.Request.t) =
+  (try
+     let p = T.InitializeParams.t_of_yojson (params_json r.params) in
+     match p.capabilities.textDocument with
+     | Some td -> (
+         match td.semanticTokens with
+         | Some st ->
+             compute_legend ~announced_types:st.tokenTypes
+               ~announced_modifiers:st.tokenModifiers
+         | None -> compute_legend ~announced_types:[] ~announced_modifiers:[])
+     | None -> compute_legend ~announced_types:[] ~announced_modifiers:[]
+   with _ -> compute_legend ~announced_types:[] ~announced_modifiers:[]);
   let capabilities =
     T.ServerCapabilities.create
       ~textDocumentSync:
@@ -109,6 +175,13 @@ let on_initialize (r : Jsonrpc.Request.t) =
       ~hoverProvider:(`Bool true)
       ~completionProvider:
         (T.CompletionOptions.create ~triggerCharacters:[ "{" ] ())
+      ~semanticTokensProvider:
+        (`SemanticTokensOptions
+           (T.SemanticTokensOptions.create
+              ~legend:
+                (T.SemanticTokensLegend.create ~tokenTypes:!legend_types
+                   ~tokenModifiers:!legend_modifiers)
+              ~full:(`Bool true) ()))
       ()
   in
   let serverInfo =
@@ -155,13 +228,40 @@ let on_completion (r : Jsonrpc.Request.t) =
       in
       respond r.id (`List (List.map T.CompletionItem.yojson_of_t items)))
 
+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 shutdown_received = ref false
 
 let handle_request (r : Jsonrpc.Request.t) =
   match r.method_ with
   | "initialize" -> on_initialize r
   | "textDocument/hover" -> on_hover r
   | "textDocument/completion" -> on_completion r
+  | "textDocument/semanticTokens/full" -> on_semantic_tokens r
   | "shutdown" ->
       shutdown_received := true;
       respond r.id `Null

lib/refs.ml

@@ -11,6 +11,8 @@ type occurrence = {
   ref_start : int;  (** doc-absolute byte range of the whole ref *)
   ref_stop : int;
   text : string;  (** ref body text ([req1.body.id]) *)
+  path_segments : (int * int) list;
+      (** doc-absolute ranges of path identifiers ([body], [id]) *)
 }
 
 let named_children node =
@@ -39,22 +41,36 @@ let rec collect_refs node ~content ~base acc =
           with
           | None -> acc
           | Some ident ->
-              let has_path =
-                List.exists (fun c -> kind c = "dot_path") (named_children body)
+              let dot_path =
+                List.find_opt
+                  (fun c -> kind c = "dot_path")
+                  (named_children body)
+              in
+              let path_segments =
+                match dot_path with
+                | None -> []
+                | Some dp ->
+                    named_children dp
+                    |> List.concat_map (fun seg ->
+                        named_children seg
+                        |> List.filter (fun c -> kind c = "identifier")
+                        |> List.map (fun id ->
+                            (base + start_byte id, base + end_byte id)))
               in
               let occ =
                 {
                   name =
                     String.sub content (start_byte ident)
                       (end_byte ident - start_byte ident);
-                  has_path;
+                  has_path = Option.is_some dot_path;
                   name_start = base + start_byte ident;
                   name_stop = base + end_byte ident;
                   ref_start = base + start_byte node;
                   ref_stop = base + end_byte node;
                   text =
                     String.sub content (start_byte body)
                       (end_byte body - start_byte body);
+                  path_segments;
                 }
               in
               occ :: acc)

lib/semantic_tokens.ml

@@ -0,0 +1,64 @@
+(* Abstract semantic tokens for refs: alias declarations in info strings,
+   ref names and path segments. The LSP layer maps each kind to a token
+   type name according to the client's announced capabilities (server-side
+   downgrade) and encodes positions; this module stays protocol-free. *)
+
+type kind = Alias | Env_var | Ref_path
+
+type t = {
+  t_start : int;  (** doc-absolute byte range *)
+  t_stop : int;
+  kind : kind;
+  unresolved : bool;  (** ref with path whose alias is not in scope *)
+  declaration : bool;  (** [alias=...] declaration site in the info string *)
+}
+
+let of_blocks blocks =
+  List.concat
+    (List.mapi
+       (fun i (b : Block.t) ->
+         if not (Block.is_executable b) then []
+         else
+           let scope = Analyze.aliases_above blocks ~index:i in
+           let declaration =
+             match (b.alias, b.alias_offset) with
+             | Some a, Some off ->
+                 [
+                   {
+                     t_start = off;
+                     t_stop = off + String.length a;
+                     kind = Alias;
+                     unresolved = false;
+                     declaration = true;
+                   };
+                 ]
+             | _ -> []
+           in
+           let refs =
+             Refs.of_block b
+             |> List.concat_map (fun (r : Refs.occurrence) ->
+                 let known = List.mem_assoc r.name scope in
+                 let name_kind =
+                   if r.has_path || known then Alias else Env_var
+                 in
+                 {
+                   t_start = r.name_start;
+                   t_stop = r.name_stop;
+                   kind = name_kind;
+                   unresolved = r.has_path && not known;
+                   declaration = false;
+                 }
+                 :: List.map
+                      (fun (s, e) ->
+                        {
+                          t_start = s;
+                          t_stop = e;
+                          kind = Ref_path;
+                          unresolved = false;
+                          declaration = false;
+                        })
+                      r.path_segments)
+           in
+           declaration @ refs)
+       blocks)
+  |> List.sort (fun a b -> compare a.t_start b.t_start)

test/test_httui_lang.ml

@@ -120,6 +120,39 @@ let () =
     (Httui_lang.Analyze.completion_at doc blocks ~offset:(b2.content_offset + 4)
     = []);
 
+  (* --- semantic tokens --- *)
+  let toks = Httui_lang.Semantic_tokens.of_blocks blocks in
+  (* 2 alias declarations + ghost (1 name + 1 segment)
+     + req1 ref (1 name + 2 segments) + TOKEN (1 name) *)
+  check "token count" (List.length toks = 8);
+  (match toks with
+  | first :: _ ->
+      check "first token is req1 declaration"
+        (first.declaration
+        && first.kind = Httui_lang.Semantic_tokens.Alias
+        && String.sub doc first.t_start (first.t_stop - first.t_start) = "req1"
+        )
+  | [] -> check "first token is req1 declaration" false);
+  check "ghost name token is unresolved"
+    (List.exists
+       (fun (t : Httui_lang.Semantic_tokens.t) ->
+         t.unresolved
+         && String.sub doc t.t_start (t.t_stop - t.t_start) = "ghost")
+       toks);
+  check "TOKEN is env var kind"
+    (List.exists
+       (fun (t : Httui_lang.Semantic_tokens.t) ->
+         t.kind = Httui_lang.Semantic_tokens.Env_var
+         && String.sub doc t.t_start (t.t_stop - t.t_start) = "TOKEN")
+       toks);
+  check "tokens sorted by position"
+    (let rec sorted = function
+       | (a : Httui_lang.Semantic_tokens.t) :: (b :: _ as rest) ->
+           a.t_start <= b.t_start && sorted rest
+       | _ -> true
+     in
+     sorted toks);
+
   (* --- positions (UTF-16 with multibyte) --- *)
   let mdoc = "caf\xc3\xa9 {{x}}\n" in
   let p = Httui_lang.Doc_position.of_offset mdoc 5 in