diff --git a/Makefile b/Makefile index 8e0d2592..c5058f32 100644 --- a/Makefile +++ b/Makefile @@ -45,6 +45,7 @@ $(PY_VENV_DIR)/stamp: \ syntax_highlighting/fr/pygments/pyproject.toml \ syntax_highlighting/pl/pygments/pyproject.toml test -d $(PY_VENV_DIR) || python3 -m venv $(PY_VENV_DIR) + $(PY_VENV_ACTIVATE) python3 -m pip install -U pip $(PY_VENV_ACTIVATE) python3 -m pip install -U \ -e runtimes/python/catala \ -e syntax_highlighting/en/pygments \ @@ -102,7 +103,6 @@ runtimes: #> plugins : Builds the compiler backend plugins plugins: runtimes dune build compiler/plugins/ - @echo "define CATALA_PLUGINS=_build/default/compiler/plugins to test the plugins" ########################################## # Rules related to promoted files diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 7befb6a9..a7d4687f 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -57,10 +57,10 @@ let ninja_output = Arg.( value & opt (some string) None - & info ["o"; "output"] ~docv:"OUTPUT" + & info ["o"; "output"] ~docv:"FILE" ~doc: - "$(i, OUTPUT) is the file that will contain the build.ninja file \ - output. If not specified, the build.ninja file will be outputed in \ + "$(i,FILE) is the file that will contain the build.ninja file \ + output. If not specified, the build.ninja file will be output in \ the temporary directory of the system.") let scope = @@ -384,8 +384,6 @@ let add_reset_rules_aux [ Var.catala_cmd; Var.tested_file; - Lit "--unstyled"; - Lit "--output=-"; Lit redirect; Var.expected_output; Lit "2>&1"; @@ -422,8 +420,6 @@ let add_test_rules_aux :: [ Var.catala_cmd; Var.tested_file; - Lit "--unstyled"; - Lit "--output=-"; Lit "2>&1 | colordiff -u -b"; Var.expected_output; Lit "-"; @@ -630,16 +626,15 @@ let run_inline_tests let cmd_out_rd, cmd_out_wr = Unix.pipe () in let ic = Unix.in_channel_of_descr cmd_out_rd in let cmd = - Array.of_list - ((catala_exe :: catala_opts) - @ test.params - @ [file; "--unstyled"; "--output=-"]) + Array.of_list ((catala_exe :: catala_opts) @ test.params @ [file]) in let env = Unix.environment () |> Array.to_seq |> Seq.filter (fun s -> not (String.starts_with ~prefix:"OCAMLRUNPARAM=" s)) + |> Seq.cons "CATALA_OUT=-" + |> Seq.cons "CATALA_COLOR=never" |> Array.of_seq in let pid = @@ -885,7 +880,7 @@ let driver (reset_test_outputs : bool) (ninja_output : string option) : int = try - if debug then Cli.debug_flag := true; + let _options = Cli.enforce_globals ~debug () in let ninja_flags = makeflags_to_ninja_flags makeflags in let files_or_folders = List.sort_uniq String.compare files_or_folders and catala_exe = Option.fold ~none:"catala" ~some:Fun.id catala_exe diff --git a/compiler/catala_utils/cli.ml b/compiler/catala_utils/cli.ml index 5380fe01..79496f24 100644 --- a/compiler/catala_utils/cli.ml +++ b/compiler/catala_utils/cli.ml @@ -15,23 +15,12 @@ License for the specific language governing permissions and limitations under the License. *) -type backend_lang = En | Fr | Pl +(* Types used by flags & options *) -type backend_option = - [ `Latex - | `Makefile - | `Html - | `Interpret - | `Interpret_Lcalc - | `Typecheck - | `OCaml - | `Python - | `Scalc - | `Lcalc - | `Dcalc - | `Scopelang - | `Exceptions - | `Proof ] +type backend_lang = En | Fr | Pl +type when_enum = Auto | Always | Never +type message_format_enum = Human | GNU +type input_file = FileName of string | Contents of string (** Associates a {!type: Cli.backend_lang} with its string represtation. *) let languages = ["en", En; "fr", Fr; "pl", Pl] @@ -40,200 +29,275 @@ let language_code = let rl = List.map (fun (a, b) -> b, a) languages in fun l -> List.assoc l rl -(** Source files to be compiled *) -let source_files : string list ref = ref [] +let message_format_opt = ["human", Human; "gnu", GNU] -let locale_lang : backend_lang ref = ref En -let contents : string ref = ref "" +type options = { + mutable input_file : input_file; + mutable language : backend_lang option; + mutable debug : bool; + mutable color : when_enum; + mutable message_format : message_format_enum; + mutable trace : bool; + mutable plugins_dirs : string list; + mutable disable_warnings : bool; + mutable max_prec_digits : int; +} -(** Prints debug information *) -let debug_flag = ref false +(* Note: we force that the global options (ie options common to all commands) + and the options available through global refs are the same. While this is a + bit arbitrary, it makes some sense code-wise and provides some safeguard + against explosion of the number of global references. Reducing the number of + globals further would be nice though. *) +let globals = + { + input_file = Contents ""; + language = None; + debug = false; + color = Auto; + message_format = Human; + trace = false; + plugins_dirs = []; + disable_warnings = false; + max_prec_digits = 20; + } -type when_enum = Auto | Always | Never - -(* Styles the terminal output *) -let style_flag = ref Auto - -(* Max number of digits to show for decimal results *) -let max_prec_digits = ref 20 -let trace_flag = ref false -let disable_warnings_flag = ref false -let optimize_flag = ref false -let disable_counterexamples = ref false -let avoid_exceptions_flag = ref false -let check_invariants_flag = ref false - -type message_format_enum = Human | GNU - -let message_format_flag = ref Human +let enforce_globals + ?input_file + ?language + ?debug + ?color + ?message_format + ?trace + ?plugins_dirs + ?disable_warnings + ?max_prec_digits + () = + Option.iter (fun x -> globals.input_file <- x) input_file; + Option.iter (fun x -> globals.language <- x) language; + Option.iter (fun x -> globals.debug <- x) debug; + Option.iter (fun x -> globals.color <- x) color; + Option.iter (fun x -> globals.message_format <- x) message_format; + Option.iter (fun x -> globals.trace <- x) trace; + Option.iter (fun x -> globals.plugins_dirs <- x) plugins_dirs; + Option.iter (fun x -> globals.disable_warnings <- x) disable_warnings; + Option.iter (fun x -> globals.max_prec_digits <- x) max_prec_digits; + globals open Cmdliner -let file = - Arg.( - required - & pos 0 (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.") +(* Arg converters for our custom types *) let when_opt = Arg.enum ["auto", Auto; "always", Always; "never", Never] -let color = - Arg.( - value - & opt ~vopt:Always when_opt Auto - & info ["color"] - ~doc: - "Allow output of colored and styled text. If set to $(i,auto), \ - enabled when the standard output is to a terminal.") +(** CLI flags and options *) -let message_format_opt = Arg.enum ["human", Human; "gnu", GNU] +module Flags = struct + open Cmdliner + open Arg -let message_format = - Arg.( - value - & opt message_format_opt Human - & info ["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.") + module Global = struct + let info = info ~docs:Manpage.s_common_options -let unstyled = - Arg.( + let input_file = + let converter = + conv ~docv:"FILE" + ( (fun s -> + Result.map (fun f -> FileName f) (conv_parser non_dir_file s)), + fun ppf -> function + | FileName f -> conv_printer non_dir_file ppf f + | _ -> assert false ) + in + required + & pos 0 (some converter) None + & Arg.info [] ~docv:"FILE" ~docs:Manpage.s_arguments + ~doc:"Catala master file to be compiled." + + let language = + value + & opt (some (enum languages)) None + & info ["l"; "language"] ~docv:"LANG" + ~doc: + "Locale variant of the input language to use when it can not be \ + inferred from the file extension." + + let debug = + value + & flag + & info ["debug"; "d"] + ~env:(Cmd.Env.info "CATALA_DEBUG") + ~doc:"Prints debug information." + + let color = + let unstyled = + value + & flag + & info ["unstyled"] + ~doc:"Removes styling (colors, etc.) from terminal output." + ~deprecated:"Use $(b,--color=)$(i,never) instead" + in + let color = + value + & opt ~vopt:Always when_opt Auto + & info ["color"] + ~env:(Cmd.Env.info "CATALA_COLOR") + ~doc: + "Allow output of colored and styled text. Use $(i,auto), to \ + enable when the standard output is to a terminal, $(i,never) to \ + disable." + in + Term.( + const (fun color unstyled -> if unstyled then Never else color) + $ color + $ unstyled) + + let message_format = + value + & opt (enum message_format_opt) Human + & info ["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 trace = + value + & flag + & info ["trace"; "t"] + ~doc: + "Displays a trace of the interpreter's computation or generates \ + logging instructions in translate programs." + + let plugins_dirs = + let doc = "Set the given directory to be searched for backend plugins." in + let env = Cmd.Env.info "CATALA_PLUGINS" in + let default = + let ( / ) = Filename.concat in + [ + Filename.dirname Sys.executable_name + / Filename.parent_dir_name + / "lib" + / "catala" + / "plugins"; + "_build" / "default" / "compiler" / "plugins"; + ] + in + value & opt_all dir default & info ["plugin-dir"] ~docv:"DIR" ~env ~doc + + let disable_warnings = + value + & flag + & info ["disable_warnings"] + ~doc:"Disable all the warnings emitted by the compiler." + + let max_prec_digits = + value + & opt int 20 + & info + ["p"; "max_digits_printed"] + ~docv:"NUM" + ~doc: + "Maximum number of significant digits printed for decimal results." + + let flags = + let make + language + debug + color + message_format + trace + plugins_dirs + disable_warnings + max_prec_digits : options = + if debug then Printexc.record_backtrace true; + (* This sets some global refs for convenience, but most importantly + returns the options record. *) + enforce_globals ~language ~debug ~color ~message_format ~trace + ~plugins_dirs ~disable_warnings ~max_prec_digits () + in + Term.( + const make + $ language + $ debug + $ color + $ message_format + $ trace + $ plugins_dirs + $ disable_warnings + $ max_prec_digits) + + let options = + let make input_file options : options = + (* Set some global refs for convenience *) + globals.input_file <- input_file; + { options with input_file } + in + Term.(const make $ input_file $ flags) + end + + let check_invariants = value & flag - & info ["unstyled"] - ~doc: - "Removes styling (colors, etc.) from terminal output. Equivalent to \ - $(b,--color=never)") + & info ["check_invariants"] ~doc:"Check structural invariants on the AST." -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 disable_warnings_opt = - Arg.( - value - & flag - & info ["disable_warnings"] - ~doc:"Disable all the warnings emitted by the compiler.") - -let check_invariants_opt = - Arg.( - value - & flag - & info ["check_invariants"] ~doc:"Check structural invariants on the AST.") - -let avoid_exceptions = - Arg.( - value - & flag - & info ["avoid_exceptions"] - ~doc:"Compiles the default calculus without exceptions.") - -let closure_conversion = - Arg.( - value - & flag - & info ["closure_conversion"] - ~doc:"Performs closure conversion on the lambda calculus.") - -let wrap_weaved_output = - Arg.( + let wrap_weaved_output = value & flag & info ["wrap"; "w"] - ~doc:"Wraps literate programming output with a minimal preamble.") + ~doc:"Wraps literate programming output with a minimal preamble." -let print_only_law = - Arg.( + let print_only_law = value & flag & info ["print_only_law"] ~doc: "In literate programming output, skip all code and metadata sections \ - and print only the text of the law.") + and print only the text of the law." -let plugins_dirs = - let doc = "Set the given directory to be searched for backend plugins." in - let env = Cmd.Env.info "CATALA_PLUGINS" ~doc in - let default = - let ( / ) = Filename.concat in - [ - Filename.dirname Sys.executable_name - / Filename.parent_dir_name - / "lib" - / "catala" - / "plugins"; - ] - in - Arg.(value & opt_all dir default & info ["plugin-dir"] ~docv:"DIR" ~env ~doc) + let ex_scope = + required + & opt (some string) None + & info ["s"; "scope"] ~docv:"SCOPE" ~doc:"Scope to be focused on." -let language = - Arg.( + let ex_scope_opt = value & opt (some string) None - & info ["l"; "language"] ~docv:"LANG" - ~doc:"Input language among: en, fr, pl.") + & info ["s"; "scope"] ~docv:"SCOPE" ~doc:"Scope to be focused on." -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 + let ex_variable = + required & opt (some string) None - & info ["s"; "scope"] ~docv:"SCOPE" ~doc:"Scope to be focused on.") + & info ["v"; "variable"] ~docv:"VARIABLE" ~doc:"Variable to be focused on." -let ex_variable = - Arg.( - value - & opt (some string) None - & info ["v"; "variable"] ~docv:"VARIABLE" ~doc:"Variable to be focused on.") - -let output = - Arg.( + let output = value & opt (some string) None & info ["output"; "o"] ~docv:"OUTPUT" + ~env:(Cmd.Env.info "CATALA_OUT") ~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. Use $(b,-o -) for stdout.") + the chosen backend. Use $(b,-o -) for stdout." -let link_modules = - Arg.( + let optimize = + value & flag & info ["optimize"; "O"] ~doc:"Run compiler optimizations." + + let avoid_exceptions = + value + & flag + & info ["avoid_exceptions"] + ~doc:"Compiles the default calculus without exceptions." + + let closure_conversion = + value + & flag + & info ["closure_conversion"] + ~doc: + "Performs closure conversion on the lambda calculus. Implies \ + $(b,--avoid-exceptions) and $(b,--optimize)." + + let link_modules = value & opt_all file [] & info ["use"; "u"] ~docv:"FILE" @@ -242,207 +306,21 @@ let link_modules = $(i,FILE) must be a catala file with a metadata section expressing \ what is exported ; for interpretation, a compiled OCaml shared \ module by the same basename (either .cmo or .cmxs) will be \ - expected.") + expected." -type global_options = { - debug : bool; - color : when_enum; - message_format : message_format_enum; - wrap_weaved_output : bool; - avoid_exceptions : bool; - plugins_dirs : string list; - language : string option; - max_prec_digits : int option; - trace : bool; - disable_warnings : bool; - disable_counterexamples : bool; - check_invariants : bool; - optimize : bool; - ex_scope : string option; - ex_variable : string option; - output_file : string option; - closure_conversion : bool; - print_only_law : bool; - link_modules : string list; -} - -let global_options = - let make - debug - color - message_format - unstyled - wrap_weaved_output - avoid_exceptions - closure_conversion - plugins_dirs - language - max_prec_digits - disable_warnings - trace - disable_counterexamples - optimize - check_invariants - ex_scope - ex_variable - output_file - print_only_law - link_modules : global_options = - { - debug; - color = (if unstyled then Never else color); - message_format; - wrap_weaved_output; - avoid_exceptions; - plugins_dirs; - language; - max_prec_digits; - disable_warnings; - trace; - disable_counterexamples; - optimize; - check_invariants; - ex_scope; - ex_variable; - output_file; - closure_conversion; - print_only_law; - link_modules; - } - in - Term.( - const make - $ debug - $ color - $ message_format - $ unstyled - $ wrap_weaved_output - $ avoid_exceptions - $ closure_conversion - $ plugins_dirs - $ language - $ max_prec_digits_opt - $ disable_warnings_opt - $ trace_opt - $ disable_counterexamples_opt - $ optimize - $ check_invariants_opt - $ ex_scope - $ ex_variable - $ output - $ print_only_law - $ link_modules) - -let set_option_globals options : unit = - debug_flag := options.debug; - style_flag := options.color; - (match options.max_prec_digits with - | None -> () - | Some i -> max_prec_digits := i); - disable_warnings_flag := options.disable_warnings; - trace_flag := options.trace; - optimize_flag := options.optimize; - check_invariants_flag := options.check_invariants; - disable_counterexamples := options.disable_counterexamples; - avoid_exceptions_flag := options.avoid_exceptions; - message_format_flag := options.message_format - -let subcommands handler = - [ - Cmd.v - (Cmd.info "interpret" - ~doc: - "Runs the interpreter on the Catala program, executing the scope \ - specified by the $(b,-s) option assuming no additional external \ - inputs.") - Term.(const (handler `Interpret) $ file $ global_options); - Cmd.v - (Cmd.info "interpret_lcalc" - ~doc: - "Runs the interpreter on the lcalc pass on the Catala program, \ - executing the scope specified by the $(b,-s) option assuming no \ - additional external inputs.") - Term.(const (handler `Interpret_Lcalc) $ file $ global_options); - Cmd.v - (Cmd.info "typecheck" - ~doc:"Parses and typechecks a Catala program, without interpreting it.") - Term.(const (handler `Typecheck) $ file $ global_options); - Cmd.v - (Cmd.info "proof" - ~doc: - "Generates and proves verification conditions about the \ - well-behaved execution of the Catala program.") - Term.(const (handler `Proof) $ file $ global_options); - Cmd.v - (Cmd.info "ocaml" - ~doc:"Generates an OCaml translation of the Catala program.") - Term.(const (handler `OCaml) $ file $ global_options); - Cmd.v - (Cmd.info "python" - ~doc:"Generates a Python translation of the Catala program.") - Term.(const (handler `Python) $ file $ global_options); - Cmd.v - (Cmd.info "latex" - ~doc: - "Weaves a LaTeX literate programming output of the Catala program.") - Term.(const (handler `Latex) $ file $ global_options); - Cmd.v - (Cmd.info "html" - ~doc: - "Weaves an HTML literate programming output of the Catala program.") - Term.(const (handler `Html) $ file $ global_options); - Cmd.v - (Cmd.info "makefile" - ~doc: - "Generates a Makefile-compatible list of the file dependencies of a \ - Catala program.") - Term.(const (handler `Makefile) $ file $ global_options); - Cmd.v - (Cmd.info "scopelang" - ~doc: - "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.") - Term.(const (handler `Scopelang) $ file $ global_options); - Cmd.v - (Cmd.info "dcalc" - ~doc: - "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.") - Term.(const (handler `Dcalc) $ file $ global_options); - Cmd.v - (Cmd.info "lcalc" - ~doc: - "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.") - Term.(const (handler `Lcalc) $ file $ global_options); - Cmd.v - (Cmd.info "scalc" - ~doc: - "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.") - Term.(const (handler `Scalc) $ file $ global_options); - Cmd.v - (Cmd.info "exceptions" - ~doc: - "Prints the exception tree for the definitions of a particular \ - variable, for debugging purposes. Use the $(b,-s) option to select \ - the scope and the $(b,-v) option to select the variable. Use \ - foo.bar to access state bar of variable foo or variable bar of \ - subscope foo.") - Term.(const (handler `Exceptions) $ file $ global_options); - Cmd.v - (Cmd.info "pygmentize" - ~doc: - "This special command is a wrapper around the $(b,pygmentize) \ - command that enables support for colorising Catala code.") - Term.(const (fun _ -> assert false) $ file); - ] + let disable_counterexamples = + value + & flag + & info + ["disable_counterexamples"] + ~doc: + "Disables the search for counterexamples. Useful when you want a \ + deterministic output from the Catala compiler, since provers can \ + have some randomness in them." +end let version = "0.8.0" +let s_plugins = "INSTALLED PLUGINS" let info = let doc = @@ -451,18 +329,30 @@ let info = in let man = [ + `S Manpage.s_synopsis; + `P "$(mname) [$(i,COMMAND)] $(i,FILE) [$(i,OPTION)]…"; + `P + "Use $(mname) [$(i,COMMAND)] $(b,--hel)p for documentation on a \ + specific command"; `S Manpage.s_description; `P "Catala is a domain-specific language for deriving \ faithful-by-construction algorithms from legislative texts."; + `S Manpage.s_commands; + `S s_plugins; `S Manpage.s_authors; - `P "The authors are listed by alphabetical order."; - `P "Nicolas Chataing "; - `P "Alain Delaët-Tixeuil "; - `P "Aymeric Fromherz "; - `P "Louis Gesbert "; - `P "Denis Merigoux "; - `P "Emile Rolley "; + `P "The authors are listed by alphabetical order:"; + `P "Nicolas Chataing <$(i,nicolas.chataing@ens.fr)>"; + `Noblank; + `P "Alain Delaët-Tixeuil <$(i,alain.delaet--tixeuil@inria.fr)>"; + `Noblank; + `P "Aymeric Fromherz <$(i,aymeric.fromherz@inria.fr)>"; + `Noblank; + `P "Louis Gesbert <$(i,louis.gesbert@ocamlpro.com)>"; + `Noblank; + `P "Denis Merigoux <$(i,denis.merigoux@inria.fr)>"; + `Noblank; + `P "Emile Rolley <$(i,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"; @@ -474,4 +364,4 @@ let info = let exits = Cmd.Exit.defaults @ [Cmd.Exit.info ~doc:"on error." 1] in Cmd.info "catala" ~version ~doc ~exits ~man -let catala_t ?(extra = []) handler = Cmd.group info (subcommands handler @ extra) +exception Exit_with of int diff --git a/compiler/catala_utils/cli.mli b/compiler/catala_utils/cli.mli index 1e5c58a9..141bc8cf 100644 --- a/compiler/catala_utils/cli.mli +++ b/compiler/catala_utils/cli.mli @@ -17,25 +17,15 @@ type backend_lang = En | Fr | Pl -type backend_option = - [ `Latex - | `Makefile - | `Html - | `Interpret - | `Interpret_Lcalc - | `Typecheck - | `OCaml - | `Python - | `Scalc - | `Lcalc - | `Dcalc - | `Scopelang - | `Exceptions - | `Proof ] - (** The usual auto/always/never option argument *) type when_enum = Auto | Always | Never +type message_format_enum = + | Human + | GNU (** Format of error and warning messages output by the compiler. *) + +type input_file = FileName of string | Contents of string + val languages : (string * backend_lang) list val language_code : backend_lang -> string @@ -43,85 +33,82 @@ val language_code : backend_lang -> string (** {2 Configuration globals} *) -val source_files : string list ref -(** Source files to be compiled *) - -val locale_lang : backend_lang ref -val contents : string ref -val debug_flag : bool ref - -val style_flag : when_enum ref -(** Styles the terminal output *) - -val optimize_flag : bool ref - -val max_prec_digits : int ref -(** Max number of digits to show for decimal results *) - -val trace_flag : bool ref -val disable_warnings_flag : bool ref - -val check_invariants_flag : bool ref -(** Check structural invariants on the AST. *) - -val disable_counterexamples : bool ref -(** Disables model-generated counterexamples for proofs that fail. *) - -val avoid_exceptions_flag : bool ref -(** Avoids using [try ... with] exceptions when compiling the default calculus. *) - -type message_format_enum = - | Human - | GNU (** Format of error and warning messages output by the compiler. *) - -val message_format_flag : message_format_enum ref - -(** {2 CLI terms} *) - -val file : string Cmdliner.Term.t -val debug : bool Cmdliner.Term.t -val unstyled : bool Cmdliner.Term.t -val trace_opt : bool Cmdliner.Term.t -val check_invariants_opt : bool Cmdliner.Term.t -val wrap_weaved_output : bool Cmdliner.Term.t -val print_only_law : bool Cmdliner.Term.t -val plugins_dirs : string list Cmdliner.Term.t -val language : string option Cmdliner.Term.t -val max_prec_digits_opt : int option Cmdliner.Term.t -val ex_scope : string option Cmdliner.Term.t -val output : string option Cmdliner.Term.t - -type global_options = { - debug : bool; - color : when_enum; - message_format : message_format_enum; - wrap_weaved_output : bool; - avoid_exceptions : bool; - plugins_dirs : string list; - language : string option; - max_prec_digits : int option; - trace : bool; - disable_warnings : bool; - disable_counterexamples : bool; - check_invariants : bool; - optimize : bool; - ex_scope : string option; - ex_variable : string option; - output_file : string option; - closure_conversion : bool; - print_only_law : bool; - link_modules : string list; +type options = private { + mutable input_file : input_file; + mutable language : backend_lang option; + mutable debug : bool; + mutable color : when_enum; + mutable message_format : message_format_enum; + mutable trace : bool; + mutable plugins_dirs : string list; + mutable disable_warnings : bool; + mutable max_prec_digits : int; } +(** Global options, common to all subcommands (note: the fields are internally + mutable only for purposes of the [globals] toplevel value defined below) *) + +val globals : options +(** A global definition to the global options is provided for convenience, e.g. + choosing the proper output in formatting functions. Prefer the use of the + options returned by the command-line parsing whenever possible. *) + +val enforce_globals : + ?input_file:input_file -> + ?language:backend_lang option -> + ?debug:bool -> + ?color:when_enum -> + ?message_format:message_format_enum -> + ?trace:bool -> + ?plugins_dirs:string list -> + ?disable_warnings:bool -> + ?max_prec_digits:int -> + unit -> + options +(** Sets up the global options (side-effect); for specific use-cases only, this + should never be called from the compiler or when going through normal + command-line parsing. Proper uses include setting up the compiler library + when using it directly through a specific front-end. *) + +(** {2 CLI flags and options} *) + +module Flags : sig + open Cmdliner + + module Global : sig + val flags : options Term.t + (** Global flags available to all commands. Note that parsing this term also + performs some side-effects into [GlobalRefs] and sets up signal/error + processing. Sets [input_file] to [FileName "-"], use [options] for the + full parser *) + + val options : options Term.t + (** [flags] plus an additional positional argument for the input file *) + end + + (** Parsers for all flags and options that commands can use *) + + val check_invariants : bool Term.t + val wrap_weaved_output : bool Term.t + val print_only_law : bool Term.t + val ex_scope : string Term.t + val ex_scope_opt : string option Term.t + val ex_variable : string Term.t + val output : string option Term.t + val optimize : bool Term.t + val avoid_exceptions : bool Term.t + val closure_conversion : bool Term.t + val link_modules : string list Term.t + val disable_counterexamples : bool Term.t +end + (** {2 Command-line application} *) -val global_options : global_options Cmdliner.Term.t - -val catala_t : - ?extra:int Cmdliner.Cmd.t list -> - (backend_option -> string -> global_options -> int) -> - int Cmdliner.Cmd.t -(** Main entry point: [catala_t file options] *) - -val set_option_globals : global_options -> unit val version : string val info : Cmdliner.Cmd.info + +val s_plugins : string +(** Manpage section name for the installed plugins *) + +exception Exit_with of int +(** Exit with a specific exit code (but less brutally than [Sys.exit] which + would bypass all finalisers) *) diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index 0aadad13..84f0b2fe 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -28,7 +28,7 @@ let finally f k = let temp_file pfx sfx = let f = Filename.temp_file pfx sfx in - if not !Cli.debug_flag then + if not Cli.globals.debug then at_exit (fun () -> try Sys.remove f with _ -> ()); f @@ -58,7 +58,7 @@ let get_out_channel ~source_file ~output_file ?ext () = | Some f, _ -> Some f, with_out_channel f | None, Some ext -> let src = - match source_file with Pos.FileName f -> f | Pos.Contents _ -> "a" + match source_file with Cli.FileName f -> f | Cli.Contents _ -> "a" in let f = Filename.remove_extension src ^ ext in Some f, with_out_channel f @@ -108,3 +108,11 @@ let process_out ?check_exit cmd args = done; assert false with End_of_file -> Buffer.contents buf + +let check_directory d = + try + let d = Unix.realpath d in + if Sys.is_directory d then Some d else None + with Unix.Unix_error _ | Sys_error _ -> None + +let ( / ) = Filename.concat diff --git a/compiler/catala_utils/file.mli b/compiler/catala_utils/file.mli index 19e4e8c5..4e096eef 100644 --- a/compiler/catala_utils/file.mli +++ b/compiler/catala_utils/file.mli @@ -42,7 +42,7 @@ val with_formatter_of_opt_file : string option -> (Format.formatter -> 'a) -> 'a {!with_formatter_of_file}), otherwise, uses the [Format.std_formatter]. *) val get_out_channel : - source_file:Pos.input_file -> + source_file:Cli.input_file -> output_file:string option -> ?ext:string -> unit -> @@ -52,7 +52,7 @@ val get_out_channel : equal to [Some "-"] returns a wrapper around [stdout]. *) val get_formatter_of_out_channel : - source_file:Pos.input_file -> + source_file:Cli.input_file -> output_file:string option -> ?ext:string -> unit -> @@ -79,3 +79,11 @@ val process_out : ?check_exit:(int -> unit) -> string -> string list -> string arguments, and returns the stdout of the process as a string. [check_exit] is called on the return code of the sub-process, the default is to fail on anything but 0. *) + +val check_directory : string -> string option +(** Checks if the given directory exists and returns it normalised (as per + [Unix.realpath]). *) + +val ( / ) : string -> string -> string +(** [Filename.concat]: Sugar to allow writing + [File.("some" / "relative" / "path")] *) diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index db4cdfa0..2e8ba2a8 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -1,3 +1,20 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2023 Inria, + contributors: Denis Merigoux , Louis Gesbert + + + 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. *) + (** Error formatting and helper functions *) (**{1 Terminal formatting}*) @@ -22,7 +39,7 @@ let () = ignore (unstyle_formatter Format.str_formatter) below std_ppf / err_ppf *) let has_color oc = - match !Cli.style_flag with + match Cli.globals.color with | Cli.Never -> false | Always -> true | Auto -> Unix.(isatty (descr_of_out_channel oc)) @@ -61,8 +78,8 @@ type content_type = Error | Warning | Debug | Log | Result let get_ppf = function | Result -> Lazy.force std_ppf - | Debug when not !Cli.debug_flag -> Lazy.force ignore_ppf - | Warning when !Cli.disable_warnings_flag -> Lazy.force ignore_ppf + | Debug when not Cli.globals.debug -> Lazy.force ignore_ppf + | Warning when Cli.globals.disable_warnings -> Lazy.force ignore_ppf | Error | Log | Debug | Warning -> Lazy.force err_ppf (**{3 Markers}*) @@ -75,7 +92,7 @@ let print_time_marker = time := new_time; let delta = (new_time -. old_time) *. 1000. in if delta > 50. then - Format.fprintf ppf "@{[TIME] %.0fms@}@ " delta + Format.fprintf ppf "@{[TIME] %.0fms@}@\n" delta let pp_marker target ppf = let open Ocolor_types in @@ -129,14 +146,14 @@ open Content let emit_content (content : Content.t) (target : content_type) : unit = let { message; positions } = content in - match !Cli.message_format_flag with + match Cli.globals.message_format with | Cli.Human -> let ppf = get_ppf target in Format.fprintf ppf "@[@[%t%t%t@]%a@]@." (pp_marker target) (fun ppf -> match target with - | Log | Error | Warning -> Format.pp_print_char ppf ' ' - | Result | Debug -> Format.pp_print_space ppf ()) + | Log | Error | Warning | Debug -> Format.pp_print_char ppf ' ' + | Result -> Format.pp_print_space ppf ()) message (fun ppf l -> Format.pp_print_list diff --git a/compiler/catala_utils/pos.ml b/compiler/catala_utils/pos.ml index d5de0f14..f928da0e 100644 --- a/compiler/catala_utils/pos.ml +++ b/compiler/catala_utils/pos.ml @@ -84,8 +84,6 @@ let get_end_column (pos : t) : int = let get_file (pos : t) : string = (fst pos.code_pos).Lexing.pos_fname -type input_file = FileName of string | Contents of string - let to_string (pos : t) : string = let s, e = pos.code_pos in Printf.sprintf "in file %s, from %d:%d to %d:%d" s.Lexing.pos_fname @@ -146,7 +144,10 @@ let format_loc_text ppf (pos : t) = let ic, input_line_opt = if filename = "stdin" then let line_index = ref 0 in - let lines = String.split_on_char '\n' !Cli.contents in + let lines = + String.split_on_char '\n' + (match Cli.globals.input_file with Contents s -> s | _ -> "") + in let input_line_opt () : string option = match List.nth_opt lines !line_index with | Some l -> diff --git a/compiler/catala_utils/pos.mli b/compiler/catala_utils/pos.mli index 69be2f5d..efce5f71 100644 --- a/compiler/catala_utils/pos.mli +++ b/compiler/catala_utils/pos.mli @@ -39,8 +39,6 @@ val join : t -> t -> t if they don't belong to the same file. The law position used is the one of the earliest position. *) -type input_file = FileName of string | Contents of string - (**{2 Formatters}*) val to_string : t -> string diff --git a/compiler/catala_web_interpreter.ml b/compiler/catala_web_interpreter.ml index 35e53290..7dcad020 100644 --- a/compiler/catala_web_interpreter.ml +++ b/compiler/catala_web_interpreter.ml @@ -10,27 +10,22 @@ let _ = (scope : Js.js_string Js.t) (language : Js.js_string Js.t) (trace : bool) = - driver `Interpret - (Contents (Js.to_string contents)) - { - Cli.debug = false; - color = Never; - wrap_weaved_output = false; - avoid_exceptions = false; - plugins_dirs = []; - language = Some (Js.to_string language); - max_prec_digits = None; - closure_conversion = false; - message_format = Human; - trace; - disable_warnings = true; - disable_counterexamples = false; - optimize = false; - check_invariants = false; - ex_scope = Some (Js.to_string scope); - ex_variable = None; - output_file = None; - print_only_law = false; - link_modules = []; - } + let contents = Js.to_string contents in + let scope = Js.to_string scope in + let language = Js.to_string language in + let language = + try List.assoc (String.lowercase_ascii language) Cli.languages + with Not_found -> + Message.raise_error "Unrecognised input locale %S" language + in + let options = + Cli.enforce_globals ~input_file:(Contents contents) + ~language:(Some language) ~debug:false ~color:Never ~trace () + in + let prg, ctx, _type_order = + Passes.dcalc options ~link_modules:[] ~optimize:false + ~check_invariants:false + in + Shared_ast.Interpreter.interpret_program_dcalc prg + (Commands.get_scope_uid ctx scope) end) diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index e01b0192..be5da368 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -135,7 +135,7 @@ let tag_with_log_entry (markings : Uid.MarkedString.info list) : 'm Ast.expr boxed = let m = mark_tany (Mark.get e) (Expr.pos e) in - if !Cli.trace_flag then + if Cli.globals.trace then Expr.eapp (Expr.eop (Log (l, markings)) [TAny, Expr.pos e] m) [e] m else e diff --git a/compiler/driver.ml b/compiler/driver.ml index f839fbc5..1b36a34b 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -1,7 +1,7 @@ (* 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 , Emile Rolley - + , Louis Gesbert 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 @@ -16,21 +16,208 @@ the License. *) open Catala_utils +open Shared_ast (** Associates a file extension with its corresponding {!type: Cli.backend_lang} string representation. *) let extensions = [".catala_fr", "fr"; ".catala_en", "en"; ".catala_pl", "pl"] -type backend = [ Cli.backend_option | `Plugin of Plugin.handler ] +let modname_of_file f = + (* Fixme: make this more robust *) + String.capitalize_ascii Filename.(basename (remove_extension f)) -let get_scope_uid - (options : Cli.global_options) - (backend : backend) - (ctxt : Desugared.Name_resolution.context) = - match options.ex_scope, backend with - | None, `Interpret -> - Message.raise_error "No scope was provided for execution." - | None, _ -> +let get_lang options filename = + Option.bind + (List.assoc_opt (Filename.extension filename) extensions) + (fun l -> List.assoc_opt l Cli.languages) + |> function + | Some lang -> lang + | None -> ( + match options.Cli.language with + | Some lang -> lang + | None -> + Message.raise_error + "Could not infer language variant from the extension of \ + @{%s@}, and @{--language@} was not specified" + filename) + +let load_module_interfaces prg options link_modules = + List.fold_left + (fun prg f -> + let lang = get_lang options f in + let modname = modname_of_file f in + Surface.Parser_driver.add_interface (FileName f) lang [modname] prg) + prg link_modules + +module Passes = struct + (* Each pass takes only its cli options, then calls upon its dependent passes + (forwarding their options as needed) *) + + let surface options : Surface.Ast.program * Cli.backend_lang = + Message.emit_debug "Reading files..."; + let language = + get_lang options + (match options.input_file with FileName s -> s | Contents _ -> "") + in + let prg = + Surface.Parser_driver.parse_top_level_file options.input_file language + in + Surface.Fill_positions.fill_pos_with_legislative_info prg, language + + let desugared options ~link_modules : + Desugared.Ast.program * Desugared.Name_resolution.context = + let prg, _ = surface options in + let prg = load_module_interfaces prg options link_modules in + Message.emit_debug "Name resolution..."; + let ctx = Desugared.Name_resolution.form_context prg in + (* let scope_uid = get_scope_uid options backend ctx in + * (\* This uid is a Desugared identifier *\) + * let variable_uid = get_variable_uid options backend ctx scope_uid in *) + Message.emit_debug "Desugaring..."; + let prg = Desugared.From_surface.translate_program ctx prg in + Message.emit_debug "Disambiguating..."; + let prg = Desugared.Disambiguate.program prg in + Message.emit_debug "Linting..."; + Desugared.Linting.lint_program prg; + prg, ctx + (* Note: we forward the name resolution context throughout in order to locate + uids from strings. Maybe a reduced form should be included directly in + [prg] for that purpose *) + + let scopelang options ~link_modules : + untyped Scopelang.Ast.program + * Desugared.Name_resolution.context + * Desugared.Dependency.ExceptionsDependencies.t + Desugared.Ast.ScopeDef.Map.t = + Message.emit_debug "Collecting rules..."; + let prg, ctx = desugared options ~link_modules in + let exceptions_graphs = + Scopelang.From_desugared.build_exceptions_graph prg + in + let prg = + Scopelang.From_desugared.translate_program prg exceptions_graphs + in + prg, ctx, exceptions_graphs + + let dcalc options ~link_modules ~optimize ~check_invariants : + typed Dcalc.Ast.program + * Desugared.Name_resolution.context + * Scopelang.Dependency.TVertex.t list = + let prg, ctx, _ = scopelang options ~link_modules in + Message.emit_debug "Typechecking..."; + let type_ordering = + Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs + prg.program_ctx.ctx_enums + in + let prg = Scopelang.Ast.type_program prg in + Message.emit_debug "Translating to default calculus..."; + let prg = Dcalc.From_scopelang.translate_program prg in + let prg = + if optimize then begin + Message.emit_debug "Optimizing default calculus..."; + Optimizations.optimize_program prg + end + else prg + in + Message.emit_debug "Typechecking again..."; + let prg = + try Typing.program ~leave_unresolved:false prg + with Message.CompilerError error_content -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace + (Message.CompilerError + (Message.Content.mark_as_internal_error error_content)) + bt + in + if check_invariants then ( + Message.emit_debug "Checking invariants..."; + let result = Dcalc.Invariants.check_all_invariants prg in + if not result then + raise (Message.raise_internal_error "Some Dcalc invariants are invalid")); + prg, ctx, type_ordering + + let lcalc + options + ~link_modules + ~optimize + ~check_invariants + ~avoid_exceptions + ~closure_conversion : + untyped Lcalc.Ast.program + * Desugared.Name_resolution.context + * Scopelang.Dependency.TVertex.t list = + let prg, ctx, type_ordering = + dcalc options ~link_modules ~optimize ~check_invariants + in + Message.emit_debug "Compiling program into lambda calculus..."; + let avoid_exceptions = avoid_exceptions || closure_conversion in + let optimize = optimize || closure_conversion in + (* --closure_conversion implies --avoid_exceptions and --optimize *) + let prg = + if avoid_exceptions then ( + if options.trace then + Message.raise_error + "Option --avoid_exceptions is not compatible with option --trace"; + Lcalc.Compile_without_exceptions.translate_program prg) + else Program.untype (Lcalc.Compile_with_exceptions.translate_program prg) + in + let prg = + if optimize then begin + Message.emit_debug "Optimizing lambda calculus..."; + Optimizations.optimize_program prg + end + else prg + in + let prg = + if not closure_conversion then prg + else ( + Message.emit_debug "Performing closure conversion..."; + let prg = Lcalc.Closure_conversion.closure_conversion prg in + let prg = Bindlib.unbox prg in + let prg = + if optimize then ( + Message.emit_debug "Optimizing lambda calculus..."; + Optimizations.optimize_program prg) + else prg + in + Message.emit_debug "Retyping lambda calculus..."; + let prg = Program.untype (Typing.program ~leave_unresolved:true prg) in + prg) + in + prg, ctx, type_ordering + + let scalc + options + ~link_modules + ~optimize + ~check_invariants + ~avoid_exceptions + ~closure_conversion : + Scalc.Ast.program + * Desugared.Name_resolution.context + * Scopelang.Dependency.TVertex.t list = + let prg, ctx, type_ordering = + lcalc options ~link_modules ~optimize ~check_invariants ~avoid_exceptions + ~closure_conversion + in + Message.emit_debug "Compiling program into statement calculus..."; + Scalc.From_lcalc.translate_program prg, ctx, type_ordering +end + +module Commands = struct + open Cmdliner + + let get_scope_uid (ctxt : Desugared.Name_resolution.context) (scope : string) + = + match Ident.Map.find_opt scope ctxt.typedefs with + | Some (Desugared.Name_resolution.TScope (uid, _)) -> uid + | _ -> + Message.raise_error + "There is no scope @{\"%s\"@} inside the program." scope + + (* TODO: this is very weird but I'm trying to maintain the current behaviour + for now *) + let get_random_scope_uid (ctxt : Desugared.Name_resolution.context) = let _, scope = try Shared_ast.Ident.Map.filter_map @@ -43,47 +230,27 @@ let get_scope_uid Message.raise_error "There isn't any scope inside the program." in scope - | Some name, _ -> ( - match Shared_ast.Ident.Map.find_opt name ctxt.typedefs with - | Some (Desugared.Name_resolution.TScope (uid, _)) -> uid - | _ -> - Message.raise_error - "There is no scope @{\"%s\"@} inside the program." name) -let get_variable_uid - (options : Cli.global_options) - (backend : backend) - (ctxt : Desugared.Name_resolution.context) - (scope_uid : Shared_ast.ScopeName.t) = - match options.ex_variable, backend with - | None, `Exceptions -> - Message.raise_error - "Please specify a variable with the -v option to print its exception \ - tree." - | None, _ -> None - | Some name, _ -> ( - (* Sometimes the variable selected is of the form [a.b]*) + let get_variable_uid + (ctxt : Desugared.Name_resolution.context) + (scope_uid : ScopeName.t) + (variable : string) = + (* Sometimes the variable selected is of the form [a.b] *) let first_part, second_part = - match - Re.( - exec_opt - (compile - @@ whole_string - @@ seq [group (rep1 (compl [char '.'])); char '.'; group (rep1 any)] - ) - name) - with - | None -> name, None - | Some groups -> Re.Group.get groups 1, Some (Re.Group.get groups 2) + match String.index_opt variable '.' with + | Some i -> + ( String.sub variable 0 i, + Some (String.sub variable i (String.length variable - i)) ) + | None -> variable, None in match - Shared_ast.Ident.Map.find_opt first_part - (Shared_ast.ScopeName.Map.find scope_uid ctxt.scopes).var_idmap + Ident.Map.find_opt first_part + (ScopeName.Map.find scope_uid ctxt.scopes).var_idmap with | None -> Message.raise_error "Variable @{\"%s\"@} not found inside scope @{\"%a\"@}" - name Shared_ast.ScopeName.format_t scope_uid + variable ScopeName.format_t scope_uid | Some (Desugared.Name_resolution.SubScope (subscope_var_name, subscope_name)) -> ( @@ -93,513 +260,587 @@ let get_variable_uid "Subscope @{\"%a\"@} of scope @{\"%a\"@} cannot be \ selected by itself, please add \".\" where is a subscope \ variable." - Shared_ast.SubScopeName.format_t subscope_var_name - Shared_ast.ScopeName.format_t scope_uid + SubScopeName.format_t subscope_var_name ScopeName.format_t scope_uid | Some second_part -> ( match - Shared_ast.Ident.Map.find_opt second_part - (Shared_ast.ScopeName.Map.find subscope_name ctxt.scopes).var_idmap + Ident.Map.find_opt second_part + (ScopeName.Map.find subscope_name ctxt.scopes).var_idmap with | Some (Desugared.Name_resolution.ScopeVar v) -> - Some - (Desugared.Ast.ScopeDef.SubScopeVar - (subscope_var_name, v, Pos.no_pos)) + Desugared.Ast.ScopeDef.SubScopeVar (subscope_var_name, v, Pos.no_pos) | _ -> Message.raise_error "Var @{\"%s\"@} of subscope @{\"%a\"@} in scope \ @{\"%a\"@} does not exist, please check your command line \ arguments." - second_part Shared_ast.SubScopeName.format_t subscope_var_name - Shared_ast.ScopeName.format_t scope_uid)) + second_part SubScopeName.format_t subscope_var_name + ScopeName.format_t scope_uid)) | Some (Desugared.Name_resolution.ScopeVar v) -> - Some - (Desugared.Ast.ScopeDef.Var - ( v, - Option.map - (fun second_part -> - let var_sig = Shared_ast.ScopeVar.Map.find v ctxt.var_typs in - match - Shared_ast.Ident.Map.find_opt second_part - var_sig.var_sig_states_idmap - with - | Some state -> state - | None -> - Message.raise_error - "State @{\"%s\"@} is not found for variable \ - @{\"%s\"@} of scope @{\"%a\"@}" - second_part first_part Shared_ast.ScopeName.format_t - scope_uid) - second_part ))) + Desugared.Ast.ScopeDef.Var + ( v, + Option.map + (fun second_part -> + let var_sig = ScopeVar.Map.find v ctxt.var_typs in + match + Ident.Map.find_opt second_part var_sig.var_sig_states_idmap + with + | Some state -> state + | None -> + Message.raise_error + "State @{\"%s\"@} is not found for variable \ + @{\"%s\"@} of scope @{\"%a\"@}" + second_part first_part ScopeName.format_t scope_uid) + second_part ) -let modname_of_file f = - (* Fixme: make this more robust *) - String.capitalize_ascii Filename.(basename (remove_extension f)) + let get_output ?ext options output_file = + File.get_out_channel ~source_file:options.Cli.input_file ~output_file ?ext + () -(** Entry function for the executable. Returns a negative number in case of - error. Usage: [driver source_file options]*) -let driver backend source_file (options : Cli.global_options) : int = - try - Cli.set_option_globals options; - if options.debug then Printexc.record_backtrace true; - Message.emit_debug "Reading files..."; - let filename = ref "" in - (match source_file with - | Pos.FileName f -> filename := f - | Contents c -> Cli.contents := c); - let l = - match options.language with - | Some l -> l - | None -> ( - (* Try to infer the language from the intput file extension. *) - let ext = Filename.extension !filename in - if ext = "" then - Message.raise_error - "No file extension found for the file '%s'. (Try to add one or to \ - specify the -l flag)" - !filename; - try List.assoc ext extensions with Not_found -> ext) + let get_output_format ?ext options output_file = + File.get_formatter_of_out_channel ~source_file:options.Cli.input_file + ~output_file ?ext () + + let makefile options output = + let prg, _ = Passes.surface options in + let backend_extensions_list = [".tex"] in + let source_file = + match options.Cli.input_file with + | FileName f -> f + | Contents _ -> + Message.raise_error "The Makefile backend requires a filename as input" in - let language = - try List.assoc l Cli.languages - with Not_found -> + let output_file, with_output = get_output options ~ext:".d" output in + Message.emit_debug "Writing list of dependencies to %s..." + (Option.value ~default:"stdout" output_file); + with_output + @@ fun oc -> + Printf.fprintf oc "%s:\\\n%s\n%s:" + (String.concat "\\\n" + (Option.value ~default:"stdout" output_file + :: List.map + (fun ext -> Filename.remove_extension source_file ^ ext) + backend_extensions_list)) + (String.concat "\\\n" prg.Surface.Ast.program_source_files) + (String.concat "\\\n" prg.Surface.Ast.program_source_files) + + let makefile_cmd = + Cmd.v + (Cmd.info "makefile" + ~doc: + "Generates a Makefile-compatible list of the file dependencies of a \ + Catala program.") + Term.(const makefile $ Cli.Flags.Global.options $ Cli.Flags.output) + + let html options output print_only_law wrap_weaved_output = + let prg, language = Passes.surface options in + Message.emit_debug "Weaving literate program into HTML"; + let output_file, with_output = + get_output_format options ~ext:".html" output + in + with_output + @@ fun fmt -> + let weave_output = Literate.Html.ast_to_html language ~print_only_law in + Message.emit_debug "Writing to %s" + (Option.value ~default:"stdout" output_file); + if wrap_weaved_output then + Literate.Html.wrap_html prg.Surface.Ast.program_source_files language fmt + (fun fmt -> weave_output fmt prg) + else weave_output fmt prg + + let html_cmd = + Cmd.v + (Cmd.info "html" + ~doc: + "Weaves an HTML literate programming output of the Catala program.") + Term.( + const html + $ Cli.Flags.Global.options + $ Cli.Flags.output + $ Cli.Flags.print_only_law + $ Cli.Flags.wrap_weaved_output) + + let latex options output print_only_law wrap_weaved_output = + let prg, language = Passes.surface options in + Message.emit_debug "Weaving literate program into LaTeX"; + let output_file, with_output = + get_output_format options ~ext:".tex" output + in + with_output + @@ fun fmt -> + let weave_output = Literate.Latex.ast_to_latex language ~print_only_law in + Message.emit_debug "Writing to %s" + (Option.value ~default:"stdout" output_file); + if wrap_weaved_output then + Literate.Latex.wrap_latex prg.Surface.Ast.program_source_files language + fmt (fun fmt -> weave_output fmt prg) + else weave_output fmt prg + + let latex_cmd = + Cmd.v + (Cmd.info "latex" + ~doc: + "Weaves a LaTeX literate programming output of the Catala program.") + Term.( + const latex + $ Cli.Flags.Global.options + $ Cli.Flags.output + $ Cli.Flags.print_only_law + $ Cli.Flags.wrap_weaved_output) + + let exceptions options link_modules ex_scope ex_variable = + let _, ctxt, exceptions_graphs = Passes.scopelang options ~link_modules in + let scope_uid = get_scope_uid ctxt ex_scope in + let variable_uid = get_variable_uid ctxt scope_uid ex_variable in + Desugared.Print.print_exceptions_graph scope_uid variable_uid + (Desugared.Ast.ScopeDef.Map.find variable_uid exceptions_graphs) + + let exceptions_cmd = + Cmd.v + (Cmd.info "exceptions" + ~doc: + "Prints the exception tree for the definitions of a particular \ + variable, for debugging purposes. Use the $(b,-s) option to select \ + the scope and the $(b,-v) option to select the variable. Use \ + foo.bar to access state bar of variable foo or variable bar of \ + subscope foo.") + Term.( + const exceptions + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.ex_scope + $ Cli.Flags.ex_variable) + + let scopelang options link_modules output ex_scope_opt = + let prg, ctx, _ = Passes.scopelang options ~link_modules in + let _output_file, with_output = get_output_format options output in + with_output + @@ fun fmt -> + match ex_scope_opt with + | Some scope -> + let scope_uid = get_scope_uid ctx scope in + Scopelang.Print.scope ~debug:options.Cli.debug prg.program_ctx fmt + (scope_uid, ScopeName.Map.find scope_uid prg.program_scopes); + Format.pp_print_newline fmt () + | None -> + Scopelang.Print.program ~debug:options.Cli.debug fmt prg; + Format.pp_print_newline fmt () + + let scopelang_cmd = + Cmd.v + (Cmd.info "scopelang" + ~doc: + "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.") + Term.( + const scopelang + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.ex_scope_opt) + + let typecheck options link_modules = + let prg, _, _ = Passes.scopelang options ~link_modules in + Message.emit_debug "Typechecking..."; + let _type_ordering = + Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs + prg.program_ctx.ctx_enums + in + let prg = Scopelang.Ast.type_program prg in + Message.emit_debug "Translating to default calculus..."; + (* Strictly type-checking could stop here, but we also want this pass to + check full name-resolution and cycle detection. These are checked during + translation to dcalc so we run it here and drop the result. *) + let _prg = Dcalc.From_scopelang.translate_program prg in + Message.emit_result "Typechecking successful!" + + let typecheck_cmd = + Cmd.v + (Cmd.info "typecheck" + ~doc:"Parses and typechecks a Catala program, without interpreting it.") + Term.(const typecheck $ Cli.Flags.Global.options $ Cli.Flags.link_modules) + + let dcalc options link_modules output optimize ex_scope_opt check_invariants = + let prg, ctx, _ = + Passes.dcalc options ~link_modules ~optimize ~check_invariants + in + let _output_file, with_output = get_output_format options output in + with_output + @@ fun fmt -> + match ex_scope_opt with + | Some scope -> + let scope_uid = get_scope_uid ctx scope in + Print.scope ~debug:options.Cli.debug prg.decl_ctx fmt + ( scope_uid, + Option.get + (Scope.fold_left ~init:None + ~f:(fun acc def _ -> + match def with + | ScopeDef (name, body) when ScopeName.equal name scope_uid -> + Some body + | _ -> acc) + prg.code_items) ); + Format.pp_print_newline fmt () + | None -> + let scope_uid = get_random_scope_uid ctx in + (* TODO: ??? *) + let prg_dcalc_expr = Expr.unbox (Program.to_expr prg scope_uid) in + Format.fprintf fmt "%a\n" + (Print.expr ~debug:options.Cli.debug ()) + prg_dcalc_expr + + let dcalc_cmd = + Cmd.v + (Cmd.info "dcalc" + ~doc: + "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.") + Term.( + const dcalc + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.ex_scope_opt + $ Cli.Flags.check_invariants) + + let proof + options + link_modules + optimize + ex_scope_opt + check_invariants + disable_counterexamples = + let prg, ctx, _ = + Passes.dcalc options ~link_modules ~optimize ~check_invariants + in + Verification.Globals.setup ~optimize ~disable_counterexamples; + let vcs = + Verification.Conditions.generate_verification_conditions prg + (Option.map (get_scope_uid ctx) ex_scope_opt) + in + Verification.Solver.solve_vc prg.decl_ctx vcs + + let proof_cmd = + Cmd.v + (Cmd.info "proof" + ~doc: + "Generates and proves verification conditions about the \ + well-behaved execution of the Catala program.") + Term.( + const proof + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.optimize + $ Cli.Flags.ex_scope_opt + $ Cli.Flags.check_invariants + $ Cli.Flags.disable_counterexamples) + + let print_interpretation_results options interpreter prg scope_uid = + Message.emit_debug "Starting interpretation..."; + let results = + try interpreter prg scope_uid + with Shared_ast.Interpreter.CatalaException exn -> Message.raise_error - "The selected language (%s) is not supported by Catala" l + "During interpretation, the error %a has been raised but not caught!" + Shared_ast.Print.except exn in - Cli.locale_lang := language; - let prgm = - Surface.Parser_driver.parse_top_level_file source_file language + Message.emit_debug "End of interpretation"; + let results = + List.sort (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) results in - let prgm = Surface.Fill_positions.fill_pos_with_legislative_info prgm in - let prgm = - List.fold_left - (fun prgm f -> - let lang = - Option.value ~default:language - @@ Option.bind - (List.assoc_opt (Filename.extension f) extensions) - (fun l -> List.assoc_opt l Cli.languages) - in - let modname = modname_of_file f in - Surface.Parser_driver.add_interface (FileName f) lang [modname] prgm) - prgm options.link_modules - in - let get_output ?ext = - File.get_out_channel ~source_file ~output_file:options.output_file ?ext - in - let get_output_format ?ext = - File.get_formatter_of_out_channel ~source_file - ~output_file:options.output_file ?ext - in - (match backend with - | `Makefile -> - let backend_extensions_list = [".tex"] in - let source_file = - match source_file with - | FileName f -> f - | Contents _ -> - Message.raise_error - "The Makefile backend does not work if the input is not a file" - in - let output_file, with_output = get_output ~ext:".d" () in - Message.emit_debug "Writing list of dependencies to %s..." - (Option.value ~default:"stdout" output_file); - with_output - @@ fun oc -> - Printf.fprintf oc "%s:\\\n%s\n%s:" - (String.concat "\\\n" - (Option.value ~default:"stdout" output_file - :: List.map - (fun ext -> Filename.remove_extension source_file ^ ext) - backend_extensions_list)) - (String.concat "\\\n" prgm.program_source_files) - (String.concat "\\\n" prgm.program_source_files) - | (`Latex | `Html) as backend -> - Message.emit_debug "Weaving literate program into %s" - (match backend with `Latex -> "LaTeX" | `Html -> "HTML"); - let output_file, with_output = - get_output_format () - ~ext:(match backend with `Latex -> ".tex" | `Html -> ".html") - in - with_output (fun fmt -> - let weave_output = - match backend with - | `Latex -> - Literate.Latex.ast_to_latex language - ~print_only_law:options.print_only_law - | `Html -> - Literate.Html.ast_to_html language - ~print_only_law:options.print_only_law - in - Message.emit_debug "Writing to %s" - (Option.value ~default:"stdout" output_file); - if options.wrap_weaved_output then - match backend with - | `Latex -> - Literate.Latex.wrap_latex prgm.Surface.Ast.program_source_files - language fmt (fun fmt -> weave_output fmt prgm) - | `Html -> - Literate.Html.wrap_html prgm.Surface.Ast.program_source_files - language fmt (fun fmt -> weave_output fmt prgm) - else weave_output fmt prgm) - | ( `Interpret | `Interpret_Lcalc | `Typecheck | `OCaml | `Python | `Scalc - | `Lcalc | `Dcalc | `Scopelang | `Exceptions | `Proof | `Plugin _ ) as - backend -> ( - Message.emit_debug "Name resolution..."; - let ctxt = Desugared.Name_resolution.form_context prgm in - let scope_uid = get_scope_uid options backend ctxt in - (* This uid is a Desugared identifier *) - let variable_uid = get_variable_uid options backend ctxt scope_uid in - Message.emit_debug "Desugaring..."; - let prgm = Desugared.From_surface.translate_program ctxt prgm in - Message.emit_debug "Disambiguating..."; - let prgm = Desugared.Disambiguate.program prgm in - Message.emit_debug "Linting..."; - Desugared.Linting.lint_program prgm; - Message.emit_debug "Collecting rules..."; - let exceptions_graphs = - Scopelang.From_desugared.build_exceptions_graph prgm - in - let prgm = - Scopelang.From_desugared.translate_program prgm exceptions_graphs - in - match backend with - | `Exceptions -> - let variable_uid = - match variable_uid with - | Some variable_uid -> variable_uid - | None -> - Message.raise_error - "Please provide a scope variable to analyze with the -v option." - in - Desugared.Print.print_exceptions_graph scope_uid variable_uid - (Desugared.Ast.ScopeDef.Map.find variable_uid exceptions_graphs) - | `Scopelang -> - let _output_file, with_output = get_output_format () in - with_output - @@ fun fmt -> - if Option.is_some options.ex_scope then - Format.fprintf fmt "%a\n" - (Scopelang.Print.scope prgm.program_ctx ~debug:options.debug) - ( scope_uid, - Shared_ast.ScopeName.Map.find scope_uid prgm.program_scopes ) - else - Format.fprintf fmt "%a\n" - (Scopelang.Print.program ~debug:options.debug) - prgm - | ( `Interpret | `Interpret_Lcalc | `Typecheck | `OCaml | `Python | `Scalc - | `Lcalc | `Dcalc | `Proof | `Plugin _ ) as backend -> ( - Message.emit_debug "Typechecking..."; - let type_ordering = - Scopelang.Dependency.check_type_cycles prgm.program_ctx.ctx_structs - prgm.program_ctx.ctx_enums - in - let prgm = Scopelang.Ast.type_program prgm in - Message.emit_debug "Translating to default calculus..."; - let prgm = Dcalc.From_scopelang.translate_program prgm in - let prgm = - if options.optimize then begin - Message.emit_debug "Optimizing default calculus..."; - Shared_ast.Optimizations.optimize_program prgm - end - else prgm - in - (* Message.emit_debug (Format.asprintf "Typechecking results :@\n%a" - (Print.typ prgm.decl_ctx) typ); *) - match backend with - | `Typecheck -> - Message.emit_debug "Typechecking again..."; - let _ = - try Shared_ast.Typing.program prgm ~leave_unresolved:false - with Message.CompilerError error_content -> - raise - (Message.CompilerError - (Message.Content.mark_as_internal_error error_content)) - in - (* That's it! *) - Message.emit_result "Typechecking successful!" - | `Dcalc -> - let _output_file, with_output = get_output_format () in - with_output - @@ fun fmt -> - if Option.is_some options.ex_scope then - Format.fprintf fmt "%a\n" - (Shared_ast.Print.scope ~debug:options.debug prgm.decl_ctx) - ( scope_uid, - Option.get - (Shared_ast.Scope.fold_left ~init:None - ~f:(fun acc def _ -> - match def with - | ScopeDef (name, body) - when Shared_ast.ScopeName.equal name scope_uid -> - Some body - | _ -> acc) - prgm.code_items) ) - else - let prgrm_dcalc_expr = - Shared_ast.Expr.unbox (Shared_ast.Program.to_expr prgm scope_uid) - in - Format.fprintf fmt "%a\n" - (Shared_ast.Print.expr ~debug:options.debug ()) - prgrm_dcalc_expr - | ( `Interpret | `OCaml | `Python | `Scalc | `Lcalc | `Proof | `Plugin _ - | `Interpret_Lcalc ) as backend -> ( - Message.emit_debug "Typechecking again..."; - let prgm = - try Shared_ast.Typing.program ~leave_unresolved:false prgm - with Message.CompilerError error_content -> - raise - (Message.CompilerError - (Message.Content.mark_as_internal_error error_content)) - in - if !Cli.check_invariants_flag then ( - Message.emit_debug "Checking invariants..."; - let result = Dcalc.Invariants.check_all_invariants prgm in - if not result then - raise - (Message.raise_internal_error - "Some Dcalc invariants are invalid")); - match backend with - | `Proof -> - let vcs = - Verification.Conditions.generate_verification_conditions prgm - (match options.ex_scope with - | None -> None - | Some _ -> Some scope_uid) - in + Message.emit_result "Computation successful!%s" + (if List.length results > 0 then " Results:" else ""); + List.iter + (fun ((var, _), result) -> + Message.emit_result "@[%s@ =@ %a@]" var + (Print.expr ~debug:options.Cli.debug ()) + result) + results - Verification.Solver.solve_vc prgm.decl_ctx vcs - | `Interpret -> - if options.link_modules <> [] then ( - Message.emit_debug "Loading shared modules..."; - List.iter - Dynlink.( - fun m -> - loadfile - (adapt_filename (Filename.remove_extension m ^ ".cmo"))) - options.link_modules); - Message.emit_debug "Starting interpretation (dcalc)..."; - let results = - try Shared_ast.Interpreter.interpret_program_dcalc prgm scope_uid - with Shared_ast.Interpreter.CatalaException exn -> - Message.raise_error - "During interpretation, the error %a has been raised but not \ - caught!" - Shared_ast.Print.except exn - in - let results = - List.sort - (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) - results - in - Message.emit_debug "End of interpretation"; - Message.emit_result "Computation successful!%s" - (if List.length results > 0 then " Results:" else ""); - List.iter - (fun ((var, _), result) -> - Message.emit_result "@[%s@ =@ %a@]" var - (Shared_ast.Print.expr ~debug:options.debug ()) - result) - results - | `Plugin (Plugin.Dcalc p) -> - let output_file, _ = get_output_format ~ext:p.Plugin.extension () in - Message.emit_debug "Compiling program through backend \"%s\"..." - p.Plugin.name; - p.Plugin.apply ~source_file ~output_file - ~scope: - (match options.ex_scope with - | None -> None - | Some _ -> Some scope_uid) - (Shared_ast.Program.untype prgm) - type_ordering - | (`OCaml | `Interpret_Lcalc | `Python | `Lcalc | `Scalc | `Plugin _) - as backend -> ( - Message.emit_debug "Compiling program into lambda calculus..."; - let prgm = - if options.trace && options.avoid_exceptions then - Message.raise_error - "Option --avoid_exceptions is not compatible with option \ - --trace"; - if options.avoid_exceptions then - Shared_ast.Program.untype - @@ Lcalc.Compile_without_exceptions.translate_program prgm - else - Shared_ast.Program.untype - @@ Lcalc.Compile_with_exceptions.translate_program prgm - in - let prgm = - if options.optimize then begin - Message.emit_debug "Optimizing lambda calculus..."; - Shared_ast.Optimizations.optimize_program prgm - end - else Shared_ast.Program.untype prgm - in - let prgm = - if options.closure_conversion then ( - if not options.avoid_exceptions then - Message.raise_error - "Option --avoid_exceptions must be enabled for \ - --closure_conversion"; - if not options.optimize then - Message.raise_error - "Option --optimize must be enabled for --closure_conversion" - Message.emit_debug "Performing closure conversion..."; - let prgm = Lcalc.Closure_conversion.closure_conversion prgm in - let prgm = Bindlib.unbox prgm in - let prgm = - if options.optimize then ( - Message.emit_debug "Optimizing lambda calculus..."; - Shared_ast.Optimizations.optimize_program prgm) - else prgm - in - Message.emit_debug "Retyping lambda calculus..."; - try - let prgm = - Shared_ast.Program.untype - (Shared_ast.Typing.program ~leave_unresolved:true prgm) - in - prgm - with Message.CompilerError content -> - raise - (Message.CompilerError - (Message.Content.prepend_message content (fun fmt -> - Format.fprintf fmt - "As part of the compilation process, one of the \ - step (closure conversion) modified the Catala \ - program and re-typing after this modification \ - failed with the error message below. This \ - re-typing error if not your fault, but is \ - likely to indicate that the program you are \ - trying to compile is incompatible with the \ - current compilation scheme provided by the \ - Catala compiler. Try to rewrite the program to \ - avoid the problematic pattern or contact the \ - compiler developers for help.@\n")))) - else prgm - in - match backend with - | `Lcalc -> - let _output_file, with_output = get_output_format () in - with_output - @@ fun fmt -> - if Option.is_some options.ex_scope then - Format.fprintf fmt "%a\n" - (Shared_ast.Print.scope ~debug:options.debug prgm.decl_ctx) - (scope_uid, Shared_ast.Program.get_scope_body prgm scope_uid) - else - Format.fprintf fmt "%a\n" - (Shared_ast.Print.program ~debug:options.debug) - prgm - | `Interpret_Lcalc -> - Message.emit_debug "Starting interpretation (lcalc)..."; - let results = - try - Shared_ast.Interpreter.interpret_program_lcalc prgm scope_uid - with Shared_ast.Interpreter.CatalaException exn -> - Message.raise_error - "During interpretation, the error %a has been raised but \ - not caught!" - Shared_ast.Print.except exn - in - let results = - List.sort - (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) - results - in - Message.emit_debug "End of interpretation"; - Message.emit_result "Computation successful!%s" - (if List.length results > 0 then " Results:" else ""); - List.iter - (fun ((var, _), result) -> - Message.emit_result "@[%s@ =@ %a@]" var - (Shared_ast.Print.expr ~debug:options.debug ()) - result) - results - | (`OCaml | `Python | `Scalc | `Plugin _) as backend -> ( - match backend with - | `OCaml -> - let output_file, with_output = - get_output_format ~ext:".ml" () - in - with_output - @@ fun fmt -> - Message.emit_debug "Compiling program into OCaml..."; - Message.emit_debug "Writing to %s..." - (Option.value ~default:"stdout" output_file); - let modname = - match source_file with - (* FIXME: WIP placeholder *) - | FileName n -> Some (modname_of_file n) - | _ -> None - in - Lcalc.To_ocaml.format_program fmt ?modname prgm type_ordering - | `Plugin (Plugin.Dcalc _) -> assert false - | `Plugin (Plugin.Lcalc p) -> - let output_file, _ = - get_output_format ~ext:p.Plugin.extension () - in - Message.emit_debug "Compiling program through backend \"%s\"..." - p.Plugin.name; - p.Plugin.apply ~source_file ~output_file - ~scope: - (match options.ex_scope with - | None -> None - | Some _ -> Some scope_uid) - prgm type_ordering - | (`Python | `Scalc | `Plugin (Plugin.Scalc _)) as backend -> ( - let prgm = Scalc.From_lcalc.translate_program prgm in - match backend with - | `Scalc -> - let _output_file, with_output = get_output_format () in - with_output - @@ fun fmt -> - if Option.is_some options.ex_scope then - Format.fprintf fmt "%a\n" - (Scalc.Print.format_item ~debug:options.debug - prgm.decl_ctx) - (List.find - (function - | Scalc.Ast.SScope { scope_body_name; _ } -> - scope_body_name = scope_uid - | _ -> false) - prgm.code_items) - else Scalc.Print.format_program prgm.decl_ctx fmt prgm - | `Python -> - let output_file, with_output = - get_output_format ~ext:".py" () - in - Message.emit_debug "Compiling program into Python..."; - Message.emit_debug "Writing to %s..." - (Option.value ~default:"stdout" output_file); - with_output - @@ fun fmt -> - Scalc.To_python.format_program fmt prgm type_ordering - | `Plugin (Plugin.Dcalc _ | Plugin.Lcalc _) -> assert false - | `Plugin (Plugin.Scalc p) -> - let output_file, _ = get_output ~ext:p.Plugin.extension () in - Message.emit_debug - "Compiling program through backend \"%s\"..." p.Plugin.name; - Message.emit_debug "Writing to %s..." - (Option.value ~default:"stdout" output_file); - p.Plugin.apply ~source_file ~output_file - ~scope: - (match options.ex_scope with - | None -> None - | Some _ -> Some scope_uid) - prgm type_ordering))))))); - 0 - with - | Message.CompilerError content -> - let bt = Printexc.get_raw_backtrace () in - Message.emit_content content Error; - if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt; - -1 - | Sys_error msg -> - let bt = Printexc.get_raw_backtrace () in - Message.emit_content - (Message.Content.of_string ("System error: " ^ msg)) - Error; - if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt; - -1 + let interpret_dcalc options link_modules optimize check_invariants ex_scope = + Interpreter.load_runtime_modules link_modules; + let prg, ctx, _ = + Passes.dcalc options ~link_modules ~optimize ~check_invariants + in + print_interpretation_results options Interpreter.interpret_program_dcalc prg + (get_scope_uid ctx ex_scope) + + let interpret_cmd = + Cmd.v + (Cmd.info "interpret" + ~doc: + "Runs the interpreter on the Catala program, executing the scope \ + specified by the $(b,-s) option assuming no additional external \ + inputs.") + Term.( + const interpret_dcalc + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.ex_scope) + + let lcalc + options + link_modules + output + optimize + check_invariants + avoid_exceptions + closure_conversion + ex_scope_opt = + let prg, ctx, _ = + Passes.lcalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions ~closure_conversion + in + let _output_file, with_output = get_output_format options output in + with_output + @@ fun fmt -> + match ex_scope_opt with + | Some scope -> + let scope_uid = get_scope_uid ctx scope in + Print.scope ~debug:options.Cli.debug prg.decl_ctx fmt + (scope_uid, Program.get_scope_body prg scope_uid); + Format.pp_print_newline fmt () + | None -> + Print.program ~debug:options.Cli.debug fmt prg; + Format.pp_print_newline fmt () + + let lcalc_cmd = + Cmd.v + (Cmd.info "lcalc" + ~doc: + "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.") + Term.( + const lcalc + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.avoid_exceptions + $ Cli.Flags.closure_conversion + $ Cli.Flags.ex_scope_opt) + + let interpret_lcalc + options + link_modules + optimize + check_invariants + avoid_exceptions + closure_conversion + ex_scope = + let prg, ctx, _ = + Passes.lcalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions ~closure_conversion + in + print_interpretation_results options Interpreter.interpret_program_lcalc prg + (get_scope_uid ctx ex_scope) + + let interpret_lcalc_cmd = + Cmd.v + (Cmd.info "interpret_lcalc" + ~doc: + "Runs the interpreter on the lcalc pass on the Catala program, \ + executing the scope specified by the $(b,-s) option assuming no \ + additional external inputs.") + Term.( + const interpret_lcalc + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.avoid_exceptions + $ Cli.Flags.closure_conversion + $ Cli.Flags.ex_scope) + + let ocaml + options + link_modules + output + optimize + check_invariants + avoid_exceptions + closure_conversion = + let prg, _, type_ordering = + Passes.lcalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions ~closure_conversion + in + let output_file, with_output = + get_output_format options ~ext:".ml" output + in + with_output + @@ fun fmt -> + Message.emit_debug "Compiling program into OCaml..."; + Message.emit_debug "Writing to %s..." + (Option.value ~default:"stdout" output_file); + let modname = + (* TODO: module directive *) + match options.Cli.input_file with + | FileName n -> Some (modname_of_file n) + | _ -> None + in + Lcalc.To_ocaml.format_program fmt ?modname prg type_ordering + + let ocaml_cmd = + Cmd.v + (Cmd.info "ocaml" + ~doc:"Generates an OCaml translation of the Catala program.") + Term.( + const ocaml + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.avoid_exceptions + $ Cli.Flags.closure_conversion) + + let scalc + options + link_modules + output + optimize + check_invariants + avoid_exceptions + closure_conversion + ex_scope_opt = + let prg, ctx, _ = + Passes.scalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions ~closure_conversion + in + let _output_file, with_output = get_output_format options output in + with_output + @@ fun fmt -> + match ex_scope_opt with + | Some scope -> + let scope_uid = get_scope_uid ctx scope in + Scalc.Print.format_item ~debug:options.Cli.debug prg.decl_ctx fmt + (List.find + (function + | Scalc.Ast.SScope { scope_body_name; _ } -> + scope_body_name = scope_uid + | _ -> false) + prg.code_items); + Format.pp_print_newline fmt () + | None -> Scalc.Print.format_program prg.decl_ctx fmt prg + + let scalc_cmd = + Cmd.v + (Cmd.info "scalc" + ~doc: + "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.") + Term.( + const scalc + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.avoid_exceptions + $ Cli.Flags.closure_conversion + $ Cli.Flags.ex_scope_opt) + + let python + options + link_modules + output + optimize + check_invariants + avoid_exceptions + closure_conversion = + let prg, _, type_ordering = + Passes.scalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions ~closure_conversion + in + let output_file, with_output = + get_output_format options ~ext:".py" output + in + Message.emit_debug "Compiling program into Python..."; + Message.emit_debug "Writing to %s..." + (Option.value ~default:"stdout" output_file); + with_output + @@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering + + let python_cmd = + Cmd.v + (Cmd.info "python" + ~doc:"Generates a Python translation of the Catala program.") + Term.( + const python + $ Cli.Flags.Global.options + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.avoid_exceptions + $ Cli.Flags.closure_conversion) + + let pygmentize_cmd = + Cmd.v + (Cmd.info "pygmentize" + ~doc: + "This special command is a wrapper around the $(b,pygmentize) \ + command that enables support for colorising Catala code.") + Term.( + const (fun _ -> + assert false + (* Not really a catala command, this is handled preemptively at + startup *)) + $ Cli.Flags.Global.options) + + let commands = + [ + interpret_cmd; + interpret_lcalc_cmd; + typecheck_cmd; + proof_cmd; + ocaml_cmd; + python_cmd; + latex_cmd; + html_cmd; + makefile_cmd; + scopelang_cmd; + dcalc_cmd; + lcalc_cmd; + scalc_cmd; + exceptions_cmd; + pygmentize_cmd; + ] +end + +let raise_help cmdname cmds = + let plugins = Plugin.names () in + let cmds = List.filter (fun name -> not (List.mem name plugins)) cmds in + Message.raise_error + "One of the following commands was expected:@;\ + <1 4>@[@{%a@}@]%a@\n\ + Run `@{%s --help@}' or `@{%s COMMAND --help@}' for details." + (Format.pp_print_list Format.pp_print_string) + (List.sort String.compare cmds) + (fun ppf -> function + | [] -> () + | plugins -> + Format.fprintf ppf + "@\n\ + Or one of the following installed plugins:@;\ + <1 4>@[@{%a@}@]" + (Format.pp_print_list Format.pp_print_string) + plugins) + plugins cmdname cmdname + +let catala_t extra_commands = + let open Cmdliner in + let default = + Term.(const raise_help $ main_name $ choice_names $ Cli.Flags.Global.flags) + in + Cmd.group ~default Cli.info (Commands.commands @ extra_commands) let main () = let argv = Array.copy Sys.argv in @@ -609,58 +850,60 @@ let main () = cmdliner *) if Array.length Sys.argv >= 2 && argv.(1) = "pygmentize" then Literate.Pygmentize.exec (); - (* Peek to load plugins before the command-line is parsed proper *) + (* Peek to load plugins before the command-line is parsed proper (plugins add + their own commands) *) let plugins = let plugins_dirs = match - Cmdliner.Cmd.eval_peek_opts ~argv Cli.global_options ~version_opt:true + Cmdliner.Cmd.eval_peek_opts ~argv Cli.Flags.Global.flags + ~version_opt:true with - | Some opts, _ -> - Cli.set_option_globals opts; - (* Do this asap, for debug options, etc. *) - opts.Cli.plugins_dirs + | Some opts, _ -> opts.Cli.plugins_dirs | None, _ -> [] in List.iter (fun d -> match Sys.is_directory d with | true -> Plugin.load_dir d - | false -> () - | exception Sys_error _ -> ()) + | false -> Message.emit_debug "Could not read plugin directory %s" d + | exception Sys_error _ -> + Message.emit_debug "Could not read plugin directory %s" d) plugins_dirs; + Dynlink.allow_only ["Runtime_ocaml__Runtime"]; + (* We may use dynlink again, but only for runtime modules: no plugin + registration after this point *) Plugin.list () in - let return_code = - Cmdliner.Cmd.eval' ~argv - (Cli.catala_t - (fun backend f -> driver backend (FileName f)) - ~extra:plugins) - in - exit return_code + let command = catala_t plugins in + let open Cmdliner in + match Cmd.eval_value ~catch:false ~argv command with + | Ok _ -> exit Cmd.Exit.ok + | Error _ -> exit Cmd.Exit.cli_error + | exception Cli.Exit_with n -> exit n + | exception Message.CompilerError content -> + let bt = Printexc.get_raw_backtrace () in + Message.emit_content content Error; + if Cli.globals.debug then Printexc.print_raw_backtrace stderr bt; + exit Cmd.Exit.some_error + | exception Sys_error msg -> + let bt = Printexc.get_raw_backtrace () in + Message.emit_content + (Message.Content.of_string ("System error: " ^ msg)) + Error; + if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt; + exit Cmd.Exit.internal_error + | exception e -> + let bt = Printexc.get_raw_backtrace () in + Message.emit_content + (Message.Content.of_string ("Unexpected error: " ^ Printexc.to_string e)) + Error; + if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt; + exit Cmd.Exit.internal_error (* Export module PluginAPI, hide parent module Plugin *) module Plugin = struct - open Plugin - include PluginAPI - open Cmdliner - - let register_cmd info plugin = - let term = - Term.( - const (fun file opts -> driver (`Plugin plugin) (FileName file) opts) - $ Cli.file - $ Cli.global_options) - in - register_generic info term - - let info_name info = Cmd.name (Cmd.v info (Term.const ())) - - let register_dcalc info ~extension apply = - register_cmd info (Dcalc { name = info_name info; extension; apply }) - - let register_lcalc info ~extension apply = - register_cmd info (Lcalc { name = info_name info; extension; apply }) - - let register_scalc info ~extension apply = - register_cmd info (Scalc { name = info_name info; extension; apply }) + let register name ?man ?doc term = + let name = String.lowercase_ascii name in + let info = Cmdliner.Cmd.info name ?man ?doc ~docs:Cli.s_plugins in + Plugin.register info term end diff --git a/compiler/driver.mli b/compiler/driver.mli index 98ceea90..a9f35221 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -17,38 +17,101 @@ open Catala_utils -val driver : - [< Cli.backend_option | `Plugin of Plugin.handler ] -> - Pos.input_file -> - Cli.global_options -> - int -(** Entry function for the executable. Returns a negative number in case of - error. *) - val main : unit -> unit (** Main program entry point, including command-line parsing and return code *) +(** Compiler passes + + Each pass takes only its cli options, then calls upon its dependent passes + (forwarding their options as needed) *) +module Passes : sig + val surface : Cli.options -> Surface.Ast.program * Cli.backend_lang + + val desugared : + Cli.options -> + link_modules:string list -> + Desugared.Ast.program * Desugared.Name_resolution.context + + val scopelang : + Cli.options -> + link_modules:string list -> + Shared_ast.untyped Scopelang.Ast.program + * Desugared.Name_resolution.context + * Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t + + val dcalc : + Cli.options -> + link_modules:string list -> + optimize:bool -> + check_invariants:bool -> + Shared_ast.typed Dcalc.Ast.program + * Desugared.Name_resolution.context + * Scopelang.Dependency.TVertex.t list + + val lcalc : + Cli.options -> + link_modules:string list -> + optimize:bool -> + check_invariants:bool -> + avoid_exceptions:bool -> + closure_conversion:bool -> + Shared_ast.untyped Lcalc.Ast.program + * Desugared.Name_resolution.context + * Scopelang.Dependency.TVertex.t list + + val scalc : + Cli.options -> + link_modules:string list -> + optimize:bool -> + check_invariants:bool -> + avoid_exceptions:bool -> + closure_conversion:bool -> + Scalc.Ast.program + * Desugared.Name_resolution.context + * Scopelang.Dependency.TVertex.t list +end + +module Commands : sig + (** Helper functions used by top-level commands *) + + val get_output : + ?ext:string -> + Cli.options -> + string option -> + string option * ((out_channel -> 'a) -> 'a) + (** bounded open of the expected output file *) + + val get_output_format : + ?ext:string -> + Cli.options -> + string option -> + string option * ((Format.formatter -> 'a) -> 'a) + + val get_scope_uid : + Desugared.Name_resolution.context -> string -> Shared_ast.ScopeName.t + + val get_variable_uid : + Desugared.Name_resolution.context -> + Shared_ast.ScopeName.t -> + string -> + Desugared.Ast.ScopeDef.t + + val commands : unit Cmdliner.Cmd.t list + (** The list of built-in catala subcommands, as expected by + [Cmdliner.Cmd.group] *) +end + +(** Various helpers *) + +val modname_of_file : string -> string + +(** API available to plugins for their own registration *) + module Plugin : sig - include module type of Plugin.PluginAPI - open Cmdliner - - val register_generic : Cmd.info -> Cmd.Exit.code Term.t -> unit - - val register_dcalc : - Cmd.info -> - extension:string -> - Shared_ast.untyped Dcalc.Ast.program plugin_apply_fun_typ -> - unit - - val register_lcalc : - Cmd.info -> - extension:string -> - Shared_ast.untyped Lcalc.Ast.program plugin_apply_fun_typ -> - unit - - val register_scalc : - Cmd.info -> - extension:string -> - Scalc.Ast.program plugin_apply_fun_typ -> + val register : + string -> + ?man:Cmdliner.Manpage.block list -> + ?doc:string -> + (Cli.options -> unit) Cmdliner.Term.t -> unit end diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml index 2d616408..3f2a5c78 100644 --- a/compiler/lcalc/compile_with_exceptions.ml +++ b/compiler/lcalc/compile_with_exceptions.ml @@ -64,8 +64,10 @@ and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed = Expr.ecatch (translate_expr ctx arg) EmptyError (Expr.eraise NoValueProvided m) m - | EDefault { excepts = [exn]; just; cons } when !Cli.optimize_flag -> - (* FIXME: bad place to rely on a global flag *) + | EDefault { excepts = [exn]; just; cons } + (* Specific optimisation for this case *) -> + (* FIXME: this case used to be disabled when optimisations are disabled, but + the flag isn't forwarded to this function *) Expr.ecatch (translate_expr ctx exn) EmptyError (Expr.eifthenelse (translate_expr ctx just) (translate_expr ctx cons) (Expr.eraise EmptyError (Mark.get e)) diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index d683bfd7..534f7afc 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -316,12 +316,12 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : f = EApp { f = EOp { op = Log (BeginCall, info); _ }, _; args = [f] }, _; args = [arg]; } - when !Cli.trace_flag -> + when Cli.globals.trace -> Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info format_with_parens f format_with_parens arg | EApp { f = EOp { op = Log (VarDef var_def_info, info); _ }, _; args = [arg1] } - when !Cli.trace_flag -> + when Cli.globals.trace -> Format.fprintf fmt "(log_variable_definition@ %a@ {io_input=%s;@ io_output=%b}@ (%a)@ %a)" format_uid_list info @@ -333,7 +333,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : (var_def_info.log_typ, Pos.no_pos) format_with_parens arg1 | EApp { f = EOp { op = Log (PosRecordIfTrueBool, _); _ }, m; args = [arg1] } - when !Cli.trace_flag -> + when Cli.globals.trace -> let pos = Expr.mark_pos m in Format.fprintf fmt "(log_decision_taken@ @[{filename = \"%s\";@ start_line=%d;@ \ @@ -342,7 +342,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) format_with_parens arg1 | EApp { f = EOp { op = Log (EndCall, info); _ }, _; args = [arg1] } - when !Cli.trace_flag -> + when Cli.globals.trace -> Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info format_with_parens arg1 | EApp { f = EOp { op = Log _; _ }, _; args = [arg1] } -> @@ -465,7 +465,7 @@ let format_ctx Format.fprintf fmt "@[%a:@ %a@]" format_struct_field_name (None, struct_field) format_typ struct_field_type)) (StructField.Map.bindings struct_fields); - if !Cli.trace_flag then + if Cli.globals.trace then format_struct_embedding fmt (struct_name, struct_fields) in let format_enum_decl fmt (enum_name, enum_cons) = @@ -478,7 +478,7 @@ let format_ctx Format.fprintf fmt "@[| %a@ of@ %a@]" format_enum_cons_name enum_cons format_typ enum_cons_type)) (EnumConstructor.Map.bindings enum_cons); - if !Cli.trace_flag then format_enum_embedding fmt (enum_name, enum_cons) + if Cli.globals.trace then format_enum_embedding fmt (enum_name, enum_cons) in let is_in_type_ordering s = List.exists diff --git a/compiler/plugin.ml b/compiler/plugin.ml index e0d43315..2012e04a 100644 --- a/compiler/plugin.ml +++ b/compiler/plugin.ml @@ -15,44 +15,19 @@ the License. *) open Catala_utils +open Cmdliner -type t = Cmdliner.Cmd.Exit.code Cmdliner.Cmd.t +type t = unit Cmdliner.Cmd.t let backend_plugins : (string, t) Hashtbl.t = Hashtbl.create 17 -let register t = - Hashtbl.replace backend_plugins - (String.lowercase_ascii (Cmdliner.Cmd.name t)) - t +let register info term = + let name = String.lowercase_ascii (Cmd.name (Cmd.v info (Term.const ()))) in + Hashtbl.replace backend_plugins name + (Cmd.v info Term.(term $ Cli.Flags.Global.options)) let list () = Hashtbl.to_seq_values backend_plugins |> List.of_seq - -module PluginAPI = struct - open Cmdliner - - let register_generic info term = register (Cmd.v info term) - - (* For plugins relying on the standard [Driver] *) - - type 'ast plugin_apply_fun_typ = - source_file:Pos.input_file -> - output_file:string option -> - scope:Shared_ast.ScopeName.t option -> - 'ast -> - Scopelang.Dependency.TVertex.t list -> - unit -end - -type 'ast gen = { - name : string; - extension : string; - apply : 'ast PluginAPI.plugin_apply_fun_typ; -} - -type handler = - | Dcalc of Shared_ast.untyped Dcalc.Ast.program gen - | Lcalc of Shared_ast.untyped Lcalc.Ast.program gen - | Scalc of Scalc.Ast.program gen +let names () = Hashtbl.to_seq_keys backend_plugins |> List.of_seq let load_file f = try @@ -62,6 +37,7 @@ let load_file f = Message.emit_warning "Could not load plugin %S: %s" f (Printexc.to_string e) let rec load_dir d = + Message.emit_debug "Loading plugins from %s" d; let dynlink_exts = if Dynlink.is_native then [".cmxs"] else [".cmo"; ".cma"] in diff --git a/compiler/plugin.mli b/compiler/plugin.mli index a4baf346..072214fe 100644 --- a/compiler/plugin.mli +++ b/compiler/plugin.mli @@ -14,53 +14,30 @@ License for the specific language governing permissions and limitations under the License. *) -open Catala_utils - -type t = Cmdliner.Cmd.Exit.code Cmdliner.Cmd.t +type t = unit Cmdliner.Cmd.t (** Plugins just provide an additional top-level command *) (** {2 plugin-facing API} *) -module PluginAPI : sig - open Cmdliner - - val register_generic : Cmd.info -> Cmd.Exit.code Term.t -> unit - (** Entry point for the registration of a generic catala subcommand *) - - (** The following are used by [Driver.Plugin] to provide a higher-level - interface, registering plugins that rely on the [Driver.driver] function. *) - - type 'ast plugin_apply_fun_typ = - source_file:Pos.input_file -> - output_file:string option -> - scope:Shared_ast.ScopeName.t option -> - 'ast -> - Scopelang.Dependency.TVertex.t list -> - unit -end - -val register : t -> unit +val register : + Cmdliner.Cmd.info -> + (Catala_utils.Cli.options -> unit) Cmdliner.Term.t -> + unit +(** Plugins are registerd as [Cmdliner] commands, which must take at least the + default global options as arguments (this is required for e.g. + [--plugins-dirs] to be handled correctly, and for setting debug flags), but + can add more. *) (** {2 catala-facing API} *) val list : unit -> t list (** List registered plugins *) +val names : unit -> string list +(** List the names of registered plugins *) + val load_file : string -> unit (** Load the given plugin (cmo/cma or cmxs file) *) val load_dir : string -> unit (** Load all plugins found in the given directory *) - -(** {3 Facilities for plugins using the standard driver} *) - -type 'ast gen = { - name : string; - extension : string; - apply : 'ast PluginAPI.plugin_apply_fun_typ; -} - -type handler = - | Dcalc of Shared_ast.untyped Dcalc.Ast.program gen - | Lcalc of Shared_ast.untyped Lcalc.Ast.program gen - | Scalc of Scalc.Ast.program gen diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index e67a9e5d..da782e25 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -22,15 +22,6 @@ open Lcalc.Ast open Lcalc.To_ocaml module D = Dcalc.Ast -let name = "api_web" -let extension = ".ml" - -let info = - Cmdliner.Cmd.info name - ~doc: - "Catala plugin for generating web APIs. It generates OCaml code before \ - the associated [js_of_ocaml] wrapper." - (** Contains all format functions used to generating the [js_of_ocaml] wrapper of the corresponding Catala program. *) module To_jsoo = struct @@ -432,44 +423,60 @@ module To_jsoo = struct prgm.code_items end -let apply - ~(source_file : Pos.input_file) - ~(output_file : string option) - ~scope - (prgm : 'm Lcalc.Ast.program) - (type_ordering : Scopelang.Dependency.TVertex.t list) = - ignore scope; - File.with_formatter_of_opt_file output_file (fun fmt -> - Cli.trace_flag := true; - Message.emit_debug "Writing OCaml code to %s..." - (Option.value ~default:"stdout" output_file); - To_ocaml.format_program fmt prgm type_ordering); - - let output_file, filename_without_ext = - match output_file with - | Some "-" -> output_file, output_file - | Some f -> - output_file, Some (Filename.basename f |> Filename.remove_extension) - | None -> Some "-", None +let run + link_modules + output + optimize + check_invariants + avoid_exceptions + closure_conversion + options = + if not options.Cli.trace then + Message.raise_error "This plugin requires the --trace flag."; + let prg, _, type_ordering = + Driver.Passes.lcalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions ~closure_conversion + in + let modname = + (* TODO: module directive support *) + match options.Cli.input_file with + | FileName n -> Some (Driver.modname_of_file n) + | _ -> None + in + let () = + (* First compile to ocaml (with --trace on) *) + let output_file, with_output = + Driver.Commands.get_output_format options ~ext:".ml" output + in + with_output + @@ fun fmt -> + Message.emit_debug "Compiling program into OCaml..."; + Message.emit_debug "Writing to %s..." + (Option.value ~default:"stdout" output_file); + Lcalc.To_ocaml.format_program fmt ?modname prg type_ordering in let jsoo_output_file, with_formatter = - File.get_formatter_of_out_channel ~source_file - ~output_file: - (Option.map - (fun name -> - if "-" = name then "-" - else Filename.remove_extension name ^ "_api_web.ml") - output_file) - ~ext:"_api_web.ml" () - in - let module_name = - Option.map - (fun name -> Printf.sprintf "open %s" (String.capitalize_ascii name)) - filename_without_ext + Driver.Commands.get_output_format options ~ext:"_api_web.ml" output in with_formatter (fun fmt -> Message.emit_debug "Writing JSOO API code to %s..." (Option.value ~default:"stdout" jsoo_output_file); - To_jsoo.format_program fmt module_name prgm type_ordering) + To_jsoo.format_program fmt + (Option.map (( ^ ) "open ") modname) + prg type_ordering) -let () = Driver.Plugin.register_lcalc info ~extension apply +let term = + let open Cmdliner.Term in + const run + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.avoid_exceptions + $ Cli.Flags.closure_conversion + +let () = + Driver.Plugin.register "api_web" term + ~doc: + "Catala plugin for generating web APIs. It generates OCaml code before \ + the associated [js_of_ocaml] wrapper." diff --git a/compiler/plugins/json_schema.ml b/compiler/plugins/json_schema.ml index 3fd8efdf..27d9754e 100644 --- a/compiler/plugins/json_schema.ml +++ b/compiler/plugins/json_schema.ml @@ -14,15 +14,6 @@ License for the specific language governing permissions and limitations under the License. *) -let name = "json_schema" -let extension = "_schema.json" - -let info = - Cmdliner.Cmd.info name - ~doc: - "Catala plugin for generating {{:https://json-schema.org} JSON schemas} \ - used to build forms for the Catala website." - open Catala_utils open Shared_ast open Lcalc.To_ocaml @@ -215,24 +206,44 @@ module To_json = struct scope_body.scope_body_input_struct end -let apply - ~(source_file : Pos.input_file) - ~(output_file : string option) - ~(scope : Shared_ast.ScopeName.t option) - (prgm : 'm Lcalc.Ast.program) - (type_ordering : Scopelang.Dependency.TVertex.t list) = - ignore source_file; - ignore type_ordering; - match scope with - | Some s -> - File.with_formatter_of_opt_file output_file (fun fmt -> - Message.emit_debug - "Writing JSON schema corresponding to the scope '%a' to the file \ - %s..." - ScopeName.format_t s - (Option.value ~default:"stdout" output_file); - To_json.format_program fmt s prgm) - | None -> - Message.raise_error "A scope must be specified for the plugin: %s" name +let run + link_modules + output + optimize + check_invariants + avoid_exceptions + closure_conversion + ex_scope + options = + let prg, ctx, _ = + Driver.Passes.lcalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions ~closure_conversion + in + let output_file, with_output = + Driver.Commands.get_output_format options ~ext:"_schema.json" output + in + with_output + @@ fun fmt -> + let scope_uid = Driver.Commands.get_scope_uid ctx ex_scope in + Message.emit_debug + "Writing JSON schema corresponding to the scope '%a' to the file %s..." + ScopeName.format_t scope_uid + (Option.value ~default:"stdout" output_file); + To_json.format_program fmt scope_uid prg -let () = Driver.Plugin.register_lcalc info ~extension apply +let term = + let open Cmdliner.Term in + const run + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.avoid_exceptions + $ Cli.Flags.closure_conversion + $ Cli.Flags.ex_scope + +let () = + Driver.Plugin.register "json_schema" term + ~doc: + "Catala plugin for generating {{:https://json-schema.org} JSON schemas} \ + used to build forms for the Catala website." diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index 880c8528..534f657e 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -17,10 +17,6 @@ open Catala_utils open Shared_ast -let name = "lazy" -let extension = ".out" (* unused *) -let info = Cmdliner.Cmd.info name ~doc:"Experimental lazy evaluation (plugin)" - (* -- Definition of the lazy interpreter -- *) let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n") @@ -256,18 +252,24 @@ let interpret_program (prg : ('dcalc, 'm) gexpr program) (scope : ScopeName.t) : (* -- Plugin registration -- *) -let apply ~source_file ~output_file ~scope prg _type_ordering = - let scope = - match scope with - | None -> Message.raise_error "A scope must be specified" - | Some s -> s +let run link_modules optimize check_invariants ex_scope options = + Interpreter.load_runtime_modules link_modules; + let prg, ctx, _ = + Driver.Passes.dcalc options ~link_modules ~optimize ~check_invariants in - ignore source_file; - (* File.with_formatter_of_opt_file output_file - * @@ fun fmt -> *) - ignore output_file; - let fmt = Format.std_formatter in + let scope = Driver.Commands.get_scope_uid ctx ex_scope in let result_expr, _env = interpret_program prg scope in + let fmt = Format.std_formatter in Expr.format fmt result_expr -let () = Driver.Plugin.register_dcalc info ~extension apply +let term = + let open Cmdliner.Term in + const run + $ Cli.Flags.link_modules + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.ex_scope + +let () = + Driver.Plugin.register "lazy" term + ~doc:"Experimental lazy evaluation (plugin)" diff --git a/compiler/plugins/python.ml b/compiler/plugins/python.ml index da716627..a259ae82 100644 --- a/compiler/plugins/python.ml +++ b/compiler/plugins/python.ml @@ -22,19 +22,37 @@ open Catala_utils -let name = "python-plugin" -let extension = ".py" +let run + link_modules + output + optimize + check_invariants + avoid_exceptions + closure_conversion + options = + let open Driver.Commands in + let prg, _, type_ordering = + Driver.Passes.scalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions ~closure_conversion + in + let output_file, with_output = get_output_format options ~ext:".py" output in + Message.emit_debug "Compiling program into Python..."; + Message.emit_debug "Writing to %s..." + (Option.value ~default:"stdout" output_file); + with_output @@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering -let info = - Cmdliner.Cmd.info name +let term = + let open Cmdliner.Term in + const run + $ Cli.Flags.link_modules + $ Cli.Flags.output + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.avoid_exceptions + $ Cli.Flags.closure_conversion + +let () = + Driver.Plugin.register "python-plugin" term ~doc: "This plugin is for demonstration purposes and should be equivalent to \ using the built-in Python backend" - -let apply ~source_file ~output_file ~scope prgm type_ordering = - ignore source_file; - ignore scope; - File.with_formatter_of_opt_file output_file - @@ fun fmt -> Scalc.To_python.format_program fmt prgm type_ordering - -let () = Driver.Plugin.register_scalc info ~extension apply diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index 8af42050..3e45aa0d 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -308,11 +308,11 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op (op, Pos.no_pos) (format_expression ctx) arg2 | EApp ((EApp ((EOp (Log (BeginCall, info)), _), [f]), _), [arg]) - when !Cli.trace_flag -> + when Cli.globals.trace -> Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info (format_expression ctx) f (format_expression ctx) arg | EApp ((EOp (Log (VarDef var_def_info, info)), _), [arg1]) - when !Cli.trace_flag -> + when Cli.globals.trace -> Format.fprintf fmt "log_variable_definition(%a,@ LogIO(io_input=%s,@ io_output=%b),@ %a)" format_uid_list info @@ -322,14 +322,14 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : | Runtime.Reentrant -> "Reentrant") var_def_info.log_io_output (format_expression ctx) arg1 | EApp ((EOp (Log (PosRecordIfTrueBool, _)), pos), [arg1]) - when !Cli.trace_flag -> + when Cli.globals.trace -> Format.fprintf fmt "log_decision_taken(SourcePosition(filename=\"%s\",@ start_line=%d,@ \ start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)" (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) (format_expression ctx) arg1 - | EApp ((EOp (Log (EndCall, info)), _), [arg1]) when !Cli.trace_flag -> + | EApp ((EOp (Log (EndCall, info)), _), [arg1]) when Cli.globals.trace -> Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info (format_expression ctx) arg1 | EApp ((EOp (Log _), _), [arg1]) -> diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index f3873e03..d4e260f5 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -36,7 +36,7 @@ let tag_with_log_entry (e : untyped Ast.expr boxed) (l : log_entry) (markings : Uid.MarkedString.info list) : untyped Ast.expr boxed = - if !Cli.trace_flag then + if Cli.globals.trace then Expr.eapp (Expr.eop (Log (l, markings)) [TAny, Expr.pos e] (Mark.get e)) [e] (Mark.get e) diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 72c0dafc..568b926b 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -65,7 +65,7 @@ let indent_str = ref "" (** {1 Evaluation} *) let print_log entry infos pos e = - if !Cli.trace_flag then + if Cli.globals.trace then match entry with | VarDef _ -> Message.emit_log "%s%a %a: @{%s@}" !indent_str Print.log_entry @@ -671,7 +671,7 @@ let rec evaluate_expr : } -> Message.raise_spanned_error (Expr.pos e') "Assertion failed: %a %a %a" (Print.expr ()) e1 - (Print.operator ~debug:!Cli.debug_flag) + (Print.operator ~debug:Cli.globals.debug) op (Print.expr ()) e2 | _ -> Message.emit_debug "%a" (Print.expr ()) e'; @@ -867,3 +867,13 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list Message.raise_spanned_error (Expr.pos e) "The interpreter can only interpret terms starting with functions having \ thunked arguments" + +let load_runtime_modules = function + | [] -> () + | modules -> + Message.emit_debug "Loading shared modules..."; + List.iter + Dynlink.( + fun m -> + loadfile (adapt_filename (Filename.remove_extension m ^ ".cmo"))) + modules diff --git a/compiler/shared_ast/interpreter.mli b/compiler/shared_ast/interpreter.mli index d673d5d0..dc0625fa 100644 --- a/compiler/shared_ast/interpreter.mli +++ b/compiler/shared_ast/interpreter.mli @@ -67,3 +67,7 @@ val interpret_program_lcalc : function whose argument are all thunked. The function is executed by providing for each argument a thunked empty default. Returns a list of all the computed values for the scope variables of the executed scope. *) + +val load_runtime_modules : string list -> unit +(** Dynlink the given runtime modules, in order to make them callable by the + interpreter *) diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index 49e9edc4..d6b27b78 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -171,13 +171,9 @@ let lit (fmt : Format.formatter) (l : lit) : unit = | LUnit -> lit_style fmt "()" | LRat i -> lit_style fmt - (Runtime.decimal_to_string ~max_prec_digits:!Cli.max_prec_digits i) - | LMoney e -> ( - match !Cli.locale_lang with - | En -> lit_style fmt (Format.asprintf "$%s" (Runtime.money_to_string e)) - | Fr -> lit_style fmt (Format.asprintf "%s €" (Runtime.money_to_string e)) - | Pl -> lit_style fmt (Format.asprintf "%s PLN" (Runtime.money_to_string e)) - ) + (Runtime.decimal_to_string ~max_prec_digits:Cli.globals.max_prec_digits i) + | LMoney e -> + lit_style fmt (Format.asprintf "¤%s" (Runtime.money_to_string e)) | LDate d -> lit_style fmt (Runtime.date_to_string d) | LDuration d -> lit_style fmt (Runtime.duration_to_string d) @@ -712,7 +708,7 @@ let rec colors = let typ_debug = typ None ~colors let typ ctx = typ (Some ctx) ~colors -let expr ?(hide_function_body = false) ?(debug = !Cli.debug_flag) () ppf e = +let expr ?(hide_function_body = false) ?(debug = Cli.globals.debug) () ppf e = expr_aux ~hide_function_body ~debug Bindlib.empty_ctxt colors ppf e let scope_let_kind ?debug:(_debug = true) _ctx fmt k = diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 0014fc03..63c3c905 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -152,10 +152,11 @@ let rec format_typ ")" (format_typ ~colors) t2 | TArray t1 -> ( match Mark.remove (UnionFind.get (UnionFind.find t1)) with - | TAny _ when not !Cli.debug_flag -> Format.pp_print_string fmt "collection" + | TAny _ when not Cli.globals.debug -> + Format.pp_print_string fmt "collection" | _ -> Format.fprintf fmt "@[collection@ %a@]" (format_typ ~colors) t1) | TAny v -> - if !Cli.debug_flag then Format.fprintf fmt "" (Any.hash v) + if Cli.globals.debug then Format.fprintf fmt "" (Any.hash v) else Format.pp_print_string fmt "" | TClosureEnv -> Format.fprintf fmt "closure_env" diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index d53ded17..7bb8efa1 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -269,7 +269,7 @@ let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function (** Parses a single source file *) let rec parse_source_file - (source_file : Pos.input_file) + (source_file : Cli.input_file) (language : Cli.backend_lang) : Ast.program = Message.emit_debug "Parsing %s" (match source_file with FileName s | Contents s -> s); @@ -307,7 +307,7 @@ and expand_includes match command with | Ast.LawInclude (Ast.CatalaFile sub_source) -> let source_dir = Filename.dirname source_file in - let sub_source = Filename.concat source_dir (Mark.remove sub_source) in + let sub_source = File.(source_dir / Mark.remove sub_source) in let includ_program = parse_source_file (FileName sub_source) language in { program_interfaces = []; @@ -377,7 +377,7 @@ let add_interface source_file language path program = } let parse_top_level_file - (source_file : Pos.input_file) + (source_file : Cli.input_file) (language : Cli.backend_lang) : Ast.program = let program = parse_source_file source_file language in let interface = get_interface program in diff --git a/compiler/surface/parser_driver.mli b/compiler/surface/parser_driver.mli index e0abf5f8..f608e7bd 100644 --- a/compiler/surface/parser_driver.mli +++ b/compiler/surface/parser_driver.mli @@ -20,7 +20,7 @@ open Catala_utils val add_interface : - Pos.input_file -> + Cli.input_file -> Cli.backend_lang -> Shared_ast.Qident.path -> Ast.program -> @@ -28,4 +28,4 @@ val add_interface : (** Reads only declarations in metadata in the supplied input file, and add them to the given program *) -val parse_top_level_file : Pos.input_file -> Cli.backend_lang -> Ast.program +val parse_top_level_file : Cli.input_file -> Cli.backend_lang -> Ast.program diff --git a/compiler/verification/conditions.ml b/compiler/verification/conditions.ml index 5687e44a..b787e252 100644 --- a/compiler/verification/conditions.ml +++ b/compiler/verification/conditions.ml @@ -346,7 +346,7 @@ let rec generate_verification_conditions_scope_body_expr let e = match_and_ignore_outer_reentrant_default ctx e in let vc_confl = generate_vc_must_not_return_conflict ctx e in let vc_confl = - if !Cli.optimize_flag then + if Globals.optimize () then Expr.unbox (Shared_ast.Optimizations.optimize_expr ctx.decl vc_confl) else vc_confl @@ -369,7 +369,7 @@ let rec generate_verification_conditions_scope_body_expr | ScopeVarDefinition -> let vc_empty = generate_vc_must_not_return_empty ctx e in let vc_empty = - if !Cli.optimize_flag then + if Globals.optimize () then Expr.unbox (Shared_ast.Optimizations.optimize_expr ctx.decl vc_empty) else vc_empty diff --git a/compiler/verification/globals.ml b/compiler/verification/globals.ml new file mode 100644 index 00000000..f7a804f2 --- /dev/null +++ b/compiler/verification/globals.ml @@ -0,0 +1,28 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Aymeric Fromherz , Denis Merigoux + + + 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. *) + +let optimize_ref = ref false +let disable_counterexamples_ref = ref false + +(** This sub-lib relies on global refs in many places. This should be cleaned + up. *) +let setup ~optimize ~disable_counterexamples = + optimize_ref := optimize; + disable_counterexamples_ref := disable_counterexamples + +let optimize () = !optimize_ref +let disable_counterexamples () = !disable_counterexamples_ref diff --git a/compiler/verification/globals.mli b/compiler/verification/globals.mli new file mode 100644 index 00000000..bff5bca5 --- /dev/null +++ b/compiler/verification/globals.mli @@ -0,0 +1,29 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Aymeric Fromherz , Denis Merigoux + + + 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. *) + +(** This sub-lib relies on global refs in many places. This should be cleaned + up. *) + +val setup : optimize:bool -> disable_counterexamples:bool -> unit + +val optimize : unit -> bool +(** Not sure what that means in this context: does it turn on optimisations in + the verif backend, or trigger special handling that is dependent on the + input code having been optimised ?? *) + +val disable_counterexamples : unit -> bool +(** This should really be passed along through arguments *) diff --git a/compiler/verification/io.ml b/compiler/verification/io.ml index 69705e83..7875d05a 100644 --- a/compiler/verification/io.ml +++ b/compiler/verification/io.ml @@ -115,7 +115,7 @@ module MakeBackendIO (B : Backend) = struct Pos.format_loc_text (Mark.get vc.vc_variable) in let counterexample : string option = - if !Cli.disable_counterexamples then + if Globals.disable_counterexamples () then Some "Counterexample generation is disabled so none was generated." else match model with diff --git a/compiler/verification/z3backend.real.ml b/compiler/verification/z3backend.real.ml index 8e98ed7d..185ef91f 100644 --- a/compiler/verification/z3backend.real.ml +++ b/compiler/verification/z3backend.real.ml @@ -139,7 +139,7 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string = Catala sources *) | TUnit -> "" | TInt -> Expr.to_string e - | TRat -> Arithmetic.Real.to_decimal_string e !Cli.max_prec_digits + | TRat -> Arithmetic.Real.to_decimal_string e Cli.globals.max_prec_digits (* TODO: Print the right money symbol according to language *) | TMoney -> let z3_str = Expr.to_string e in @@ -833,7 +833,7 @@ module Backend = struct let make_context (decl_ctx : decl_ctx) : backend_context = let cfg = - (if !Cli.disable_counterexamples then [] else ["model", "true"]) + (if Globals.disable_counterexamples () then [] else ["model", "true"]) @ ["proof", "false"] in let z3_ctx = mk_context cfg in diff --git a/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en b/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en index c2972880..f75005f1 100644 --- a/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en +++ b/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en @@ -45,7 +45,7 @@ Last good token: 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` @@ -89,7 +89,7 @@ Last good token: 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` @@ -133,7 +133,7 @@ Last good token: 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` @@ -179,5 +179,5 @@ Last good token: 11 │ context my_gaming scope GamingAuthorized │ ‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/examples/aides_logement/tests/tests_calcul_al_accession_propriete.catala_fr b/examples/aides_logement/tests/tests_calcul_al_accession_propriete.catala_fr index a760f8b6..e7720f35 100644 --- a/examples/aides_logement/tests/tests_calcul_al_accession_propriete.catala_fr +++ b/examples/aides_logement/tests/tests_calcul_al_accession_propriete.catala_fr @@ -75,24 +75,24 @@ champ d'application Exemple2: ```catala-test-inline $ catala Interpret -s Exemple1 [RESULT] Computation successful! Results: -[RESULT] montant = 96.48 € +[RESULT] montant = ¤96.48 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple1 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 96.48 € +[RESULT] montant = ESome ¤96.48 ``` ```catala-test-inline $ catala Interpret -s Exemple2 [RESULT] Computation successful! Results: -[RESULT] montant = 85.00 € +[RESULT] montant = ¤85.00 ``` ```catala-test-inline -$ catala Interpret -s Exemple2 --avoid_exceptions +$ catala Interpret_lcalc -s Exemple2 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = 85.00 € +[RESULT] montant = ESome ¤85.00 ``` diff --git a/examples/aides_logement/tests/tests_calcul_al_locatif.catala_fr b/examples/aides_logement/tests/tests_calcul_al_locatif.catala_fr index 31a365c2..fcc8f4eb 100644 --- a/examples/aides_logement/tests/tests_calcul_al_locatif.catala_fr +++ b/examples/aides_logement/tests/tests_calcul_al_locatif.catala_fr @@ -128,47 +128,47 @@ champ d'application Exemple4 : ```catala-test-inline $ catala Interpret -s Exemple1 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 345.73 € +[RESULT] montant = ¤345.73 ``` ```catala-test-inline $ catala Interpret -s Exemple2 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 352.77 € +[RESULT] montant = ¤352.77 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple1 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 345.73 € +[RESULT] montant = ESome ¤345.73 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple2 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 352.77 € +[RESULT] montant = ESome ¤352.77 ``` ```catala-test-inline $ catala Interpret -s Exemple3 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 339.70 € +[RESULT] montant = ¤339.70 ``` ```catala-test-inline $ catala Interpret -s Exemple4 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 230.63 € +[RESULT] montant = ¤230.63 ``` ```catala-test-inline -$ catala Interpret -s Exemple3 --disable_warnings --avoid_exceptions +$ catala Interpret_lcalc -s Exemple3 --disable_warnings --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = 339.70 € +[RESULT] montant = ESome ¤339.70 ``` ```catala-test-inline -$ catala Interpret -s Exemple4 --disable_warnings --avoid_exceptions +$ catala Interpret_lcalc -s Exemple4 --disable_warnings --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = 230.63 € +[RESULT] montant = ESome ¤230.63 ``` diff --git a/examples/aides_logement/tests/tests_calcul_al_logement_foyer.catala_fr b/examples/aides_logement/tests/tests_calcul_al_logement_foyer.catala_fr index 694b3e60..cdf28005 100644 --- a/examples/aides_logement/tests/tests_calcul_al_logement_foyer.catala_fr +++ b/examples/aides_logement/tests/tests_calcul_al_logement_foyer.catala_fr @@ -34,10 +34,10 @@ champ d'application CasTest1: ```catala-test-inline $ catala Interpret -s CasTest1 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 76.38 € +[RESULT] montant = ¤76.38 ``` ```catala-test-inline $ catala Interpret_Lcalc -s CasTest1 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 76.38 € +[RESULT] montant = ESome ¤76.38 ``` diff --git a/examples/aides_logement/tests/tests_calcul_apl_accession_propriete.catala_fr b/examples/aides_logement/tests/tests_calcul_apl_accession_propriete.catala_fr index bed2b9de..3cb72c07 100644 --- a/examples/aides_logement/tests/tests_calcul_apl_accession_propriete.catala_fr +++ b/examples/aides_logement/tests/tests_calcul_apl_accession_propriete.catala_fr @@ -150,44 +150,44 @@ champ d'application Exemple4: ```catala-test-inline $ catala Interpret -s Exemple1 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 181.91 € +[RESULT] montant = ¤181.91 ``` ```catala-test-inline $ catala Interpret -s Exemple2 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 67.34 € +[RESULT] montant = ¤67.34 ``` ```catala-test-inline $ catala Interpret -s Exemple3 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 181.91 € +[RESULT] montant = ¤181.91 ``` ```catala-test-inline $ catala Interpret -s Exemple4 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 118.59 € +[RESULT] montant = ¤118.59 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple1 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 181.91 € +[RESULT] montant = ESome ¤181.91 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple2 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 67.34 € +[RESULT] montant = ESome ¤67.34 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple3 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 181.91 € +[RESULT] montant = ESome ¤181.91 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple4 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 118.59 € +[RESULT] montant = ESome ¤118.59 ``` diff --git a/examples/aides_logement/tests/tests_calcul_apl_locatif.catala_fr b/examples/aides_logement/tests/tests_calcul_apl_locatif.catala_fr index 42dfa889..f800088b 100644 --- a/examples/aides_logement/tests/tests_calcul_apl_locatif.catala_fr +++ b/examples/aides_logement/tests/tests_calcul_apl_locatif.catala_fr @@ -281,98 +281,98 @@ champ d'application Exemple9: ```catala-test-inline $ catala Interpret -s Exemple1 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 0.00 € +[RESULT] montant = ¤0.00 ``` ```catala-test-inline $ catala Interpret -s Exemple2 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 352.77 € +[RESULT] montant = ¤352.77 ``` ```catala-test-inline $ catala Interpret -s Exemple3 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 321.61 € +[RESULT] montant = ¤321.61 ``` ```catala-test-inline $ catala Interpret -s Exemple4 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 0.00 € +[RESULT] montant = ¤0.00 ``` ```catala-test-inline $ catala Interpret -s Exemple5 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 311.56 € +[RESULT] montant = ¤311.56 ``` ```catala-test-inline $ catala Interpret -s Exemple6 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 0.00 € +[RESULT] montant = ¤0.00 ``` ```catala-test-inline $ catala Interpret -s Exemple7 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 153.77 € +[RESULT] montant = ¤153.77 ``` ```catala-test-inline $ catala Interpret -s Exemple8 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 11.06 € +[RESULT] montant = ¤11.06 ``` ```catala-test-inline $ catala Interpret -s Exemple9 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 210.06 € +[RESULT] montant = ¤210.06 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple1 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 0.00 € +[RESULT] montant = ESome ¤0.00 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple2 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 352.77 € +[RESULT] montant = ESome ¤352.77 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple3 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 321.61 € +[RESULT] montant = ESome ¤321.61 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple4 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 0.00 € +[RESULT] montant = ESome ¤0.00 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple5 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 311.56 € +[RESULT] montant = ESome ¤311.56 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple6 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 0.00 € +[RESULT] montant = ESome ¤0.00 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple7 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 153.77 € +[RESULT] montant = ESome ¤153.77 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple8 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 11.06 € +[RESULT] montant = ESome ¤11.06 ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple9 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 210.06 € +[RESULT] montant = ESome ¤210.06 ``` diff --git a/examples/aides_logement/tests/tests_calcul_apl_logement_foyer.catala_fr b/examples/aides_logement/tests/tests_calcul_apl_logement_foyer.catala_fr index 9c20ea8e..880f27fe 100644 --- a/examples/aides_logement/tests/tests_calcul_apl_logement_foyer.catala_fr +++ b/examples/aides_logement/tests/tests_calcul_apl_logement_foyer.catala_fr @@ -139,54 +139,54 @@ champ d'application CasTest5: ```catala-test-inline $ catala Interpret -s CasTest1 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 12.06 € +[RESULT] montant = ¤12.06 ``` ```catala-test-inline $ catala Interpret -s CasTest2 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 23.12 € +[RESULT] montant = ¤23.12 ``` ```catala-test-inline $ catala Interpret -s CasTest3 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 154.78 € +[RESULT] montant = ¤154.78 ``` ```catala-test-inline $ catala Interpret -s CasTest4 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 154.78 € +[RESULT] montant = ¤154.78 ``` ```catala-test-inline $ catala Interpret -s CasTest5 --disable_warnings [RESULT] Computation successful! Results: -[RESULT] montant = 129.65 € +[RESULT] montant = ¤129.65 ``` ```catala-test-inline $ catala Interpret_Lcalc -s CasTest1 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 12.06 € +[RESULT] montant = ESome ¤12.06 ``` ```catala-test-inline $ catala Interpret_Lcalc -s CasTest2 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 23.12 € +[RESULT] montant = ESome ¤23.12 ``` ```catala-test-inline $ catala Interpret_Lcalc -s CasTest3 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 154.78 € +[RESULT] montant = ESome ¤154.78 ``` ```catala-test-inline $ catala Interpret_Lcalc -s CasTest4 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 154.78 € +[RESULT] montant = ESome ¤154.78 ``` ```catala-test-inline $ catala Interpret_Lcalc -s CasTest5 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant = ESome 129.65 € +[RESULT] montant = ESome ¤129.65 ``` diff --git a/examples/aides_logement/tests/tests_calculette_globale.catala_fr b/examples/aides_logement/tests/tests_calculette_globale.catala_fr index 350a5ba3..a6b6c171 100644 --- a/examples/aides_logement/tests/tests_calculette_globale.catala_fr +++ b/examples/aides_logement/tests/tests_calculette_globale.catala_fr @@ -158,40 +158,40 @@ champ d'application Exemple2 : ```catala-test-inline $ catala Interpret -s Exemple1 [RESULT] Computation successful! Results: -[RESULT] montant_versé = 246.23 € +[RESULT] montant_versé = ¤246.23 [RESULT] éligibilité = true ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple1 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant_versé = ESome 246.23 € +[RESULT] montant_versé = ESome ¤246.23 [RESULT] éligibilité = ESome true ``` ```catala-test-inline $ catala Interpret_Lcalc -s Exemple1 --avoid_exceptions -O --closure_conversion [RESULT] Computation successful! Results: -[RESULT] montant_versé = ESome 246.23 € +[RESULT] montant_versé = ESome ¤246.23 [RESULT] éligibilité = ESome true ``` ```catala-test-inline $ catala Interpret -s Exemple2 [RESULT] Computation successful! Results: -[RESULT] montant_versé = 230.63 € +[RESULT] montant_versé = ¤230.63 [RESULT] éligibilité = true ``` ```catala-test-inline -$ catala Interpret -s Exemple2 --avoid_exceptions +$ catala Interpret_lcalc -s Exemple2 --avoid_exceptions [RESULT] Computation successful! Results: -[RESULT] montant_versé = 230.63 € -[RESULT] éligibilité = true +[RESULT] montant_versé = ESome ¤230.63 +[RESULT] éligibilité = ESome true ``` ```catala-test-inline -$ catala Interpret -s Exemple2 --avoid_exceptions -O --closure_conversion +$ catala Interpret_lcalc -s Exemple2 -O --avoid_exceptions --closure_conversion [RESULT] Computation successful! Results: -[RESULT] montant_versé = 230.63 € -[RESULT] éligibilité = true +[RESULT] montant_versé = ESome ¤230.63 +[RESULT] éligibilité = ESome true ``` diff --git a/french_law/catala_legifrance/catala_legifrance.ml b/french_law/catala_legifrance/catala_legifrance.ml index 3c87c0d8..993ed315 100644 --- a/french_law/catala_legifrance/catala_legifrance.ml +++ b/french_law/catala_legifrance/catala_legifrance.ml @@ -254,7 +254,7 @@ let driver_lwt (client_id : string) (client_secret : string) = try - if debug then Cli.debug_flag := true; + let _options = Cli.enforce_globals ~debug () in if not (expiration || diff) then Message.raise_error "You have to check at least something, see the list of options with \ diff --git a/runtimes/ocaml/runtime.ml b/runtimes/ocaml/runtime.ml index 7f1923c0..df8698ff 100644 --- a/runtimes/ocaml/runtime.ml +++ b/runtimes/ocaml/runtime.ml @@ -43,6 +43,9 @@ exception IndivisibleDurations exception ImpossibleDate exception NoValueProvided of source_position +(* TODO: register exception printers for the above + (Printexc.register_printer) *) + let money_of_cents_string (cents : string) : money = Z.of_string cents let money_of_units_int (units : int) : money = Z.(of_int units * of_int 100) let money_of_cents_integer (cents : integer) : money = cents diff --git a/tests/test_arithmetic/bad/division_by_zero.catala_en b/tests/test_arithmetic/bad/division_by_zero.catala_en index 32c2929b..09095273 100644 --- a/tests/test_arithmetic/bad/division_by_zero.catala_en +++ b/tests/test_arithmetic/bad/division_by_zero.catala_en @@ -50,7 +50,7 @@ The null denominator: │ ‾‾ └┬ `Division_by_zero` exception management └─ with decimals -#return code 255# +#return code 123# ``` ```catala-test-inline @@ -72,7 +72,7 @@ The null denominator: │ ‾ └┬ `Division_by_zero` exception management └─ with integers -#return code 255# +#return code 123# ``` ```catala-test-inline @@ -94,5 +94,5 @@ The null denominator: │ ‾‾‾‾ └┬ `Division_by_zero` exception management └─ with money -#return code 255# +#return code 123# ``` diff --git a/tests/test_arithmetic/bad/logical_prio.catala_en b/tests/test_arithmetic/bad/logical_prio.catala_en index fc562ace..e9931045 100644 --- a/tests/test_arithmetic/bad/logical_prio.catala_en +++ b/tests/test_arithmetic/bad/logical_prio.catala_en @@ -7,7 +7,7 @@ scope S1: ``` ```catala-test-inline -$ catala typecheck -s S1 +$ catala typecheck [ERROR] Please add parentheses to explicit which of these operators should be applied first ┌─⯈ tests/test_arithmetic/bad/logical_prio.catala_en:6.28-6.31: @@ -21,5 +21,5 @@ $ catala typecheck -s S1 6 │ definition o equals true and (false and true and true) or false │ ‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_array/bad/fold_error.catala_en b/tests/test_array/bad/fold_error.catala_en index 9755a2cf..d5396f48 100644 --- a/tests/test_array/bad/fold_error.catala_en +++ b/tests/test_array/bad/fold_error.catala_en @@ -33,5 +33,5 @@ Type money coming from expression: 10 │ definition list_high_count equals number of (m >= $7) for m among list │ ‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_array/good/aggregation.catala_en b/tests/test_array/good/aggregation.catala_en index 169adec8..ba20c929 100644 --- a/tests/test_array/good/aggregation.catala_en +++ b/tests/test_array/good/aggregation.catala_en @@ -26,27 +26,27 @@ scope B: ```catala-test-inline $ catala Interpret -s A [RESULT] Computation successful! Results: -[RESULT] x = [ $0.00; $9.00; $5.20 ] +[RESULT] x = [ ¤0.00; ¤9.00; ¤5.20 ] ``` ```catala-test-inline $ catala Interpret -s B [RESULT] Computation successful! Results: -[RESULT] max = $18.00 -[RESULT] min = $5.00 -[RESULT] y = $17.20 +[RESULT] max = ¤18.00 +[RESULT] min = ¤5.00 +[RESULT] y = ¤17.20 [RESULT] z = 1 ``` ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = ESome [ ESome $0.00; ESome $9.00; ESome $5.20 ] +[RESULT] x = ESome [ ESome ¤0.00; ESome ¤9.00; ESome ¤5.20 ] ``` ```catala-test-inline $ catala Interpret_Lcalc -s B --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] max = ESome $18.00 -[RESULT] min = ESome $5.00 -[RESULT] y = ESome $17.20 +[RESULT] max = ESome ¤18.00 +[RESULT] min = ESome ¤5.00 +[RESULT] y = ESome ¤17.20 [RESULT] z = ESome 1 ``` diff --git a/tests/test_array/good/aggregation_2.catala_en b/tests/test_array/good/aggregation_2.catala_en index 0e0c7128..69eccc95 100644 --- a/tests/test_array/good/aggregation_2.catala_en +++ b/tests/test_array/good/aggregation_2.catala_en @@ -34,16 +34,16 @@ $ catala Interpret -s A [RESULT] Computation successful! Results: [RESULT] x = - [ { S id = 0; income = $0.00; }; - { S id = 1; income = $9.00; }; - { S id = 2; income = $5.20; } ] + [ { S id = 0; income = ¤0.00; }; + { S id = 1; income = ¤9.00; }; + { S id = 2; income = ¤5.20; } ] ``` ```catala-test-inline $ catala Interpret -s B [RESULT] Computation successful! Results: -[RESULT] argmax = { S id = 1; income = $9.00; } -[RESULT] argmin = { S id = 0; income = $0.00; } +[RESULT] argmax = { S id = 1; income = ¤9.00; } +[RESULT] argmin = { S id = 0; income = ¤0.00; } ``` ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize @@ -51,13 +51,13 @@ $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] x = ESome - [ ESome { S id = ESome 0; income = ESome $0.00; }; - ESome { S id = ESome 1; income = ESome $9.00; }; - ESome { S id = ESome 2; income = ESome $5.20; } ] + [ ESome { S id = ESome 0; income = ESome ¤0.00; }; + ESome { S id = ESome 1; income = ESome ¤9.00; }; + ESome { S id = ESome 2; income = ESome ¤5.20; } ] ``` ```catala-test-inline $ catala Interpret_Lcalc -s B --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] argmax = ESome { S id = ESome 1; income = ESome $9.00; } -[RESULT] argmin = ESome { S id = ESome 0; income = ESome $0.00; } +[RESULT] argmax = ESome { S id = ESome 1; income = ESome ¤9.00; } +[RESULT] argmin = ESome { S id = ESome 0; income = ESome ¤0.00; } ``` diff --git a/tests/test_array/good/filter.catala_en b/tests/test_array/good/filter.catala_en index a07b6403..819eef67 100644 --- a/tests/test_array/good/filter.catala_en +++ b/tests/test_array/good/filter.catala_en @@ -19,13 +19,13 @@ scope B: ```catala-test-inline $ catala Interpret -s A [RESULT] Computation successful! Results: -[RESULT] x = [ $0.00; $9.00; $5.20 ] +[RESULT] x = [ ¤0.00; ¤9.00; ¤5.20 ] ``` ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = ESome [ ESome $0.00; ESome $9.00; ESome $5.20 ] +[RESULT] x = ESome [ ESome ¤0.00; ESome ¤9.00; ESome ¤5.20 ] ``` @@ -33,11 +33,11 @@ $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize ```catala-test-inline $ catala Interpret -s B [RESULT] Computation successful! Results: -[RESULT] y = [ $9.00; $5.20 ] +[RESULT] y = [ ¤9.00; ¤5.20 ] ``` ```catala-test-inline $ catala Interpret_Lcalc -s B --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] y = ESome [ ESome $9.00; ESome $5.20 ] +[RESULT] y = ESome [ ESome ¤9.00; ESome ¤5.20 ] ``` diff --git a/tests/test_array/good/filter_map.catala_en b/tests/test_array/good/filter_map.catala_en index 501acc37..5902e127 100644 --- a/tests/test_array/good/filter_map.catala_en +++ b/tests/test_array/good/filter_map.catala_en @@ -20,23 +20,23 @@ scope B: ```catala-test-inline $ catala Interpret -s A [RESULT] Computation successful! Results: -[RESULT] x = [ $0.00; $9.00; $5.20 ] +[RESULT] x = [ ¤0.00; ¤9.00; ¤5.20 ] ``` ```catala-test-inline $ catala Interpret -s B [RESULT] Computation successful! Results: -[RESULT] y = [ $9.00; $5.20 ] +[RESULT] y = [ ¤9.00; ¤5.20 ] [RESULT] z = [ false; true; true ] ``` ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = ESome [ ESome $0.00; ESome $9.00; ESome $5.20 ] +[RESULT] x = ESome [ ESome ¤0.00; ESome ¤9.00; ESome ¤5.20 ] ``` ```catala-test-inline $ catala Interpret_Lcalc -s B --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] y = ESome [ ESome $9.00; ESome $5.20 ] +[RESULT] y = ESome [ ESome ¤9.00; ESome ¤5.20 ] [RESULT] z = ESome [ ESome false; ESome true; ESome true ] ``` diff --git a/tests/test_array/good/fold.catala_en b/tests/test_array/good/fold.catala_en index 0e0c7128..69eccc95 100644 --- a/tests/test_array/good/fold.catala_en +++ b/tests/test_array/good/fold.catala_en @@ -34,16 +34,16 @@ $ catala Interpret -s A [RESULT] Computation successful! Results: [RESULT] x = - [ { S id = 0; income = $0.00; }; - { S id = 1; income = $9.00; }; - { S id = 2; income = $5.20; } ] + [ { S id = 0; income = ¤0.00; }; + { S id = 1; income = ¤9.00; }; + { S id = 2; income = ¤5.20; } ] ``` ```catala-test-inline $ catala Interpret -s B [RESULT] Computation successful! Results: -[RESULT] argmax = { S id = 1; income = $9.00; } -[RESULT] argmin = { S id = 0; income = $0.00; } +[RESULT] argmax = { S id = 1; income = ¤9.00; } +[RESULT] argmin = { S id = 0; income = ¤0.00; } ``` ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize @@ -51,13 +51,13 @@ $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] x = ESome - [ ESome { S id = ESome 0; income = ESome $0.00; }; - ESome { S id = ESome 1; income = ESome $9.00; }; - ESome { S id = ESome 2; income = ESome $5.20; } ] + [ ESome { S id = ESome 0; income = ESome ¤0.00; }; + ESome { S id = ESome 1; income = ESome ¤9.00; }; + ESome { S id = ESome 2; income = ESome ¤5.20; } ] ``` ```catala-test-inline $ catala Interpret_Lcalc -s B --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] argmax = ESome { S id = ESome 1; income = ESome $9.00; } -[RESULT] argmin = ESome { S id = ESome 0; income = ESome $0.00; } +[RESULT] argmax = ESome { S id = ESome 1; income = ESome ¤9.00; } +[RESULT] argmin = ESome { S id = ESome 0; income = ESome ¤0.00; } ``` diff --git a/tests/test_array/good/map.catala_en b/tests/test_array/good/map.catala_en index 1945c5d9..4aa3cdd9 100644 --- a/tests/test_array/good/map.catala_en +++ b/tests/test_array/good/map.catala_en @@ -13,13 +13,13 @@ scope B: ```catala-test-inline $ catala Interpret -s B [RESULT] Computation successful! Results: -[RESULT] x = [ $4.00; $8.00 ] +[RESULT] x = [ ¤4.00; ¤8.00 ] [RESULT] z = [ false; true ] ``` ```catala-test-inline $ catala Interpret_Lcalc -s B --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = ESome [ ESome $4.00; ESome $8.00 ] +[RESULT] x = ESome [ ESome ¤4.00; ESome ¤8.00 ] [RESULT] z = ESome [ ESome false; ESome true ] ``` diff --git a/tests/test_bool/bad/bad_assert.catala_en b/tests/test_bool/bad/bad_assert.catala_en index b764c155..4d7b8271 100644 --- a/tests/test_bool/bad/bad_assert.catala_en +++ b/tests/test_bool/bad/bad_assert.catala_en @@ -36,5 +36,5 @@ Type bool coming from expression: 9 │ assertion x │ ‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_bool/bad/test_xor_with_int.catala_en b/tests/test_bool/bad/test_xor_with_int.catala_en index bd8bd9f9..30705f6b 100644 --- a/tests/test_bool/bad/test_xor_with_int.catala_en +++ b/tests/test_bool/bad/test_xor_with_int.catala_en @@ -34,5 +34,5 @@ Type bool coming from expression: 8 │ definition test_var equals 10 xor 20 │ ‾‾‾ └─ 'xor' should be a boolean operator -#return code 255# +#return code 123# ``` diff --git a/tests/test_date/bad/rounding_option.catala_en b/tests/test_date/bad/rounding_option.catala_en index 4430aeb0..9d632c4c 100644 --- a/tests/test_date/bad/rounding_option.catala_en +++ b/tests/test_date/bad/rounding_option.catala_en @@ -12,8 +12,6 @@ scope Test: ```catala-test-inline $ catala Interpret -s Test -catala: internal error, uncaught exception: - Dates_calc.Dates.AmbiguousComputation - +[ERROR] Unexpected error: Dates_calc.Dates.AmbiguousComputation #return code 125# ``` diff --git a/tests/test_date/bad/rounding_option.catala_fr b/tests/test_date/bad/rounding_option.catala_fr index 7cbea53d..35edcf03 100644 --- a/tests/test_date/bad/rounding_option.catala_fr +++ b/tests/test_date/bad/rounding_option.catala_fr @@ -12,8 +12,6 @@ champ d'application Test: ```catala-test-inline $ catala Interpret -s Test -catala: internal error, uncaught exception: - Dates_calc.Dates.AmbiguousComputation - +[ERROR] Unexpected error: Dates_calc.Dates.AmbiguousComputation #return code 125# ``` diff --git a/tests/test_date/bad/rounding_option_conflict.catala_en b/tests/test_date/bad/rounding_option_conflict.catala_en index c6f75c59..d3d508a9 100644 --- a/tests/test_date/bad/rounding_option_conflict.catala_en +++ b/tests/test_date/bad/rounding_option_conflict.catala_en @@ -38,5 +38,5 @@ $ catala Interpret -s Test 12 │ date round increasing │ ‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_date/bad/uncomparable_duration.catala_en b/tests/test_date/bad/uncomparable_duration.catala_en index 8101bad8..b056e26f 100644 --- a/tests/test_date/bad/uncomparable_duration.catala_en +++ b/tests/test_date/bad/uncomparable_duration.catala_en @@ -57,7 +57,7 @@ $ catala Interpret -s Ge │ ‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `>=` operator -#return code 255# +#return code 123# ``` ```catala-test-inline @@ -77,7 +77,7 @@ $ catala Interpret -s Gt │ ‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<=` operator -#return code 255# +#return code 123# ``` ```catala-test-inline @@ -97,7 +97,7 @@ $ catala Interpret -s Le │ ‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<=` operator -#return code 255# +#return code 123# ``` ```catala-test-inline @@ -117,5 +117,5 @@ $ catala Interpret -s Lt │ ‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<` operator -#return code 255# +#return code 123# ``` diff --git a/tests/test_default/bad/conflict.catala_en b/tests/test_default/bad/conflict.catala_en index b9c26328..eb926788 100644 --- a/tests/test_default/bad/conflict.catala_en +++ b/tests/test_default/bad/conflict.catala_en @@ -26,5 +26,5 @@ This consequence has a valid justification: 9 │ definition x under condition true consequence equals 0 │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_default/bad/empty.catala_en b/tests/test_default/bad/empty.catala_en index 541d8d82..b57d713d 100644 --- a/tests/test_default/bad/empty.catala_en +++ b/tests/test_default/bad/empty.catala_en @@ -25,5 +25,5 @@ $ catala Interpret -s A 6 │ output y content boolean │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_default/bad/empty_with_rules.catala_en b/tests/test_default/bad/empty_with_rules.catala_en index c04cefc6..d9dfbaa3 100644 --- a/tests/test_default/bad/empty_with_rules.catala_en +++ b/tests/test_default/bad/empty_with_rules.catala_en @@ -21,5 +21,5 @@ $ catala Interpret -s A 5 │ output x content integer │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/ambiguous_cases.catala_en b/tests/test_enum/bad/ambiguous_cases.catala_en index d86dbc1a..29fb87be 100644 --- a/tests/test_enum/bad/ambiguous_cases.catala_en +++ b/tests/test_enum/bad/ambiguous_cases.catala_en @@ -23,5 +23,5 @@ $ catala Interpret -s A 14 │ definition e equals Case1 │ ‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/ambiguous_wildcard.catala_en b/tests/test_enum/bad/ambiguous_wildcard.catala_en index 040bacc4..d66e5927 100644 --- a/tests/test_enum/bad/ambiguous_wildcard.catala_en +++ b/tests/test_enum/bad/ambiguous_wildcard.catala_en @@ -24,5 +24,5 @@ $ catala Interpret -s A 15 │ -- anything : 31 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Wildcard cannot be used as single match case -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/duplicate_case.catala_en b/tests/test_enum/bad/duplicate_case.catala_en index 72bdc509..eee4d5a5 100644 --- a/tests/test_enum/bad/duplicate_case.catala_en +++ b/tests/test_enum/bad/duplicate_case.catala_en @@ -33,5 +33,5 @@ $ catala Interpret -s A 17 │ -- Case3 : false │ ‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/empty.catala_en b/tests/test_enum/bad/empty.catala_en index 8929c17b..72ae80b1 100644 --- a/tests/test_enum/bad/empty.catala_en +++ b/tests/test_enum/bad/empty.catala_en @@ -16,5 +16,5 @@ $ catala Typecheck 4 │ declaration enumeration Foo: │ ‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/missing_case.catala_en b/tests/test_enum/bad/missing_case.catala_en index 4efbbbaf..e2e3dca6 100644 --- a/tests/test_enum/bad/missing_case.catala_en +++ b/tests/test_enum/bad/missing_case.catala_en @@ -36,5 +36,5 @@ $ catala Interpret -s A 16 │ -- Case2 of b : b │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/not_ending_wildcard.catala_en b/tests/test_enum/bad/not_ending_wildcard.catala_en index aba6cf0c..5add38bd 100644 --- a/tests/test_enum/bad/not_ending_wildcard.catala_en +++ b/tests/test_enum/bad/not_ending_wildcard.catala_en @@ -55,7 +55,7 @@ Next reachable case: │ ‾‾‾‾‾‾‾‾‾‾‾‾‾ └┬ Wildcard must be the last case └─ Wildcard can't be the first case -#return code 255# +#return code 123# ``` ```catala-test-inline @@ -77,5 +77,5 @@ Next reachable case: │ ‾‾‾‾‾‾‾‾‾‾‾‾‾ └┬ Wildcard must be the last case └─ Wildcard can't be the first case -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/quick_pattern_2.catala_en b/tests/test_enum/bad/quick_pattern_2.catala_en index 1c78cc05..1c4a53ca 100644 --- a/tests/test_enum/bad/quick_pattern_2.catala_en +++ b/tests/test_enum/bad/quick_pattern_2.catala_en @@ -54,5 +54,5 @@ Type F coming from expression: 28 │ definition y equals x with pattern Case3 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/quick_pattern_3.catala_en b/tests/test_enum/bad/quick_pattern_3.catala_en index 8d50ba75..99a9aef6 100644 --- a/tests/test_enum/bad/quick_pattern_3.catala_en +++ b/tests/test_enum/bad/quick_pattern_3.catala_en @@ -44,5 +44,5 @@ Type F coming from expression: 18 │ definition y equals x with pattern Case3 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/quick_pattern_4.catala_en b/tests/test_enum/bad/quick_pattern_4.catala_en index 343a2a14..b4d60ca2 100644 --- a/tests/test_enum/bad/quick_pattern_4.catala_en +++ b/tests/test_enum/bad/quick_pattern_4.catala_en @@ -43,5 +43,5 @@ Type F coming from expression: 17 │ definition y equals x with pattern Case3 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/quick_pattern_fail.catala_en b/tests/test_enum/bad/quick_pattern_fail.catala_en index b96619a4..a60c5146 100644 --- a/tests/test_enum/bad/quick_pattern_fail.catala_en +++ b/tests/test_enum/bad/quick_pattern_fail.catala_en @@ -24,5 +24,5 @@ $ catala Interpret -s A 15 │ definition y equals x with pattern Case3 │ ‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_enum/bad/too_many_cases.catala_en b/tests/test_enum/bad/too_many_cases.catala_en index bb8c1955..7e9e5fee 100644 --- a/tests/test_enum/bad/too_many_cases.catala_en +++ b/tests/test_enum/bad/too_many_cases.catala_en @@ -30,5 +30,5 @@ $ catala Interpret -s A 21 │ -- Case4 : true │ ‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en b/tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en index b385e4b0..20b58f2f 100644 --- a/tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en +++ b/tests/test_exception/bad/ambiguous_unlabeled_exception.catala_en @@ -39,5 +39,5 @@ Candidate definition 8 │ definition x equals 0 │ ‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_exception/bad/dangling_exception.catala_en b/tests/test_exception/bad/dangling_exception.catala_en index 565d503d..d35db3b5 100644 --- a/tests/test_exception/bad/dangling_exception.catala_en +++ b/tests/test_exception/bad/dangling_exception.catala_en @@ -22,5 +22,5 @@ $ catala Interpret -s A 12 │ exception base_y │ ‾‾‾‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_exception/bad/exceptions_cycle.catala_en b/tests/test_exception/bad/exceptions_cycle.catala_en index 38bbb256..9d570caa 100644 --- a/tests/test_exception/bad/exceptions_cycle.catala_en +++ b/tests/test_exception/bad/exceptions_cycle.catala_en @@ -51,5 +51,5 @@ $ catala Interpret -s A 18 │ definition x equals 2 │ ‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_exception/bad/missing_unlabeled_definition.catala_en b/tests/test_exception/bad/missing_unlabeled_definition.catala_en index aae38a1b..3466c4eb 100644 --- a/tests/test_exception/bad/missing_unlabeled_definition.catala_en +++ b/tests/test_exception/bad/missing_unlabeled_definition.catala_en @@ -20,5 +20,5 @@ $ catala Interpret -s A 9 │ definition x equals 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_exception/bad/one_ambiguous_exception.catala_en b/tests/test_exception/bad/one_ambiguous_exception.catala_en index 3171d7dc..9c8d7c32 100644 --- a/tests/test_exception/bad/one_ambiguous_exception.catala_en +++ b/tests/test_exception/bad/one_ambiguous_exception.catala_en @@ -45,5 +45,5 @@ Candidate definition 14 │ definition y equals 2 │ ‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_exception/bad/self_exception.catala_en b/tests/test_exception/bad/self_exception.catala_en index 428dcef6..8b928188 100644 --- a/tests/test_exception/bad/self_exception.catala_en +++ b/tests/test_exception/bad/self_exception.catala_en @@ -19,5 +19,5 @@ $ catala Interpret -s A 9 │ exception base_y │ ‾‾‾‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_exception/bad/two_exceptions.catala_en b/tests/test_exception/bad/two_exceptions.catala_en index ac11f22f..29d676c4 100644 --- a/tests/test_exception/bad/two_exceptions.catala_en +++ b/tests/test_exception/bad/two_exceptions.catala_en @@ -32,5 +32,5 @@ This consequence has a valid justification: 15 │ definition x equals 2 │ ‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_exception/good/grouped_exceptions.catala_en b/tests/test_exception/good/grouped_exceptions.catala_en index 9f5d9866..8837f3c5 100644 --- a/tests/test_exception/good/grouped_exceptions.catala_en +++ b/tests/test_exception/good/grouped_exceptions.catala_en @@ -49,12 +49,12 @@ scope Benefit: ```catala-test-inline $ catala Interpret -s Benefit [RESULT] Computation successful! Results: -[RESULT] benefit = $2000.00 +[RESULT] benefit = ¤2000.00 [RESULT] person = { Person age = 26; disabled = true; } ``` ```catala-test-inline $ catala Interpret_Lcalc -s Benefit --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] benefit = ESome $2000.00 +[RESULT] benefit = ESome ¤2000.00 [RESULT] person = ESome { Person age = ESome 26; disabled = ESome true; } ``` diff --git a/tests/test_func/bad/bad_func.catala_en b/tests/test_func/bad/bad_func.catala_en index 0d97dfcb..bc8db220 100644 --- a/tests/test_func/bad/bad_func.catala_en +++ b/tests/test_func/bad/bad_func.catala_en @@ -44,5 +44,5 @@ This consequence has a valid justification: 15 │ definition f of x under condition not b consequence equals x * x │ ‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_func/bad/param_inconsistency.catala_en b/tests/test_func/bad/param_inconsistency.catala_en index b7aed2ae..92d332ab 100644 --- a/tests/test_func/bad/param_inconsistency.catala_en +++ b/tests/test_func/bad/param_inconsistency.catala_en @@ -29,5 +29,5 @@ Defined here: 10 │ definition f1 of y under condition not cond │ ‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_func/bad/param_inconsistency2.catala_en b/tests/test_func/bad/param_inconsistency2.catala_en index 14979e88..f40f0af4 100644 --- a/tests/test_func/bad/param_inconsistency2.catala_en +++ b/tests/test_func/bad/param_inconsistency2.catala_en @@ -28,5 +28,5 @@ Defined here: 9 │ exception definition f1 of y under condition not cond │ ‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_func/bad/param_inconsistency3.catala_en b/tests/test_func/bad/param_inconsistency3.catala_en index cefbe7c6..7e324c06 100644 --- a/tests/test_func/bad/param_inconsistency3.catala_en +++ b/tests/test_func/bad/param_inconsistency3.catala_en @@ -28,5 +28,5 @@ Defined here: 9 │ exception definition f1 of y under condition not cond │ ‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_func/bad/recursive.catala_en b/tests/test_func/bad/recursive.catala_en index f1cf9cd8..1f8711d1 100644 --- a/tests/test_func/bad/recursive.catala_en +++ b/tests/test_func/bad/recursive.catala_en @@ -17,5 +17,5 @@ $ catala Interpret -s RecursiveFunc 8 │ definition f of x equals f of x + 1 │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_func/good/closure_conversion_reduce.catala_en b/tests/test_func/good/closure_conversion_reduce.catala_en index 34983359..e22c8eec 100644 --- a/tests/test_func/good/closure_conversion_reduce.catala_en +++ b/tests/test_func/good/closure_conversion_reduce.catala_en @@ -46,7 +46,8 @@ let scope S return { S y = y; } ``` -The next test of closure conversion does not go through for the moment. +The next test of closure conversion should give the same results, it checks that +`--avoid_exceptions` and `-O` are correctly implied by `--closure_conversion` The detection of closures that should not be converted because they are arguments to reduce or other special operators relies on pattern matching the special operator and its EAbs argument. However without exceptions on, because the @@ -56,7 +57,40 @@ option. This let-binding is reduced by partial evaluation, which is why the test with optimizations on passes. ```catala-test-inline -$ catala Lcalc -s S --avoid_exceptions --closure_conversion -[ERROR] Option --optimize must be enabled for --closure_conversion -#return code 255# +$ catala Lcalc -s S --closure_conversion +let scope S + (S_in: S_in {x_in: eoption collection eoption integer}) + : S {y: eoption integer} + = + let get x : eoption collection eoption integer = S_in.x_in in + let set y : eoption integer = + ESome + match + (handle_default_opt + [ ] + (λ (_: unit) → ESome true) + (λ (_: unit) → + match x with + | ENone _1 → ENone _1 + | ESome y_2 → + reduce + (λ (f: eoption integer) (init: eoption integer) → + match init with + | ENone _1 → ENone _1 + | ESome y_3 → + match f with + | ENone _1 → ENone _1 + | ESome y_0 → + let potential_max_1 : integer = y_0 in + let potential_max_2 : integer = y_3 in + if potential_max_1 < potential_max_2 + then ESome potential_max_1 + else ESome potential_max_2) + ESome -1 + y_2)) + with + | ENone _ → raise NoValueProvided + | ESome y → y + in + return { S y = y; } ``` diff --git a/tests/test_func/good/context_func.catala_en b/tests/test_func/good/context_func.catala_en index d2846b48..b25fc45d 100644 --- a/tests/test_func/good/context_func.catala_en +++ b/tests/test_func/good/context_func.catala_en @@ -39,7 +39,7 @@ Incriminated subscope variable definition: 15 │ definition a.f of x under condition b and x > 0 consequence equals x - 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` ```catala-test-inline @@ -66,7 +66,7 @@ Incriminated subscope variable definition: 15 │ definition a.f of x under condition b and x > 0 consequence equals x - 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` ```catala-test-inline @@ -93,5 +93,5 @@ Incriminated subscope variable definition: 15 │ definition a.f of x under condition b and x > 0 consequence equals x - 1 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_io/bad/forgot_input.catala_en b/tests/test_io/bad/forgot_input.catala_en index 37f769da..607fb945 100644 --- a/tests/test_io/bad/forgot_input.catala_en +++ b/tests/test_io/bad/forgot_input.catala_en @@ -31,5 +31,5 @@ Incriminated variable: 6 │ input x content integer │ ‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_io/bad/inputing_to_not_input.catala_en b/tests/test_io/bad/inputing_to_not_input.catala_en index 54a0260d..c28e607d 100644 --- a/tests/test_io/bad/inputing_to_not_input.catala_en +++ b/tests/test_io/bad/inputing_to_not_input.catala_en @@ -38,5 +38,5 @@ Incriminated subscope variable definition: 14 │ definition a.a equals 0 │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_io/bad/redefining_input.catala_en b/tests/test_io/bad/redefining_input.catala_en index 51dd5665..e97a525d 100644 --- a/tests/test_io/bad/redefining_input.catala_en +++ b/tests/test_io/bad/redefining_input.catala_en @@ -24,5 +24,5 @@ Incriminated variable definition: 8 │ definition a equals 0 │ ‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_io/bad/using_non_output.catala_en b/tests/test_io/bad/using_non_output.catala_en index 96353bed..7e264637 100644 --- a/tests/test_io/bad/using_non_output.catala_en +++ b/tests/test_io/bad/using_non_output.catala_en @@ -44,5 +44,5 @@ Incriminated subscope declaration: 8 │ a scope A │ ‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_io/good/all_io.catala_en b/tests/test_io/good/all_io.catala_en index 43781973..e134abd6 100644 --- a/tests/test_io/good/all_io.catala_en +++ b/tests/test_io/good/all_io.catala_en @@ -43,6 +43,6 @@ let scope A ``` ```catala-test-inline -$ catala Typecheck -s A +$ catala Typecheck [RESULT] Typechecking successful! ``` diff --git a/tests/test_io/good/subscope.catala_en b/tests/test_io/good/subscope.catala_en index 9f0d620a..1c934383 100644 --- a/tests/test_io/good/subscope.catala_en +++ b/tests/test_io/good/subscope.catala_en @@ -32,6 +32,6 @@ let scope B (B_in: B_in): B = ``` ```catala-test-inline -$ catala Typecheck -s B +$ catala Typecheck [RESULT] Typechecking successful! ``` diff --git a/tests/test_money/bad/no_mingle.catala_en b/tests/test_money/bad/no_mingle.catala_en index f24c5cb5..2bfeb39e 100644 --- a/tests/test_money/bad/no_mingle.catala_en +++ b/tests/test_money/bad/no_mingle.catala_en @@ -35,5 +35,5 @@ Type money coming from expression: 6 │ context y content money │ ‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_money/good/literal_parsing.catala_en b/tests/test_money/good/literal_parsing.catala_en index f2904fe3..00c52f64 100644 --- a/tests/test_money/good/literal_parsing.catala_en +++ b/tests/test_money/good/literal_parsing.catala_en @@ -14,12 +14,12 @@ scope A: ```catala-test-inline $ catala Interpret -s A [RESULT] Computation successful! Results: -[RESULT] x = $0.30 -[RESULT] y = $0.30 +[RESULT] x = ¤0.30 +[RESULT] y = ¤0.30 ``` ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = ESome $0.30 -[RESULT] y = ESome $0.30 +[RESULT] x = ESome ¤0.30 +[RESULT] y = ESome ¤0.30 ``` diff --git a/tests/test_money/good/simple.catala_en b/tests/test_money/good/simple.catala_en index 8c6b54fd..88c5bd41 100644 --- a/tests/test_money/good/simple.catala_en +++ b/tests/test_money/good/simple.catala_en @@ -15,14 +15,14 @@ scope A: ```catala-test-inline $ catala Interpret -s A [RESULT] Computation successful! Results: -[RESULT] x = $123.54 -[RESULT] y = $8548650.96 -[RESULT] z = $7.23 +[RESULT] x = ¤123.54 +[RESULT] y = ¤8548650.96 +[RESULT] z = ¤7.23 ``` ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = ESome $123.54 -[RESULT] y = ESome $8548650.96 -[RESULT] z = ESome $7.23 +[RESULT] x = ESome ¤123.54 +[RESULT] y = ESome ¤8548650.96 +[RESULT] z = ESome ¤7.23 ``` diff --git a/tests/test_name_resolution/bad/toplevel_defs.catala_en b/tests/test_name_resolution/bad/toplevel_defs.catala_en index ac447416..ebbd8ba3 100644 --- a/tests/test_name_resolution/bad/toplevel_defs.catala_en +++ b/tests/test_name_resolution/bad/toplevel_defs.catala_en @@ -20,5 +20,5 @@ $ catala typecheck 11 │ equals (output of S1).a │ ‾‾‾‾‾‾‾‾‾‾‾‾ └─ Scope calls are not allowed outside of scopes -#return code 255# +#return code 123# ``` diff --git a/tests/test_name_resolution/good/toplevel_defs.catala_en b/tests/test_name_resolution/good/toplevel_defs.catala_en index 585a692b..11f71b03 100644 --- a/tests/test_name_resolution/good/toplevel_defs.catala_en +++ b/tests/test_name_resolution/good/toplevel_defs.catala_en @@ -114,7 +114,7 @@ let S2_6 (S2_in_11: S2_in) = try: decl temp_a_16 : any; let temp_a_16 (__17 : unit) = - return glob3_3 $44.00 + 100.; + return glob3_3 ¤44.00 + 100.; decl temp_a_14 : any; let temp_a_14 (__15 : unit) = return true; @@ -131,7 +131,7 @@ let S3_7 (S3_in_18: S3_in) = try: decl temp_a_23 : any; let temp_a_23 (__24 : unit) = - return 50. + glob4_4 $44.00 55.; + return 50. + glob4_4 ¤44.00 55.; decl temp_a_21 : any; let temp_a_21 (__22 : unit) = return true; diff --git a/tests/test_proof/bad/dates_get_year-empty.catala_en b/tests/test_proof/bad/dates_get_year-empty.catala_en index a9932432..4cd0c642 100644 --- a/tests/test_proof/bad/dates_get_year-empty.catala_en +++ b/tests/test_proof/bad/dates_get_year-empty.catala_en @@ -30,5 +30,5 @@ Incriminated variable definition: 9 │ definition x equals |2022-01-16| │ ‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_proof/bad/prolala_motivating_example.catala_en b/tests/test_proof/bad/prolala_motivating_example.catala_en index 1136b06b..33747ac0 100644 --- a/tests/test_proof/bad/prolala_motivating_example.catala_en +++ b/tests/test_proof/bad/prolala_motivating_example.catala_en @@ -147,5 +147,5 @@ Incriminated subscope variable definition: 64 │ definition eligibility.is_student equals is_student │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_scope/bad/cycle_in_scope.catala_en b/tests/test_scope/bad/cycle_in_scope.catala_en index 00b4119a..071d9f07 100644 --- a/tests/test_scope/bad/cycle_in_scope.catala_en +++ b/tests/test_scope/bad/cycle_in_scope.catala_en @@ -39,5 +39,5 @@ y is used here in the definition of z: 13 │ definition z under condition y < 1 consequence equals y │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_scope/bad/cyclic_scope_calls.catala_en b/tests/test_scope/bad/cyclic_scope_calls.catala_en index 073a6c07..f730a074 100644 --- a/tests/test_scope/bad/cyclic_scope_calls.catala_en +++ b/tests/test_scope/bad/cyclic_scope_calls.catala_en @@ -51,5 +51,5 @@ S2 is used here in the definition of S4: 24 │ definition o equals (output of S2).o │ ‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_scope/bad/cyclic_scopes.catala_en b/tests/test_scope/bad/cyclic_scopes.catala_en index e4eff437..2102d888 100644 --- a/tests/test_scope/bad/cyclic_scopes.catala_en +++ b/tests/test_scope/bad/cyclic_scopes.catala_en @@ -34,5 +34,5 @@ A is used here in the definition of B: 9 │ a scope A │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_scope/bad/scope.catala_en b/tests/test_scope/bad/scope.catala_en index 2fd80e41..19ae233b 100644 --- a/tests/test_scope/bad/scope.catala_en +++ b/tests/test_scope/bad/scope.catala_en @@ -31,5 +31,5 @@ This consequence has a valid justification: 14 │ definition b under condition not c consequence equals 0 │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_scope/bad/scope_call_duplicate.catala_en b/tests/test_scope/bad/scope_call_duplicate.catala_en index f2afbc36..010852f5 100644 --- a/tests/test_scope/bad/scope_call_duplicate.catala_en +++ b/tests/test_scope/bad/scope_call_duplicate.catala_en @@ -23,5 +23,5 @@ $ catala dcalc -s Titi 14 │ definition fizz equals output of Toto with {--bar: 1 --baz: 2.1 -- bar: 3} │ ‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_scope/bad/scope_call_extra.catala_en b/tests/test_scope/bad/scope_call_extra.catala_en index 4c87987a..a90f5ba1 100644 --- a/tests/test_scope/bad/scope_call_extra.catala_en +++ b/tests/test_scope/bad/scope_call_extra.catala_en @@ -30,5 +30,5 @@ Scope Toto declared here 2 │ declaration scope Toto: │ ‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_scope/bad/scope_call_missing.catala_en b/tests/test_scope/bad/scope_call_missing.catala_en index 46fd4b20..0f3c40ac 100644 --- a/tests/test_scope/bad/scope_call_missing.catala_en +++ b/tests/test_scope/bad/scope_call_missing.catala_en @@ -30,5 +30,5 @@ Declaration of the missing input variable 4 │ input output baz content decimal │ ‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_scope/bad/sub_vars_in_sub_var.catala_en b/tests/test_scope/bad/sub_vars_in_sub_var.catala_en index 500c2e11..c8429dc5 100644 --- a/tests/test_scope/bad/sub_vars_in_sub_var.catala_en +++ b/tests/test_scope/bad/sub_vars_in_sub_var.catala_en @@ -22,5 +22,5 @@ $ catala Interpret -s A 13 │ definition a.y equals if a.x then 0 else 1 │ ‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_struct/bad/bug_107.catala_en b/tests/test_struct/bad/bug_107.catala_en index 2248e75c..6f6091f5 100644 --- a/tests/test_struct/bad/bug_107.catala_en +++ b/tests/test_struct/bad/bug_107.catala_en @@ -33,5 +33,5 @@ Second definition: 8 │ declaration structure S: │ ‾ └─ https://github.com/CatalaLang/catala/issues/107 -#return code 255# +#return code 123# ``` diff --git a/tests/test_struct/bad/empty_struct.catala_en b/tests/test_struct/bad/empty_struct.catala_en index 21d5e6dc..0ee5b128 100644 --- a/tests/test_struct/bad/empty_struct.catala_en +++ b/tests/test_struct/bad/empty_struct.catala_en @@ -16,5 +16,5 @@ $ catala Typecheck 4 │ declaration structure Foo: │ ‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_struct/bad/nested.catala_en b/tests/test_struct/bad/nested.catala_en index f5d6cbcb..78366ec7 100644 --- a/tests/test_struct/bad/nested.catala_en +++ b/tests/test_struct/bad/nested.catala_en @@ -28,5 +28,5 @@ $ catala Interpret -s A 6 │ -- Rec content E │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_struct/bad/nested2.catala_en b/tests/test_struct/bad/nested2.catala_en index f3e09dbd..d61f4b37 100644 --- a/tests/test_struct/bad/nested2.catala_en +++ b/tests/test_struct/bad/nested2.catala_en @@ -65,5 +65,5 @@ Used here in the definition of another cycle type S: 5 │ data x content E │ ‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_struct/bad/nonexisting_struct.catala_en b/tests/test_struct/bad/nonexisting_struct.catala_en index 27df1718..75cba9d8 100644 --- a/tests/test_struct/bad/nonexisting_struct.catala_en +++ b/tests/test_struct/bad/nonexisting_struct.catala_en @@ -22,5 +22,5 @@ $ catala Interpret -s A 13 │ definition y equals x.Fo.f │ ‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_struct/bad/wrong_qualified_field.catala_en b/tests/test_struct/bad/wrong_qualified_field.catala_en index 26ca5889..f0af14ff 100644 --- a/tests/test_struct/bad/wrong_qualified_field.catala_en +++ b/tests/test_struct/bad/wrong_qualified_field.catala_en @@ -26,5 +26,5 @@ $ catala Interpret -s A 17 │ definition y equals x.Foo.g │ ‾‾‾‾‾‾‾ └─ Article -#return code 255# +#return code 123# ``` diff --git a/tests/test_typing/bad/err1.catala_en b/tests/test_typing/bad/err1.catala_en index 30c54b24..ce7c250d 100644 --- a/tests/test_typing/bad/err1.catala_en +++ b/tests/test_typing/bad/err1.catala_en @@ -36,5 +36,5 @@ Type integer coming from expression: 8 │ data i content integer │ ‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_typing/bad/err2.catala_en b/tests/test_typing/bad/err2.catala_en index e105e6d3..98a39ebe 100644 --- a/tests/test_typing/bad/err2.catala_en +++ b/tests/test_typing/bad/err2.catala_en @@ -36,5 +36,5 @@ Type collection coming from expression: 10 │ definition a equals number of (z ++ 1.1) / 2 │ ‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_typing/bad/err3.catala_en b/tests/test_typing/bad/err3.catala_en index e4c624d6..7047fe92 100644 --- a/tests/test_typing/bad/err3.catala_en +++ b/tests/test_typing/bad/err3.catala_en @@ -43,7 +43,7 @@ Type decimal coming from expression: 15 │ output a content decimal │ ‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` Re-putting the same check again, to ensure that the `Typecheck` and `ocaml` subcommands output the same type error consistently (bug pointed out and fixed in 498429e). @@ -81,5 +81,5 @@ Type decimal coming from expression: 15 │ output a content decimal │ ‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_typing/bad/err4.catala_en b/tests/test_typing/bad/err4.catala_en index 774d84f5..56eaf971 100644 --- a/tests/test_typing/bad/err4.catala_en +++ b/tests/test_typing/bad/err4.catala_en @@ -55,5 +55,5 @@ Type Structure coming from expression: 14 │ output z content collection Structure │ ‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_typing/bad/err5.catala_en b/tests/test_typing/bad/err5.catala_en index 6cc3bb21..5b15bd81 100644 --- a/tests/test_typing/bad/err5.catala_en +++ b/tests/test_typing/bad/err5.catala_en @@ -36,5 +36,5 @@ Type Structure coming from expression: 6 │ Structure { -- i: 3 -- e: Int content x }; │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_typing/bad/err6.catala_en b/tests/test_typing/bad/err6.catala_en index 21c6065e..dd8fbe9c 100644 --- a/tests/test_typing/bad/err6.catala_en +++ b/tests/test_typing/bad/err6.catala_en @@ -52,5 +52,5 @@ Type integer coming from expression: 12 │ input x content integer │ ‾‾‾‾‾‾‾ -#return code 255# +#return code 123# ``` diff --git a/tests/test_typing/good/overload.catala_en b/tests/test_typing/good/overload.catala_en index 9d193285..23d2eef8 100644 --- a/tests/test_typing/good/overload.catala_en +++ b/tests/test_typing/good/overload.catala_en @@ -63,7 +63,7 @@ $ catala Interpret -s S [RESULT] o_b = true [RESULT] o_d = [0 years, 0 months, -13 days] [RESULT] o_i = -5 -[RESULT] o_m = $-5.75 +[RESULT] o_m = ¤-5.75 [RESULT] o_t = 2022-01-24 [RESULT] o_x = 0.14285714285714285714… ``` @@ -73,7 +73,7 @@ $ catala Interpret_Lcalc -s S --avoid_exceptions --optimize [RESULT] o_b = ESome true [RESULT] o_d = ESome [0 years, 0 months, -13 days] [RESULT] o_i = ESome -5 -[RESULT] o_m = ESome $-5.75 +[RESULT] o_m = ESome ¤-5.75 [RESULT] o_t = ESome 2022-01-24 [RESULT] o_x = ESome 0.14285714285714285714… ``` diff --git a/tests/test_variable_state/bad/def_no_state.catala_en b/tests/test_variable_state/bad/def_no_state.catala_en index 9728ab02..1d4f7404 100644 --- a/tests/test_variable_state/bad/def_no_state.catala_en +++ b/tests/test_variable_state/bad/def_no_state.catala_en @@ -26,5 +26,5 @@ Variable declaration: 5 │ output foo content integer │ ‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_variable_state/bad/double_same_state.catala_en b/tests/test_variable_state/bad/double_same_state.catala_en index 57f79d67..e83db650 100644 --- a/tests/test_variable_state/bad/double_same_state.catala_en +++ b/tests/test_variable_state/bad/double_same_state.catala_en @@ -27,5 +27,5 @@ Second instance of state "bar": 7 │ state bar │ ‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_variable_state/bad/no_cross_exceptions.catala_en b/tests/test_variable_state/bad/no_cross_exceptions.catala_en index 49f59781..9e14a3b3 100644 --- a/tests/test_variable_state/bad/no_cross_exceptions.catala_en +++ b/tests/test_variable_state/bad/no_cross_exceptions.catala_en @@ -23,5 +23,5 @@ $ catala Typecheck 14 │ exception thing definition foo state baz under condition true consequence equals 3 │ ‾‾‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_variable_state/bad/self_reference_first_state.catala_en b/tests/test_variable_state/bad/self_reference_first_state.catala_en index 12613210..db3f193b 100644 --- a/tests/test_variable_state/bad/self_reference_first_state.catala_en +++ b/tests/test_variable_state/bad/self_reference_first_state.catala_en @@ -21,5 +21,5 @@ $ catala Typecheck 10 │ definition foo state bar equals foo + 1 │ ‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_variable_state/bad/state_cycle.catala_en b/tests/test_variable_state/bad/state_cycle.catala_en index 9d491093..2b5e1133 100644 --- a/tests/test_variable_state/bad/state_cycle.catala_en +++ b/tests/test_variable_state/bad/state_cycle.catala_en @@ -51,5 +51,5 @@ foo@baz is used here in the definition of foofoo@bar: 17 │ definition foofoo state bar equals foo │ ‾‾‾ └─ Test -#return code 255# +#return code 123# ``` diff --git a/tests/test_variable_state/bad/unknown_state.catala_en b/tests/test_variable_state/bad/unknown_state.catala_en index f681a473..46eb4729 100644 --- a/tests/test_variable_state/bad/unknown_state.catala_en +++ b/tests/test_variable_state/bad/unknown_state.catala_en @@ -28,5 +28,5 @@ Variable declaration: 5 │ output foo content integer │ ‾‾‾ └─ Test -#return code 255# +#return code 123# ```