CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Move global options of Cli to their own module

Browse Source 
This resolves a dependency cycle that would forbid `Cli` from using the modue
`File`, which was annoying.
This commit is contained in:
Louis Gesbert 2024-03-15 14:23:30 +01:00
parent 77ba1b8b38
commit 4cec981f62
45 changed files with 370 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
build_system/clerk_driver.ml
View File

@ -87,7 +87,7 @@ module Cli = struct
catala_opts:string list ->
build_dir:File.t option ->
include_dirs:string list ->
color:Cli.when_enum ->
color:Global.when_enum ->
debug:bool ->
ninja_output:File.t option ->
'a) ->
@ -103,7 +103,7 @@ module Cli = struct
let color =
Arg.(
value
& opt ~vopt:Cli.Always Cli.when_opt Auto
& opt ~vopt:Global.Always Cli.when_opt Auto
& info ["color"]
~env:(Cmd.Env.info "CATALA_COLOR")
~doc:
@ -895,7 +895,7 @@ let ninja_init
~debug
~ninja_output :
extra:def Seq.t -> test_flags:string list -> (File.t -> 'a) -> 'a =
let _options = Catala_utils.Cli.enforce_globals ~debug ~color () in
let _options = Catala_utils.Global.enforce_options ~debug ~color () in
let chdir =
match chdir with None -> Lazy.force Poll.project_root | some -> some
in
@ -933,7 +933,7 @@ let ninja_cmdline ninja_flags nin_file targets =
:: "-f"
:: nin_file
:: (if ninja_flags = "" then [] else [ninja_flags])
@ (if Catala_utils.Cli.globals.debug then ["-v"] else [])
@ (if Catala_utils.Global.options.debug then ["-v"] else [])
@ targets)
open Cmdliner
@ -1074,7 +1074,7 @@ let main () =
| Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit content Error;
if Catala_utils.Cli.globals.debug then
if Catala_utils.Global.options.debug then
Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
| Sys_error msg ->

3
build_system/clerk_scan.ml
View File

@ -54,7 +54,8 @@ let test_command_args =
fun str ->
exec_opt re str |> Option.map (fun g -> String.trim (Re.Group.get g 1))
let catala_file (file : File.t) (lang : Catala_utils.Cli.backend_lang) : item =
let catala_file (file : File.t) (lang : Catala_utils.Global.backend_lang) : item
=
let module L = Surface.Lexer_common in
let rec parse lines n acc =
match Seq.uncons lines with

4
build_system/clerk_scan.mli
View File

@ -46,10 +46,10 @@ type item = {
(** Contains all the data extracted from a single Catala file. Lists are in
reverse file order. *)
val get_lang : File.t -> Cli.backend_lang option
val get_lang : File.t -> Global.backend_lang option
(** Guesses Catala dialect from file-name and global options *)
val catala_file : File.t -> Catala_utils.Cli.backend_lang -> item
val catala_file : File.t -> Global.backend_lang -> item
(** Scans a single Catala file into an item *)
val tree : File.t -> (File.t * File.t list * item list) Seq.t

116
compiler/catala_utils/cli.ml
View File

@ -15,16 +15,11 @@
License for the specific language governing permissions and limitations under
the License. *)
(* Types used by flags & options *)
open Global
type file = string
type raw_file = file
type backend_lang = En | Fr | Pl
type when_enum = Auto | Always | Never
type message_format_enum = Human | GNU
type input_src = FileName of file | Contents of string * file | Stdin of file
(* Manipulation of types used by flags & options *)
(** Associates a {!type: Cli.backend_lang} with its string represtation. *)
(** Associates a {!type: Global.backend_lang} with its string represtation. *)
let languages = ["en", En; "fr", Fr; "pl", Pl]
let language_code =
@ -34,68 +29,17 @@ let language_code =
let input_src_file = function FileName f | Contents (_, f) | Stdin f -> f
let message_format_opt = ["human", Human; "gnu", GNU]
type options = {
mutable input_src : input_src;
mutable language : backend_lang option;
mutable debug : bool;
mutable color : when_enum;
mutable message_format : message_format_enum;
mutable trace : bool;
mutable plugins_dirs : file list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(* 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_src = Stdin "-stdin-";
language = None;
debug = false;
color = Auto;
message_format = Human;
trace = false;
plugins_dirs = [];
disable_warnings = false;
max_prec_digits = 20;
path_rewrite = (fun _ -> assert false);
}
let enforce_globals
?input_src
?language
?debug
?color
?message_format
?trace
?plugins_dirs
?disable_warnings
?max_prec_digits
?path_rewrite
() =
Option.iter (fun x -> globals.input_src <- x) input_src;
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;
Option.iter (fun x -> globals.path_rewrite <- x) path_rewrite;
globals
open Cmdliner
(* Arg converters for our custom types *)
let when_opt = Arg.enum ["auto", Auto; "always", Always; "never", Never]
let raw_file =
Arg.conv ~docv:"FILE"
( (fun f -> Result.map raw_file (Arg.conv_parser Arg.string f)),
(fun ppf f -> Format.pp_print_string ppf (f :> string)) )
(* Some helpers for catala sources *)
let extensions = [".catala_fr", Fr; ".catala_en", En; ".catala_pl", Pl]
@ -105,7 +49,7 @@ let file_lang filename =
|> function
| Some lang -> lang
| None -> (
match globals.language with
match Global.options.language with
| Some lang -> lang
| None ->
Format.kasprintf failwith
@ -123,7 +67,7 @@ let exec_dir =
Filename.dirname Sys.executable_name
let reverse_path ?(from_dir = Sys.getcwd ()) ~to_dir f =
if Filename.is_relative from_dir then invalid_arg "File.with_reverse_path"
if Filename.is_relative from_dir then invalid_arg "Cli.reverse_path"
else if not (Filename.is_relative f) then f
else if not (Filename.is_relative to_dir) then Filename.concat from_dir f
else
@ -160,11 +104,11 @@ module Flags = struct
let converter =
conv ~docv:"FILE"
( (fun s ->
if s = "-" then Ok (Stdin "-stdin-")
else Result.map (fun f -> FileName f) (conv_parser non_dir_file s)),
if s = "-" then Ok (Stdin (Global.raw_file "-stdin-"))
else Result.map (fun f -> FileName (Global.raw_file f)) (conv_parser non_dir_file s)),
fun ppf -> function
| Stdin _ -> Format.pp_print_string ppf "-"
| FileName f -> conv_printer non_dir_file ppf f
| FileName f -> conv_printer non_dir_file ppf (f :> file)
| _ -> assert false )
in
required
@ -291,13 +235,16 @@ module Flags = struct
if debug then Printexc.record_backtrace true;
let path_rewrite =
match directory with
| None -> fun f -> f
| None -> fun (f: Global.raw_file) -> (f :> file)
| Some to_dir -> (
function "-" -> "-" | f -> reverse_path ~to_dir f)
fun (f: Global.raw_file) ->
match (f :> file) with
| "-" -> "-"
| f -> reverse_path ~to_dir f)
in
(* This sets some global refs for convenience, but most importantly
returns the options record. *)
enforce_globals ~language ~debug ~color ~message_format ~trace
Global.enforce_options ~language ~debug ~color ~message_format ~trace
~plugins_dirs ~disable_warnings ~max_prec_digits ~path_rewrite ()
in
Term.(
@ -316,25 +263,16 @@ module Flags = struct
let make input_src name directory options : options =
(* Set some global refs for convenience *)
let input_src =
match name with
| None -> input_src
| Some name -> (
match input_src with
| FileName f -> FileName f
| Contents (str, _) -> Contents (str, name)
| Stdin _ -> Stdin name)
in
let input_src =
let rename f =
match name with None -> f | Some n -> Global.raw_file n
in
match input_src with
| FileName f -> FileName (options.path_rewrite f)
| Contents (str, f) -> Contents (str, options.path_rewrite f)
| Stdin f -> Stdin (options.path_rewrite f)
| Contents (str, f) -> Contents (str, options.path_rewrite (rename f))
| Stdin f -> Stdin (options.path_rewrite (rename f))
in
let plugins_dirs = List.map options.path_rewrite options.plugins_dirs in
Option.iter Sys.chdir directory;
globals.input_src <- input_src;
globals.plugins_dirs <- plugins_dirs;
{ options with input_src; plugins_dirs }
Global.enforce_options ~input_src ()
in
Term.(const make $ input_src $ name_flag $ directory $ flags)
end
@ -343,7 +281,7 @@ module Flags = struct
let arg =
Arg.(
value
& opt_all (list ~sep:':' string) []
& opt_all (list ~sep:':' raw_file) []
& info ["I"; "include"] ~docv:"DIR"
~env:(Cmd.Env.info "CATALA_INCLUDE")
~doc:
@ -394,7 +332,7 @@ module Flags = struct
let output =
value
& opt (some string) None
& opt (some raw_file) None
& info ["output"; "o"] ~docv:"OUTPUT"
~env:(Cmd.Env.info "CATALA_OUT")
~doc:

74
compiler/catala_utils/cli.mli
View File

@ -15,33 +15,7 @@
License for the specific language governing permissions and limitations under
the License. *)
type file = string
(** File names ; equal to [File.t] but let's avoid cyclic dependencies *)
type raw_file
(** A file name that has not yet been resolved, [options.path_rewrite] must be
called on it *)
type backend_lang = En | Fr | Pl
(** The usual auto/always/never option argument *)
type when_enum = Auto | Always | Never
val when_opt : when_enum Cmdliner.Arg.conv
type message_format_enum =
| Human
| GNU (** Format of error and warning messages output by the compiler. *)
(** Sources for program input *)
type input_src =
| FileName of file (** A file path to read from disk *)
| Contents of string * file
(** A raw string containing the code, and the corresponding (fake)
filename *)
| Stdin of file
(** Read from stdin; the specified filename will be used for file lookups,
error reportings, etc. *)
open Global
val languages : (string * backend_lang) list
@ -49,10 +23,10 @@ val language_code : backend_lang -> string
(** Returns the lowercase two-letter language code *)
val file_lang : file -> backend_lang
(** Associates a file extension with its corresponding {!type: Cli.backend_lang}
(** Associates a file extension with its corresponding {!type: Global.backend_lang}
string representation. *)
val input_src_file : input_src -> file
val input_src_file : file input_src -> file
val reverse_path : ?from_dir:file -> to_dir:file -> file -> file
(** If [to_dir] is a path to a given directory and [f] a path to a file as seen
@ -60,48 +34,10 @@ val reverse_path : ?from_dir:file -> to_dir:file -> file -> file
leading to [f] from [to_dir]. The results attempts to be relative to
[to_dir]. *)
(** {2 Configuration globals} *)
type options = private {
mutable input_src : input_src;
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;
mutable path_rewrite : raw_file -> file;
}
(** 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_src:input_src ->
?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 ->
?path_rewrite:(file -> file) ->
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} *)
val when_opt: when_enum Cmdliner.Arg.conv
module Flags : sig
open Cmdliner

6
compiler/catala_utils/file.ml
View File

@ -16,6 +16,8 @@
type t = string
let format ppf t = Format.fprintf ppf "\"@{<cyan>%s@}\"" t
(** Run finaliser [f] unconditionally after running [k ()], propagating any
raised exception. *)
let finally f k =
@ -30,7 +32,7 @@ let finally f k =
let temp_file pfx sfx =
let f = Filename.temp_file pfx sfx in
if not Cli.globals.debug then
if not Global.options.debug then
at_exit (fun () -> try Sys.remove f with _ -> ());
f
@ -190,8 +192,6 @@ let equal a b =
let compare a b =
String.compare (String.lowercase_ascii a) (String.lowercase_ascii b)
let format ppf t = Format.fprintf ppf "\"@{<cyan>%s@}\"" t
module Set = Set.Make (struct
type nonrec t = t

4
compiler/catala_utils/file.mli
View File

@ -44,7 +44,7 @@ val with_formatter_of_opt_file : t option -> (Format.formatter -> 'a) -> 'a
{!with_formatter_of_file}), otherwise, uses the [Format.std_formatter]. *)
val get_out_channel :
source_file:Cli.input_src ->
source_file:t Global.input_src ->
output_file:t option ->
?ext:string ->
unit ->
@ -54,7 +54,7 @@ val get_out_channel :
equal to [Some "-"] returns a wrapper around [stdout]. *)
val get_formatter_of_out_channel :
source_file:Cli.input_src ->
source_file:t Global.input_src ->
output_file:t option ->
?ext:string ->
unit ->

84
compiler/catala_utils/global.ml Normal file
View File

@ -0,0 +1,84 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2024 Inria,
contributors: Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
type file = string
type raw_file = file
type backend_lang = En | Fr | Pl
type when_enum = Auto | Always | Never
type message_format_enum = Human | GNU
type 'file input_src =
| FileName of 'file
| Contents of string * 'file
| Stdin of 'file
(* ['file] is expected to be [file] or [raw_file] *)
type options = {
mutable input_src : file input_src;
mutable language : backend_lang option;
mutable debug : bool;
mutable color : when_enum;
mutable message_format : message_format_enum;
mutable trace : bool;
mutable plugins_dirs : file list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(* 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 options =
{
input_src = Stdin "-stdin-";
language = None;
debug = false;
color = Auto;
message_format = Human;
trace = false;
plugins_dirs = [];
disable_warnings = false;
max_prec_digits = 20;
path_rewrite = (fun _ -> assert false);
}
let enforce_options
?input_src
?language
?debug
?color
?message_format
?trace
?plugins_dirs
?disable_warnings
?max_prec_digits
?path_rewrite
() =
Option.iter (fun x -> options.input_src <- x) input_src;
Option.iter (fun x -> options.language <- x) language;
Option.iter (fun x -> options.debug <- x) debug;
Option.iter (fun x -> options.color <- x) color;
Option.iter (fun x -> options.message_format <- x) message_format;
Option.iter (fun x -> options.trace <- x) trace;
Option.iter (fun x -> options.plugins_dirs <- x) plugins_dirs;
Option.iter (fun x -> options.disable_warnings <- x) disable_warnings;
Option.iter (fun x -> options.max_prec_digits <- x) max_prec_digits;
Option.iter (fun x -> options.path_rewrite <- x) path_rewrite;
options
let raw_file f = f

85
compiler/catala_utils/global.mli Normal file
View File

@ -0,0 +1,85 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2024 Inria,
contributors: Louis Gesbert <louis.gesbert@inria.fr>
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 module contains definitions of global flags and types used throughout. They should be defined from the command-line and never modified afterwards. *)
type file = string
(** File names ; equal to [File.t] but let's avoid cyclic dependencies *)
type raw_file = private file
(** A file name that has not yet been resolved, [options.path_rewrite] must be
called on it *)
type backend_lang = En | Fr | Pl
(** 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. *)
(** Sources for program input *)
type 'file input_src =
| FileName of 'file (** A file path to read from disk *)
| Contents of string * 'file
(** A raw string containing the code, and the corresponding (fake)
filename *)
| Stdin of 'file
(** Read from stdin; the specified filename will be used for file lookups,
error reportings, etc. *)
(** {2 Configuration globals} *)
type options = private {
mutable input_src : file input_src;
mutable language : backend_lang option;
mutable debug : bool;
mutable color : when_enum;
mutable message_format : message_format_enum;
mutable trace : bool;
mutable plugins_dirs : file list;
mutable disable_warnings : bool;
mutable max_prec_digits : int;
mutable path_rewrite : raw_file -> file;
}
(** Global options, common to all subcommands (note: the fields are internally
mutable only for purposes of the [globals] toplevel value defined below) *)
val options : 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_options :
?input_src:file input_src ->
?language:backend_lang option ->
?debug:bool ->
?color:when_enum ->
?message_format:message_format_enum ->
?trace:bool ->
?plugins_dirs:file list ->
?disable_warnings:bool ->
?max_prec_digits:int ->
?path_rewrite:(raw_file -> file) ->
unit ->
options
(** Sets up the global options (side-effect); for specific use-cases only, this
should never be called from the compiler outside of the [Cli] module. Other proper uses include setting up the compiler library
when using it directly through a specific front-end. *)
val raw_file : string -> raw_file
(** Create a [raw_file], for use directly after parsing from the cmdline *)

14
compiler/catala_utils/message.ml
View File

@ -39,8 +39,8 @@ let () = ignore (unstyle_formatter Format.str_formatter)
below std_ppf / err_ppf *)
let has_color oc =
match Cli.globals.color with
| Cli.Never -> false
match Global.options.color with
| Global.Never -> false
| Always -> true
| Auto -> Unix.(isatty (descr_of_out_channel oc))
@ -78,8 +78,8 @@ type content_type = Error | Warning | Debug | Log | Result
let get_ppf = function
| Result -> Lazy.force std_ppf
| Debug when not Cli.globals.debug -> Lazy.force ignore_ppf
| Warning when Cli.globals.disable_warnings -> Lazy.force ignore_ppf
| Debug when not Global.options.debug -> Lazy.force ignore_ppf
| Warning when Global.options.disable_warnings -> Lazy.force ignore_ppf
| Error | Log | Debug | Warning -> Lazy.force err_ppf
(**{3 Markers}*)
@ -150,8 +150,8 @@ module Content = struct
[MainMessage (fun ppf -> Format.pp_print_string ppf s)]
let emit (content : t) (target : content_type) : unit =
match Cli.globals.message_format with
| Cli.Human ->
match Global.options.message_format with
| Global.Human ->
let ppf = get_ppf target in
Format.fprintf ppf "@[<hv>%t%t%a@]@." (pp_marker target)
(fun (ppf : Format.formatter) ->
@ -174,7 +174,7 @@ module Content = struct
Suggestions.format ppf suggestions_list)
ppf message_elements)
content
| Cli.GNU ->
| Global.GNU ->
(* The top message doesn't come with a position, which is not something
the GNU standard allows. So we look the position list and put the top
message everywhere there is not a more precise message. If we can't

2
compiler/catala_utils/pos.ml
View File

@ -130,7 +130,7 @@ let format_loc_text ppf (pos : t) =
let eline = get_end_line pos in
let ic, input_line_opt =
let from_contents =
match Cli.globals.input_src with
match Global.options.input_src with
| Contents (str, _) when str = filename -> Some str
| _ -> None
in

2
compiler/catala_web_interpreter.ml
View File

@ -19,7 +19,7 @@ let () =
Message.raise_error "Unrecognised input locale %S" language
in
let options =
Cli.enforce_globals
Global.enforce_options
~input_src:(Contents (contents, "-inline-"))
~language:(Some language) ~debug:false ~color:Never ~trace ()
in

2
compiler/dcalc/from_scopelang.ml
View File

@ -140,7 +140,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.globals.trace then
if Global.options.trace then
Expr.eappop ~op:(Log (l, markings)) ~tys:[TAny, Expr.pos e] ~args:[e] m
else e

2
compiler/desugared/ast.ml
View File

@ -238,7 +238,7 @@ type program = {
program_ctx : decl_ctx;
program_modules : modul ModuleName.Map.t;
program_root : modul;
program_lang : Cli.backend_lang;
program_lang : Global.backend_lang;
}
let rec locations_used e : LocationSet.t =

2
compiler/desugared/ast.mli
View File

@ -126,7 +126,7 @@ type program = {
program_modules : modul ModuleName.Map.t;
(** Contains all submodules of the program, in a flattened structure *)
program_root : modul;
program_lang : Cli.backend_lang;
program_lang : Global.backend_lang;
}
(** {1 Helpers} *)

50
compiler/driver.ml
View File

@ -18,7 +18,7 @@
open Catala_utils
open Shared_ast
(** Associates a file extension with its corresponding {!type: Cli.backend_lang}
(** Associates a file extension with its corresponding {!type: Global.backend_lang}
string representation. *)
let extensions = [".catala_fr", "fr"; ".catala_en", "en"; ".catala_pl", "pl"]
@ -37,7 +37,7 @@ let load_module_interfaces
if program.Surface.Ast.program_used_modules <> [] then
Message.emit_debug "Loading module interfaces...";
let includes =
List.map options.Cli.path_rewrite includes @ more_includes
List.map options.Global.path_rewrite includes @ more_includes
|> List.map File.Tree.build
|> List.fold_left File.Tree.union File.Tree.empty
in
@ -90,7 +90,7 @@ let load_module_interfaces
in
let intf =
Surface.Parser_driver.load_interface ?default_module_name
(Cli.FileName f)
(Global.FileName f)
in
let modname = ModuleName.fresh intf.intf_modname in
let seen = File.Map.add f None seen in
@ -137,7 +137,7 @@ module Passes = struct
let surface options : Surface.Ast.program =
debug_pass_name "surface";
let prg =
Surface.Parser_driver.parse_top_level_file options.Cli.input_src
Surface.Parser_driver.parse_top_level_file options.Global.input_src
in
Surface.Fill_positions.fill_pos_with_legislative_info prg
@ -169,8 +169,8 @@ module Passes = struct
let dcalc :
type ty.
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
typed:ty mark ->
@ -402,18 +402,18 @@ module Commands = struct
second_part )
let get_output ?ext options output_file =
let output_file = Option.map options.Cli.path_rewrite output_file in
File.get_out_channel ~source_file:options.Cli.input_src ~output_file ?ext ()
let output_file = Option.map options.Global.path_rewrite output_file in
File.get_out_channel ~source_file:options.Global.input_src ~output_file ?ext ()
let get_output_format ?ext options output_file =
let output_file = Option.map options.Cli.path_rewrite output_file in
File.get_formatter_of_out_channel ~source_file:options.Cli.input_src
let output_file = Option.map options.Global.path_rewrite output_file in
File.get_formatter_of_out_channel ~source_file:options.Global.input_src
~output_file ?ext ()
let makefile options output =
let prg = Passes.surface options in
let backend_extensions_list = [".tex"] in
let source_file = Cli.input_src_file options.Cli.input_src in
let source_file = Cli.input_src_file options.Global.input_src in
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);
@ -444,7 +444,7 @@ module Commands = struct
in
with_output
@@ fun fmt ->
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
let language = Cli.file_lang (Cli.input_src_file options.Global.input_src) in
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);
@ -480,7 +480,7 @@ module Commands = struct
in
with_output
@@ fun fmt ->
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
let language = Cli.file_lang (Cli.input_src_file options.Global.input_src) in
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);
@ -549,11 +549,11 @@ module Commands = struct
match ex_scope_opt with
| Some scope ->
let scope_uid = get_scope_uid prg.program_ctx scope in
Scopelang.Print.scope ~debug:options.Cli.debug prg.program_ctx fmt
Scopelang.Print.scope ~debug:options.Global.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;
Scopelang.Print.program ~debug:options.Global.debug fmt prg;
Format.pp_print_newline fmt ()
let scopelang_cmd =
@ -615,7 +615,7 @@ module Commands = struct
match ex_scope_opt with
| Some scope ->
let scope_uid = get_scope_uid prg.decl_ctx scope in
Print.scope ~debug:options.Cli.debug prg.decl_ctx fmt
Print.scope ~debug:options.Global.debug prg.decl_ctx fmt
( scope_uid,
BoundList.find
~f:(function
@ -629,7 +629,7 @@ module Commands = struct
(* 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 ())
(Print.expr ~debug:options.Global.debug ())
prg_dcalc_expr
let dcalc_cmd =
@ -694,11 +694,11 @@ module Commands = struct
in
Message.emit_result "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
let language = Cli.file_lang (Cli.input_src_file options.Cli.input_src) in
let language = Cli.file_lang (Cli.input_src_file options.Global.input_src) in
List.iter
(fun ((var, _), result) ->
Message.emit_result "@[<hov 2>%s@ =@ %a@]" var
(if options.Cli.debug then Print.expr ~debug:false ()
(if options.Global.debug then Print.expr ~debug:false ()
else Print.UserFacing.value language)
result)
results
@ -733,11 +733,11 @@ module Commands = struct
match ex_scope_opt with
| Some scope ->
let scope_uid = get_scope_uid prg.decl_ctx scope in
Print.scope ~debug:options.Cli.debug prg.decl_ctx fmt
Print.scope ~debug:options.Global.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;
Print.program ~debug:options.Global.debug fmt prg;
Format.pp_print_newline fmt ()
let lcalc_cmd =
@ -880,7 +880,7 @@ module Commands = struct
match ex_scope_opt with
| Some scope ->
let scope_uid = get_scope_uid prg.ctx.decl_ctx scope in
Scalc.Print.format_item ~debug:options.Cli.debug prg.ctx.decl_ctx fmt
Scalc.Print.format_item ~debug:options.Global.debug prg.ctx.decl_ctx fmt
(List.find
(function
| Scalc.Ast.SScope { scope_body_name; _ } ->
@ -1001,7 +1001,7 @@ module Commands = struct
$ Cli.Flags.check_invariants)
let depends options includes prefix extension extra_files =
let file = Cli.input_src_file options.Cli.input_src in
let file = Cli.input_src_file options.Global.input_src in
let more_includes = List.map Filename.dirname (file :: extra_files) in
let prg =
Surface.Ast.
@ -1151,7 +1151,7 @@ let main () =
Cmdliner.Cmd.eval_peek_opts ~argv Cli.Flags.Global.flags
~version_opt:true
with
| Some opts, _ -> opts.Cli.plugins_dirs
| Some opts, _ -> opts.Global.plugins_dirs
| None, _ -> []
in
Passes.debug_pass_name "init";
@ -1181,7 +1181,7 @@ let main () =
| exception Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit content Error;
if Cli.globals.debug then Printexc.print_raw_backtrace stderr bt;
if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
| exception Failure msg ->
let bt = Printexc.get_raw_backtrace () in

32
compiler/driver.mli
View File

@ -25,29 +25,29 @@ val main : unit -> unit
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
val surface : Global.options -> Surface.Ast.program
val desugared :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
Desugared.Ast.program * Desugared.Name_resolution.context
val scopelang :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
Shared_ast.untyped Scopelang.Ast.program
val dcalc :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
typed:'m Shared_ast.mark ->
'm Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list
val lcalc :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
typed:'m Shared_ast.mark ->
@ -57,8 +57,8 @@ module Passes : sig
Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
val scalc :
Cli.options ->
includes:Cli.raw_file list ->
Global.options ->
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
avoid_exceptions:bool ->
@ -75,15 +75,15 @@ module Commands : sig
val get_output :
?ext:string ->
Cli.options ->
Cli.raw_file option ->
Global.options ->
Global.raw_file option ->
string option * ((out_channel -> 'a) -> 'a)
(** bounded open of the expected output file *)
val get_output_format :
?ext:string ->
Cli.options ->
Cli.raw_file option ->
Global.options ->
Global.raw_file option ->
string option * ((Format.formatter -> 'a) -> 'a)
val get_scope_uid : Shared_ast.decl_ctx -> string -> Shared_ast.ScopeName.t
@ -110,6 +110,6 @@ module Plugin : sig
string ->
?man:Cmdliner.Manpage.block list ->
?doc:string ->
(Cli.options -> unit) Cmdliner.Term.t ->
(Global.options -> unit) Cmdliner.Term.t ->
unit
end

12
compiler/lcalc/to_ocaml.ml
View File

@ -392,11 +392,11 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
args = [arg];
_;
}
when Cli.globals.trace ->
when Global.options.trace ->
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
format_with_parens f format_with_parens arg
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1]; _ }
when Cli.globals.trace ->
when Global.options.trace ->
Format.fprintf fmt
"(log_variable_definition@ %a@ {io_input=%s;@ io_output=%b}@ (%a)@ %a)"
format_uid_list info
@ -408,7 +408,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
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1]; _ }
when Cli.globals.trace ->
when Global.options.trace ->
let pos = Expr.pos e in
Format.fprintf fmt
"(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
@ -416,7 +416,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(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_with_parens arg1
| EAppOp { op = Log (EndCall, info); args = [arg1]; _ } when Cli.globals.trace
| EAppOp { op = Log (EndCall, info); args = [arg1]; _ } when Global.options.trace
->
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info
format_with_parens arg1
@ -540,7 +540,7 @@ let format_ctx
Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
(None, struct_field) format_typ struct_field_type))
(StructField.Map.bindings struct_fields);
if Cli.globals.trace then
if Global.options.trace then
format_struct_embedding fmt (struct_name, struct_fields)
in
let format_enum_decl fmt (enum_name, enum_cons) =
@ -553,7 +553,7 @@ let format_ctx
Format.fprintf fmt "@[<hov 2>| %a@ of@ %a@]" format_enum_cons_name
enum_cons format_typ enum_cons_type))
(EnumConstructor.Map.bindings enum_cons);
if Cli.globals.trace then format_enum_embedding fmt (enum_name, enum_cons)
if Global.options.trace then format_enum_embedding fmt (enum_name, enum_cons)
in
let is_in_type_ordering s =
List.exists

