Add support for ranged semantic tokens requests

src/lsp/cobol_lsp/lsp_diagnostics.ml

@@ -46,7 +46,7 @@ let translate_one ~rootdir ~uri (diag: DIAG.t) =
     | Some (Lexing.{ pos_fname = f; _ }, _ as lexloc) ->
         pseudo_normalized_uri ~rootdir f, Lsp_position.range_of_lexloc lexloc
     | None ->
-        uri, Lsp_position.none_range
+        uri, Lsp_position.pointwise_range_at_start
   in
   let diag =
     Lsp.Types.Diagnostic.create ()

src/lsp/cobol_lsp/lsp_position.ml

@@ -19,44 +19,60 @@ open Srcloc.TYPES
 open Lsp.Types
 
 (** Range of length [0], at position [0, 0] *)
-let none_range =
-  let none_pos = Position.create ~line:0 ~character:0 in
-  Range.create ~start:none_pos ~end_:none_pos
+let pointwise_range_at_start =
+  let start_pos = Position.create ~line:0 ~character:0 in
+  Range.create ~start:start_pos ~end_:start_pos
 
 (** {1 Postions {i w.r.t} lexical locations} *)
 
+(** [start_of_lexloc] creates a representation of the start of the given lexical
+    location that is suitable for the LSP library. *)
+let start_of_lexloc ((start_pos, _end_pos): lexloc) =
+  Position.create           (* NOTE: Line numbers start at 0 in LSP protocol. *)
+    ~line:(start_pos.pos_lnum - 1)
+    ~character:(start_pos.pos_cnum - start_pos.pos_bol)
+
+(** [end_of_lexloc] creates a representation of the end of the given lexical
+    location that is suitable for the LSP library. *)
+let end_of_lexloc ((_start_pos, end_pos): lexloc) =
+  Position.create           (* NOTE: Line numbers start at 0 in LSP protocol. *)
+    ~line:(end_pos.pos_lnum - 1)
+    ~character:(end_pos.pos_cnum - end_pos.pos_bol)
+
 (** [range_of_lexloc] creates a representation of the given lexical location
     that is suitable for the LSP library. *)
-let range_of_lexloc ((start_pos, end_pos): lexloc) =
-  (* NOTE: Line numbers start at 0 in LSP protocol. *)
-  let sl = start_pos.pos_lnum - 1
-  and sc = start_pos.pos_cnum - start_pos.pos_bol
-  and el = end_pos.pos_lnum - 1
-  and ec = end_pos.pos_cnum - end_pos.pos_bol in
-  Range.create
-    ~start:(Position.create ~line:sl ~character:sc)
-    ~end_:(Position.create ~line:el ~character:ec)
-
-(** [is_before_lexloc pos lexloc] holds when [pos] is strictly before [lexloc] *)
-let is_before_lexloc pos lexloc =
-  let Range.{start = {line; character;}; _} = range_of_lexloc lexloc in
-  Position.(pos.line < line || (pos.line = line && pos.character < character))
-
-(** [is_after_lexloc pos lexloc] holds when [pos] is strictly after [lexloc] *)
-let is_after_lexloc pos lexloc =
-  let Range.{end_ = {line; character;}; _} = range_of_lexloc lexloc in
-  Position.(pos.line > line || (pos.line = line && pos.character > character))
-
-(** [is_in_lexloc pos lexloc] holds when [pos] is neither before or after
-    [lexloc] *)
+let range_of_lexloc lexloc =
+  Range.create ~start:(start_of_lexloc lexloc) ~end_:(end_of_lexloc lexloc)
+
+(** [is_before_lexloc pos lexloc] holds when [pos] strictly precedes [lexloc] *)
+let is_before_lexloc (pos: Position.t) lexloc =
+  let Position.{ line; character } = start_of_lexloc lexloc in
+  pos.line < line ||
+  pos.line = line && pos.character < character
+
+(** [is_after_lexloc pos lexloc] holds when [pos] strictly follows [lexloc] *)
+let is_after_lexloc (pos: Position.t) lexloc =
+  let Position.{ line; character } = end_of_lexloc lexloc in
+  pos.line > line ||
+  pos.line = line && pos.character > character
+
+(** [is_in_lexloc pos lexloc] holds when [pos] is strictly neither before nor
+    after [lexloc] *)
 let is_in_lexloc pos lexloc =
-  (not @@ is_after_lexloc pos lexloc) && (not @@ is_before_lexloc pos lexloc)
+  not (is_before_lexloc pos lexloc || is_after_lexloc pos lexloc)
 
