Fix handling of MF-style compiler directives, and emit related semtoks

Author: nberth

src/lsp/cobol_lsp/lsp_request.ml

@@ -236,7 +236,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 _ ->
+      | Cobol_preproc.Replace _
+      | Cobol_preproc.LexDir _ ->
           false
     end (Cobol_preproc.Trace.events pplog)
   in
@@ -264,6 +265,7 @@ let handle_hover registry (params: HoverParams.t) =
           Pretty.string_to (hover_markdown ~loc) "```%s\n%s\n```" mdlang text
       | Some FileCopy { status = MissingCopy _; _ }
       | Some Replace _
+      | Some LexDir _
       | None ->
           None
     end

src/lsp/cobol_lsp/lsp_semtoks.ml

@@ -569,7 +569,8 @@ let semtoks_of_comments ~filename ?range comments = comments |>
 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 } ->
+    | Cobol_preproc.Trace.Replace { replloc = loc }
+    | Cobol_preproc.Trace.LexDir { loc; _ } ->
         acc_semtoks ~filename ?range TOKTYP.macro loc acc
     | Cobol_preproc.Trace.Replacement _ ->
         acc

src/lsp/cobol_preproc/preproc.ml

@@ -16,6 +16,7 @@ open Cobol_common.Srcloc.TYPES
 open Cobol_common.Srcloc.INFIX
 open Cobol_common.Diagnostics.TYPES
 open Text.TYPES
+open Preproc_directives                         (* import types of directives *)
 
 module DIAGS = Cobol_common.Diagnostics
 
@@ -126,10 +127,6 @@ let srclex_restart_on_file ?position filename =
 
 (* SOURCE FORMAT *)
 
-type lexing_directive =
-  | LexDirSource:
-      'k Src_format.source_format with_loc -> lexing_directive         [@@unboxed]
-
 let cdir_source_format ~dialect format =
   match Src_format.decypher ~dialect ~&format with
   | Ok (SF sf) ->
@@ -141,50 +138,6 @@ let cdir_source_format ~dialect format =
 
 (* COPY/REPLACING *)
 
-type copy_statement =
-  | CDirCopy of
-      {
-        library: library;
-        suppress_printing: bool;
-        replacing: replacing with_loc list;
-      }
-and replace_statement =
-  | CDirReplace of
-      {
-        also: bool;
-        replacing: replacing with_loc list;
-      }
-  | CDirReplaceOff of
-      {
-        last: bool;
-      }
-and library =
-  {
-    libname: fileloc with_loc;
-    cbkname: fileloc with_loc option;
-  }
-and fileloc = [`Word | `Alphanum] * string
-and replacing =
-  | ReplaceExact of
-      {
-        repl_from: pseudotext with_loc;
-        repl_to: pseudotext with_loc;
-      }
-  | ReplacePartial of
-      {
-        repl_subst: partial_subst with_loc;
-        repl_to: string with_loc option;
-      }
-and partial_subst =
-  {
-    partial_subst_dir: replacing_direction;
-    partial_subst_len: int;
-    partial_subst_regexp: Str.regexp;
-  }
-and replacing_direction = Leading | Trailing
-
-(* --- Implementation of replacing operations ------------------------------- *)
-
 let concat_strings = Cobol_common.Srcloc.concat_strings_with_loc
 let lift_textword w = TextWord ~&w &@<- w
 
@@ -218,12 +171,6 @@ let partial_word (type k) (req: k partial_word_request) words : (k, _) result =
   | _, _ ->
       Error (DIAGS.One.error ~loc:~@words "Expected@ one@ text-word")
 
