Merge pull request #331 from NeoKaios/feat/relax-order-env-paragraph

Relax order of paragraphs in `CONFIGURATION SECTION`

CHANGELOG.md

@@ -8,6 +8,7 @@
 - COBOL language configuration for highlighting matching brackets and auto-insertion of line numbers in fixed-format code [#330](https://github.com/OCamlPro/superbol-studio-oss/pull/330)
 
 ### Fixed
+- Improvements to the grammar [#331](https://github.com/OCamlPro/superbol-studio-oss/pull/331)
 - Word wrapping in presence of hyphens [#330](https://github.com/OCamlPro/superbol-studio-oss/pull/330)
 
 

src/lsp/cobol_parser/grammar.mly

@@ -232,6 +232,34 @@ let ioloc (X) ==
   |             {None}
   | ~ = loc(X); <Some>
 
+let any_permut2 (A, B) :=
+ | a = A; b = ro(B); { (Some a, b, AB) }
+ | b = B; a = ro(A); { (a, Some b, BA) }
+
+let any_permut2_nullable [@recovery (None, None, AB)] (A, B) :=
+ | any_permut2(A, B)
+ | { (None, None, AB) }
+
+let any_permut3 (A, B, C) :=
+ | a = A; u = any_permut2_nullable(B, C); { prepend_as_trio @@ `A (Some a, u) }
+ | b = B; u = any_permut2_nullable(A, C); { prepend_as_trio @@ `B (Some b, u) }
+ | c = C; u = any_permut2_nullable(A, B); { prepend_as_trio @@ `C (Some c, u) }
+
+let any_permut3_nullable [@recovery (None, None, None, (A3, AB))] (A, B, C) :=
+ | any_permut3(A, B, C)
+ | { (None, None, None, (A3, AB)) }
+
+let any_permut4 (A, B, C, D) :=
+ | a = A; u = any_permut3_nullable(B, C, D); { prepend_as_quartet @@ `A (Some a, u) }
+ | b = B; u = any_permut3_nullable(A, C, D); { prepend_as_quartet @@ `B (Some b, u) }
+ | c = C; u = any_permut3_nullable(A, B, D); { prepend_as_quartet @@ `C (Some c, u) }
+ | d = D; u = any_permut3_nullable(A, B, C); { prepend_as_quartet @@ `D (Some d, u) }
+
+let any_permut4_nullable [@recovery (None, None, None, None, (A4, (A3, AB)))]
+                 (A, B, C, D) :=
+ | any_permut4(A, B, C, D)
+ | { (None, None, None, None, (A4, (A3, AB))) }
+
 (* --------------------- COMPILATION GROUPS AND UNITS ---------------------- *)
 
 let compilation_group :=
@@ -608,33 +636,36 @@ let intermediate_rounding_clause [@context intermediate_rounding_clause] :=
 
 let environment_division :=
  | ENVIRONMENT; DIVISION; ".";
-   env_configuration = ro(loc(configuration_section));
-   env_input_output  = ro(loc(input_output_section));
-   { { env_configuration; env_input_output } }
+   permuted = any_permut2_nullable(
+                       loc(configuration_section),
+                       loc(input_output_section));
+   { let (env_configuration, env_input_output, env_order) = permuted in
+     { env_configuration; env_input_output; env_order } }
  (* Allows skipping ENVIRONMENT DIVISION on MF *)
- | env_configuration = loc(configuration_section);
-   env_input_output  = ro(loc(input_output_section));
-   { { env_configuration = Some env_configuration;
-       env_input_output } }
- | env_input_output  = loc(input_output_section);
-   { { env_configuration = None;
-       env_input_output = Some env_input_output } }
+ | permuted = any_permut2(loc(configuration_section), loc(input_output_section));
+   { let (env_configuration, env_input_output, env_order) = permuted in
+     { env_configuration; env_input_output; env_order } }
 
 
 (* ------------- ENVIRONMENT DIVISION / CONFIGURATION SECTION -------------- *)
 
 let configuration_section :=
  | CONFIGURATION; SECTION; ".";
-   source_computer_paragraph = ro(loc(source_computer_paragraph));
-   object_computer_paragraph = ro(loc(object_computer_paragraph));
-   special_names_paragraph   = ro(loc(special_names_paragraph));
-   repository_paragraph      = ro(loc(repository_paragraph));     (* +COB2002 *)
-   { { source_computer_paragraph;
-       object_computer_paragraph;
-       special_names_paragraph;
-       repository_paragraph } }
-
-
+   permuted = any_permut4_nullable(
+                          loc(source_computer_paragraph),
+                          loc(object_computer_paragraph),
+                          loc(special_names_paragraph),
+                          loc(repository_paragraph));
+  { let (source_computer_paragraph,
+         object_computer_paragraph,
+         special_names_paragraph,
+         repository_paragraph,
+         conf_sec_order) = permuted in
+    { source_computer_paragraph;
+      object_computer_paragraph;
+      special_names_paragraph;
+      repository_paragraph;
+      conf_sec_order } }
 
 (* ENVIRONMENT DIVISION / CONFIGURATION SECTION / SOURCE-COMPUTER PARAGRAPH *)
 

src/lsp/cobol_ptree/common.ml

@@ -30,3 +30,57 @@ type 'a nel = 'a NEL.t
 [@@deriving ord]
 
 let pp_nel ppe = NEL.pp ~fsep:"@ " ~fopen:"" ~fclose:"" ppe
+
+type permutation_duo = AB | BA
+
+and trio_head = A3 | B3 | C3
+
+and permutation_trio = trio_head * permutation_duo
+
+and quartet_head = A4 | B4 | C4 | D4
+
+and permutation_quartet = quartet_head * permutation_trio
+[@@deriving ord]
+
+let prepend_as_trio: _ -> _ * _ * _ * permutation_trio = function
+  | `A (a, (b, c, duo)) -> (a, b, c, (A3, duo))
+  | `B (b, (a, c, duo)) -> (a, b, c, (B3, duo))
+  | `C (c, (a, b, duo)) -> (a, b, c, (C3, duo))
+
+let prepend_as_quartet: _ -> _ * _ * _ * _ * permutation_quartet = function
+  | `A (a, (b, c, d, trio)) -> (a, b, c, d, (A4, trio))
+  | `B (b, (a, c, d, trio)) -> (a, b, c, d, (B4, trio))
+  | `C (c, (a, b, d, trio)) -> (a, b, c, d, (C4, trio))
+  | `D (d, (a, b, c, trio)) -> (a, b, c, d, (D4, trio))
+
+let fold_duo duo (a, b) (fa, fb) acc =
+  match duo with
+  | AB -> acc |> fa a |> fb b
+  | BA -> acc |> fb b |> fa a
+
+let fold_trio trio (a,b,c) (fa, fb, fc) acc =
+  match trio with
+  | A3, duo -> acc |> fa a |> fold_duo duo (b,c) (fb, fc)
+  | B3, duo -> acc |> fb b |> fold_duo duo (a,c) (fa, fc)
+  | C3, duo -> acc |> fc c |> fold_duo duo (a,b) (fa, fb)
+
+let fold_quartet quartet (a,b,c,d) (fa, fb, fc, fd) acc =
+  match quartet with
+  | A4, trio -> acc |> fa a |> fold_trio trio (b,c,d) (fb, fc, fd)
+  | B4, trio -> acc |> fb b |> fold_trio trio (a,c,d) (fa, fc, fd)
+  | C4, trio -> acc |> fc c |> fold_trio trio (a,b,d) (fa, fb, fd)
+  | D4, trio -> acc |> fd d |> fold_trio trio (a,b,c) (fa, fb, fc)
+
+let unit_acc (f: 'a -> unit) = fun x () -> f x
+
+let iter_duo duo tuple (fa, fb) =
+  fold_duo duo tuple (unit_acc fa, unit_acc fb) ()
+
+let iter_trio trio tuple (fa, fb, fc) =
+  fold_trio trio tuple
+    (unit_acc fa, unit_acc fb, unit_acc fc) ()
+
+let iter_quartet quartet tuple (fa, fb, fc, fd) =
+  fold_quartet quartet tuple
+    (unit_acc fa, unit_acc fb, unit_acc fc, unit_acc fd) ()
+

src/lsp/cobol_ptree/env_division.ml

@@ -21,6 +21,7 @@ type environment_division =
   {
     env_configuration: configuration_section with_loc option;
     env_input_output: input_output_section with_loc option;
+    env_order: permutation_duo;
   }
 [@@deriving ord]
 
@@ -31,6 +32,7 @@ and configuration_section =
     object_computer_paragraph: object_computer_paragraph with_loc option;
     special_names_paragraph: special_names_paragraph with_loc option;
     repository_paragraph: repository_paragraph with_loc option;   (* +COB2002 *)
+    conf_sec_order: permutation_quartet;
   }
 
 (* ENVIRONMENT DIVISION / CONFIGURATION SECTION / SOURCE-COMPUTER PARAGRAPH *)
@@ -560,14 +562,15 @@ let pp_special_names_paragraph ppf sncs =
       Fmt.(list ~sep:sp (pp_with_loc pp_special_names_clause)) sncs
 
 let pp_configuration_section ppf
-  { source_computer_paragraph = scp; object_computer_paragraph = ocp;
-    special_names_paragraph = snp; repository_paragraph = rp }
-=
-  Fmt.pf ppf "CONFIGURATION SECTION.%a%a%a%a"
-    Fmt.(option (sp ++ pp_with_loc pp_source_computer_paragraph)) scp
-    Fmt.(option (sp ++ pp_with_loc pp_object_computer_paragraph)) ocp
-    Fmt.(option (sp ++ pp_with_loc pp_special_names_paragraph)) snp
-    Fmt.(option (sp ++ pp_with_loc pp_repository_paragraph)) rp
+    { source_computer_paragraph = scp; object_computer_paragraph = ocp;
+      special_names_paragraph = snp; repository_paragraph = rp; conf_sec_order }
+  =
+  Fmt.pf ppf "CONFIGURATION SECTION.";
+  iter_quartet conf_sec_order (scp, ocp, snp, rp)
+    Fmt.(option (sp ++ pp_with_loc pp_source_computer_paragraph) ppf,
+         option (sp ++ pp_with_loc pp_object_computer_paragraph) ppf,
+         option (sp ++ pp_with_loc pp_special_names_paragraph) ppf,
+         option (sp ++ pp_with_loc pp_repository_paragraph) ppf)
 
 let pp_record_delimiter ppf = function
   | Standard_1 -> Fmt.pf ppf "STANDARD-1"
@@ -656,8 +659,9 @@ let pp_input_output_section ppf
   Fmt.(option (sp ++ pp_with_loc pp_io_control_paragraph)) ppf icp
 
 let pp_environment_division ppf
-  { env_configuration = ec; env_input_output = eio }
-=
-  Fmt.pf ppf "ENVIRONMENT DIVISION.%a%a"
-    Fmt.(option (sp ++ pp_with_loc pp_configuration_section)) ec
-    Fmt.(option (sp ++ pp_with_loc pp_input_output_section)) eio
+    { env_configuration = ec; env_input_output = eio; env_order }
+  =
+  Fmt.pf ppf "ENVIRONMENT DIVISION.";
+  iter_duo env_order (ec, eio)
+    Fmt.(option (sp ++ pp_with_loc pp_configuration_section) ppf,
+         option (sp ++ pp_with_loc pp_input_output_section) ppf)

src/lsp/cobol_ptree/env_division_visitor.ml

@@ -451,15 +451,17 @@ let fold_configuration_section (v: _ #folder) =
     ~continue:begin fun { source_computer_paragraph;
                           object_computer_paragraph;
                           special_names_paragraph;
-                          repository_paragraph } x -> x
-      >> fold_option v source_computer_paragraph
-        ~fold:fold_source_computer_paragraph'
-      >> fold_option v object_computer_paragraph
-        ~fold:fold_object_computer_paragraph'
-      >> fold_option v special_names_paragraph
-        ~fold:fold_special_names_paragraph'
-      >> fold_option v repository_paragraph
-        ~fold:fold_repository_paragraph'
+                          repository_paragraph;
+                          conf_sec_order } x -> x
+      >> fold_quartet conf_sec_order
+        (source_computer_paragraph,
+         object_computer_paragraph,
+         special_names_paragraph,
+         repository_paragraph)
+        (fold_option v ~fold:fold_source_computer_paragraph',
+         fold_option v ~fold:fold_object_computer_paragraph',
+         fold_option v ~fold:fold_special_names_paragraph',
+         fold_option v ~fold:fold_repository_paragraph')
     end
 
 let fold_configuration_section' (v: _ #folder) =
@@ -468,9 +470,10 @@ let fold_configuration_section' (v: _ #folder) =
 
 let fold_environment_division (v: _ #folder) =
   handle v#fold_environment_division
-    ~continue:begin fun { env_configuration; env_input_output } x -> x
-      >> fold_option ~fold:fold_configuration_section' v env_configuration
-      >> fold_option ~fold:fold_input_output_section' v env_input_output
+    ~continue:begin fun { env_configuration; env_input_output; env_order } x -> x
+      >> fold_duo env_order (env_configuration, env_input_output)
+        (fold_option ~fold:fold_configuration_section' v,
+         fold_option ~fold:fold_input_output_section' v)
     end
 
 let fold_environment_division' (v: _ #folder) =

test/output-tests/run_fundamental.expected

@@ -215,16 +215,6 @@ run_fundamental.at-1390-prog.cob:18.11-18.17:
   20          END FUNCTION f2.
 >> Warning: Invalid syntax
 
-run_fundamental.at-1390-prog.cob:29.7-29.20:
-  26          REPOSITORY.
-  27              FUNCTION f1
-  28              FUNCTION f2.
-  29 >        SPECIAL-NAMES.
-----          ^^^^^^^^^^^^^
-  30              CURRENCY SIGN IS "Y"
-  31              DECIMAL-POINT IS COMMA.
->> Error: Invalid syntax
-
 run_fundamental.at-1390-prog.cob:45.19-45.20:
   42          77  curr  PIC 9.9999,99Y.
   43   

test/output-tests/syn_misc.expected

@@ -1494,55 +1494,7 @@ syn_misc.at-2876-prog.cob:6.11-6.17:
 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:2910:0
 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:2943:0
 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:2987:0
-syn_misc.at-2987-prog.cob:8.7-8.22:
-   5          ENVIRONMENT    DIVISION.
-   6          CONFIGURATION  SECTION.
-   7          OBJECT-COMPUTER. a.
-   8 >        SOURCE-COMPUTER. b.
-----          ^^^^^^^^^^^^^^^
->> Error: Invalid syntax
-
 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:3048:0
-syn_misc.at-3048-prog.cob:8.7-8.22:
-   5          ENVIRONMENT    DIVISION.
-   6          CONFIGURATION  SECTION.
-   7          REPOSITORY.
-   8 >        SOURCE-COMPUTER. b.
-----          ^^^^^^^^^^^^^^^
-   9          OBJECT-COMPUTER. a.
-  10          SPECIAL-NAMES.
->> Error: Invalid syntax
-
-syn_misc.at-3048-prog.cob:22.7-22.20:
-  19          SOURCE-COMPUTER. b.
-  20          OBJECT-COMPUTER. a.
-  21          REPOSITORY.
-  22 >        SPECIAL-NAMES.
-----          ^^^^^^^^^^^^^
-  23   
-  24          END PROGRAM prog2.
->> Error: Invalid syntax
-
-syn_misc.at-3048-prog.cob:32.7-32.22:
-  29          ENVIRONMENT    DIVISION.
-  30          CONFIGURATION  SECTION.
-  31          REPOSITORY.
-  32 >        SOURCE-COMPUTER. b.
-----          ^^^^^^^^^^^^^^^
-  33          OBJECT-COMPUTER. a.
-  34   
->> Error: Invalid syntax
-
-syn_misc.at-3048-prog.cob:43.7-43.20:
-  40          ENVIRONMENT    DIVISION.
-  41          CONFIGURATION  SECTION.
-  42          REPOSITORY.
-  43 >        SPECIAL-NAMES.
-----          ^^^^^^^^^^^^^
-  44          SOURCE-COMPUTER. b.
-  45          OBJECT-COMPUTER. a.
->> Error: Invalid syntax
-
 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:3104:0
 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:3107:0
 Considering: import/gnucobol/tests/testsuite.src/syn_misc.at:3109:0