-(** [contains_lexloc range lexloc] holds when [lexloc] is strictly contained
-    inside [range]. *)
-let contains_lexloc Range.{start; end_} lexloc =
+(** [contains_lexloc range lexloc] holds when the range described by [lexloc] is
+    strictly contained within [range]. *)
+let contains_lexloc Range.{ start; end_ } lexloc =
   is_before_lexloc start lexloc && is_after_lexloc end_ lexloc
 
+(** [intersects_lexloc range lexloc] holds when the range described by [lexloc]
+    and [range] have a non-empty intersection. *)
+let intersects_lexloc (Range.{ start; end_ } as range) lexloc =
+  is_in_lexloc start lexloc ||
+  is_in_lexloc end_ lexloc ||
+  contains_lexloc range lexloc
+
 (* --- *)
 
 (** {1 Postions {i w.r.t} generalized source locations} *)

src/lsp/cobol_lsp/lsp_position.mli

@@ -15,7 +15,7 @@
     {!Lsp.Types.Range} types with {!Srcloc.lexloc} and {!Srcloc.srcloc}. *)
 
 (** Range of length [0], at position [0, 0] *)
-val none_range: Lsp.Types.Range.t
+val pointwise_range_at_start: Lsp.Types.Range.t
 
 (** [range_of_lexloc] creates a representation of the given lexical location
     that is suitable for the LSP library. *)
@@ -32,9 +32,8 @@ val is_after_lexloc: Lsp.Types.Position.t -> Cobol_common.Srcloc.lexloc -> bool
     [lexloc] *)
 val is_in_lexloc: Lsp.Types.Position.t -> Cobol_common.Srcloc.lexloc -> bool
 
-(** [contains_lexloc range lexloc] holds when [lexloc] is strictly contained
-    within [range]. *)
 val contains_lexloc: Lsp.Types.Range.t -> Cobol_common.Srcloc.lexloc -> bool
+val intersects_lexloc: Lsp.Types.Range.t -> Cobol_common.Srcloc.lexloc -> bool
 
 (* --- *)
 

src/lsp/cobol_lsp/lsp_request.ml

@@ -79,19 +79,20 @@ let try_with_document_data ~f =
 
    NOTE: For now we don't use them because we don't have any special
    response. *)
-let make_capabilities _ =
+let make_capabilities (_: ClientCapabilities.t) =
   let sync =
     TextDocumentSyncOptions.create ()
       ~openClose:true
       ~change:Incremental
-  and semantic =
+  and semtoks =
     let legend =
       SemanticTokensLegend.create
         ~tokenTypes:Lsp_semtoks.token_types
         ~tokenModifiers:Lsp_semtoks.token_modifiers
     in
     SemanticTokensOptions.create ()
       ~full:(`Full (SemanticTokensOptions.create_full ~delta:false ()))
+      ~range:true
       ~legend
   and hover =
     HoverOptions.create ()
@@ -104,7 +105,7 @@ let make_capabilities _ =
     ~referencesProvider:(`Bool true)
     ~documentRangeFormattingProvider: (`Bool true)
     ~documentFormattingProvider: (`Bool true)