-type partial_replacing =
-  {
-    repl_dir: replacing_direction;
-    repl_strict: bool;
-  }
-
 let partial_subst (k: partial_replacing) ({ payload = pat; _ } as repl_from) =
   { partial_subst_dir = k.repl_dir;
     partial_subst_len = String.length pat;

src/lsp/cobol_preproc/preproc.mli

@@ -15,107 +15,27 @@ open Cobol_common.Srcloc.TYPES
 open Cobol_common.Diagnostics.TYPES
 open Text.TYPES
 
+(** {1 Source text lexer} *)
+
 type 'k srclexer = 'k Src_lexing.state * Lexing.lexbuf
 and any_srclexer =
   | Plx: 'k srclexer -> any_srclexer                                   [@@unboxed]
 
-(* --- Compiler Directives -------------------------------------------------- *)
-
-(* SOURCE FORMAT *)
-
-type lexing_directive =
-  | LexDirSource:
-      'k Src_format.source_format with_loc -> lexing_directive         [@@unboxed]
-
-(* COPY/REPLACING *)
-
-type copy_statement =
-  | CDirCopy of
-      {
-        library: library;
-        suppress_printing: bool;
-        replacing: replacing with_loc list;
-      }
-and replace_statement =
-  | CDirReplace of
-      {
-        also: bool;
-        replacing: replacing with_loc list;
-      }
-  | CDirReplaceOff of
-      {
-        last: bool;
-      }
-and library =
-  {
-    libname: fileloc with_loc;
-    cbkname: fileloc with_loc option;
-  }
-and fileloc = [`Word | `Alphanum] * string
-and replacing
-
-type (_, _) repl_attempt =
-  | OnPartText: ([`NoReplacement | `MissingText],
-                 partial_text_repl_result) repl_attempt
-  | OnFullText: ([`NoReplacement],
-                 text * Preproc_trace.log) repl_attempt
-and partial_text_repl_result =
-  (text * Preproc_trace.log,
-   [`MissingText of text * Preproc_trace.log * text]) result
-
-module type ENTRY_POINTS = sig
-  type 'x entry
-  val replace_statement: replace_statement with_diags with_loc entry
-  val lexing_directive: lexing_directive option with_diags with_loc entry
-  val copy_statement: copy_statement with_diags with_loc entry
-end
-
-module type PPPARSER = sig
-  exception Error
-
-  (* The incremental API. *)
-  module MenhirInterpreter: MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE
-    with type token = Preproc_tokens.token
-
-  (* The entry point(s) to the incremental API. *)
-  module Incremental: ENTRY_POINTS with type
-    'x entry := Lexing.position -> 'x MenhirInterpreter.checkpoint
-end
-
-type partial_replacing =
-  {
-    repl_dir: replacing_direction;
-    repl_strict: bool;
-  }
-and replacing_direction = Leading | Trailing
-
-val replacing
-  : ?partial:partial_replacing
-  -> pseudotext with_loc
-  -> pseudotext with_loc
-  -> replacing option with_diags
-val apply_replacing
-  : (_, 'a) repl_attempt
-  -> replacing with_loc list
-  -> Preproc_trace.log
-  -> text
-  -> 'a
-
-(** {3 Source format} *)
+(** {2 Source format} *)
 
 val source_format
   : any_srclexer
   -> Src_format.any
 val cdir_source_format
   : dialect: Cobol_config.dialect
   -> string with_loc
-  -> lexing_directive option with_diags
+  -> Preproc_directives.lexing_directive option with_diags
 val with_source_format
   : 'k Src_format.source_format with_loc
   -> any_srclexer
   -> any_srclexer
 
-(** {3 Instantiation} *)
+(** {2 Instantiation} *)
 
 val srclex_from_file
   : source_format: Src_format.any
@@ -132,7 +52,7 @@ val srclex_from_channel
   -> in_channel
   -> any_srclexer
 
-(** {3 Resetting the input} *)
+(** {2 Resetting the input} *)
 
 (** Note: the functions below assume [position] corresponds to the begining of
     the input.} *)
@@ -153,7 +73,7 @@ val srclex_restart_on_channel
   -> any_srclexer
   -> any_srclexer
 
-(** {3 Queries} *)
+(** {2 Queries} *)
 
 val srclex_diags
   : any_srclexer
@@ -167,12 +87,46 @@ val srclex_comments
 val srclex_newline_cnums
   : any_srclexer
   -> int list
+val next_source_line
+  : any_srclexer
+  -> any_srclexer * text
+val fold_source_lines
+  : any_srclexer
+  -> (text -> 'a -> 'a)
+  -> 'a
+  -> 'a
+val print_source_lines
+  : Format.formatter
+  -> any_srclexer
+  -> unit
 
-val next_source_line: any_srclexer -> any_srclexer * text
-val fold_source_lines: any_srclexer -> (text -> 'a -> 'a) -> 'a -> 'a
-val print_source_lines: Format.formatter -> any_srclexer -> unit
+(** {1 Compiler Directives} *)
 
-(* --- *)
+val replacing
+  : ?partial: Preproc_directives.partial_replacing
+  -> pseudotext with_loc
+  -> pseudotext with_loc
+  -> Preproc_directives.replacing option with_diags
+
+type (_, _) repl_attempt =
+  | OnPartText: ([`NoReplacement | `MissingText],
+                 partial_text_repl_result) repl_attempt
+  | OnFullText: ([`NoReplacement],
+                 text * Preproc_trace.log) repl_attempt
+and partial_text_repl_result =
+  (text * Preproc_trace.log,
+   [`MissingText of text * Preproc_trace.log * text]) result
+val apply_replacing
+  : (_, 'a) repl_attempt
+  -> Preproc_directives.replacing with_loc list
+  -> Preproc_trace.log
+  -> text
+  -> 'a
+
+(** {1 Preprocessor state}
+
+    This state is used to track some preprocessing-related divisions, like the
+    `CONTROL DIVISION` in the GCOS dialect. *)
 
 type state
 
@@ -198,3 +152,27 @@ val find_preproc_phrase
   -> text
   -> (preproc_phrase * state,
       [> `MissingPeriod | `MissingText | `NoneFound ]) result
+
+(** {1 Parsing statements and directives} *)
+
+module type ENTRY_POINTS = sig
+  type 'x entry
+  val replace_statement
+    : Preproc_directives.replace_statement with_diags with_loc entry
+  val lexing_directive
+    : Preproc_directives.lexing_directive option with_diags with_loc entry
+  val copy_statement
+    : Preproc_directives.copy_statement with_diags with_loc entry
+end
+
+module type PPPARSER = sig
+  exception Error
+
+  (* The incremental API. *)
+  module MenhirInterpreter: MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE
+    with type token = Preproc_tokens.token
+
+  (* The entry point(s) to the incremental API. *)
+  module Incremental: ENTRY_POINTS with type
+    'x entry := Lexing.position -> 'x MenhirInterpreter.checkpoint
+end

src/lsp/cobol_preproc/preproc_directives.ml

@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                        SuperBOL OSS Studio                             *)
+(*                                                                        *)
+(*  Copyright (c) 2022-2023 OCamlPro SAS                                  *)
+(*                                                                        *)
+(* All rights reserved.                                                   *)
+(* This source code is licensed under the GNU Affero General Public       *)
+(* License version 3 found in the LICENSE.md file in the root directory   *)
+(* of this source tree.                                                   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Cobol_common.Srcloc.TYPES
+open Text.TYPES
+
+type lexing_directive =
+  | LexDirSource:
+      'k Src_format.source_format with_loc -> lexing_directive         [@@unboxed]
+
+type copy_statement =
+  | CDirCopy of
+      {
+        library: library;
+        suppress_printing: bool;
+        replacing: replacing with_loc list;
+      }
+and replace_statement =
+  | CDirReplace of
+      {
+        also: bool;
+        replacing: replacing with_loc list;
+      }
+  | CDirReplaceOff of
+      {
+        last: bool;
+      }
+and library =
+  {
+    libname: fileloc with_loc;
+    cbkname: fileloc with_loc option;
+  }
+and fileloc = [`Word | `Alphanum] * string
+and replacing =
+  | ReplaceExact of
+      {
+        repl_from: pseudotext with_loc;
+        repl_to: pseudotext with_loc;
+      }
+  | ReplacePartial of
+      {
+        repl_subst: partial_subst with_loc;
+        repl_to: string with_loc option;
+      }
+and partial_subst =
+  {
+    partial_subst_dir: replacing_direction;
+    partial_subst_len: int;
+    partial_subst_regexp: Str.regexp;
+  }
+and replacing_direction = Leading | Trailing
+
+type partial_replacing =
+  {
+    repl_dir: replacing_direction;
+    repl_strict: bool;
+  }