Rewindable parser

src/lsp/cobol_ast/misc_descr.ml

@@ -14,25 +14,26 @@
 open Terms
 open Operands
 
-let if_empty pp_el pp_nel ppf = function
-  | [] -> pp_el ppf ()
-  | xs -> pp_nel ppf xs
-
-let elist ?prefix:(prf = Fmt.nop) ?sep pp =
-  if_empty Fmt.nop Fmt.(prf ++ list ?sep pp)
-
 
 (* -------------------- IDENTIFICATION DIVISION (EXTRA) -------------------- *)
 
 type informational_paragraphs =
-  {
-    author: string with_loc option;
-    installation: string with_loc option;
-    date_written: string with_loc option;
-    date_compiled: string with_loc option;
-    security: string with_loc option;
-  }
-[@@deriving show, ord]
+  informational_paragraph with_loc list
+[@@deriving ord]
+
+and informational_paragraph =
+  informational_paragraph_header * comment_entry with_loc
+
+and informational_paragraph_header =
+  | Author
+  | DateCompiled
+  | DateModified
+  | DateWritten
+  | Installation
+  | Remarks
+  | Security
+
+and comment_entry = string list
 
 
 (* ------------------------- ENVIRONMENT DIVISION -------------------------- *)
@@ -655,7 +656,8 @@ let pp_select_clause ppf = function
   | SelectRecordKey { key; source } ->
     Fmt.pf ppf "RECORD %a%a"
       pp_qualname key