-    ~semanticTokensProvider:(`SemanticTokensOptions semantic)
+    ~semanticTokensProvider:(`SemanticTokensOptions semtoks)
     ~hoverProvider:(`HoverOptions hover)
     ~completionProvider:(completion_option)
 
@@ -245,17 +246,23 @@ let handle_formatting registry params =
   with Failure msg ->
     internal_error "Formatting error: %s" msg
 
-let handle_semantic_tokens_full registry (params: SemanticTokensParams.t) =
-  try_with_document_data registry params.textDocument
-    ~f:begin fun ~doc:{ artifacts = { pplog; tokens; comments };
-                        _ } Lsp_document.{ ast; _ } ->
-      let filename = Lsp.Uri.to_path params.textDocument.uri in
-      let data =
-        Lsp_semtoks.data ~filename ~pplog ~comments
-          ~tokens:(Lazy.force tokens) ~ptree:ast
-      in
-      Some (SemanticTokens.create ~data ())
-    end
+let handle_semtoks_full,
+    handle_semtoks_range =
+  let handle registry ?range (doc: TextDocumentIdentifier.t) =
+    try_with_document_data registry doc
+      ~f:begin fun ~doc:{ artifacts = { pplog; tokens; comments };
+                          _ } Lsp_document.{ ast; _ } ->
+        let data =
+          Lsp_semtoks.data ~filename:(Lsp.Uri.to_path doc.uri) ~range
+            ~pplog ~comments ~tokens:(Lazy.force tokens) ~ptree:ast
+        in
+        Some (SemanticTokens.create ~data ())
+      end
+  in
+  (fun registry (SemanticTokensParams.{ textDocument; _ }) ->
+     handle registry textDocument),
+  (fun registry (SemanticTokensRangeParams.{ textDocument; range; _ }) ->
+     handle registry ~range textDocument)
 
 let handle_hover registry (params: HoverParams.t) =
   let filename = Lsp.Uri.to_path params.textDocument.uri in
@@ -335,7 +342,9 @@ let on_request
     | TextDocumentFormatting params ->
         Ok (handle_formatting registry params, state)
     | SemanticTokensFull params ->
-        Ok (handle_semantic_tokens_full registry params, state)
+        Ok (handle_semtoks_full registry params, state)
+    | SemanticTokensRange params ->
+        Ok (handle_semtoks_range registry params, state)
     | TextDocumentHover hover_params ->
         Ok (handle_hover registry hover_params, state)
     | TextDocumentCompletion completion_params ->
@@ -370,7 +379,6 @@ let on_request
     | SelectionRange  (* SelectionRangeParams.t.t *) _
     | ExecuteCommand  (* ExecuteCommandParams.t.t *) _
     | SemanticTokensDelta  (* SemanticTokensDeltaParams.t.t *) _
-    | SemanticTokensRange  (* SemanticTokensRangeParams.t.t *) _
     | LinkedEditingRange  (* LinkedEditingRangeParams.t.t *) _
     | CallHierarchyIncomingCalls  (* CallHierarchyIncomingCallsParams.t.t *) _
     | CallHierarchyOutgoingCalls  (* CallHierarchyOutgoingCallsParams.t.t *) _

src/lsp/cobol_lsp/lsp_semtoks.ml

@@ -107,6 +107,12 @@ let semtok ?(tokmods = TOKMOD.none) toktyp lexloc =
 let single_line_lexlocs_in ~filename =
   Srcloc.shallow_single_line_lexlocs_in ~ignore_invalid_filename:true ~filename
 
+let acc_semtoks ~filename ?range ?tokmods toktyp loc acc =
+  List.fold_left begin fun acc lexloc -> match range with
+    | Some r when not (Lsp_position.intersects_lexloc r lexloc) -> acc
+    | _ -> semtok toktyp ?tokmods lexloc :: acc
+  end acc @@ single_line_lexlocs_in ~filename loc
+
 type token_category =
   | ProgramName
   | ParagraphName
@@ -127,13 +133,13 @@ type token_category =
    this way, we don't need to worry about the order in which parse-tree elements
    are visited.  If really needed, the accumulator may carry some context
    information that can be used in generic methods like `fold_name'`. *)
-let semtoks_from_ptree ~filename ptree =
+let semtoks_from_ptree ~filename ?range ptree =
   let open Cobol_parser.PTree_visitor in
   let open Cobol_ast.Terms_visitor in
   let open Cobol_ast.Operands_visitor in
   let open Cobol_common.Visitor in
 
-  let semtok_of lexloc category =
+  let acc_semtoks category loc acc =
     let toktyp, tokmods = match category with
       | ProgramName -> TOKTYP.string, TOKMOD.(union [definition; readonly])
       | ParagraphName -> TOKTYP.function_, TOKMOD.(one definition)
@@ -148,12 +154,10 @@ let semtoks_from_ptree ~filename ptree =
       | MnemonicName
       | FileName -> TOKTYP.variable, TOKMOD.(one readonly)
     in
-    semtok ~tokmods toktyp lexloc
+    acc_semtoks ~filename ?range ~tokmods toktyp loc acc
   in
-  let add_name' name toktyp acc =
-    List.rev_map
-      (fun lexloc -> semtok_of lexloc toktyp)
-      (single_line_lexlocs_in ~filename ~@name) @ acc
+  let add_name' name category acc =
+    acc_semtoks category ~@name acc
   in
   let rec add_qualname (qn:Cobol_ast.qualname) toktyp acc =
     match qn with
@@ -551,28 +555,30 @@ let semtoks_from_ptree ~filename ptree =
 
   end) ptree [] |> List.rev
 
-let semtoks_of_comments ~filename comments = comments |>
+let semtoks_of_comments ~filename ?range comments = comments |>
   List.filter_map begin function
     | Cobol_preproc.Text.{ comment_loc = s, _ as lexloc; _ }
-      when s.Lexing.pos_fname = filename ->
+      when s.Lexing.pos_fname = filename &&
+           Option.fold range
+             ~some:(fun r -> Lsp_position.intersects_lexloc r lexloc)
+             ~none:true ->
         Some (semtok TOKTYP.comment lexloc)
     | _ ->
         None
   end
 
