Refactor IRJ parser for Menhir new error handling

.github/workflows/binary-releases.yml

@@ -20,51 +20,6 @@ jobs:
           tag_name: ${{ github.run_number }}
           release_name: Release ${{ github.run_number }}
 
-  macos-build:
-    runs-on: macos-latest
-    needs: create-release
-
-    steps:
-      - uses: actions/checkout@v2
-
-      - name: Opam modules cache
-        uses: actions/cache@v1
-        env:
-          cache-name: cache-opam-modules
-        with:
-          path: ~/.opam
-          key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('mlang.opam', 'Makefile') }}
-          restore-keys: |
-            ${{ runner.os }}-build-${{ env.cache-name }}-
-            ${{ runner.os }}-build-
-            ${{ runner.os }}-
-
-      - name: Set up OCaml
-        uses: ocaml/setup-ocaml@v2
-        with:
-          ocaml-compiler: 4.11.2
-
-      - name: Install dependencies
-        run: |
-          brew install gmp mpfr
-          opam update
-          make init-without-switch
-
-      - name: Make mlang binary
-        run: |
-          eval $(opam env)
-          make build
-
-      - name: Upload release asset
-        uses: actions/upload-release-asset@v1
-        env:
-          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-        with:
-          upload_url: ${{ needs.create-release.outputs.upload_url }}
-          asset_path: ./_build/default/src/main.exe
-          asset_name: mlang-macos-v${{ github.run_number }}.exe
-          asset_content_type: application/octet-stream
-
   linux-build:
     # The type of runner that the job will run on
     runs-on: ubuntu-latest

src/irj_checker/backend_irj/pas_calc.ml

