Merge pull request #62 from nberth/src-line-folding

Support changes of reference format when folding over source lines

.drom

@@ -5,7 +5,7 @@ version:0.9.0
 
 # hash of toml configuration files
 # used for generation of all files
-65727d1df3313fa04a075346c1986694:.
+f593ca640b0428b52f00f9a54b784372:.
 # end context for .
 
 # begin context for .github/workflows/workflow.yml
@@ -340,7 +340,7 @@ c830729656f586961a44188b55cb4ac6:src/lsp/cobol_data/dune
 
 # begin context for src/lsp/cobol_preproc/dune
 # file src/lsp/cobol_preproc/dune
-801b4cd6ad70e6c633b48431afb67519:src/lsp/cobol_preproc/dune
+72290e9f09cebbc9fdea47a9045c0330:src/lsp/cobol_preproc/dune
 # end context for src/lsp/cobol_preproc/dune
 
 # begin context for src/lsp/cobol_preproc/version.mlt

src/lsp/cobol_common/diagnostics.ml

@@ -66,6 +66,14 @@ let is_error = function
   | { severity = Error; _ } -> true
   | _ -> false
 
+let compare_severity a b =
+  if a = b then 0 else match a, b with
+    | Hint, _ -> -1 | _, Hint -> 1
+    | Note, _ -> -1 | _, Note -> 1
+    | Info, _ -> -1 | _, Info -> 1
+    | Warn, _ -> -1 | _, Warn -> 1
+    | Error, _ -> -1
+
 let pp_msg ppf diag = diag.message ppf
 let message diag = diag.message
 let severity diag = diag.severity
@@ -126,6 +134,9 @@ module Set = struct
   let pp ppf diags =
     Pretty.list ~fopen:"@[<v>" ~fclose:"@]@\n" ~fsep:"@\n" ~fempty:""
       pp ppf (sort diags)
+  let pp_above ~level ppf diags =
+    pp ppf @@
+    List.filter (fun { severity; _ } -> compare_severity level severity <= 0) diags
   let none: t = []
   let one d = [d]
   let two d d' = [d; d']
@@ -211,6 +222,10 @@ let cons_option_result = function
 let forget_result { diags; _ } = diags
 let merge_results ~f r1 r2 =
   result (f r1.result r2.result) ~diags:(Set.union r1.diags r2.diags)
+let show_n_forget ?(min_level = Hint) ?(ppf = Fmt.stderr) { result; diags } =
+  Set.pp_above ~level:min_level ppf diags;
+  result
+
 
 let hint_result r = Cont.khint (with_diag r)
 let note_result r = Cont.knote (with_diag r)

src/lsp/cobol_common/diagnostics.mli

@@ -115,6 +115,7 @@ val more_result: f:('a -> 'b with_diags) -> 'a with_diags -> 'b with_diags
 val cons_option_result: 'a option with_diags -> 'a list with_diags -> 'a list with_diags
 val forget_result: _ with_diags -> diagnostics
 val merge_results: f:('a -> 'b -> 'c) -> 'a with_diags -> 'b with_diags -> 'c with_diags
+val show_n_forget: ?min_level:severity -> ?ppf:Format.formatter -> 'a with_diags -> 'a
 
 val hint_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func
 val note_result: 'a -> ?loc:Srcloc.srcloc -> ('b, 'a with_diags) Pretty.func

src/lsp/cobol_config/cobol_config.ml

@@ -283,3 +283,5 @@ let from_dialect (module Diags: DIAGS.STATEFUL) ~strict d =
   | Realia          -> load_gnucobol_conf d ~strict       "realia"
   | RM              -> load_gnucobol_conf d ~strict       "rm"
   | XOpen           -> load_gnucobol_conf d ~strict       "xopen"
+
+let dialect (module C: T) = C.dialect

src/lsp/cobol_config/cobol_config.mli

@@ -38,3 +38,5 @@ val from_dialect
   -> strict: bool
   -> Types.DIALECT.t
   -> (module T)
+
+val dialect: t -> dialect

src/lsp/cobol_indent/cobol_indent.ml

@@ -11,20 +11,17 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* If you delete or rename this file, you should add
-   'src/cobol_indent/main.ml' to the 'skip' field in "drom.toml" *)
-
 module Type = Indent_type
 
 (*return the result of indentation. use user-defined indent_config*)
 let indent_range' = Indenter.indent_range'
 
 (*indent the whole file and print*)
-let indent_file ~source_format ~file ~indent_config =
-  indent_range' ~source_format ~range:None ~indent_config ~file
+let indent_file ~dialect ~source_format ~file ~indent_config =
+  indent_range' ~dialect ~source_format ~range:None ~indent_config ~file
   |> Fmt.pr "%s"
 
 (*indent a range of file and print*)