-let semtoks_of_preproc_statements ~filename pplog =
+let semtoks_of_preproc_statements ~filename ?range pplog =
   List.rev @@ List.fold_left begin fun acc -> function
     | Cobol_preproc.Trace.FileCopy { copyloc = loc; _ }
     | Cobol_preproc.Trace.Replace { replloc = loc } ->
-        List.rev_map (semtok TOKTYP.macro)
-          (single_line_lexlocs_in ~filename loc) @ acc
+        acc_semtoks ~filename ?range TOKTYP.macro loc acc
     | Cobol_preproc.Trace.Replacement _ ->
         acc
   end [] (Cobol_preproc.Trace.events pplog)
 
 (** [semtoks_of_non_ambigious_tokens ~filename tokens] returns tokens that do
     not need to have more analyzing to get their type. *)
-let semtoks_of_non_ambigious_tokens ~filename tokens =
+let semtoks_of_non_ambigious_tokens ~filename ?range tokens =
   List.rev @@ List.fold_left begin fun acc { payload = token; loc } ->
     let semtok_infos = match token with
       | WORD _ | WORD_IN_AREA_A _ -> None
@@ -613,10 +619,10 @@ let semtoks_of_non_ambigious_tokens ~filename tokens =
           Some (TOKTYP.keyword, TOKMOD.none)
     in
     match semtok_infos with
-    | None -> acc
+    | None ->
+        acc
     | Some (toktyp, tokmods) ->
-        List.rev_map (semtok toktyp ~tokmods)
-          (single_line_lexlocs_in ~filename loc) @ acc
+        acc_semtoks ~filename ?range ~tokmods toktyp loc acc
   end [] tokens
 
 let compare_semtoks first second =
@@ -658,11 +664,11 @@ let ensure_sorted name ~filename cmp l =
       List.fast_sort cmp l
 
 
-let data ~filename ~tokens ~pplog ~comments ~ptree : int array =
-  let semtoks1 = semtoks_of_non_ambigious_tokens ~filename tokens in
-  let semtoks2 = semtoks_from_ptree              ~filename ptree in
-  let semtoks3 = semtoks_of_comments             ~filename comments in
-  let semtoks4 = semtoks_of_preproc_statements   ~filename pplog in
+let data ~filename ~range ~tokens ~pplog ~comments ~ptree : int array =
+  let semtoks1 = semtoks_of_non_ambigious_tokens ~filename ?range tokens in
+  let semtoks2 = semtoks_from_ptree              ~filename ?range ptree in
+  let semtoks3 = semtoks_of_comments             ~filename ?range comments in
+  let semtoks4 = semtoks_of_preproc_statements   ~filename ?range pplog in
   (* NB: In *principle* all those lists are already sorted w.r.t lexical
      locations in [filename].  We just check that for now and raise a warning,
      in case. *)

src/lsp/cobol_lsp/lsp_semtoks.mli

@@ -18,6 +18,7 @@ val token_modifiers: string list
    to lsp>=16, and avoid having to use an array below. *)
 val data
   : filename: string
+  -> range: Lsp.Types.Range.t option
   -> tokens: Cobol_parser.tokens_with_locs
   -> pplog: Cobol_preproc.log
   -> comments: Cobol_preproc.comments

src/lsp/cobol_preproc/src_overlay.ml

@@ -134,16 +134,16 @@ let join_limits: manager -> limit * limit -> srcloc = fun ctx (s, e) ->
     (* Printexc.(print_raw_backtrace Stdlib.stderr @@ get_callstack 10); *)
     loc
   in
-  (* first attempt assumes proper token limits: `s` is a left and `e` is a right
-     of tokens *)
+  (* first attempt assumes proper token limits: `s` is a left and `e` is a
+     right of tokens *)
   try try_limits (s, e) with Not_found ->
   (* try assuming `s` is an end of token *)
   try try_limits (Links.find ctx.over_right_gap s, e) with Not_found ->
-    if s.pos_cnum = 0 (* potential special case with left-position forged by the
-                         parser: retry with leftmost limit if it differs from
-                         s *)
+    if s.pos_cnum = 0 (* potential special case with left-position forged by
+                         the parser: retry with leftmost limit if it differs
+                         from s *)
     then match leftmost_limit_in ~filename:s.pos_fname ctx with
-      | Some l when l != s -> try_limits (l, e)  (* physical equality is enough *)
+      | Some l when l != s -> try_limits (l, e) (* physical equality is enough *)
       | Some _ | None -> join_failure (s, e)
     else join_failure (s, e)