4
compiler/literate/html.ml
View File

@ -23,7 +23,7 @@ open Literate_common
module A = Surface.Ast
module P = Printf
module R = Re.Pcre
module C = Cli
module C = Global
(** {1 Helpers} *)
@ -47,7 +47,7 @@ let remove_cb_last_lines : string -> string =
Prints an HTML complete page structure around the [wrapped] content. *)
let wrap_html
(source_files : string list)
(language : Cli.backend_lang)
(language : Global.backend_lang)
(fmt : Format.formatter)
(wrapped : Format.formatter -> unit) : unit =
let css_as_string =

4
compiler/literate/html.mli
View File

@ -23,7 +23,7 @@ open Catala_utils
val wrap_html :
string list ->
Cli.backend_lang ->
Global.backend_lang ->
Format.formatter ->
(Format.formatter -> unit) ->
unit
@ -34,7 +34,7 @@ val wrap_html :
(** {1 API} *)
val ast_to_html :
Cli.backend_lang ->
Global.backend_lang ->
print_only_law:bool ->
Format.formatter ->
Surface.Ast.program ->

2
compiler/literate/latex.ml
View File

@ -21,7 +21,7 @@
open Catala_utils
open Literate_common
module A = Surface.Ast
module C = Cli
module C = Global
(** {1 Helpers} *)

