catala/compiler/utils/cli.ml

(* This file is part of the Catala compiler, a specification language for tax
   and social benefits computation rules. Copyright (C) 2020 Inria,
   contributors: Denis Merigoux <denis.merigoux@inria.fr>, Emile Rolley
   <emile.rolley@tuta.io>

   Licensed under the Apache License, Version 2.0 (the "License"); you may not
   use this file except in compliance with the License. You may obtain a copy of
   the License at

   http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
   WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
   License for the specific language governing permissions and limitations under
   the License. *)

type backend_lang = En | Fr | Pl

(** Source files to be compiled *)
let source_files : string list ref = ref []

let locale_lang : backend_lang ref = ref En
let contents : string ref = ref ""

(** Prints debug information *)
let debug_flag = ref false

(* Styles the terminal output *)
let style_flag = ref true

(* Max number of digits to show for decimal results *)
let max_prec_digits = ref 20
let trace_flag = ref false
let optimize_flag = ref false
let disable_counterexamples = ref false
let avoid_exceptions_flag = ref false

open Cmdliner

let file =
  Arg.(
    required
    & pos 1 (some file) None
    & info [] ~docv:"FILE" ~doc:"Catala master file to be compiled.")

let debug =
  Arg.(value & flag & info [ "debug"; "d" ] ~doc:"Prints debug information.")

let unstyled =
  Arg.(
    value & flag
    & info [ "unstyled"; "u" ]
        ~doc:"Removes styling (colors, etc.) from terminal output.")

let optimize =
  Arg.(
    value & flag & info [ "optimize"; "O" ] ~doc:"Run compiler optimizations.")

let trace_opt =
  Arg.(
    value & flag
    & info [ "trace"; "t" ]
        ~doc:
          "Displays a trace of the interpreter's computation or generates \
           logging instructions in translate programs.")

let avoid_exceptions =
  Arg.(
    value & flag
    & info [ "avoid_exceptions" ]
        ~doc:"Compiles the default calculus without exceptions")

let wrap_weaved_output =
  Arg.(
    value & flag
    & info [ "wrap"; "w" ]
        ~doc:"Wraps literate programming output with a minimal preamble.")

let backend =
  Arg.(
    required
    & pos 0 (some string) None
    & info [] ~docv:"COMMAND"
        ~doc:
          "Backend selection (see the list of commands for available options).")

type backend_option =
  | Dcalc
  | Html
  | Interpret
  | Latex
  | Lcalc
  | Makefile
  | OCaml
  | Proof
  | Python
  | Scalc
  | Scopelang
  | Typecheck

let language =
  Arg.(
    value
    & opt (some string) None
    & info [ "l"; "language" ] ~docv:"LANG"
        ~doc:"Input language among: en, fr, pl.")

let max_prec_digits_opt =
  Arg.(
    value
    & opt (some int) None
    & info
        [ "p"; "max_digits_printed" ]
        ~docv:"DIGITS"
        ~doc:
          "Maximum number of significant digits printed for decimal results \
           (default 20).")

let disable_counterexamples_opt =
  Arg.(
    value & flag
    & info
        [ "disable_counterexamples" ]
        ~doc:
          "Disables the search for counterexamples in proof mode. Useful when \
           you want a deterministic output from the Catala compiler, since \
           provers can have some randomness in them.")

let ex_scope =
  Arg.(
    value
    & opt (some string) None
    & info [ "s"; "scope" ] ~docv:"SCOPE" ~doc:"Scope to be focused on.")

let output =
  Arg.(
    value
    & opt (some string) None
    & info [ "output"; "o" ] ~docv:"OUTPUT"
        ~doc:
          "$(i, OUTPUT) is the file that will contain the output of the \
           compiler. Defaults to $(i,FILE).$(i,EXT) where $(i,EXT) depends on \
           the chosen backend.")

let catala_t f =
  Term.(
    const f $ file $ debug $ unstyled $ wrap_weaved_output $ avoid_exceptions
    $ backend $ language $ max_prec_digits_opt $ trace_opt
    $ disable_counterexamples_opt $ optimize $ ex_scope $ output)

let version = "0.5.0"

let info =
  let doc =
    "Compiler for Catala, a specification language for tax and social benefits \
     computation rules."
  in
  let man =
    [
      `S Manpage.s_description;
      `P
        "Catala is a domain-specific language for deriving \
         faithful-by-construction algorithms from legislative texts.";
      `S Manpage.s_commands;
      `I
        ( "$(b,Intepret)",
          "Runs the interpreter on the Catala program, executing the scope \
           specified by the $(b,-s) option assuming no additional external \
           inputs." );
      `I
        ( "$(b,Typecheck)",
          "Parses and typechecks a Catala program, without interpreting it." );
      `I
        ( "$(b,Proof)",
          "Generates and proves verification conditions about the well-behaved \
           execution of the Catala program." );
      `I ("$(b,OCaml)", "Generates an OCaml translation of the Catala program.");
      `I ("$(b,Python)", "Generates a Python translation of the Catala program.");
      `I
        ( "$(b,LaTeX)",
          "Weaves a LaTeX literate programming output of the Catala program." );
      `I
        ( "$(b,HTML)",
          "Weaves an HTML literate programming output of the Catala program." );
      `I
        ( "$(b,Makefile)",
          "Generates a Makefile-compatible list of the file dependencies of a \
           Catala program." );
      `I
        ( "$(b,Scopelang)",
          "Prints a debugging verbatim of the scope language intermediate \
           representation of the Catala program. Use the $(b,-s) option to \
           restrict the output to a particular scope." );
      `I
        ( "$(b,Dcalc)",
          "Prints a debugging verbatim of the default calculus intermediate \
           representation of the Catala program. Use the $(b,-s) option to \
           restrict the output to a particular scope." );
      `I
        ( "$(b,Lcalc)",
          "Prints a debugging verbatim of the lambda calculus intermediate \
           representation of the Catala program. Use the $(b,-s) option to \
           restrict the output to a particular scope." );
      `I
        ( "$(b,Scalc)",
          "Prints a debugging verbatim of the statement calculus intermediate \
           representation of the Catala program. Use the $(b,-s) option to \
           restrict the output to a particular scope." );
      `S Manpage.s_authors;
      `P "The authors are listed by alphabetical order.";
      `P "Nicolas Chataing <nicolas.chataing@ens.fr>";
      `P "Alain Delaët-Tixeuil <alain.delaet--tixeuil@inria.fr>";
      `P "Aymeric Fromherz <aymeric.fromherz@inria.fr>";
      `P "Louis Gesbert <louis.gesbert@ocamlpro.com>";
      `P "Denis Merigoux <denis.merigoux@inria.fr>";
      `P "Emile Rolley <erolley@tutamail.com>";
      `S Manpage.s_examples;
      `Pre "catala Interpret -s Foo file.catala_en";
      `Pre "catala Ocaml -o target/file.ml file.catala_en";
      `S Manpage.s_bugs;
      `P
        "Please file bug reports at https://github.com/CatalaLang/catala/issues";
    ]
  in
  let exits = Term.default_exits @ [ Term.exit_info ~doc:"on error." 1 ] in
  Term.info "catala" ~version ~doc ~exits ~man

