From 84d4e6302672e31f5acbde37803a2a85d71fded1 Mon Sep 17 00:00:00 2001 From: Nicolas Berthier Date: Mon, 18 Sep 2023 11:43:11 +0200 Subject: [PATCH] Add support for ranged semantic tokens requests --- src/lsp/cobol_lsp/lsp_diagnostics.ml | 2 +- src/lsp/cobol_lsp/lsp_position.ml | 74 +++++++++++++++++----------- src/lsp/cobol_lsp/lsp_position.mli | 5 +- src/lsp/cobol_lsp/lsp_request.ml | 40 +++++++++------ src/lsp/cobol_lsp/lsp_semtoks.ml | 48 ++++++++++-------- src/lsp/cobol_lsp/lsp_semtoks.mli | 1 + src/lsp/cobol_preproc/src_overlay.ml | 12 ++--- 7 files changed, 106 insertions(+), 76 deletions(-) diff --git a/src/lsp/cobol_lsp/lsp_diagnostics.ml b/src/lsp/cobol_lsp/lsp_diagnostics.ml index 525d20317..3a976b6f3 100644 --- a/src/lsp/cobol_lsp/lsp_diagnostics.ml +++ b/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 () diff --git a/src/lsp/cobol_lsp/lsp_position.ml b/src/lsp/cobol_lsp/lsp_position.ml index c587ee140..ece838258 100644 --- a/src/lsp/cobol_lsp/lsp_position.ml +++ b/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} *) diff --git a/src/lsp/cobol_lsp/lsp_position.mli b/src/lsp/cobol_lsp/lsp_position.mli index 9996a587c..a56357d65 100644 --- a/src/lsp/cobol_lsp/lsp_position.mli +++ b/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 (* --- *) diff --git a/src/lsp/cobol_lsp/lsp_request.ml b/src/lsp/cobol_lsp/lsp_request.ml index 111009268..074b95978 100644 --- a/src/lsp/cobol_lsp/lsp_request.ml +++ b/src/lsp/cobol_lsp/lsp_request.ml @@ -79,12 +79,12 @@ 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 @@ -92,6 +92,7 @@ let make_capabilities _ = 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 *) _ diff --git a/src/lsp/cobol_lsp/lsp_semtoks.ml b/src/lsp/cobol_lsp/lsp_semtoks.ml index 7576057c6..317c5b7d6 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.ml +++ b/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. *) diff --git a/src/lsp/cobol_lsp/lsp_semtoks.mli b/src/lsp/cobol_lsp/lsp_semtoks.mli index 6b684c9f6..e8b35572b 100644 --- a/src/lsp/cobol_lsp/lsp_semtoks.mli +++ b/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 diff --git a/src/lsp/cobol_preproc/src_overlay.ml b/src/lsp/cobol_preproc/src_overlay.ml index e073ff002..da7d62d70 100644 --- a/src/lsp/cobol_preproc/src_overlay.ml +++ b/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)