-let indent_range ~source_format ~file ~range ~indent_config =
-  indent_range' ~source_format ~range ~indent_config ~file
+let indent_range ~dialect ~source_format ~file ~range ~indent_config =
+  indent_range' ~dialect ~source_format ~range ~indent_config ~file
   |> Fmt.pr "%s"

src/lsp/cobol_indent/indenter.ml

@@ -62,7 +62,7 @@ let indenter ~source_format (str:string) (rdl:indent_record list) range =
   String.concat "\n" strl
 
 (*indent a range of file, with the default indent_config*)
-let indent_range' ~source_format ~range ~file =
+let indent_range' ~dialect ~source_format ~range ~file =
   let file_content = Ez_file.V1.EzFile.read_file file in
   (*
     Not satisfied with the `Cobol_preproc.fold_text_lines`,
@@ -72,17 +72,19 @@ let indent_range' ~source_format ~range ~file =
      (* NB: not anymore. *)
   *)
   let state =
-    Cobol_preproc.fold_source_lines ~source_format
+    Cobol_preproc.fold_source_lines ~dialect ~source_format
+      ~skip_compiler_directives_text:false
       ~f:(fun _lnum line acc -> Indent_check.check_indentation line acc)
       (Filename file) { scope = BEGIN; context  = []; acc = []; range }
   in
-  let ind_recds = state.acc in
-  indenter ~source_format file_content ind_recds state.range
+  (* NB: note here we ignore diagnostics *)
+  let ind_recds = state.result.acc in
+  indenter ~source_format file_content ind_recds state.result.range
 
 (*indent a range of file, with the user-defined indent_config*)
-let indent_range' ~source_format ~indent_config ~range ~file =
+let indent_range' ~dialect ~source_format ~indent_config ~range ~file =
   begin match indent_config with
     | Some indent_config -> Indent_config.set_config ~indent_config
     | None -> ()
   end;
-  indent_range' ~source_format ~range ~file
+  indent_range' ~dialect ~source_format ~range ~file

src/lsp/cobol_indent/indenter.mli

@@ -13,7 +13,8 @@
 
 (*indent a range of file, with the user-defined or default indent_config*)
 val indent_range'
-  : source_format:Cobol_config.source_format_spec
+  : dialect: Cobol_config.dialect
+  -> source_format:Cobol_config.source_format_spec
   -> indent_config:string option
   -> range:Indent_type.range option
   -> file:string

src/lsp/cobol_lsp/lsp_request.ml

@@ -177,6 +177,7 @@ let handle_range_formatting registry params =
   in
   let newText =
     Cobol_indent.indent_range'
+      ~dialect:(Cobol_config.dialect project.cobol_config)
       ~source_format:project.source_format
       ~indent_config:None
       ~file:(Lsp.Uri.to_path doc.uri)
@@ -201,6 +202,7 @@ let handle_formatting registry params =
   try
     let newText =
       Cobol_indent.indent_range'
+        ~dialect:(Cobol_config.dialect project.cobol_config)
         ~source_format:project.source_format
         ~indent_config:None
         ~file:path
@@ -233,7 +235,7 @@ let handle_hover registry (params: HoverParams.t) =
   let find_hovered_pplog_event pplog =
     List.find_opt begin function
       | Cobol_preproc.Trace.Replace _
-      | LexDir _ ->
+      | CompilerDirective _ ->
           false
       | Replacement { matched_loc = loc; _ }
       | FileCopy { copyloc = loc; _ } ->
@@ -265,7 +267,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 _
+      | Some CompilerDirective _
       | None ->
           None
     end

src/lsp/cobol_lsp/lsp_semtoks.ml

@@ -570,7 +570,7 @@ 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.LexDir { loc; _ } ->
+    | Cobol_preproc.Trace.CompilerDirective { loc; _ } ->
         acc_semtoks ~filename ?range TOKTYP.macro loc acc
     | Cobol_preproc.Trace.Replacement _ ->
         acc

src/lsp/cobol_preproc/.gitattributes

@@ -0,0 +1,2 @@
+preproc_keywords.ml     linguist-generated
+compdir_keywords.ml     linguist-generated

src/lsp/cobol_preproc/compdir_grammar.mly