@@ -0,0 +1,61 @@
+open Mlang.Irj_ast
+
+type avis_type = Texte | Gavlir
+
+let open_file filename =
+  let oc = open_out filename in
+  let fmt = Format.formatter_of_out_channel oc in
+  (oc, fmt)
+
+let print_comma oc () = Format.fprintf oc ","
+
+let format_value fmt (value : literal) =
+  match value with
+  | I i -> Format.fprintf fmt "%d" i
+  | F f -> Format.fprintf fmt "%f" f
+
+let format_code_revenu fmt (((var, _), (value, _)) : var_value) =
+  Format.fprintf fmt
+    {|@;<0 2>{@;<0 4>"code": "%s",@;<0 4>"valeur": "%a"@;<0 2>}|} var
+    format_value value
+
+let format_rappel fmt (rappel : rappel) =
+  Format.fprintf fmt
+    {|@;<0 2>{@;<0 4>"numEvt": "%d",@;<0 4>"numRappel": "%d",@;<0 4>"descripteur": "%s",@;<0 4>"montant": "%d",@;<0 4>"sens": "%s",@;<0 4>"penalite": "%a",@;<0 4>"baseTL": "%a",@;<0 4>"date": "%.6d",@;<0 4>"abatt": "%a"@;<0 2>}|}
+    rappel.event_nb rappel.rappel_nb rappel.variable_code rappel.change_value
+    rappel.direction
+    (Format.pp_print_option Format.pp_print_int)
+    rappel.penalty_code
+    (Format.pp_print_option Format.pp_print_int)
+    rappel.base_tolerance_legale rappel.month_year
+    (Format.pp_print_option Format.pp_print_int)
+    rappel.decl_2042_rect
+
+let format_code_list fmt input_list =
+  Format.pp_print_list ~pp_sep:print_comma format_code_revenu fmt input_list
+
+let format_rappel_list fmt rappels =
+  Format.pp_print_list ~pp_sep:print_comma format_rappel fmt rappels
+
+let format_avis_element fmt avis_type =
+  Format.fprintf fmt {|"formatAvis": "%s",@,|}
+    (match avis_type with Texte -> "texte" | Gavlir -> "gavlir")
+
+let gen_pas_calc_json_primitif fmt (prim_data : prim_data_block) mode =
+  Format.fprintf fmt {|@[<%c 2>{@,%a"listeCodes": [%a@,]@]|} mode
+    format_avis_element Texte format_code_list prim_data.entrees;
+  Format.fprintf fmt "}"
+
+let gen_pas_calc_json_correctif fmt (test_data : irj_file) mode =
+  (*Pour l’instant on va se contenter de partir en dur sur du correctif avec avis.*)
+  let rappels : rappel list option =
+    match test_data.rapp with
+    | None -> None
+    | Some rappels -> Some rappels.entrees_rappels
+  in
+  Format.fprintf fmt
+    {|@[<%c 2>{@,%a"codesRevenu": [%a@,],@,"lignesRappel": [%a@,]@]|} mode
+    format_avis_element Texte format_code_list test_data.prim.entrees
+    (Format.pp_print_option format_rappel_list)
+    rappels;
+  Format.fprintf fmt "}"

src/irj_checker/dune

@@ -1,3 +1,5 @@
+(include_subdirs unqualified)
+
 (env
  (dev
   (flags
@@ -7,4 +9,4 @@
  (name irj_checker)
  (package irj_checker)
  (public_name irj_checker)
- (libraries mlang))
+ (libraries mlang cmdliner dune-build-info))

src/irj_checker/irj_checker.ml

@@ -14,29 +14,134 @@
    this program. If not, see <https://www.gnu.org/licenses/>. *)
 
 (** The Irj_checker Module is a simple entry point to use the Mlang IRJ file
-    parser in order to perform syntactic checks on test files.
-
-    Usage: irj_checker.exe <test_file.irj>*)
-
-let () =
-  if Array.length Sys.argv <> 2 then (
-    Printf.eprintf "This program requires a test file as argument\n";
-    exit 1);
-  let f = Sys.argv.(1) in
-  let _tf =
-    try Mlang.Irj_file.parse_file f with
-    | Mlang.Irj_ast.TestParsingError (s, pos) ->
-        let pos_1, pos_2 = pos.pos_loc in
-        Printf.eprintf "%s" (Filename.basename f);
-        Printf.eprintf ":(%d,%d)-(%d,%d)" pos_1.pos_lnum
-          (pos_1.pos_cnum - pos_1.pos_bol + 1)
-          pos_2.pos_lnum
-          (pos_2.pos_cnum - pos_2.pos_bol + 1);
-        Printf.eprintf " : %s\n" s;
-        exit 1
-    | _ ->
-        Printf.eprintf "%s" (Filename.basename f);
-        Printf.eprintf " : Unknown error\n";
-        exit 1
+    parser in order to perform syntactic checks on test files or produce other IR
+    test formats.
+
+    Usage: irj_checker.exe [--message-format=VAL] <test_file.irj> [transformation-target]*)
+
+open Cmdliner
+open Mlang
+
+type message_format_enum = Human | GNU
+
+type validation_mode_enum = Strict | Corrective | Primitive
+
+type transformation_target = None | PasCalcP | PasCalcC
+
+let gen_file generator test_data =
+  let mode = 'v' in
+  (* use h for a monoline json *)
+  let out_fmt = Format.std_formatter in
+  generator out_fmt test_data mode;
+  Format.pp_print_newline out_fmt ();
+  Format.pp_print_flush out_fmt ()
+
+let irj_checker (f : string) (message_format : message_format_enum)
+    (validation_mode : validation_mode_enum)
+    (transform_target : transformation_target) : unit =
+  try
+    if not (Sys.file_exists f && not (Sys.is_directory f)) then
+      Errors.raise_error
+        (Format.asprintf "%s: this path is not a valid file in the filesystem" f);
+    let test_data = Mlang.Irj_file.parse_file f in
+    let test_data =
+      match validation_mode with
+      | Primitive ->
+          if Option.is_some test_data.rapp then
+            Errors.raise_error
+              (Format.asprintf "%s: is a corrective file!" test_data.nom)
+          else test_data
+      | Corrective ->
+          if Option.is_none test_data.rapp then
+            Errors.raise_error
+              (Format.asprintf "%s: is a primitive file!" test_data.nom)
+          else test_data
+      | _ -> test_data
+    in
+    match transform_target with
+    | None ->
+        Cli.result_print "%s: checked as %s with %d primitive codes!"
+          test_data.nom
+          (match test_data.rapp with
+          | Some _ -> "corrective"
+          | None -> "primitive")
+          (List.length test_data.prim.entrees)
+    | PasCalcP -> gen_file Pas_calc.gen_pas_calc_json_primitif test_data.prim
+    | PasCalcC -> gen_file Pas_calc.gen_pas_calc_json_correctif test_data
+  with Errors.StructuredError (msg, pos, kont) ->
+    (match message_format with
+    | Human -> Cli.error_print "%a" Errors.format_structured_error
+    | GNU -> Format.eprintf "%a" Errors.format_structured_error_gnu_format)
+      (msg, pos);
+    (match kont with None -> () | Some kont -> kont ());
+    exit 123
+
+let validation_mode_opt =
+  [ ("strict", Strict); ("corrective", Corrective); ("primitive", Primitive) ]
+
+let validation_mode =
+  Arg.(
+    value
+    & opt (enum validation_mode_opt) Strict
+    & info [ "v"; "validation-mode" ]
+        ~doc:
+          "Select the validation criteria. If set to $(i,strict), the whole \
+           grammar is applied. If set to $(i,corrective) or $(i,primitive), \
+           only the corresponding files are accepted, for instance primitive \
+           file in corrective mode will raise an error.")
+
+let message_format_opt = [ ("human", Human); ("gnu", GNU) ]
+
+let message_format =
+  Arg.(
+    value
+    & opt (enum message_format_opt) Human
+    & info [ "m"; "message-format" ]
+        ~doc:
+          "Selects the format of error and warning messages emitted by the \
+           compiler. If set to $(i,human), the messages will be nicely \
+           displayed and meant to be read by a human. If set to $(i,gnu), the \
+           messages will be rendered according to the GNU coding standards.")
+
+let file =
+  let doc = "Test file (usually with the .irj extension)" in
+  Arg.(value & pos 0 string "" & info [] ~docv:"FILE" ~doc)
+
+let transformation_target_opt =
+  [ ("none", None); ("pasp", PasCalcP); ("pasc", PasCalcC) ]
+
+let transform_target =
+  let doc =
+    "Transformation target, among the following list: $(i,none) (only checks \
+     test syntax), $(i,pasp) (API PAS-CALC for primitive computation \
+     resources), $(i,pasc) (API PAS-CALC for corrective computation \
+     resources)."
   in
-  ()
+  Arg.(
+    value
+    & pos 1 (enum transformation_target_opt) None
+    & info [] ~docv:"TARGET" ~doc)
+
+let irj_checker_t =
+  Term.(
+    const irj_checker $ file $ message_format $ validation_mode
+    $ transform_target)
+
+let cmd =
+  let doc = "parses, validates and transforms IRJ test files" in
+  let man =
+    [
+      `S Manpage.s_bugs;
+      `P "File bug reports at <https://github.com/MLanguage/mlang/issues>.";
+    ]
+  in
+  Cmd.v
+    (Cmd.info "irj_checker"
+       ~version:
+         (match Build_info.V1.version () with
+         | None -> "n/a"
+         | Some v -> Build_info.V1.Version.to_string v)
+       ~doc ~man)
+    irj_checker_t
+
+let () = exit (Cmd.eval cmd)

src/mlang/dune

@@ -2,7 +2,8 @@
 
 (library
  (public_name mlang)
- (libraries re ANSITerminal parmap cmdliner threads dune-build-info num gmp))
+ (libraries re ANSITerminal parmap cmdliner threads dune-build-info num gmp
+   menhirLib))
 
 (documentation
  (package mlang)

src/mlang/test_framework/dune

@@ -2,4 +2,39 @@
 
 (menhir
  (modules irj_parser)
- (flags --explain))
+ (flags --dump --explain --table))
+
+;; This section deals with the .messages file.
+
+;; The following rule generates "parserMessages.ml" based on the source file
+;; "parserMessages.messages". It requires the completeness check to have been
+;; performed first. (If desired, this check could be disabled.)
+
+(rule
+ (deps parserMessages.check)
+ (action
+  (with-stdout-to
+   parserMessages.ml
+   (run menhir %{dep:irj_parser.mly} --compile-errors
+     %{dep:parserMessages.messages}))))
+
+;; This rule generates a file "parserMessages.auto.messages" that contains a
+
+;; list of all error states. It is used by the completeness check.
+
+(rule
+ (with-stdout-to
+  parserMessages.auto.messages
+  (run menhir %{dep:irj_parser.mly} --list-errors)))
+
+;; This rule implements the completeness check. It checks that every error
+;; state listed in the auto-generated file "parserMessages.auto.messages"
+;; is also listed in the file "parserMessages.messages" that is maintained
+;; by the programmer.
+
+(rule
+ (with-stdout-to
+  parserMessages.check
+  (run menhir %{dep:irj_parser.mly} --compare-errors
+    %{dep:parserMessages.auto.messages} --compare-errors
+    %{dep:parserMessages.messages})))

src/mlang/test_framework/irj_ast.ml

@@ -14,24 +14,16 @@
    You should have received a copy of the GNU General Public License along with
    this program. If not, see <https://www.gnu.org/licenses/>. *)
 
-type pos = {
-  pos_filename : string;
-  pos_loc : Lexing.position * Lexing.position;
-}
-
-let mk_position sloc =
-  { pos_filename = (fst sloc).Lexing.pos_fname; pos_loc = sloc }
-
-exception TestParsingError of (string * pos)
-(* duplication of some of the utils *)
+let mk_position sloc : Pos.t =
+  Pos.make_position (fst sloc).Lexing.pos_fname sloc
 
 type literal = I of int | F of float
 
-type var_value = string * literal * pos
+type var_value = string Pos.marked * literal Pos.marked
 
 (* type var_values = var_value list *)
 
-type calc_error = string * pos
+type calc_error = string Pos.marked
 
 (* type calc_errors = calc_error list *)
 
@@ -51,7 +43,7 @@ type rappel = {
   (* MMYYYY *)
   decl_2042_rect : int option;
   (* 0 or 1 *)
-  pos : pos;
+  pos : Pos.t;
 }
 
 type prim_data_block = {