Emit semantic tokens for COPY and REPLACE preprocessor statements

src/lsp/cobol_lsp/lsp_request.ml

@@ -265,6 +265,8 @@ let handle_hover registry (params: HoverParams.t) =
       | Cobol_preproc.FileCopy { copyloc = loc; _ } ->
           Lsp_position.is_in_lexloc params.position
             (Cobol_common.Srcloc.lexloc_in ~filename loc)
+      | Cobol_preproc.Replace _ ->
+          false
     end (Cobol_preproc.Trace.events pplog)
   in
   let hover_markdown ~loc value =
@@ -289,7 +291,9 @@ let handle_hover registry (params: HoverParams.t) =
             | SF _ | Auto -> "cobol"
           in
           Pretty.string_to (hover_markdown ~loc) "```%s\n%s\n```" mdlang text
-      | Some FileCopy { status = MissingCopy _; _ } | None ->
+      | Some FileCopy { status = MissingCopy _; _ }
+      | Some Replace _
+      | None ->
           None
     end
 

src/lsp/cobol_lsp/lsp_semtoks.ml

@@ -46,7 +46,7 @@ module TOKTYP = struct
   (* "enumMember"; *)
   (* "event"; *)
   (* "method"; *)
-  (* "macro"; *)
+  let macro     = mk "macro"
   (* "regexp"; *)
   let all =
     List.sort (fun a b -> b.index - a.index) !all |>
@@ -121,6 +121,12 @@ type token_category =
   | MnemonicName
   | FileName
 
+
+(* TODO: incrementally build a map that associates locations in filename with
+   token types and modifiers, and then extract the (sorted) list at the end.  In
+   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 open Cobol_parser.PTree_visitor in
   let open Cobol_ast.Terms_visitor in
@@ -554,6 +560,16 @@ let semtoks_of_comments ~filename comments = comments |>
         None
   end
 
+let semtoks_of_preproc_statements ~filename pplog =
+  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
+    | 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 =
@@ -642,19 +658,22 @@ let ensure_sorted name ~filename cmp l =
       List.fast_sort cmp l
 
 
-let data ~filename ~tokens ~pplog:_ ~comments ~ptree : int array =
+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 semtoks2 = semtoks_from_ptree              ~filename ptree in
+  let semtoks3 = semtoks_of_comments             ~filename comments in
+  let semtoks4 = semtoks_of_preproc_statements   ~filename 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. *)
   (* let semtoks1 = List.fast_sort compare_semtoks semtoks1 *)
   (* and semtoks2 = List.fast_sort compare_semtoks semtoks2 *)
   (* and semtoks3 = List.fast_sort compare_semtoks semtoks3 in *)
   let semtoks1 = ensure_sorted "nonambiguous" ~filename compare_semtoks semtoks1
-  and semtoks2 = ensure_sorted "ptree" ~filename compare_semtoks semtoks2
-  and semtoks3 = ensure_sorted "comments" ~filename compare_semtoks semtoks3 in
+  and semtoks2 = ensure_sorted "ptree"        ~filename compare_semtoks semtoks2
+  and semtoks3 = ensure_sorted "comments"     ~filename compare_semtoks semtoks3
+  and semtoks4 = ensure_sorted "preproc"      ~filename compare_semtoks semtoks4 in
   relative_semtoks
     List.(merge compare_semtoks semtoks1 @@
-          merge compare_semtoks semtoks2 semtoks3)
+          merge compare_semtoks semtoks2 @@
+          merge compare_semtoks semtoks3 @@ semtoks4)

src/lsp/cobol_preproc/preproc_engine.ml

@@ -274,7 +274,7 @@ and do_copy lp rev_prefix copy suffix =
   `CopyDone (lp, text)
 
 and do_replace lp rev_prefix repl suffix =
-  let { result = repl; diags } = ~&repl in
+  let { payload = { result = repl; diags }; loc } = repl in
   let lp = add_diags lp diags in
   let prefix, pplog =
     (* NB: this applies the current replacing on all remaining text leading to
@@ -283,7 +283,7 @@ and do_replace lp rev_prefix repl suffix =
        replacing phrase. *)
     apply_active_replacing_full lp @@ List.rev rev_prefix
   in
-  let lp = with_pplog lp pplog in
+  let lp = with_pplog lp @@ Preproc_trace.new_replace ~loc pplog in
   let lp = match repl, lp.persist.replacing with
     | CDirReplace { replacing = repl; _ }, ([] as replacing)
     | CDirReplace { replacing = repl; also = false }, replacing ->

src/lsp/cobol_preproc/preproc_trace.ml

@@ -19,6 +19,10 @@ module TYPES = struct
           copyloc: srcloc;
           status: copy_event_status;
         }
+    | Replace of
+        {
+          replloc: srcloc;
+        }
     | Replacement of
         {
           matched_loc: srcloc;
@@ -45,6 +49,8 @@ let cyclic_copy ~loc ~filename : log -> log =
   List.cons @@ FileCopy { copyloc = loc; status = CyclicCopy filename }
 let missing_copy ~loc ~info : log -> log =
   List.cons @@ FileCopy { copyloc = loc; status = MissingCopy info }
+let new_replace ~loc : log -> log =
+  List.cons @@ Replace { replloc = loc }
 
 (* --- *)
 

src/lsp/cobol_preproc/preproc_trace.mli

@@ -12,12 +12,16 @@ module TYPES: sig
   type log_entry =
     | FileCopy of
         {
-          copyloc: Cobol_common.Srcloc.srcloc;
+          copyloc: Cobol_common.srcloc;
           status: copy_event_status;
         }
+    | Replace of
+        {
+          replloc: Cobol_common.srcloc;
+        }
     | Replacement of
         {
-          matched_loc: Cobol_common.Srcloc.srcloc;
+          matched_loc: Cobol_common.srcloc;
           replacement_text: Text.text;
         }
 
@@ -50,6 +54,9 @@ val missing_copy
   : loc: Cobol_common.srcloc
   -> info: Copybook.lib_not_found_info
   -> log -> log
+val new_replace
+  : loc: Cobol_common.srcloc
+  -> log -> log
 
 (* --- *)