@@ -0,0 +1,79 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                        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 Compdir_tree
+%}
+
+%token EOL
+%token <string> TEXT_WORD
+%token <string> ALPHANUM
+%token CDIR_SET                  [@keyword ">>SET", "$SET"]
+%token CDIR_SOURCE               [@keyword ">>SOURCE", "$SOURCE"]
+%token FORMAT                    [@keyword]
+%token FREE                      [@keyword]                       (* +COB2002 *)
+%token IS                        [@keyword]
+%token SOURCEFORMAT              [@keyword]
+
+%token <Text.text_word> INVALID_
+
+(* Entry points *)
+
+%start <Compdir_tree.directive> compiler_directive
+
+%start <unit> _unused_symbols             (* <- used to supress some warnings *)
+
+(* -------------------------------------------------------------------------- *)
+
+%%
+
+(* --------------------- DEDICATED UTILITIES -------------------------------- *)
+
+let loc (X) ==
+  | x = X; { x, $sloc }
+
+(* --- Entry points --------------------------------------------------------- *)
+
+let compiler_directive :=
+  | ~ = source_format; EOL; < >
+  | ~ = set_sourceformat; EOL; < >
+  | ~ = set_generic; EOL; < >
+
+(* --- >>SOURCE | $ SET SOURCEFORMAT ---------------------------------------- *)
+
+let source_format :=
+  | CDIR_SOURCE; FORMAT?; IS?; free = loc(FREE);
+    { Source_format_is_free (snd free) }
+  | CDIR_SOURCE; FORMAT?; IS?; i = text_word;
+    { Source_format_is i }
+
+let set_sourceformat :=
+  | CDIR_SET; SOURCEFORMAT; i = loc(ALPHANUM);  (* elementary_string_literal? *)
+    { Set_sourceformat i }
+
+(* --- >>SET ... | $ SET ... ------------------------------------------------ *)
+
+let set_generic :=
+  | CDIR_SET; w = text_word;
+    { Set w }
+
+(* --- Misc ----------------------------------------------------------------- *)
+
+let text_word ==                                    (* text-word with position *)
+  | ~ = loc(TEXT_WORD); < >
+
+_unused_symbols:
+  | INVALID_
+{ () }
+
+%%

src/lsp/cobol_preproc/compdir_tree.ml

@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                        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
+
+type directive =
+  | Source_format_is_free of lexloc
+  | Source_format_is of (string * lexloc)
+  | Set_sourceformat of (string * lexloc)
+  | Set of (string * lexloc)

src/lsp/cobol_preproc/dune

@@ -24,6 +24,19 @@
   (package cobol_preproc))
 
 ; use field 'dune-trailer' to add more stuff here
+(menhir (modules grammar_common compdir_grammar)
+        (merge_into compdir_grammar)
+        (flags --cmly --table))
+
+(rule
+  (targets compdir_keywords.ml)
+  (enabled_if (<> %{profile} "release"))
+  (deps    compdir_grammar.cmly)
+  (mode    promote)
+  (action
+    (with-stdout-to %{targets}
+       (run %{exe:../cobol_parser/keywords/gen_keywords.exe} %{deps}))))
+
 (menhir (modules preproc_tokens grammar_common preproc_grammar)
         (merge_into preproc_grammar)
         (flags --cmly --table

src/lsp/cobol_preproc/grammar_common.mly

@@ -1,13 +1,14 @@
 %{
 (**************************************************************************)
 (*                                                                        *)
-(*  Copyright (c) 2022-2023 OCamlPro SAS                                  *)
+(*                        SuperBOL OSS Studio                             *)
 (*                                                                        *)
-(*  All rights reserved.                                                  *)
-(*  This file is distributed under the terms of the GNU Lesser General    *)
-(*  Public License version 2.1, with the special exception on linking     *)
-(*  described in the LICENSE.md file in the root directory.               *)
+(*  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.                                                   *)
 (*                                                                        *)
 (**************************************************************************)
 

src/lsp/cobol_preproc/package.toml

@@ -78,6 +78,19 @@ version = ">=1.2"
 [fields]
 dune-libraries = "str"
 dune-trailer = """
+(menhir (modules grammar_common compdir_grammar)
+        (merge_into compdir_grammar)
+        (flags --cmly --table))
+
+(rule
+  (targets compdir_keywords.ml)
+  (enabled_if (<> %{profile} "release"))
+  (deps    compdir_grammar.cmly)
+  (mode    promote)
+  (action
+    (with-stdout-to %{targets}
+       (run %{exe:../cobol_parser/keywords/gen_keywords.exe} %{deps}))))
+
 (menhir (modules preproc_tokens grammar_common preproc_grammar)
         (merge_into preproc_grammar)
         (flags --cmly --table

src/lsp/cobol_preproc/preproc_directives.ml

@@ -14,9 +14,9 @@
 open Cobol_common.Srcloc.TYPES
 open Text.TYPES
 
-type lexing_directive =
-  | LexDirSource:
-      'k Src_format.source_format with_loc -> lexing_directive         [@@unboxed]
+type compiler_directive =
+  | CDirSource of Src_format.any with_loc
+  | CDirSet of string with_loc
 
 type copy_statement =
   | CDirCopy of