4
compiler/literate/latex.mli
View File

@ -23,7 +23,7 @@ open Catala_utils
val wrap_latex :
string list ->
Cli.backend_lang ->
Global.backend_lang ->
Format.formatter ->
(Format.formatter -> unit) ->
unit
@ -34,7 +34,7 @@ val wrap_latex :
(** {1 API} *)
val ast_to_latex :
Cli.backend_lang ->
Global.backend_lang ->
print_only_law:bool ->
Format.formatter ->
Surface.Ast.program ->

2
compiler/literate/literate_common.ml
View File

@ -15,7 +15,7 @@
the License. *)
open Catala_utils
open Cli
open Global
let literal_title = function
| En -> "Legislative text implementation"

28
compiler/literate/literate_common.mli
View File

@ -16,30 +16,30 @@
open Catala_utils
val literal_title : Cli.backend_lang -> string
val literal_title : Global.backend_lang -> string
(** Return the title traduction according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val literal_generated_by : Cli.backend_lang -> string
val literal_generated_by : Global.backend_lang -> string
(** Return the 'generated by' traduction according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val literal_source_files : Cli.backend_lang -> string
val literal_source_files : Global.backend_lang -> string
(** Return the 'source files weaved' traduction according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val literal_disclaimer_and_link : Cli.backend_lang -> string
val literal_disclaimer_and_link : Global.backend_lang -> string
(** Return the traduction of a paragraph giving a basic disclaimer about Catala
and a link to the website according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val literal_last_modification : Cli.backend_lang -> string
val literal_last_modification : Global.backend_lang -> string
(** Return the 'last modification' traduction according the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val get_language_extension : Cli.backend_lang -> string
val get_language_extension : Global.backend_lang -> string
(** Return the file extension corresponding to the given
{!type:Catala_utils.Cli.backend_lang}. *)
{!type:Catala_utils.Global.backend_lang}. *)
val run_pandoc : string -> [ `Html | `Latex ] -> string
(** Runs the [pandoc] on a string to pretty-print markdown features into the
@ -49,11 +49,11 @@ val check_exceeding_lines : ?max_len:int -> int -> string -> string -> unit
(** [check_exceeding_lines ~max_len start_line filename content] prints a
warning message for each lines of [content] exceeding [max_len] characters. *)
val call_pygmentize : ?lang:Cli.backend_lang -> string list -> string
val call_pygmentize : ?lang:Global.backend_lang -> string list -> string
(** Calls the [pygmentize] command with the given arguments, and returns the
results as a string. If [lang] is specified, the proper arguments for the
Catala lexer are already passed. *)
val with_pygmentize_lexer : Cli.backend_lang -> (string list -> 'a) -> 'a
val with_pygmentize_lexer : Global.backend_lang -> (string list -> 'a) -> 'a
(** Creates the required lexer file and returns the corresponding [pygmentize]
command-line arguments *)

6
compiler/literate/pygmentize.ml
View File

@ -20,9 +20,9 @@ open Literate_common
let lang_of_ext s =
if String.starts_with ~prefix:"catala_" s then
match s with
| "catala_en" -> Some Cli.En
| "catala_fr" -> Some Cli.Fr
| "catala_pl" -> Some Cli.Pl
| "catala_en" -> Some Global.En
| "catala_fr" -> Some Global.Fr
| "catala_pl" -> Some Global.Pl
| _ -> failwith "Unknown Catala dialect"
else None

2
compiler/plugin.mli
View File

@ -21,7 +21,7 @@ type t = unit Cmdliner.Cmd.t
val register :
Cmdliner.Cmd.info ->
(Catala_utils.Cli.options -> unit) Cmdliner.Term.t ->
(Catala_utils.Global.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.

4
compiler/plugins/api_web.ml
View File

@ -475,7 +475,7 @@ let run
closure_conversion
monomorphize_types
_options =
let options = Cli.enforce_globals ~trace:true () in
let options = Global.enforce_options ~trace:true () in
let prg, type_ordering =
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion ~typed:Expr.typed
@ -494,7 +494,7 @@ let run
String.capitalize_ascii
Filename.(
basename
(remove_extension (Cli.input_src_file options.Cli.input_src)))
(remove_extension (Cli.input_src_file options.Global.input_src)))
in
To_jsoo.format_program fmt (Some modname) prg type_ordering)

12
compiler/plugins/explain.ml
View File

@ -23,7 +23,7 @@ type flags = {
merge_level : int;
format : [ `Dot | `Convert of string ];
show : string option;
output : Cli.raw_file option;
output : Global.raw_file option;
base_src_url : string;
}
@ -264,7 +264,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
e
in
let e =
Interpreter.evaluate_operator eval op m Cli.En
Interpreter.evaluate_operator eval op m Global.En
(* Default language to English but this should not raise any error
messages so we don't care. *)
args
@ -989,7 +989,7 @@ let rec graph_cleanup options g base_vars =
let expr_to_dot_label0 :
type a.
Cli.backend_lang ->
Global.backend_lang ->
decl_ctx ->
Env.t ->
Format.formatter ->
@ -997,7 +997,7 @@ let expr_to_dot_label0 :
unit =
fun lang ctx env ->
let xlang ~en ?(pl = en) ~fr () =
match lang with Cli.Fr -> fr | Cli.En -> en | Cli.Pl -> pl
match lang with Global.Fr -> fr | Global.En -> en | Global.Pl -> pl
in
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
fun ppf e -> Print.UserFacing.value ~fallback lang ppf e
@ -1369,7 +1369,7 @@ let run includes optimize ex_scope explain_options global_options =
graph_cleanup explain_options g base_vars
else g
in
let lang = Cli.file_lang (Cli.input_src_file global_options.Cli.input_src) in
let lang = Cli.file_lang (Cli.input_src_file global_options.Global.input_src) in
let dot_content =
to_dot lang Format.str_formatter prg.decl_ctx env base_vars g
~base_src_url:explain_options.base_src_url;
@ -1386,7 +1386,7 @@ let run includes optimize ex_scope explain_options global_options =
fun f ->
f
(Option.value ~default:"-"
(Option.map Cli.globals.path_rewrite output))
(Option.map Global.options.path_rewrite output))
in
with_dot_file
@@ fun dotfile ->

2
compiler/plugins/lazy_interp.ml
View File

@ -112,7 +112,7 @@ let rec lazy_eval :
renv := env;
e
in
( Interpreter.evaluate_operator eval op m Cli.En
( Interpreter.evaluate_operator eval op m Global.En
(* Default language to English but this should not raise any error
messages so we don't care. *)
args,

8
compiler/scalc/to_python.ml
View File

@ -319,11 +319,11 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(op, Pos.no_pos) (format_expression ctx) arg2
| EApp
{ f = EAppOp { op = Log (BeginCall, info); args = [f] }, _; args = [arg] }
when Cli.globals.trace ->
when Global.options.trace ->
Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info
(format_expression ctx) f (format_expression ctx) arg
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1] }
when Cli.globals.trace ->
when Global.options.trace ->
Format.fprintf fmt
"log_variable_definition(%a,@ LogIO(input_io=InputIO.%s,@ \
output_io=%s),@ %a)"
@ -335,7 +335,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(if var_def_info.log_io_output then "True" else "False")
(format_expression ctx) arg1
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1] }
when Cli.globals.trace ->
when Global.options.trace ->
let pos = Mark.get e in
Format.fprintf fmt
"log_decision_taken(SourcePosition(filename=\"%s\",@ start_line=%d,@ \
@ -343,7 +343,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
(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
| EAppOp { op = Log (EndCall, info); args = [arg1] } when Cli.globals.trace ->
| EAppOp { op = Log (EndCall, info); args = [arg1] } when Global.options.trace ->
Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info
(format_expression ctx) arg1
| EAppOp { op = Log _; args = [arg1] } ->

2
compiler/scopelang/ast.ml
View File

@ -62,7 +62,7 @@ type 'm program = {
program_modules : nil scope_decl Mark.pos ScopeName.Map.t ModuleName.Map.t;
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_lang : Cli.backend_lang;
program_lang : Global.backend_lang;
}
let type_rule decl_ctx env = function

2
compiler/scopelang/ast.mli
View File

@ -58,7 +58,7 @@ type 'm program = {
the scope signatures needed to respect the call convention *)
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_lang : Cli.backend_lang;
program_lang : Global.backend_lang;
}
val type_program : 'm program -> typed program

2
compiler/scopelang/from_desugared.ml
View File

@ -37,7 +37,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.globals.trace then
if Global.options.trace then
Expr.eappop
~op:(Log (l, markings))
~tys:[TAny, Expr.pos e]

2
compiler/shared_ast/definitions.ml
View File

@ -699,6 +699,6 @@ type decl_ctx = {
type 'e program = {
decl_ctx : decl_ctx;
code_items : 'e code_item_list;
lang : Cli.backend_lang;
lang : Global.backend_lang;
module_name : ModuleName.t option;
}

8
compiler/shared_ast/interpreter.ml
View File

@ -35,13 +35,13 @@ let indent_str = ref ""
(** {1 Evaluation} *)
let print_log lang entry infos pos e =
if Cli.globals.trace then
if Global.options.trace then
match entry with
| VarDef _ ->
Message.emit_log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry
entry Print.uid_list infos
(Message.unformat (fun ppf ->
(if Cli.globals.debug then Print.expr ~debug:true ()
(if Global.options.debug then Print.expr ~debug:true ()
else Print.UserFacing.expr lang)
ppf e))
| PosRecordIfTrueBool -> (
@ -609,7 +609,7 @@ and val_to_runtime :
let rec evaluate_expr :
type d e.
decl_ctx ->
Cli.backend_lang ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
@ -817,7 +817,7 @@ let rec evaluate_expr :
and partially_evaluate_expr_for_assertion_failure_message :
type d e.
decl_ctx ->
Cli.backend_lang ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->

4
compiler/shared_ast/interpreter.mli
View File

@ -26,7 +26,7 @@ val evaluate_operator :
((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
'a operator ->
'm mark ->
Cli.backend_lang ->
Global.backend_lang ->
('a, 'm) gexpr list ->
('a, 'm) gexpr
(** Evaluates the result of applying the given operator to the given arguments,
@ -36,7 +36,7 @@ val evaluate_operator :
val evaluate_expr :
decl_ctx ->
Cli.backend_lang ->
Global.backend_lang ->
(('a, 'b, _) interpr_kind, 'm) gexpr ->
(('a, 'b, yes) interpr_kind, 'm) gexpr
(** Evaluates an expression according to the semantics of the default calculus. *)

2
compiler/shared_ast/optimizations.ml
View File

@ -184,7 +184,7 @@ let rec optimize_expr :
feed the expression to the interpreter that will print the beautiful
right error message *)
let (_ : _ gexpr) =
Interpreter.evaluate_expr ctx.decl_ctx Cli.En
Interpreter.evaluate_expr ctx.decl_ctx Global.En
(* Default language to English, no errors should be raised normally
so we don't care *)
e

36
compiler/shared_ast/print.ml
View File

@ -180,7 +180,7 @@ 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.globals.max_prec_digits i)
(Runtime.decimal_to_string ~max_prec_digits:Global.options.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)
@ -771,7 +771,7 @@ end
module ExprDebug = ExprGen (ExprDebugParam)
let expr ?(debug = Cli.globals.debug) () ppf e =
let expr ?(debug = Global.options.debug) () ppf e =
if debug then ExprDebug.expr ppf e else ExprConcise.expr ppf e
let scope_let_kind ?debug:(_debug = true) _ctx fmt k =
@ -958,15 +958,15 @@ module UserFacing = struct
(* Refs:
https://en.wikipedia.org/wiki/Wikipedia:Manual_of_Style/Dates_and_numbers#Grouping_of_digits
https://fr.wikipedia.org/wiki/Wikip%C3%A9dia:Conventions_concernant_les_nombres#Pour_un_comptage_ou_une_mesure *)
let bigsep (lang : Cli.backend_lang) =
let bigsep (lang : Global.backend_lang) =
match lang with En -> ",", 3 | Fr -> " ", 3 | Pl -> ",", 3
let decsep (lang : Cli.backend_lang) =
let decsep (lang : Global.backend_lang) =
match lang with En -> "." | Fr -> "," | Pl -> "."
let unit (_lang : Cli.backend_lang) ppf () = Format.pp_print_string ppf "()"
let unit (_lang : Global.backend_lang) ppf () = Format.pp_print_string ppf "()"
let bool (lang : Cli.backend_lang) ppf b =
let bool (lang : Global.backend_lang) ppf b =
let s =
match lang, b with
| En, true -> "true"
@ -978,7 +978,7 @@ module UserFacing = struct
in
Format.pp_print_string ppf s
let integer (lang : Cli.backend_lang) ppf n =
let integer (lang : Global.backend_lang) ppf n =
let sep, nsep = bigsep lang in
let nsep = Z.pow (Z.of_int 10) nsep in
if Z.sign n < 0 then Format.pp_print_char ppf '-';
@ -991,7 +991,7 @@ module UserFacing = struct
in
aux (Z.abs n)
let money (lang : Cli.backend_lang) ppf n =
let money (lang : Global.backend_lang) ppf n =
let num = Z.abs n in
let units, cents = Z.div_rem num (Z.of_int 100) in
if Z.sign n < 0 then Format.pp_print_char ppf '-';
@ -1004,7 +1004,7 @@ module UserFacing = struct
| Fr -> Format.pp_print_string ppf " €"
| Pl -> Format.pp_print_string ppf " PLN"
let decimal (lang : Cli.backend_lang) ppf r =
let decimal (lang : Global.backend_lang) ppf r =
let den = Q.den r in
let num = Z.abs (Q.num r) in
let int_part, rem = Z.div_rem num den in
@ -1021,7 +1021,7 @@ module UserFacing = struct
| None ->
if Z.equal n Z.zero then None, false
else
let r = Cli.globals.max_prec_digits in
let r = Global.options.max_prec_digits in
Some (r - 1), r <= 1
| Some r -> Some (r - 1), r <= 1
in
@ -1037,19 +1037,19 @@ module UserFacing = struct
in
aux 0
(if Z.equal int_part Z.zero then None
else Some (Cli.globals.max_prec_digits - ndigits int_part))
else Some (Global.options.max_prec_digits - ndigits int_part))
rem
(* It would be nice to print ratios as % but that's impossible to guess.
Trying would lead to inconsistencies where some comparable numbers are in %
and some others not, adding confusion. *)
let date (lang : Cli.backend_lang) ppf d =
let date (lang : Global.backend_lang) ppf d =
let y, m, d = Dates_calc.Dates.date_to_ymd d in
match lang with
| En | Pl -> Format.fprintf ppf "%04d-%02d-%02d" y m d
| Fr -> Format.fprintf ppf "%02d/%02d/%04d" d m y
let duration (lang : Cli.backend_lang) ppf dr =
let duration (lang : Global.backend_lang) ppf dr =
let y, m, d = Dates_calc.Dates.period_to_ymds dr in
let rec filter0 = function
| (0, _) :: (_ :: _ as r) -> filter0 r
@ -1069,7 +1069,7 @@ module UserFacing = struct
ppf;
Format.pp_print_char ppf ']'
let lit_raw (lang : Cli.backend_lang) ppf lit : unit =
let lit_raw (lang : Global.backend_lang) ppf lit : unit =
match lit with
| LUnit -> unit lang ppf ()
| LBool b -> bool lang ppf b
@ -1079,20 +1079,20 @@ module UserFacing = struct
| LDate d -> date lang ppf d
| LDuration dr -> duration lang ppf dr
let lit_to_string (lang : Cli.backend_lang) lit =
let lit_to_string (lang : Global.backend_lang) lit =
let buf = Buffer.create 32 in
let ppf = Format.formatter_of_buffer buf in
lit_raw lang ppf lit;
Format.pp_print_flush ppf ();
Buffer.contents buf
let lit (lang : Cli.backend_lang) ppf lit : unit =
let lit (lang : Global.backend_lang) ppf lit : unit =
with_color (lit_raw lang) Ocolor_types.yellow ppf lit
let rec value :
type a.
?fallback:(Format.formatter -> (a, 't) gexpr -> unit) ->
Cli.backend_lang ->
Global.backend_lang ->
Format.formatter ->
(a, 't) gexpr ->
unit =
@ -1132,7 +1132,7 @@ module UserFacing = struct
fallback ppf e
let expr :
type a. Cli.backend_lang -> Format.formatter -> (a, 't) gexpr -> unit =
type a. Global.backend_lang -> Format.formatter -> (a, 't) gexpr -> unit =
fun lang ->
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
fun ppf e -> value ~fallback lang ppf e

22
compiler/shared_ast/print.mli
View File

@ -96,22 +96,22 @@ val program : ?debug:bool -> Format.formatter -> ('a, 'm) gexpr program -> unit
(** User-facing, localised printer *)
module UserFacing : sig
val unit : Cli.backend_lang -> Format.formatter -> Runtime.unit -> unit
val bool : Cli.backend_lang -> Format.formatter -> Runtime.bool -> unit
val integer : Cli.backend_lang -> Format.formatter -> Runtime.integer -> unit
val decimal : Cli.backend_lang -> Format.formatter -> Runtime.decimal -> unit
val money : Cli.backend_lang -> Format.formatter -> Runtime.money -> unit
val date : Cli.backend_lang -> Format.formatter -> Runtime.date -> unit
val unit : Global.backend_lang -> Format.formatter -> Runtime.unit -> unit
val bool : Global.backend_lang -> Format.formatter -> Runtime.bool -> unit
val integer : Global.backend_lang -> Format.formatter -> Runtime.integer -> unit
val decimal : Global.backend_lang -> Format.formatter -> Runtime.decimal -> unit
val money : Global.backend_lang -> Format.formatter -> Runtime.money -> unit
val date : Global.backend_lang -> Format.formatter -> Runtime.date -> unit
val duration :
Cli.backend_lang -> Format.formatter -> Runtime.duration -> unit
Global.backend_lang -> Format.formatter -> Runtime.duration -> unit
val lit : Cli.backend_lang -> Format.formatter -> lit -> unit
val lit_to_string : Cli.backend_lang -> lit -> string
val lit : Global.backend_lang -> Format.formatter -> lit -> unit
val lit_to_string : Global.backend_lang -> lit -> string
val value :
?fallback:(Format.formatter -> ('a, 't) gexpr -> unit) ->
Cli.backend_lang ->
Global.backend_lang ->
Format.formatter ->
('a, 't) gexpr ->
unit
@ -121,7 +121,7 @@ module UserFacing : sig
is called upon non-value expressions (by default, [Invalid_argument] is
raised) *)
val expr : Cli.backend_lang -> Format.formatter -> (_, _) gexpr -> unit
val expr : Global.backend_lang -> Format.formatter -> (_, _) gexpr -> unit
(** This combines the user-facing value printer and the generic expression
printer to handle all AST nodes *)
end

8
compiler/shared_ast/typing.ml
View File

@ -159,14 +159,14 @@ let rec format_typ
")" (format_typ ~colors) t2
| TArray t1 -> (
match Mark.remove (UnionFind.get (UnionFind.find t1)) with
| TAny _ when not Cli.globals.debug -> Format.pp_print_string fmt "list"
| TAny _ when not Global.options.debug -> Format.pp_print_string fmt "list"
| _ -> Format.fprintf fmt "@[list of@ %a@]" (format_typ ~colors) t1)
| TDefault t1 ->
Format.pp_print_as fmt 1 "⟨";
format_typ ~colors fmt t1;
Format.pp_print_as fmt 1 "⟩"
| TAny v ->
if Cli.globals.debug then Format.fprintf fmt "<a%d>" (Any.hash v)
if Global.options.debug then Format.fprintf fmt "<a%d>" (Any.hash v)
else Format.pp_print_string fmt "<any>"
| TClosureEnv -> Format.fprintf fmt "closure_env"
@ -234,7 +234,7 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
( (fun ppf ->
Format.fprintf ppf "@[<hv 2>@[<hov>%a@ %a@]:" Format.pp_print_text
"This expression has type" (format_typ ctx) t1;
if Cli.globals.debug then Format.fprintf ppf "@ %a@]" Expr.format e
if Global.options.debug then Format.fprintf ppf "@ %a@]" Expr.format e
else Format.pp_close_box ppf ()),
e_pos );
( (fun ppf ->
@ -248,7 +248,7 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
( (fun ppf ->
Format.fprintf ppf "@[<hv 2>@[<hov>%a:@]" Format.pp_print_text
"While typechecking the following expression";
if Cli.globals.debug then Format.fprintf ppf "@ %a@]" Expr.format e
if Global.options.debug then Format.fprintf ppf "@ %a@]" Expr.format e
else Format.pp_close_box ppf ()),
e_pos );
( (fun ppf ->

2
compiler/surface/ast.ml
View File

@ -333,7 +333,7 @@ and program = {
program_items : law_structure list;
program_source_files : (string[@opaque]) list;
program_used_modules : module_use list;
program_lang : Cli.backend_lang; [@opaque]
program_lang : Global.backend_lang; [@opaque]
}
and source_file = law_structure list

14
compiler/surface/parser_driver.ml
View File

@ -198,14 +198,14 @@ module Parser_En = ParserAux (Lexer_en)
module Parser_Fr = ParserAux (Lexer_fr)
module Parser_Pl = ParserAux (Lexer_pl)
let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function
let localised_parser : Global.backend_lang -> lexbuf -> Ast.source_file = function
| En -> Parser_En.commands_or_includes
| Fr -> Parser_Fr.commands_or_includes
| Pl -> Parser_Pl.commands_or_includes
(** Lightweight lexer for dependency *)
let lines (file : File.t) (language : Cli.backend_lang) =
let lines (file : File.t) (language : Global.backend_lang) =
let lex_line =
match language with
| En -> Lexer_en.lex_line
@ -387,12 +387,12 @@ let get_interface program =
let with_sedlex_source source_file f =
match source_file with
| Cli.FileName file -> with_sedlex_file file f
| Cli.Contents (str, file) ->
| Global.FileName file -> with_sedlex_file file f
| Global.Contents (str, file) ->
let lexbuf = Sedlexing.Utf8.from_string str in
Sedlexing.set_filename lexbuf file;
f lexbuf
| Cli.Stdin file ->
| Global.Stdin file ->
let lexbuf = Sedlexing.Utf8.from_channel stdin in
Sedlexing.set_filename lexbuf file;
f lexbuf
@ -400,7 +400,7 @@ let with_sedlex_source source_file f =
let check_modname program source_file =
match program.Ast.program_module_name, source_file with
| ( Some (mname, pos),
(Cli.FileName file | Cli.Contents (_, file) | Cli.Stdin file) )
(Global.FileName file | Global.Contents (_, file) | Global.Stdin file) )
when not File.(equal mname Filename.(remove_extension (basename file))) ->
Message.raise_spanned_error pos
"@[<hov>Module declared as@ @{<blue>%s@},@ which@ does@ not@ match@ the@ \
@ -437,7 +437,7 @@ let load_interface ?default_module_name source_file =
Ast.intf_submodules = used_modules;
}
let parse_top_level_file (source_file : Cli.input_src) : Ast.program =
let parse_top_level_file (source_file : File.t Global.input_src) : Ast.program =
let program = with_sedlex_source source_file parse_source in
check_modname program source_file;
{

6
compiler/surface/parser_driver.mli
View File

@ -20,17 +20,17 @@
open Catala_utils
val lines :
File.t -> Cli.backend_lang -> (string * Lexer_common.line_token) Seq.t
File.t -> Global.backend_lang -> (string * Lexer_common.line_token) Seq.t
(** Raw file parser that doesn't interpret any includes and returns the flat law
structure as is *)
val load_interface :
?default_module_name:string -> Cli.input_src -> Ast.interface
?default_module_name:string -> File.t Global.input_src -> Ast.interface
(** Reads only declarations in metadata in the supplied input file, and only
keeps type information. The list of submodules is initialised with names
only and empty contents. *)
val parse_top_level_file : Cli.input_src -> Ast.program
val parse_top_level_file : File.t Global.input_src -> Ast.program
(** Parses a catala file (handling file includes) and returns a program.
Interfaces of the used modules are returned empty, use [load_interface] to
fill them. *)

2
compiler/verification/z3backend.real.ml
View File

@ -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.globals.max_prec_digits
| TRat -> Arithmetic.Real.to_decimal_string e Global.options.max_prec_digits
(* TODO: Print the right money symbol according to language *)
| TMoney ->
let z3_str = Expr.to_string e in

2
runtimes/rescript/package.json
View File

@ -1,6 +1,6 @@
{
"name": "@catala-lang/rescript-catala",
"version": "0.8.1-b.0",
"version": "0.9.0",
"description": "ReScript wrapper for the Catala runtime",
"scripts": {
"clean": "rescript clean",