Skip to content

Commit

Permalink
tmp: relax order different variant
Browse files Browse the repository at this point in the history
  • Loading branch information
@NeoKaios
NeoKaios committed Jul 30, 2024
1 parent c70742e commit e9d5057
Show file tree
Hide file tree
Showing 4 changed files with 296 additions and 24 deletions.
76 changes: 68 additions & 8 deletions src/lsp/cobol_parser/grammar.mly
View file
Original file line number Diff line number Diff line change
Expand Up @@ -623,16 +623,76 @@ let environment_division :=

(* ------------- ENVIRONMENT DIVISION / CONFIGURATION SECTION -------------- *)

let configuration_section :=
| CONFIGURATION; SECTION; "."; body = rl(configuration_body);
{ build_configuration_section body }
(*
(* order *)
let unorder2_opt (A, B) ==
| a = A; b = ro(B); { (P1 (Some a), P2 b) }
| b = B; a = ro(A); { (P2 a, P1 (Some b)) }
| { (P1 None, P2 None) }
let unorder3_opt (A, B, C) ==
| a = A; u = unorder2_opt(B, C); { let (b, c) = u in (P1 (Some a), ~+!b, ~+!c) }
| b = B; u = unorder2_opt(A, C); { let (a, c) = u in (~+!a, P1 (Some b), ~+!c) }
| c = C; u = unorder2_opt(A, B); { let (a, b) = u in (~+!a, ~+!b, P1 (Some c)) }
| { (P1 None, P2 None, P3 None) }
let unorder4_opt (A, B, C, D) ==
| a = A; u = unorder3_opt(B, C, D); { let (b, c, d) = u in (P1 (Some a), ~+!b, ~+!c, ~+!d) }
| b = B; u = unorder3_opt(A, C, D); { let (a, c, d) = u in (~+!a, P1 (Some b), ~+!c, ~+!d) }
| c = C; u = unorder3_opt(A, B, D); { let (a, b, d) = u in (~+!a, ~+!b, P1 (Some c), ~+!d) }
| d = D; u = unorder3_opt(A, B, C); { let (a, b, c) = u in (~+!a, ~+!b, ~+!c, P1 (Some d)) }
| { (P1 None, P2 None, P3 None, P4 None) }
*)