(**{1 Terminal formatting}*)

(**{2 Markers}*)

let time : float ref = ref (Unix.gettimeofday ())

let with_style
    (styles : ANSITerminal.style list) (str : ('a, unit, string) format) =
  if !style_flag then ANSITerminal.sprintf styles str else Printf.sprintf str

let format_with_style (styles : ANSITerminal.style list) fmt (str : string) =
  if !style_flag then
    Format.pp_print_as fmt (String.length str)
      (ANSITerminal.sprintf styles "%s" str)
  else Format.pp_print_string fmt str

let time_marker () =
  let new_time = Unix.gettimeofday () in
  let old_time = !time in
  time := new_time;
  let delta = (new_time -. old_time) *. 1000. in
  if delta > 50. then
    Printf.printf "%s"
      (with_style
         [ ANSITerminal.Bold; ANSITerminal.black ]
         "[TIME] %.0f ms\n" delta)

(** Prints [\[DEBUG\]] in purple on the terminal standard output *)
let debug_marker () =
  time_marker ();
  with_style [ ANSITerminal.Bold; ANSITerminal.magenta ] "[DEBUG] "

(** Prints [\[ERROR\]] in red on the terminal error output *)
let error_marker () =
  with_style [ ANSITerminal.Bold; ANSITerminal.red ] "[ERROR] "

(** Prints [\[WARNING\]] in yellow on the terminal standard output *)
let warning_marker () =
  with_style [ ANSITerminal.Bold; ANSITerminal.yellow ] "[WARNING] "

(** Prints [\[RESULT\]] in green on the terminal standard output *)
let result_marker () =
  with_style [ ANSITerminal.Bold; ANSITerminal.green ] "[RESULT] "

(** Prints [\[LOG\]] in red on the terminal error output *)
let log_marker () =
  with_style [ ANSITerminal.Bold; ANSITerminal.black ] "[LOG] "

(**{2 Printers}*)

(** All the printers below print their argument after the correct marker *)

let concat_with_line_depending_prefix_and_suffix
    (prefix : int -> string) (suffix : int -> string) (ss : string list) =
  match ss with
  | hd :: rest ->
      let out, _ =
        List.fold_left
          (fun (acc, i) s ->
            ( (acc ^ prefix i ^ s
              ^ if i = List.length ss - 1 then "" else suffix i),
              i + 1 ))
          ((prefix 0 ^ hd ^ if 0 = List.length ss - 1 then "" else suffix 0), 1)
          rest
      in
      out
  | [] -> prefix 0

(** The int argument of the prefix corresponds to the line number, starting at 0 *)
let add_prefix_to_each_line (s : string) (prefix : int -> string) =
  concat_with_line_depending_prefix_and_suffix
    (fun i -> prefix i)
    (fun _ -> "\n")
    (String.split_on_char '\n' s)

let debug_print (format : ('a, out_channel, unit) format) =
  if !debug_flag then Printf.printf ("%s" ^^ format ^^ "\n%!") (debug_marker ())
  else Printf.ifprintf stdout format

let debug_format (format : ('a, Format.formatter, unit) format) =
  if !debug_flag then
    Format.printf ("%s@[<hov>" ^^ format ^^ "@]@.") (debug_marker ())
  else Format.ifprintf Format.std_formatter format

let error_print (format : ('a, out_channel, unit) format) =
  Printf.eprintf ("%s" ^^ format ^^ "\n%!") (error_marker ())

let warning_print (format : ('a, out_channel, unit) format) =
  Printf.printf ("%s" ^^ format ^^ "\n%!") (warning_marker ())

let result_print (format : ('a, out_channel, unit) format) =
  Printf.printf ("%s" ^^ format ^^ "\n%!") (result_marker ())

let result_format (format : ('a, Format.formatter, unit) format) =
  Format.printf ("%s" ^^ format ^^ "\n%!") (result_marker ())

let log_print (format : ('a, out_channel, unit) format) =
  Printf.printf ("%s" ^^ format ^^ "\n%!") (log_marker ())

let log_format (format : ('a, Format.formatter, unit) format) =
  Format.printf ("%s@[<hov>" ^^ format ^^ "@]@.") (log_marker ())