-      Fmt.(elist ~prefix:(any "SOURCE ") ~sep:sp pp_name') source
+      Pretty.(list ~fopen:"SOURCE " ~fsep:"@ " ~fclose:"" ~fempty:""
+                pp_name') source
   | SelectRelativeKey n ->
     Fmt.pf ppf "RELATIVE %a" pp_name' n
   | SelectReserve n -> Fmt.pf ppf "RESERVE %a" pp_integer n
@@ -711,6 +713,8 @@ and arithmetic_mode =
 and entry_convention =
   | COBOL
 
+(* --- *)
+
 let pp_entry_convention ppf = function
   | COBOL -> Fmt.pf ppf "COBOL"
 
@@ -721,21 +725,46 @@ let pp_arithmetic_mode ppf = function
   | StandardDecimal -> Fmt.pf ppf "STANDARD-DECIMAL"
 
 let pp_options_clause ppf = function
-  | Arithmetic am -> Fmt.pf ppf "ARITHMETIC %a" pp_arithmetic_mode am
+  | Arithmetic am ->
+      Fmt.pf ppf "ARITHMETIC %a" pp_arithmetic_mode am
   | DefaultRoundedMode rm ->
-    Fmt.pf ppf "DEFAULT ROUNDED MODE %a" pp_rounding_mode rm
+      Fmt.pf ppf "DEFAULT ROUNDED MODE %a" pp_rounding_mode rm
   | EntryConvention ec ->
-    Fmt.pf ppf "ENTRY-CONVENTION %a" pp_entry_convention ec
+      Fmt.pf ppf "ENTRY-CONVENTION %a" pp_entry_convention ec
   | FloatBinaryDefault em ->
-    Fmt.pf ppf "FLOAT-BINARY %a" Data_descr.pp_endianness_mode em
+      Fmt.pf ppf "FLOAT-BINARY %a" Data_descr.pp_endianness_mode em
   | FloatDecimalDefault ee ->
-    Fmt.pf ppf "FLOAT-DECIMAL %a" Data_descr.pp_encoding_endianness ee
+      Fmt.pf ppf "FLOAT-DECIMAL %a" Data_descr.pp_encoding_endianness ee
   | IntermediateRounding rm ->
-    Fmt.pf ppf "INTERMEDIATE-ROUNDING %a" pp_rounding_mode rm
+      Fmt.pf ppf "INTERMEDIATE-ROUNDING %a" pp_rounding_mode rm
 
 let pp_options_paragraph : options_paragraph Fmt.t =
-  Fmt.(
-    any "OPTIONS.@ " ++
-    box (list ~sep:sp (pp_with_loc pp_options_clause))
-    ++ any "."
-  )
+  Fmt.(any "OPTIONS.@ " ++
+       box (list ~sep:sp (pp_with_loc pp_options_clause)) ++
+       any ".")
+
+
+(* --- *)
+
+let pp_informational_paragraph_header ppf = function
+  | Author -> Fmt.pf ppf "AUTHOR"
+  | DateCompiled -> Fmt.pf ppf "DATE-COMPILED"
+  | DateModified -> Fmt.pf ppf "DATE-MODIFIED"
+  | DateWritten -> Fmt.pf ppf "DATE-WRITTEN"
+  | Installation -> Fmt.pf ppf "INSTALLATION"
+  | Remarks -> Fmt.pf ppf "REMARKS"
+  | Security -> Fmt.pf ppf "SECURITY"
+
+let pp_comment_entry: comment_entry Pretty.printer =
+  Fmt.(list ~sep:sp string)
+
+let pp_informational_paragraph: informational_paragraph Pretty.printer =
+  Fmt.(any "@[<4>" ++                       (* <- indent by 4 to avoid Area A *)
+       pair ~sep:(any ".@ ")
+         pp_informational_paragraph_header
+         (pp_with_loc pp_comment_entry) ++
+       any "@]")
+
+let pp_informational_paragraphs: informational_paragraphs Pretty.printer =
+  Fmt.(list ~sep:(any "@\n")                                (* force newlines *)
+         (pp_with_loc pp_informational_paragraph))

src/lsp/cobol_ast/raw.ml

@@ -13,17 +13,10 @@
 
 open Ast
 
-module Misc_sections = struct
-  type informational_paragraphs        = Ast.informational_paragraphs
-  let pp_informational_paragraphs      = Ast.pp_informational_paragraphs
-  let compare_informational_paragraphs = Ast.compare_informational_paragraphs
-  type options_paragraph               = Ast.options_paragraph
-  let pp_options_paragraph             = Ast.pp_options_paragraph
-  let compare_options_paragraph        = Ast.compare_options_paragraph
-  type environment_division            = Ast.environment_division
-  let pp_environment_division          = Ast.pp_environment_division
-  let compare_environment_division     = Ast.compare_environment_division
-end
+module Misc_sections: Abstract.MISC_SECTIONS
+  with type informational_paragraphs = Ast.informational_paragraphs
+   and type options_paragraph        = Ast.options_paragraph
+   and type environment_division     = Ast.environment_division = Ast
 
 module Data_sections (Picture: Abstract.PICTURE) = struct
   include Picture
@@ -819,9 +812,13 @@ struct
     | ProgramDefinition of
         {       (* Note: more general than before (allows nested prototypes): *)
           kind: program_kind option;
-          has_identification_division: bool;
-          informational_paragraphs: informational_paragraphs
-            [@compare fun _ _ -> 0]; (* ~COB85, -COB2002 *)
+          has_identification_division_header: bool;
+          preliminary_informational_paragraphs:
+            informational_paragraphs         (* GC extension (before PROGRAM-ID) *)
+            [@compare fun _ _ -> 0];
+          supplementary_informational_paragraphs:
+            informational_paragraphs
+            [@compare fun _ _ -> 0];                         (* ~COB85, -COB2002 *)
           nested_programs: program_unit with_loc list;
         }
     | ProgramPrototype
@@ -837,42 +834,37 @@ struct
     | Initial -> Fmt.pf ppf "INITIAL"
     | Recursive -> Fmt.pf ppf "RECURSIVE"
 
-  let rec pp_program_unit ppf {
-    program_name;
-    program_as;
-    program_level;
-    program_options;
-    program_env;
-    program_data;
-    program_proc;
-    program_end_name;
-  } =
-    let has_identification_division =
+  let rec pp_program_unit ppf { program_name;
+                                program_as;
+                                program_level;
+                                program_options;
+                                program_env;
+                                program_data;
+                                program_proc;
+                                program_end_name } =
+    let has_identification_division_header,
+        preliminary_info, supplementary_info,
+        nested_programs,
+        kind =
       match program_level with
-      | ProgramDefinition { has_identification_division = true; _ } -> true
-      | _ -> false
+      | ProgramDefinition { has_identification_division_header = p;
+                            preliminary_informational_paragraphs = ip0;
+                            supplementary_informational_paragraphs = ip1;
+                            nested_programs;
+                            kind } ->
+          p, Some ip0, Some ip1, nested_programs, Some kind
+      | ProgramPrototype ->
+          false, None, None, [], None
     in
-    let nested_programs =
-      match program_level with
-      | ProgramDefinition { nested_programs; _ } -> nested_programs
-      | ProgramPrototype -> []
-    in
-    let _informational_paragraphs =
-      match program_level with
-      | ProgramDefinition { informational_paragraphs = ip; _ } -> Some ip
-      | ProgramPrototype -> None
-    in
-    if has_identification_division then
-      Fmt.pf ppf "@[IDENTIFICATION@ DIVISION@].@ ";
+    if has_identification_division_header then
+      Fmt.pf ppf "@[IDENTIFICATION@ DIVISION@].@\n";
+    Fmt.(option pp_informational_paragraphs) ppf preliminary_info;
     Fmt.pf ppf "@[PROGRAM-ID.@ %a" (pp_with_loc pp_name) program_name;
     Fmt.(option (any "@ AS " ++ pp_strlit)) ppf program_as;
-    (
-      match program_level with
-      | ProgramDefinition { kind; _ } ->
-        Fmt.(option (sp ++ pp_program_kind)) ppf kind
-      | ProgramPrototype -> Fmt.pf ppf "@ PROTOTYPE"
-    );
-    Fmt.pf ppf ".@]";
+    Fmt.(option (option (sp ++ pp_program_kind))
+           ~none:(any "@ PROTOTYPE")) ppf kind;
+    Fmt.pf ppf ".@]@\n";
+    Fmt.(option pp_informational_paragraphs) ppf supplementary_info;
     Fmt.(option (sp ++ pp_with_loc pp_options_paragraph)) ppf program_options;
     Fmt.(option (sp ++ pp_with_loc pp_environment_division)) ppf program_env;
     Fmt.(option (sp ++ pp_with_loc pp_data_division)) ppf program_data;

src/lsp/cobol_ast/raw_compilation_group_visitor.ml

@@ -104,21 +104,27 @@ struct
       ~continue:begin fun { program_name; program_as; program_level;
                             program_options; program_env; program_data;
                             program_proc; program_end_name } x -> x
-        >> fold_name' v program_name
-        >> fold_strlit_opt v program_as
+        >> (fun x -> match program_level with
+            | ProgramPrototype -> x
+                >> fold_name' v program_name
+                >> fold_strlit_opt v program_as
+            | ProgramDefinition { (* has_identification_division_header; *)
+                                  preliminary_informational_paragraphs = infos0;
+                                  supplementary_informational_paragraphs = infos1;
+                                  kind; _ } -> ignore kind; x
+                (* >> fold_bool v has_identification_division_header *)
+                >> v#continue_with_informational_paragraphs infos0
+                >> fold_name' v program_name
+                >> fold_strlit_opt v program_as
+                >> v#continue_with_informational_paragraphs infos1)
         >> fold_options_paragraph'_opt v program_options
         >> fold_environment_division'_opt v program_env
         >> fold_data_division'_opt v program_data
+        >> fold_procedure_division'_opt v program_proc
         >> (fun x -> match program_level with
             | ProgramPrototype -> x
-            | ProgramDefinition { kind;
-                                  has_identification_division;
-                                  informational_paragraphs = infos;
-                                  nested_programs } -> ignore kind; x
-                >> fold_bool v has_identification_division
-                >> v#continue_with_informational_paragraphs infos
-                >> fold_with_loc_list v nested_programs ~fold:fold_program_unit)
-        >> fold_procedure_division'_opt v program_proc
+            | ProgramDefinition { nested_programs; _ } -> x
+                >> fold_with_loc_list v ~fold:fold_program_unit nested_programs)
         >> fold_name'_opt v program_end_name                  (* XXX: useful? *)
       end
 

src/lsp/cobol_ast/raw_misc_sections_visitor.ml

@@ -31,6 +31,7 @@ module Make = struct
   class virtual ['a] folder = object
     inherit ['a] Terms_visitor.folder
     inherit ['a] Misc_sections_visitor.folder
+    method fold_informational_paragraph': (informational_paragraph with_loc, 'a) fold = default
     method fold_options_clause: (options_clause, 'a) fold = default
     method fold_configuration_section: (configuration_section, 'a) fold = default
     method fold_configuration_section': (configuration_section with_loc, 'a) fold = default
@@ -161,16 +162,12 @@ module Make = struct
 
   (* --- *)
 
+  let fold_informational_paragraph' (v: _ #folder) =
+    leaf' v#fold_informational_paragraph' v
+
   let fold_informational_paragraphs (v: _ #folder) =
     handle v#fold_informational_paragraphs
-      ~continue:begin fun { author; installation; date_written;
-                            date_compiled; security } x -> x
-        >> fold_string'_opt v author
-        >> fold_string'_opt v installation
-        >> fold_string'_opt v date_written
-        >> fold_string'_opt v date_compiled
-        >> fold_string'_opt v security
-      end
+      ~continue:(fold_list ~fold:fold_informational_paragraph' v)
 
   let fold_options_paragraph (v: _ #folder) =
     handle v#fold_options_paragraph

src/lsp/cobol_ast/unparse.ml

@@ -1,3 +1,16 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                        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.                                                   *)
+(*                                                                        *)
+(**************************************************************************)
+
 module Expression : sig
   type precedence = int
 
@@ -105,4 +118,4 @@ end = struct
     AnyOp op, Fmt.(lhs ++ any " " ++ name ++ sp ++ rhs)
 
   let pp ppf (_, pp) = pp ppf ()
-end
+end

src/lsp/cobol_ast/unparse.mli

@@ -1,3 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                        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.                                                   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* NB: This module is not specific to COBOL; it does not really fit within
+   `cobol_ast`. *)
+
 module Expression : sig
   type precedence = int
   (** Operator precedence is represented using integers. Operators with a higher
@@ -38,4 +54,4 @@ module Expression : sig
   val unary : unary_op -> t -> t
 
   val binary : t -> binary_op -> t -> t
-end
+end

src/lsp/cobol_common/diagnostics.ml

@@ -199,6 +199,8 @@ let simple_result r = result r
 let some_result ?diags r = result ?diags (Some r)
 let no_result ~diags = { result = None; diags }
 let map_result f { result; diags } = { result = f result; diags }
+let more_result f { result; diags } = with_more_diags ~diags (f result)
+let forget_result { diags; _ } = diags
 
 let hint_result r = Cont.khint (with_diag r)
 let note_result r = Cont.knote (with_diag r)

src/lsp/cobol_common/diagnostics.mli

@@ -108,6 +108,8 @@ val simple_result: 'a -> 'a with_diags
 val some_result: ?diags:diagnostics -> 'a -> 'a option with_diags
 val no_result: diags:diagnostics -> _ option with_diags
 val map_result: ('a -> 'b) -> 'a with_diags -> 'b with_diags
+val more_result: ('a -> 'b with_diags) -> 'a with_diags -> 'b with_diags
+val forget_result: _ with_diags -> diagnostics
 
 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_common/visitor.ml

@@ -157,9 +157,15 @@ module Fold = struct
 
   (** Helper to shorten definitions for traversal of nodes with source
       locations *)
+  (* NOTE: we consider the traversal of `t with_loc` as a whole before the
+     generic traversal of `_ with_loc` via [fold'].  Maybe doing it the other
+     way round would be more intuitive? *)
   let handle' vfold ~fold (v: _ #folder) =
     handle vfold ~continue:(fold' ~fold v)
 
+  let leaf' vfold =
+    handle' vfold ~fold:(fun _ _ -> Fun.id)
+
   (* --- *)
 
   (** Reports a missing folding visitor implementation {e once}. *)

src/lsp/cobol_lsp/lsp_completion_keywords.ml

@@ -13,7 +13,7 @@
 
 (* open Cobol_common.Basics *)
 
-let keywords_all = fst @@ List.split Cobol_parser.Text_keywords.keywords
+let keywords_all = fst @@ List.split Cobol_parser.Keywords.keywords
 
 
 (* TODO: Too many keywords, hard to classification *)
@@ -326,4 +326,3 @@ let keywords_data = [
 let keywords_data = StringSet.elements @@ StringSet.of_list keywords_data
 let keywords_proc = StringSet.elements @@ StringSet.of_list (keywords_proc @ keywords_proc_other)
  *)
-