let configuration_body ==
| p = loc(source_computer_paragraph); { P_SOURCE_COMPUTER_PARAGRAPH p }
| p = loc(object_computer_paragraph); { P_OBJECT_COMPUTER_PARAGRAPH p }
| p = loc(special_names_paragraph); { P_SPECIAL_NAMES_PARAGRAPH p }
| p = loc(repository_paragraph); { P_REPOSITORY_PARAGRAPH p } (* +COB2002 *)
(*
(* whole *)
let unorder2_opt (A, B) ==
| a = A; b = ro(B); { (Some a, b, AB) }
| b = B; a = ro(A); { (a, Some b, BA) }
| { (None, None, AB) }
let unorder3_opt (A, B, C) ==
| a = A; u = unorder2_opt(B, C); { let (b, c, o) = u in (Some a, b, c, from_duo `BC o) }
| b = B; u = unorder2_opt(A, C); { let (a, c, o) = u in (a, Some b, c, from_duo `AC o) }
| c = C; u = unorder2_opt(A, B); { let (a, b, o) = u in (a, b, Some c, from_duo `AB o) }
| { (None, None, None, ABC) }
let unorder4_opt (A, B, C, D) ==
| a = A; u = unorder3_opt(B, C, D); { let (b, c, d, o) = u in (Some a, b, c, d, from_trio `BCD o) }
| b = B; u = unorder3_opt(A, C, D); { let (a, c, d, o) = u in (a, Some b, c, d, from_trio `ACD o) }
| c = C; u = unorder3_opt(A, B, D); { let (a, b, d, o) = u in (a, b, Some c, d, from_trio `ABD o) }
| d = D; u = unorder3_opt(A, B, C); { let (a, b, c, o) = u in (a, b, c, Some d, from_trio `ABC o) }
| { (None, None, None, None, ABCD) }
*)

let unorder2_opt (A, B) ==
| a = A; b = ro(B); { (Some a, b, AB) }
| b = B; a = ro(A); { (a, Some b, BA) }
| { (None, None, AB) }
let unorder3_opt (A, B, C) ==
| a = A; u = unorder2_opt(B, C); { let (b, c, o) = u in (Some a, b, c, from_duo' `BC o) }
| b = B; u = unorder2_opt(A, C); { let (a, c, o) = u in (a, Some b, c, from_duo' `AC o) }
| c = C; u = unorder2_opt(A, B); { let (a, b, o) = u in (a, b, Some c, from_duo' `AB o) }
| { (None, None, None, A3 AB) }
let unorder4_opt (A, B, C, D) ==
| a = A; u = unorder3_opt(B, C, D); { let (b, c, d, o) = u in (Some a, b, c, d, from_trio' `BCD o) }
| b = B; u = unorder3_opt(A, C, D); { let (a, c, d, o) = u in (a, Some b, c, d, from_trio' `ACD o) }
| c = C; u = unorder3_opt(A, B, D); { let (a, b, d, o) = u in (a, b, Some c, d, from_trio' `ABD o) }
| d = D; u = unorder3_opt(A, B, C); { let (a, b, c, o) = u in (a, b, c, Some d, from_trio' `ABC o) }
| { (None, None, None, None, A4 (A3 AB)) }

let configuration_section :=
| CONFIGURATION; SECTION; ".";
unorder = unorder4_opt(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,
order) = unorder in
{ source_computer_paragraph;
object_computer_paragraph;
special_names_paragraph;
repository_paragraph;
order } }

(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / SOURCE-COMPUTER PARAGRAPH *)

Expand Down
200 changes: 200 additions & 0 deletions src/lsp/cobol_ptree/common.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,3 +30,203 @@ type 'a nel = 'a NEL.t
[@@deriving ord]

let pp_nel ppe = NEL.pp ~fsep:"@ " ~fopen:"" ~fclose:"" ppe


(* order *)

type 'a order =
| P1 of 'a
| P2 of 'a
| P3 of 'a
| P4 of 'a
[@@deriving ord]

let (~!) = function
| P1 a -> a
| P2 a -> a
| P3 a -> a
| P4 a -> a

let (~+!) = function
| P1 a -> P2 a
| P2 a -> P3 a
| P3 a -> P4 a
| P4 _ -> raise @@ Invalid_argument "Cannot increase rank of P4"

(* whole *)

type permutation_duo =
| AB
| BA
[@@deriving ord]

type permutation_trio =
| ABC
| ACB
| BAC
| BCA
| CAB
| CBA
[@@deriving ord]

type permutation_quartet =
| ABCD
| ABDC
| ACBD
| ACDB
| ADBC
| ADCB
| BACD
| BADC
| BCAD
| BCDA
| BDAC
| BDCA
| CABD
| CADB
| CBAD
| CBDA
| CDAB
| CDBA
| DABC
| DACB
| DBAC
| DBCA
| DCAB
| DCBA
[@@deriving ord]

let from_duo conv = function
| AB -> begin match conv with
| `BC -> ABC
| `AC -> BAC
| `AB -> CAB
end
| BA -> begin match conv with
| `BC -> ACB
| `AC -> BCA
| `AB -> CBA
end

let from_trio conv = function
| ABC -> begin match conv with
| `BCD -> ABCD
| `ACD -> BACD
| `ABD -> CABD
| `ABC -> DABC
end
| ACB -> begin match conv with
| `BCD -> ABDC
| `ACD -> BADC
| `ABD -> CADB
| `ABC -> DACB
end
| BAC -> begin match conv with
| `BCD -> ACBD
| `ACD -> BCAD
| `ABD -> CBAD
| `ABC -> DBAC
end
| BCA -> begin match conv with
| `BCD -> ACDB
| `ACD -> BCDA
| `ABD -> CBDA
| `ABC -> DBCA
end
| CAB -> begin match conv with
| `BCD -> ADBC
| `ACD -> BDAC
| `ABD -> CDAB
| `ABC -> DCAB
end
| CBA -> begin match conv with
| `BCD -> ADCB
| `ACD -> BDCA
| `ABD -> CDBA
| `ABC -> DCBA
end

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
| ABC -> acc |> fa a |> fb b |> fc c
| ACB -> acc |> fa a |> fc c |> fb b
| BAC -> acc |> fb b |> fa a |> fc c
| BCA -> acc |> fb b |> fc c |> fa a
| CAB -> acc |> fc c |> fa a |> fb b
| CBA -> acc |> fc c |> fb b |> fa a

let fold_quartet quartet (a, b, c, d) (fa, fb, fc, fd) acc =
match quartet with
| ABCD -> acc |> fa a |> fb b |> fc c |> fd d
(* TODO *)
| _ -> acc |> fa a |> fb b |> fc c |> fd d

(* splitted *)

type permutation_duo =
| AB
| BA
[@@deriving ord]

type permutation_trio' =
| A3 of permutation_duo
| B3 of permutation_duo
| C3 of permutation_duo
[@@deriving ord]

type permutation_quartet' =
| A4 of permutation_trio'
| B4 of permutation_trio'
| C4 of permutation_trio'
| D4 of permutation_trio'
[@@deriving ord]

let from_duo' conv o =
match conv with
| `BC -> A3 o
| `AC -> B3 o
| `AB -> C3 o

let from_trio' conv trio =
match conv with
| `BCD -> A4 trio
| `ACD -> B4 trio
| `ABD -> C4 trio
| `ABC -> 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) ()

24 changes: 17 additions & 7 deletions src/lsp/cobol_ptree/env_division.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,12 +25,20 @@ type environment_division =
[@@deriving ord]

(* ------------- ENVIRONMENT DIVISION / CONFIGURATION SECTION -------------- *)
(* and configuration_section =
{
source_computer_paragraph: source_computer_paragraph with_loc option order;
object_computer_paragraph: object_computer_paragraph with_loc option order;
special_names_paragraph: special_names_paragraph with_loc option order;
repository_paragraph: repository_paragraph with_loc option order; (* +COB2002 *)
} *)
and configuration_section =
{
source_computer_paragraph: source_computer_paragraph with_loc option;
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 *)
order: permutation_quartet';
}

(* ENVIRONMENT DIVISION / CONFIGURATION SECTION / SOURCE-COMPUTER PARAGRAPH *)
Expand Down Expand Up @@ -561,13 +569,15 @@ let pp_special_names_paragraph ppf 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
special_names_paragraph = snp; repository_paragraph = rp; order }
=
Fmt.pf ppf "CONFIGURATION SECTION.";
iter_quartet' order (scp, ocp, snp, rp)
(Fmt.(option (sp ++ pp_with_loc pp_source_computer_paragraph)) ppf,
Fmt.(option (sp ++ pp_with_loc pp_object_computer_paragraph)) ppf,
Fmt.(option (sp ++ pp_with_loc pp_special_names_paragraph)) ppf,
Fmt.(option (sp ++ pp_with_loc pp_repository_paragraph)) ppf
)

let pp_record_delimiter ppf = function
| Standard_1 -> Fmt.pf ppf "STANDARD-1"
Expand Down
20 changes: 11 additions & 9 deletions src/lsp/cobol_ptree/env_division_visitor.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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;
order } x -> x
>> fold_quartet' 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) =
Expand Down

0 comments on commit e9d5057

Please sign in to comment.