mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Move global options of Cli to their own module
This resolves a dependency cycle that would forbid `Cli` from using the modue `File`, which was annoying.
This commit is contained in:
parent
77ba1b8b38
commit
4cec981f62
@ -87,7 +87,7 @@ module Cli = struct
|
|||||||
catala_opts:string list ->
|
catala_opts:string list ->
|
||||||
build_dir:File.t option ->
|
build_dir:File.t option ->
|
||||||
include_dirs:string list ->
|
include_dirs:string list ->
|
||||||
color:Cli.when_enum ->
|
color:Global.when_enum ->
|
||||||
debug:bool ->
|
debug:bool ->
|
||||||
ninja_output:File.t option ->
|
ninja_output:File.t option ->
|
||||||
'a) ->
|
'a) ->
|
||||||
@ -103,7 +103,7 @@ module Cli = struct
|
|||||||
let color =
|
let color =
|
||||||
Arg.(
|
Arg.(
|
||||||
value
|
value
|
||||||
& opt ~vopt:Cli.Always Cli.when_opt Auto
|
& opt ~vopt:Global.Always Cli.when_opt Auto
|
||||||
& info ["color"]
|
& info ["color"]
|
||||||
~env:(Cmd.Env.info "CATALA_COLOR")
|
~env:(Cmd.Env.info "CATALA_COLOR")
|
||||||
~doc:
|
~doc:
|
||||||
@ -895,7 +895,7 @@ let ninja_init
|
|||||||
~debug
|
~debug
|
||||||
~ninja_output :
|
~ninja_output :
|
||||||
extra:def Seq.t -> test_flags:string list -> (File.t -> 'a) -> 'a =
|
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 =
|
let chdir =
|
||||||
match chdir with None -> Lazy.force Poll.project_root | some -> some
|
match chdir with None -> Lazy.force Poll.project_root | some -> some
|
||||||
in
|
in
|
||||||
@ -933,7 +933,7 @@ let ninja_cmdline ninja_flags nin_file targets =
|
|||||||
:: "-f"
|
:: "-f"
|
||||||
:: nin_file
|
:: nin_file
|
||||||
:: (if ninja_flags = "" then [] else [ninja_flags])
|
:: (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)
|
@ targets)
|
||||||
|
|
||||||
open Cmdliner
|
open Cmdliner
|
||||||
@ -1074,7 +1074,7 @@ let main () =
|
|||||||
| Message.CompilerError content ->
|
| Message.CompilerError content ->
|
||||||
let bt = Printexc.get_raw_backtrace () in
|
let bt = Printexc.get_raw_backtrace () in
|
||||||
Message.Content.emit content Error;
|
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;
|
Printexc.print_raw_backtrace stderr bt;
|
||||||
exit Cmd.Exit.some_error
|
exit Cmd.Exit.some_error
|
||||||
| Sys_error msg ->
|
| Sys_error msg ->
|
||||||
|
@ -54,7 +54,8 @@ let test_command_args =
|
|||||||
fun str ->
|
fun str ->
|
||||||
exec_opt re str |> Option.map (fun g -> String.trim (Re.Group.get g 1))
|
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 module L = Surface.Lexer_common in
|
||||||
let rec parse lines n acc =
|
let rec parse lines n acc =
|
||||||
match Seq.uncons lines with
|
match Seq.uncons lines with
|
||||||
|
@ -46,10 +46,10 @@ type item = {
|
|||||||
(** Contains all the data extracted from a single Catala file. Lists are in
|
(** Contains all the data extracted from a single Catala file. Lists are in
|
||||||
reverse file order. *)
|
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 *)
|
(** 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 *)
|
(** Scans a single Catala file into an item *)
|
||||||
|
|
||||||
val tree : File.t -> (File.t * File.t list * item list) Seq.t
|
val tree : File.t -> (File.t * File.t list * item list) Seq.t
|
||||||
|
@ -15,16 +15,11 @@
|
|||||||
License for the specific language governing permissions and limitations under
|
License for the specific language governing permissions and limitations under
|
||||||
the License. *)
|
the License. *)
|
||||||
|
|
||||||
(* Types used by flags & options *)
|
open Global
|
||||||
|
|
||||||
type file = string
|
(* Manipulation of types used by flags & options *)
|
||||||
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
|
|
||||||
|
|
||||||
(** 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 languages = ["en", En; "fr", Fr; "pl", Pl]
|
||||||
|
|
||||||
let language_code =
|
let language_code =
|
||||||
@ -34,68 +29,17 @@ let language_code =
|
|||||||
let input_src_file = function FileName f | Contents (_, f) | Stdin f -> f
|
let input_src_file = function FileName f | Contents (_, f) | Stdin f -> f
|
||||||
let message_format_opt = ["human", Human; "gnu", GNU]
|
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
|
open Cmdliner
|
||||||
|
|
||||||
(* Arg converters for our custom types *)
|
(* Arg converters for our custom types *)
|
||||||
|
|
||||||
let when_opt = Arg.enum ["auto", Auto; "always", Always; "never", Never]
|
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 *)
|
(* Some helpers for catala sources *)
|
||||||
|
|
||||||
let extensions = [".catala_fr", Fr; ".catala_en", En; ".catala_pl", Pl]
|
let extensions = [".catala_fr", Fr; ".catala_en", En; ".catala_pl", Pl]
|
||||||
@ -105,7 +49,7 @@ let file_lang filename =
|
|||||||
|> function
|
|> function
|
||||||
| Some lang -> lang
|
| Some lang -> lang
|
||||||
| None -> (
|
| None -> (
|
||||||
match globals.language with
|
match Global.options.language with
|
||||||
| Some lang -> lang
|
| Some lang -> lang
|
||||||
| None ->
|
| None ->
|
||||||
Format.kasprintf failwith
|
Format.kasprintf failwith
|
||||||
@ -123,7 +67,7 @@ let exec_dir =
|
|||||||
Filename.dirname Sys.executable_name
|
Filename.dirname Sys.executable_name
|
||||||
|
|
||||||
let reverse_path ?(from_dir = Sys.getcwd ()) ~to_dir f =
|
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 f) then f
|
||||||
else if not (Filename.is_relative to_dir) then Filename.concat from_dir f
|
else if not (Filename.is_relative to_dir) then Filename.concat from_dir f
|
||||||
else
|
else
|
||||||
@ -160,11 +104,11 @@ module Flags = struct
|
|||||||
let converter =
|
let converter =
|
||||||
conv ~docv:"FILE"
|
conv ~docv:"FILE"
|
||||||
( (fun s ->
|
( (fun s ->
|
||||||
if s = "-" then Ok (Stdin "-stdin-")
|
if s = "-" then Ok (Stdin (Global.raw_file "-stdin-"))
|
||||||
else Result.map (fun f -> FileName f) (conv_parser non_dir_file s)),
|
else Result.map (fun f -> FileName (Global.raw_file f)) (conv_parser non_dir_file s)),
|
||||||
fun ppf -> function
|
fun ppf -> function
|
||||||
| Stdin _ -> Format.pp_print_string ppf "-"
|
| 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 )
|
| _ -> assert false )
|
||||||
in
|
in
|
||||||
required
|
required
|
||||||
@ -291,13 +235,16 @@ module Flags = struct
|
|||||||
if debug then Printexc.record_backtrace true;
|
if debug then Printexc.record_backtrace true;
|
||||||
let path_rewrite =
|
let path_rewrite =
|
||||||
match directory with
|
match directory with
|
||||||
| None -> fun f -> f
|
| None -> fun (f: Global.raw_file) -> (f :> file)
|
||||||
| Some to_dir -> (
|
| 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
|
in
|
||||||
(* This sets some global refs for convenience, but most importantly
|
(* This sets some global refs for convenience, but most importantly
|
||||||
returns the options record. *)
|
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 ()
|
~plugins_dirs ~disable_warnings ~max_prec_digits ~path_rewrite ()
|
||||||
in
|
in
|
||||||
Term.(
|
Term.(
|
||||||
@ -316,25 +263,16 @@ module Flags = struct
|
|||||||
let make input_src name directory options : options =
|
let make input_src name directory options : options =
|
||||||
(* Set some global refs for convenience *)
|
(* Set some global refs for convenience *)
|
||||||
let input_src =
|
let input_src =
|
||||||
match name with
|
let rename f =
|
||||||
| None -> input_src
|
match name with None -> f | Some n -> Global.raw_file n
|
||||||
| Some name -> (
|
|
||||||
match input_src with
|
|
||||||
| FileName f -> FileName f
|
|
||||||
| Contents (str, _) -> Contents (str, name)
|
|
||||||
| Stdin _ -> Stdin name)
|
|
||||||
in
|
in
|
||||||
let input_src =
|
|
||||||
match input_src with
|
match input_src with
|
||||||
| FileName f -> FileName (options.path_rewrite f)
|
| FileName f -> FileName (options.path_rewrite f)
|
||||||
| Contents (str, f) -> Contents (str, options.path_rewrite f)
|
| Contents (str, f) -> Contents (str, options.path_rewrite (rename f))
|
||||||
| Stdin f -> Stdin (options.path_rewrite f)
|
| Stdin f -> Stdin (options.path_rewrite (rename f))
|
||||||
in
|
in
|
||||||
let plugins_dirs = List.map options.path_rewrite options.plugins_dirs in
|
|
||||||
Option.iter Sys.chdir directory;
|
Option.iter Sys.chdir directory;
|
||||||
globals.input_src <- input_src;
|
Global.enforce_options ~input_src ()
|
||||||
globals.plugins_dirs <- plugins_dirs;
|
|
||||||
{ options with input_src; plugins_dirs }
|
|
||||||
in
|
in
|
||||||
Term.(const make $ input_src $ name_flag $ directory $ flags)
|
Term.(const make $ input_src $ name_flag $ directory $ flags)
|
||||||
end
|
end
|
||||||
@ -343,7 +281,7 @@ module Flags = struct
|
|||||||
let arg =
|
let arg =
|
||||||
Arg.(
|
Arg.(
|
||||||
value
|
value
|
||||||
& opt_all (list ~sep:':' string) []
|
& opt_all (list ~sep:':' raw_file) []
|
||||||
& info ["I"; "include"] ~docv:"DIR"
|
& info ["I"; "include"] ~docv:"DIR"
|
||||||
~env:(Cmd.Env.info "CATALA_INCLUDE")
|
~env:(Cmd.Env.info "CATALA_INCLUDE")
|
||||||
~doc:
|
~doc:
|
||||||
@ -394,7 +332,7 @@ module Flags = struct
|
|||||||
|
|
||||||
let output =
|
let output =
|
||||||
value
|
value
|
||||||
& opt (some string) None
|
& opt (some raw_file) None
|
||||||
& info ["output"; "o"] ~docv:"OUTPUT"
|
& info ["output"; "o"] ~docv:"OUTPUT"
|
||||||
~env:(Cmd.Env.info "CATALA_OUT")
|
~env:(Cmd.Env.info "CATALA_OUT")
|
||||||
~doc:
|
~doc:
|
||||||
|
@ -15,33 +15,7 @@
|
|||||||
License for the specific language governing permissions and limitations under
|
License for the specific language governing permissions and limitations under
|
||||||
the License. *)
|
the License. *)
|
||||||
|
|
||||||
type file = string
|
open Global
|
||||||
(** 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. *)
|
|
||||||
|
|
||||||
val languages : (string * backend_lang) list
|
val languages : (string * backend_lang) list
|
||||||
|
|
||||||
@ -49,10 +23,10 @@ val language_code : backend_lang -> string
|
|||||||
(** Returns the lowercase two-letter language code *)
|
(** Returns the lowercase two-letter language code *)
|
||||||
|
|
||||||
val file_lang : file -> backend_lang
|
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. *)
|
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
|
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
|
(** 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
|
leading to [f] from [to_dir]. The results attempts to be relative to
|
||||||
[to_dir]. *)
|
[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} *)
|
(** {2 CLI flags and options} *)
|
||||||
|
|
||||||
|
val when_opt: when_enum Cmdliner.Arg.conv
|
||||||
|
|
||||||
module Flags : sig
|
module Flags : sig
|
||||||
open Cmdliner
|
open Cmdliner
|
||||||
|
|
||||||
|
@ -16,6 +16,8 @@
|
|||||||
|
|
||||||
type t = string
|
type t = string
|
||||||
|
|
||||||
|
let format ppf t = Format.fprintf ppf "\"@{<cyan>%s@}\"" t
|
||||||
|
|
||||||
(** Run finaliser [f] unconditionally after running [k ()], propagating any
|
(** Run finaliser [f] unconditionally after running [k ()], propagating any
|
||||||
raised exception. *)
|
raised exception. *)
|
||||||
let finally f k =
|
let finally f k =
|
||||||
@ -30,7 +32,7 @@ let finally f k =
|
|||||||
|
|
||||||
let temp_file pfx sfx =
|
let temp_file pfx sfx =
|
||||||
let f = Filename.temp_file pfx sfx in
|
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 _ -> ());
|
at_exit (fun () -> try Sys.remove f with _ -> ());
|
||||||
f
|
f
|
||||||
|
|
||||||
@ -190,8 +192,6 @@ let equal a b =
|
|||||||
let compare a b =
|
let compare a b =
|
||||||
String.compare (String.lowercase_ascii a) (String.lowercase_ascii 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
|
module Set = Set.Make (struct
|
||||||
type nonrec t = t
|
type nonrec t = t
|
||||||
|
|
||||||
|
@ -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]. *)
|
{!with_formatter_of_file}), otherwise, uses the [Format.std_formatter]. *)
|
||||||
|
|
||||||
val get_out_channel :
|
val get_out_channel :
|
||||||
source_file:Cli.input_src ->
|
source_file:t Global.input_src ->
|
||||||
output_file:t option ->
|
output_file:t option ->
|
||||||
?ext:string ->
|
?ext:string ->
|
||||||
unit ->
|
unit ->
|
||||||
@ -54,7 +54,7 @@ val get_out_channel :
|
|||||||
equal to [Some "-"] returns a wrapper around [stdout]. *)
|
equal to [Some "-"] returns a wrapper around [stdout]. *)
|
||||||
|
|
||||||
val get_formatter_of_out_channel :
|
val get_formatter_of_out_channel :
|
||||||
source_file:Cli.input_src ->
|
source_file:t Global.input_src ->
|
||||||
output_file:t option ->
|
output_file:t option ->
|
||||||
?ext:string ->
|
?ext:string ->
|
||||||
unit ->
|
unit ->
|
||||||
|
84
compiler/catala_utils/global.ml
Normal file
84
compiler/catala_utils/global.ml
Normal 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
85
compiler/catala_utils/global.mli
Normal 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 *)
|
@ -39,8 +39,8 @@ let () = ignore (unstyle_formatter Format.str_formatter)
|
|||||||
below std_ppf / err_ppf *)
|
below std_ppf / err_ppf *)
|
||||||
|
|
||||||
let has_color oc =
|
let has_color oc =
|
||||||
match Cli.globals.color with
|
match Global.options.color with
|
||||||
| Cli.Never -> false
|
| Global.Never -> false
|
||||||
| Always -> true
|
| Always -> true
|
||||||
| Auto -> Unix.(isatty (descr_of_out_channel oc))
|
| Auto -> Unix.(isatty (descr_of_out_channel oc))
|
||||||
|
|
||||||
@ -78,8 +78,8 @@ type content_type = Error | Warning | Debug | Log | Result
|
|||||||
|
|
||||||
let get_ppf = function
|
let get_ppf = function
|
||||||
| Result -> Lazy.force std_ppf
|
| Result -> Lazy.force std_ppf
|
||||||
| Debug when not Cli.globals.debug -> Lazy.force ignore_ppf
|
| Debug when not Global.options.debug -> Lazy.force ignore_ppf
|
||||||
| Warning when Cli.globals.disable_warnings -> Lazy.force ignore_ppf
|
| Warning when Global.options.disable_warnings -> Lazy.force ignore_ppf
|
||||||
| Error | Log | Debug | Warning -> Lazy.force err_ppf
|
| Error | Log | Debug | Warning -> Lazy.force err_ppf
|
||||||
|
|
||||||
(**{3 Markers}*)
|
(**{3 Markers}*)
|
||||||
@ -150,8 +150,8 @@ module Content = struct
|
|||||||
[MainMessage (fun ppf -> Format.pp_print_string ppf s)]
|
[MainMessage (fun ppf -> Format.pp_print_string ppf s)]
|
||||||
|
|
||||||
let emit (content : t) (target : content_type) : unit =
|
let emit (content : t) (target : content_type) : unit =
|
||||||
match Cli.globals.message_format with
|
match Global.options.message_format with
|
||||||
| Cli.Human ->
|
| Global.Human ->
|
||||||
let ppf = get_ppf target in
|
let ppf = get_ppf target in
|
||||||
Format.fprintf ppf "@[<hv>%t%t%a@]@." (pp_marker target)
|
Format.fprintf ppf "@[<hv>%t%t%a@]@." (pp_marker target)
|
||||||
(fun (ppf : Format.formatter) ->
|
(fun (ppf : Format.formatter) ->
|
||||||
@ -174,7 +174,7 @@ module Content = struct
|
|||||||
Suggestions.format ppf suggestions_list)
|
Suggestions.format ppf suggestions_list)
|
||||||
ppf message_elements)
|
ppf message_elements)
|
||||||
content
|
content
|
||||||
| Cli.GNU ->
|
| Global.GNU ->
|
||||||
(* The top message doesn't come with a position, which is not something
|
(* 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
|
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
|
message everywhere there is not a more precise message. If we can't
|
||||||
|
@ -130,7 +130,7 @@ let format_loc_text ppf (pos : t) =
|
|||||||
let eline = get_end_line pos in
|
let eline = get_end_line pos in
|
||||||
let ic, input_line_opt =
|
let ic, input_line_opt =
|
||||||
let from_contents =
|
let from_contents =
|
||||||
match Cli.globals.input_src with
|
match Global.options.input_src with
|
||||||
| Contents (str, _) when str = filename -> Some str
|
| Contents (str, _) when str = filename -> Some str
|
||||||
| _ -> None
|
| _ -> None
|
||||||
in
|
in
|
||||||
|
@ -19,7 +19,7 @@ let () =
|
|||||||
Message.raise_error "Unrecognised input locale %S" language
|
Message.raise_error "Unrecognised input locale %S" language
|
||||||
in
|
in
|
||||||
let options =
|
let options =
|
||||||
Cli.enforce_globals
|
Global.enforce_options
|
||||||
~input_src:(Contents (contents, "-inline-"))
|
~input_src:(Contents (contents, "-inline-"))
|
||||||
~language:(Some language) ~debug:false ~color:Never ~trace ()
|
~language:(Some language) ~debug:false ~color:Never ~trace ()
|
||||||
in
|
in
|
||||||
|
@ -140,7 +140,7 @@ let tag_with_log_entry
|
|||||||
(markings : Uid.MarkedString.info list) : 'm Ast.expr boxed =
|
(markings : Uid.MarkedString.info list) : 'm Ast.expr boxed =
|
||||||
let m = mark_tany (Mark.get e) (Expr.pos e) in
|
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
|
Expr.eappop ~op:(Log (l, markings)) ~tys:[TAny, Expr.pos e] ~args:[e] m
|
||||||
else e
|
else e
|
||||||
|
|
||||||
|
@ -238,7 +238,7 @@ type program = {
|
|||||||
program_ctx : decl_ctx;
|
program_ctx : decl_ctx;
|
||||||
program_modules : modul ModuleName.Map.t;
|
program_modules : modul ModuleName.Map.t;
|
||||||
program_root : modul;
|
program_root : modul;
|
||||||
program_lang : Cli.backend_lang;
|
program_lang : Global.backend_lang;
|
||||||
}
|
}
|
||||||
|
|
||||||
let rec locations_used e : LocationSet.t =
|
let rec locations_used e : LocationSet.t =
|
||||||
|
@ -126,7 +126,7 @@ type program = {
|
|||||||
program_modules : modul ModuleName.Map.t;
|
program_modules : modul ModuleName.Map.t;
|
||||||
(** Contains all submodules of the program, in a flattened structure *)
|
(** Contains all submodules of the program, in a flattened structure *)
|
||||||
program_root : modul;
|
program_root : modul;
|
||||||
program_lang : Cli.backend_lang;
|
program_lang : Global.backend_lang;
|
||||||
}
|
}
|
||||||
|
|
||||||
(** {1 Helpers} *)
|
(** {1 Helpers} *)
|
||||||
|
@ -18,7 +18,7 @@
|
|||||||
open Catala_utils
|
open Catala_utils
|
||||||
open Shared_ast
|
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. *)
|
string representation. *)
|
||||||
let extensions = [".catala_fr", "fr"; ".catala_en", "en"; ".catala_pl", "pl"]
|
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
|
if program.Surface.Ast.program_used_modules <> [] then
|
||||||
Message.emit_debug "Loading module interfaces...";
|
Message.emit_debug "Loading module interfaces...";
|
||||||
let includes =
|
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.map File.Tree.build
|
||||||
|> List.fold_left File.Tree.union File.Tree.empty
|
|> List.fold_left File.Tree.union File.Tree.empty
|
||||||
in
|
in
|
||||||
@ -90,7 +90,7 @@ let load_module_interfaces
|
|||||||
in
|
in
|
||||||
let intf =
|
let intf =
|
||||||
Surface.Parser_driver.load_interface ?default_module_name
|
Surface.Parser_driver.load_interface ?default_module_name
|
||||||
(Cli.FileName f)
|
(Global.FileName f)
|
||||||
in
|
in
|
||||||
let modname = ModuleName.fresh intf.intf_modname in
|
let modname = ModuleName.fresh intf.intf_modname in
|
||||||
let seen = File.Map.add f None seen in
|
let seen = File.Map.add f None seen in
|
||||||
@ -137,7 +137,7 @@ module Passes = struct
|
|||||||
let surface options : Surface.Ast.program =
|
let surface options : Surface.Ast.program =
|
||||||
debug_pass_name "surface";
|
debug_pass_name "surface";
|
||||||
let prg =
|
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
|
in
|
||||||
Surface.Fill_positions.fill_pos_with_legislative_info prg
|
Surface.Fill_positions.fill_pos_with_legislative_info prg
|
||||||
|
|
||||||
@ -169,8 +169,8 @@ module Passes = struct
|
|||||||
|
|
||||||
let dcalc :
|
let dcalc :
|
||||||
type ty.
|
type ty.
|
||||||
Cli.options ->
|
Global.options ->
|
||||||
includes:Cli.raw_file list ->
|
includes:Global.raw_file list ->
|
||||||
optimize:bool ->
|
optimize:bool ->
|
||||||
check_invariants:bool ->
|
check_invariants:bool ->
|
||||||
typed:ty mark ->
|
typed:ty mark ->
|
||||||
@ -402,18 +402,18 @@ module Commands = struct
|
|||||||
second_part )
|
second_part )
|
||||||
|
|
||||||
let get_output ?ext options output_file =
|
let get_output ?ext options output_file =
|
||||||
let output_file = Option.map options.Cli.path_rewrite output_file in
|
let output_file = Option.map options.Global.path_rewrite output_file in
|
||||||
File.get_out_channel ~source_file:options.Cli.input_src ~output_file ?ext ()
|
File.get_out_channel ~source_file:options.Global.input_src ~output_file ?ext ()
|
||||||
|
|
||||||
let get_output_format ?ext options output_file =
|
let get_output_format ?ext options output_file =
|
||||||
let output_file = Option.map options.Cli.path_rewrite output_file in
|
let output_file = Option.map options.Global.path_rewrite output_file in
|
||||||
File.get_formatter_of_out_channel ~source_file:options.Cli.input_src
|
File.get_formatter_of_out_channel ~source_file:options.Global.input_src
|
||||||
~output_file ?ext ()
|
~output_file ?ext ()
|
||||||
|
|
||||||
let makefile options output =
|
let makefile options output =
|
||||||
let prg = Passes.surface options in
|
let prg = Passes.surface options in
|
||||||
let backend_extensions_list = [".tex"] 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
|
let output_file, with_output = get_output options ~ext:".d" output in
|
||||||
Message.emit_debug "Writing list of dependencies to %s..."
|
Message.emit_debug "Writing list of dependencies to %s..."
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
@ -444,7 +444,7 @@ module Commands = struct
|
|||||||
in
|
in
|
||||||
with_output
|
with_output
|
||||||
@@ fun fmt ->
|
@@ 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
|
let weave_output = Literate.Html.ast_to_html language ~print_only_law in
|
||||||
Message.emit_debug "Writing to %s"
|
Message.emit_debug "Writing to %s"
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
@ -480,7 +480,7 @@ module Commands = struct
|
|||||||
in
|
in
|
||||||
with_output
|
with_output
|
||||||
@@ fun fmt ->
|
@@ 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
|
let weave_output = Literate.Latex.ast_to_latex language ~print_only_law in
|
||||||
Message.emit_debug "Writing to %s"
|
Message.emit_debug "Writing to %s"
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
@ -549,11 +549,11 @@ module Commands = struct
|
|||||||
match ex_scope_opt with
|
match ex_scope_opt with
|
||||||
| Some scope ->
|
| Some scope ->
|
||||||
let scope_uid = get_scope_uid prg.program_ctx scope in
|
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);
|
(scope_uid, ScopeName.Map.find scope_uid prg.program_scopes);
|
||||||
Format.pp_print_newline fmt ()
|
Format.pp_print_newline fmt ()
|
||||||
| None ->
|
| None ->
|
||||||
Scopelang.Print.program ~debug:options.Cli.debug fmt prg;
|
Scopelang.Print.program ~debug:options.Global.debug fmt prg;
|
||||||
Format.pp_print_newline fmt ()
|
Format.pp_print_newline fmt ()
|
||||||
|
|
||||||
let scopelang_cmd =
|
let scopelang_cmd =
|
||||||
@ -615,7 +615,7 @@ module Commands = struct
|
|||||||
match ex_scope_opt with
|
match ex_scope_opt with
|
||||||
| Some scope ->
|
| Some scope ->
|
||||||
let scope_uid = get_scope_uid prg.decl_ctx scope in
|
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,
|
( scope_uid,
|
||||||
BoundList.find
|
BoundList.find
|
||||||
~f:(function
|
~f:(function
|
||||||
@ -629,7 +629,7 @@ module Commands = struct
|
|||||||
(* TODO: ??? *)
|
(* TODO: ??? *)
|
||||||
let prg_dcalc_expr = Expr.unbox (Program.to_expr prg scope_uid) in
|
let prg_dcalc_expr = Expr.unbox (Program.to_expr prg scope_uid) in
|
||||||
Format.fprintf fmt "%a\n"
|
Format.fprintf fmt "%a\n"
|
||||||
(Print.expr ~debug:options.Cli.debug ())
|
(Print.expr ~debug:options.Global.debug ())
|
||||||
prg_dcalc_expr
|
prg_dcalc_expr
|
||||||
|
|
||||||
let dcalc_cmd =
|
let dcalc_cmd =
|
||||||
@ -694,11 +694,11 @@ module Commands = struct
|
|||||||
in
|
in
|
||||||
Message.emit_result "Computation successful!%s"
|
Message.emit_result "Computation successful!%s"
|
||||||
(if List.length results > 0 then " Results:" else "");
|
(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
|
List.iter
|
||||||
(fun ((var, _), result) ->
|
(fun ((var, _), result) ->
|
||||||
Message.emit_result "@[<hov 2>%s@ =@ %a@]" var
|
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)
|
else Print.UserFacing.value language)
|
||||||
result)
|
result)
|
||||||
results
|
results
|
||||||
@ -733,11 +733,11 @@ module Commands = struct
|
|||||||
match ex_scope_opt with
|
match ex_scope_opt with
|
||||||
| Some scope ->
|
| Some scope ->
|
||||||
let scope_uid = get_scope_uid prg.decl_ctx scope in
|
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);
|
(scope_uid, Program.get_scope_body prg scope_uid);
|
||||||
Format.pp_print_newline fmt ()
|
Format.pp_print_newline fmt ()
|
||||||
| None ->
|
| None ->
|
||||||
Print.program ~debug:options.Cli.debug fmt prg;
|
Print.program ~debug:options.Global.debug fmt prg;
|
||||||
Format.pp_print_newline fmt ()
|
Format.pp_print_newline fmt ()
|
||||||
|
|
||||||
let lcalc_cmd =
|
let lcalc_cmd =
|
||||||
@ -880,7 +880,7 @@ module Commands = struct
|
|||||||
match ex_scope_opt with
|
match ex_scope_opt with
|
||||||
| Some scope ->
|
| Some scope ->
|
||||||
let scope_uid = get_scope_uid prg.ctx.decl_ctx scope in
|
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
|
(List.find
|
||||||
(function
|
(function
|
||||||
| Scalc.Ast.SScope { scope_body_name; _ } ->
|
| Scalc.Ast.SScope { scope_body_name; _ } ->
|
||||||
@ -1001,7 +1001,7 @@ module Commands = struct
|
|||||||
$ Cli.Flags.check_invariants)
|
$ Cli.Flags.check_invariants)
|
||||||
|
|
||||||
let depends options includes prefix extension extra_files =
|
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 more_includes = List.map Filename.dirname (file :: extra_files) in
|
||||||
let prg =
|
let prg =
|
||||||
Surface.Ast.
|
Surface.Ast.
|
||||||
@ -1151,7 +1151,7 @@ let main () =
|
|||||||
Cmdliner.Cmd.eval_peek_opts ~argv Cli.Flags.Global.flags
|
Cmdliner.Cmd.eval_peek_opts ~argv Cli.Flags.Global.flags
|
||||||
~version_opt:true
|
~version_opt:true
|
||||||
with
|
with
|
||||||
| Some opts, _ -> opts.Cli.plugins_dirs
|
| Some opts, _ -> opts.Global.plugins_dirs
|
||||||
| None, _ -> []
|
| None, _ -> []
|
||||||
in
|
in
|
||||||
Passes.debug_pass_name "init";
|
Passes.debug_pass_name "init";
|
||||||
@ -1181,7 +1181,7 @@ let main () =
|
|||||||
| exception Message.CompilerError content ->
|
| exception Message.CompilerError content ->
|
||||||
let bt = Printexc.get_raw_backtrace () in
|
let bt = Printexc.get_raw_backtrace () in
|
||||||
Message.Content.emit content Error;
|
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
|
exit Cmd.Exit.some_error
|
||||||
| exception Failure msg ->
|
| exception Failure msg ->
|
||||||
let bt = Printexc.get_raw_backtrace () in
|
let bt = Printexc.get_raw_backtrace () in
|
||||||
|
@ -25,29 +25,29 @@ val main : unit -> unit
|
|||||||
Each pass takes only its cli options, then calls upon its dependent passes
|
Each pass takes only its cli options, then calls upon its dependent passes
|
||||||
(forwarding their options as needed) *)
|
(forwarding their options as needed) *)
|
||||||
module Passes : sig
|
module Passes : sig
|
||||||
val surface : Cli.options -> Surface.Ast.program
|
val surface : Global.options -> Surface.Ast.program
|
||||||
|
|
||||||
val desugared :
|
val desugared :
|
||||||
Cli.options ->
|
Global.options ->
|
||||||
includes:Cli.raw_file list ->
|
includes:Global.raw_file list ->
|
||||||
Desugared.Ast.program * Desugared.Name_resolution.context
|
Desugared.Ast.program * Desugared.Name_resolution.context
|
||||||
|
|
||||||
val scopelang :
|
val scopelang :
|
||||||
Cli.options ->
|
Global.options ->
|
||||||
includes:Cli.raw_file list ->
|
includes:Global.raw_file list ->
|
||||||
Shared_ast.untyped Scopelang.Ast.program
|
Shared_ast.untyped Scopelang.Ast.program
|
||||||
|
|
||||||
val dcalc :
|
val dcalc :
|
||||||
Cli.options ->
|
Global.options ->
|
||||||
includes:Cli.raw_file list ->
|
includes:Global.raw_file list ->
|
||||||
optimize:bool ->
|
optimize:bool ->
|
||||||
check_invariants:bool ->
|
check_invariants:bool ->
|
||||||
typed:'m Shared_ast.mark ->
|
typed:'m Shared_ast.mark ->
|
||||||
'm Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
'm Dcalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
||||||
|
|
||||||
val lcalc :
|
val lcalc :
|
||||||
Cli.options ->
|
Global.options ->
|
||||||
includes:Cli.raw_file list ->
|
includes:Global.raw_file list ->
|
||||||
optimize:bool ->
|
optimize:bool ->
|
||||||
check_invariants:bool ->
|
check_invariants:bool ->
|
||||||
typed:'m Shared_ast.mark ->
|
typed:'m Shared_ast.mark ->
|
||||||
@ -57,8 +57,8 @@ module Passes : sig
|
|||||||
Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
||||||
|
|
||||||
val scalc :
|
val scalc :
|
||||||
Cli.options ->
|
Global.options ->
|
||||||
includes:Cli.raw_file list ->
|
includes:Global.raw_file list ->
|
||||||
optimize:bool ->
|
optimize:bool ->
|
||||||
check_invariants:bool ->
|
check_invariants:bool ->
|
||||||
avoid_exceptions:bool ->
|
avoid_exceptions:bool ->
|
||||||
@ -75,15 +75,15 @@ module Commands : sig
|
|||||||
|
|
||||||
val get_output :
|
val get_output :
|
||||||
?ext:string ->
|
?ext:string ->
|
||||||
Cli.options ->
|
Global.options ->
|
||||||
Cli.raw_file option ->
|
Global.raw_file option ->
|
||||||
string option * ((out_channel -> 'a) -> 'a)
|
string option * ((out_channel -> 'a) -> 'a)
|
||||||
(** bounded open of the expected output file *)
|
(** bounded open of the expected output file *)
|
||||||
|
|
||||||
val get_output_format :
|
val get_output_format :
|
||||||
?ext:string ->
|
?ext:string ->
|
||||||
Cli.options ->
|
Global.options ->
|
||||||
Cli.raw_file option ->
|
Global.raw_file option ->
|
||||||
string option * ((Format.formatter -> 'a) -> 'a)
|
string option * ((Format.formatter -> 'a) -> 'a)
|
||||||
|
|
||||||
val get_scope_uid : Shared_ast.decl_ctx -> string -> Shared_ast.ScopeName.t
|
val get_scope_uid : Shared_ast.decl_ctx -> string -> Shared_ast.ScopeName.t
|
||||||
@ -110,6 +110,6 @@ module Plugin : sig
|
|||||||
string ->
|
string ->
|
||||||
?man:Cmdliner.Manpage.block list ->
|
?man:Cmdliner.Manpage.block list ->
|
||||||
?doc:string ->
|
?doc:string ->
|
||||||
(Cli.options -> unit) Cmdliner.Term.t ->
|
(Global.options -> unit) Cmdliner.Term.t ->
|
||||||
unit
|
unit
|
||||||
end
|
end
|
||||||
|
@ -392,11 +392,11 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
|
|||||||
args = [arg];
|
args = [arg];
|
||||||
_;
|
_;
|
||||||
}
|
}
|
||||||
when Cli.globals.trace ->
|
when Global.options.trace ->
|
||||||
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
|
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
|
||||||
format_with_parens f format_with_parens arg
|
format_with_parens f format_with_parens arg
|
||||||
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1]; _ }
|
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1]; _ }
|
||||||
when Cli.globals.trace ->
|
when Global.options.trace ->
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"(log_variable_definition@ %a@ {io_input=%s;@ io_output=%b}@ (%a)@ %a)"
|
"(log_variable_definition@ %a@ {io_input=%s;@ io_output=%b}@ (%a)@ %a)"
|
||||||
format_uid_list info
|
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)
|
(var_def_info.log_typ, Pos.no_pos)
|
||||||
format_with_parens arg1
|
format_with_parens arg1
|
||||||
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1]; _ }
|
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1]; _ }
|
||||||
when Cli.globals.trace ->
|
when Global.options.trace ->
|
||||||
let pos = Expr.pos e in
|
let pos = Expr.pos e in
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
|
"(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_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_end_line pos) (Pos.get_end_column pos) format_string_list
|
||||||
(Pos.get_law_info pos) format_with_parens arg1
|
(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.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info
|
||||||
format_with_parens arg1
|
format_with_parens arg1
|
||||||
@ -540,7 +540,7 @@ let format_ctx
|
|||||||
Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
|
Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
|
||||||
(None, struct_field) format_typ struct_field_type))
|
(None, struct_field) format_typ struct_field_type))
|
||||||
(StructField.Map.bindings struct_fields);
|
(StructField.Map.bindings struct_fields);
|
||||||
if Cli.globals.trace then
|
if Global.options.trace then
|
||||||
format_struct_embedding fmt (struct_name, struct_fields)
|
format_struct_embedding fmt (struct_name, struct_fields)
|
||||||
in
|
in
|
||||||
let format_enum_decl fmt (enum_name, enum_cons) =
|
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
|
Format.fprintf fmt "@[<hov 2>| %a@ of@ %a@]" format_enum_cons_name
|
||||||
enum_cons format_typ enum_cons_type))
|
enum_cons format_typ enum_cons_type))
|
||||||
(EnumConstructor.Map.bindings enum_cons);
|
(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
|
in
|
||||||
let is_in_type_ordering s =
|
let is_in_type_ordering s =
|
||||||
List.exists
|
List.exists
|
||||||
|
@ -23,7 +23,7 @@ open Literate_common
|
|||||||
module A = Surface.Ast
|
module A = Surface.Ast
|
||||||
module P = Printf
|
module P = Printf
|
||||||
module R = Re.Pcre
|
module R = Re.Pcre
|
||||||
module C = Cli
|
module C = Global
|
||||||
|
|
||||||
(** {1 Helpers} *)
|
(** {1 Helpers} *)
|
||||||
|
|
||||||
@ -47,7 +47,7 @@ let remove_cb_last_lines : string -> string =
|
|||||||
Prints an HTML complete page structure around the [wrapped] content. *)
|
Prints an HTML complete page structure around the [wrapped] content. *)
|
||||||
let wrap_html
|
let wrap_html
|
||||||
(source_files : string list)
|
(source_files : string list)
|
||||||
(language : Cli.backend_lang)
|
(language : Global.backend_lang)
|
||||||
(fmt : Format.formatter)
|
(fmt : Format.formatter)
|
||||||
(wrapped : Format.formatter -> unit) : unit =
|
(wrapped : Format.formatter -> unit) : unit =
|
||||||
let css_as_string =
|
let css_as_string =
|
||||||
|
@ -23,7 +23,7 @@ open Catala_utils
|
|||||||
|
|
||||||
val wrap_html :
|
val wrap_html :
|
||||||
string list ->
|
string list ->
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
Format.formatter ->
|
Format.formatter ->
|
||||||
(Format.formatter -> unit) ->
|
(Format.formatter -> unit) ->
|
||||||
unit
|
unit
|
||||||
@ -34,7 +34,7 @@ val wrap_html :
|
|||||||
(** {1 API} *)
|
(** {1 API} *)
|
||||||
|
|
||||||
val ast_to_html :
|
val ast_to_html :
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
print_only_law:bool ->
|
print_only_law:bool ->
|
||||||
Format.formatter ->
|
Format.formatter ->
|
||||||
Surface.Ast.program ->
|
Surface.Ast.program ->
|
||||||
|
@ -21,7 +21,7 @@
|
|||||||
open Catala_utils
|
open Catala_utils
|
||||||
open Literate_common
|
open Literate_common
|
||||||
module A = Surface.Ast
|
module A = Surface.Ast
|
||||||
module C = Cli
|
module C = Global
|
||||||
|
|
||||||
(** {1 Helpers} *)
|
(** {1 Helpers} *)
|
||||||
|
|
||||||
|
@ -23,7 +23,7 @@ open Catala_utils
|
|||||||
|
|
||||||
val wrap_latex :
|
val wrap_latex :
|
||||||
string list ->
|
string list ->
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
Format.formatter ->
|
Format.formatter ->
|
||||||
(Format.formatter -> unit) ->
|
(Format.formatter -> unit) ->
|
||||||
unit
|
unit
|
||||||
@ -34,7 +34,7 @@ val wrap_latex :
|
|||||||
(** {1 API} *)
|
(** {1 API} *)
|
||||||
|
|
||||||
val ast_to_latex :
|
val ast_to_latex :
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
print_only_law:bool ->
|
print_only_law:bool ->
|
||||||
Format.formatter ->
|
Format.formatter ->
|
||||||
Surface.Ast.program ->
|
Surface.Ast.program ->
|
||||||
|
@ -15,7 +15,7 @@
|
|||||||
the License. *)
|
the License. *)
|
||||||
|
|
||||||
open Catala_utils
|
open Catala_utils
|
||||||
open Cli
|
open Global
|
||||||
|
|
||||||
let literal_title = function
|
let literal_title = function
|
||||||
| En -> "Legislative text implementation"
|
| En -> "Legislative text implementation"
|
||||||
|
@ -16,30 +16,30 @@
|
|||||||
|
|
||||||
open Catala_utils
|
open Catala_utils
|
||||||
|
|
||||||
val literal_title : Cli.backend_lang -> string
|
val literal_title : Global.backend_lang -> string
|
||||||
(** Return the title traduction according the given
|
(** 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
|
(** 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
|
(** 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
|
(** Return the traduction of a paragraph giving a basic disclaimer about Catala
|
||||||
and a link to the website according the given
|
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
|
(** 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
|
(** 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
|
val run_pandoc : string -> [ `Html | `Latex ] -> string
|
||||||
(** Runs the [pandoc] on a string to pretty-print markdown features into the
|
(** 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
|
(** [check_exceeding_lines ~max_len start_line filename content] prints a
|
||||||
warning message for each lines of [content] exceeding [max_len] characters. *)
|
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
|
(** Calls the [pygmentize] command with the given arguments, and returns the
|
||||||
results as a string. If [lang] is specified, the proper arguments for the
|
results as a string. If [lang] is specified, the proper arguments for the
|
||||||
Catala lexer are already passed. *)
|
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]
|
(** Creates the required lexer file and returns the corresponding [pygmentize]
|
||||||
command-line arguments *)
|
command-line arguments *)
|
||||||
|
@ -20,9 +20,9 @@ open Literate_common
|
|||||||
let lang_of_ext s =
|
let lang_of_ext s =
|
||||||
if String.starts_with ~prefix:"catala_" s then
|
if String.starts_with ~prefix:"catala_" s then
|
||||||
match s with
|
match s with
|
||||||
| "catala_en" -> Some Cli.En
|
| "catala_en" -> Some Global.En
|
||||||
| "catala_fr" -> Some Cli.Fr
|
| "catala_fr" -> Some Global.Fr
|
||||||
| "catala_pl" -> Some Cli.Pl
|
| "catala_pl" -> Some Global.Pl
|
||||||
| _ -> failwith "Unknown Catala dialect"
|
| _ -> failwith "Unknown Catala dialect"
|
||||||
else None
|
else None
|
||||||
|
|
||||||
|
@ -21,7 +21,7 @@ type t = unit Cmdliner.Cmd.t
|
|||||||
|
|
||||||
val register :
|
val register :
|
||||||
Cmdliner.Cmd.info ->
|
Cmdliner.Cmd.info ->
|
||||||
(Catala_utils.Cli.options -> unit) Cmdliner.Term.t ->
|
(Catala_utils.Global.options -> unit) Cmdliner.Term.t ->
|
||||||
unit
|
unit
|
||||||
(** Plugins are registerd as [Cmdliner] commands, which must take at least the
|
(** Plugins are registerd as [Cmdliner] commands, which must take at least the
|
||||||
default global options as arguments (this is required for e.g.
|
default global options as arguments (this is required for e.g.
|
||||||
|
@ -475,7 +475,7 @@ let run
|
|||||||
closure_conversion
|
closure_conversion
|
||||||
monomorphize_types
|
monomorphize_types
|
||||||
_options =
|
_options =
|
||||||
let options = Cli.enforce_globals ~trace:true () in
|
let options = Global.enforce_options ~trace:true () in
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
|
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~closure_conversion ~typed:Expr.typed
|
~avoid_exceptions ~closure_conversion ~typed:Expr.typed
|
||||||
@ -494,7 +494,7 @@ let run
|
|||||||
String.capitalize_ascii
|
String.capitalize_ascii
|
||||||
Filename.(
|
Filename.(
|
||||||
basename
|
basename
|
||||||
(remove_extension (Cli.input_src_file options.Cli.input_src)))
|
(remove_extension (Cli.input_src_file options.Global.input_src)))
|
||||||
in
|
in
|
||||||
To_jsoo.format_program fmt (Some modname) prg type_ordering)
|
To_jsoo.format_program fmt (Some modname) prg type_ordering)
|
||||||
|
|
||||||
|
@ -23,7 +23,7 @@ type flags = {
|
|||||||
merge_level : int;
|
merge_level : int;
|
||||||
format : [ `Dot | `Convert of string ];
|
format : [ `Dot | `Convert of string ];
|
||||||
show : string option;
|
show : string option;
|
||||||
output : Cli.raw_file option;
|
output : Global.raw_file option;
|
||||||
base_src_url : string;
|
base_src_url : string;
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -264,7 +264,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
|
|||||||
e
|
e
|
||||||
in
|
in
|
||||||
let e =
|
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
|
(* Default language to English but this should not raise any error
|
||||||
messages so we don't care. *)
|
messages so we don't care. *)
|
||||||
args
|
args
|
||||||
@ -989,7 +989,7 @@ let rec graph_cleanup options g base_vars =
|
|||||||
|
|
||||||
let expr_to_dot_label0 :
|
let expr_to_dot_label0 :
|
||||||
type a.
|
type a.
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Env.t ->
|
Env.t ->
|
||||||
Format.formatter ->
|
Format.formatter ->
|
||||||
@ -997,7 +997,7 @@ let expr_to_dot_label0 :
|
|||||||
unit =
|
unit =
|
||||||
fun lang ctx env ->
|
fun lang ctx env ->
|
||||||
let xlang ~en ?(pl = en) ~fr () =
|
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
|
in
|
||||||
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
|
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
|
||||||
fun ppf e -> Print.UserFacing.value ~fallback lang ppf e
|
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
|
graph_cleanup explain_options g base_vars
|
||||||
else g
|
else g
|
||||||
in
|
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 =
|
let dot_content =
|
||||||
to_dot lang Format.str_formatter prg.decl_ctx env base_vars g
|
to_dot lang Format.str_formatter prg.decl_ctx env base_vars g
|
||||||
~base_src_url:explain_options.base_src_url;
|
~base_src_url:explain_options.base_src_url;
|
||||||
@ -1386,7 +1386,7 @@ let run includes optimize ex_scope explain_options global_options =
|
|||||||
fun f ->
|
fun f ->
|
||||||
f
|
f
|
||||||
(Option.value ~default:"-"
|
(Option.value ~default:"-"
|
||||||
(Option.map Cli.globals.path_rewrite output))
|
(Option.map Global.options.path_rewrite output))
|
||||||
in
|
in
|
||||||
with_dot_file
|
with_dot_file
|
||||||
@@ fun dotfile ->
|
@@ fun dotfile ->
|
||||||
|
@ -112,7 +112,7 @@ let rec lazy_eval :
|
|||||||
renv := env;
|
renv := env;
|
||||||
e
|
e
|
||||||
in
|
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
|
(* Default language to English but this should not raise any error
|
||||||
messages so we don't care. *)
|
messages so we don't care. *)
|
||||||
args,
|
args,
|
||||||
|
@ -319,11 +319,11 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
|
|||||||
(op, Pos.no_pos) (format_expression ctx) arg2
|
(op, Pos.no_pos) (format_expression ctx) arg2
|
||||||
| EApp
|
| EApp
|
||||||
{ f = EAppOp { op = Log (BeginCall, info); args = [f] }, _; args = [arg] }
|
{ 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.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info
|
||||||
(format_expression ctx) f (format_expression ctx) arg
|
(format_expression ctx) f (format_expression ctx) arg
|
||||||
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1] }
|
| EAppOp { op = Log (VarDef var_def_info, info); args = [arg1] }
|
||||||
when Cli.globals.trace ->
|
when Global.options.trace ->
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"log_variable_definition(%a,@ LogIO(input_io=InputIO.%s,@ \
|
"log_variable_definition(%a,@ LogIO(input_io=InputIO.%s,@ \
|
||||||
output_io=%s),@ %a)"
|
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")
|
(if var_def_info.log_io_output then "True" else "False")
|
||||||
(format_expression ctx) arg1
|
(format_expression ctx) arg1
|
||||||
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1] }
|
| EAppOp { op = Log (PosRecordIfTrueBool, _); args = [arg1] }
|
||||||
when Cli.globals.trace ->
|
when Global.options.trace ->
|
||||||
let pos = Mark.get e in
|
let pos = Mark.get e in
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"log_decision_taken(SourcePosition(filename=\"%s\",@ start_line=%d,@ \
|
"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_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_end_line pos) (Pos.get_end_column pos) format_string_list
|
||||||
(Pos.get_law_info pos) (format_expression ctx) arg1
|
(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.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info
|
||||||
(format_expression ctx) arg1
|
(format_expression ctx) arg1
|
||||||
| EAppOp { op = Log _; args = [arg1] } ->
|
| EAppOp { op = Log _; args = [arg1] } ->
|
||||||
|
@ -62,7 +62,7 @@ type 'm program = {
|
|||||||
program_modules : nil scope_decl Mark.pos ScopeName.Map.t ModuleName.Map.t;
|
program_modules : nil scope_decl Mark.pos ScopeName.Map.t ModuleName.Map.t;
|
||||||
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
|
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
|
||||||
program_topdefs : ('m expr * typ) TopdefName.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
|
let type_rule decl_ctx env = function
|
||||||
|
@ -58,7 +58,7 @@ type 'm program = {
|
|||||||
the scope signatures needed to respect the call convention *)
|
the scope signatures needed to respect the call convention *)
|
||||||
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
|
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
|
||||||
program_topdefs : ('m expr * typ) TopdefName.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
|
val type_program : 'm program -> typed program
|
||||||
|
@ -37,7 +37,7 @@ let tag_with_log_entry
|
|||||||
(e : untyped Ast.expr boxed)
|
(e : untyped Ast.expr boxed)
|
||||||
(l : log_entry)
|
(l : log_entry)
|
||||||
(markings : Uid.MarkedString.info list) : untyped Ast.expr boxed =
|
(markings : Uid.MarkedString.info list) : untyped Ast.expr boxed =
|
||||||
if Cli.globals.trace then
|
if Global.options.trace then
|
||||||
Expr.eappop
|
Expr.eappop
|
||||||
~op:(Log (l, markings))
|
~op:(Log (l, markings))
|
||||||
~tys:[TAny, Expr.pos e]
|
~tys:[TAny, Expr.pos e]
|
||||||
|
@ -699,6 +699,6 @@ type decl_ctx = {
|
|||||||
type 'e program = {
|
type 'e program = {
|
||||||
decl_ctx : decl_ctx;
|
decl_ctx : decl_ctx;
|
||||||
code_items : 'e code_item_list;
|
code_items : 'e code_item_list;
|
||||||
lang : Cli.backend_lang;
|
lang : Global.backend_lang;
|
||||||
module_name : ModuleName.t option;
|
module_name : ModuleName.t option;
|
||||||
}
|
}
|
||||||
|
@ -35,13 +35,13 @@ let indent_str = ref ""
|
|||||||
|
|
||||||
(** {1 Evaluation} *)
|
(** {1 Evaluation} *)
|
||||||
let print_log lang entry infos pos e =
|
let print_log lang entry infos pos e =
|
||||||
if Cli.globals.trace then
|
if Global.options.trace then
|
||||||
match entry with
|
match entry with
|
||||||
| VarDef _ ->
|
| VarDef _ ->
|
||||||
Message.emit_log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry
|
Message.emit_log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry
|
||||||
entry Print.uid_list infos
|
entry Print.uid_list infos
|
||||||
(Message.unformat (fun ppf ->
|
(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)
|
else Print.UserFacing.expr lang)
|
||||||
ppf e))
|
ppf e))
|
||||||
| PosRecordIfTrueBool -> (
|
| PosRecordIfTrueBool -> (
|
||||||
@ -609,7 +609,7 @@ and val_to_runtime :
|
|||||||
let rec evaluate_expr :
|
let rec evaluate_expr :
|
||||||
type d e.
|
type d e.
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr ->
|
((d, e, yes) interpr_kind, 't) gexpr ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr =
|
((d, e, yes) interpr_kind, 't) gexpr =
|
||||||
fun ctx lang e ->
|
fun ctx lang e ->
|
||||||
@ -817,7 +817,7 @@ let rec evaluate_expr :
|
|||||||
and partially_evaluate_expr_for_assertion_failure_message :
|
and partially_evaluate_expr_for_assertion_failure_message :
|
||||||
type d e.
|
type d e.
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr ->
|
((d, e, yes) interpr_kind, 't) gexpr ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr =
|
((d, e, yes) interpr_kind, 't) gexpr =
|
||||||
fun ctx lang e ->
|
fun ctx lang e ->
|
||||||
|
@ -26,7 +26,7 @@ val evaluate_operator :
|
|||||||
((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
|
((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
|
||||||
'a operator ->
|
'a operator ->
|
||||||
'm mark ->
|
'm mark ->
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
('a, 'm) gexpr list ->
|
('a, 'm) gexpr list ->
|
||||||
('a, 'm) gexpr
|
('a, 'm) gexpr
|
||||||
(** Evaluates the result of applying the given operator to the given arguments,
|
(** Evaluates the result of applying the given operator to the given arguments,
|
||||||
@ -36,7 +36,7 @@ val evaluate_operator :
|
|||||||
|
|
||||||
val evaluate_expr :
|
val evaluate_expr :
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
(('a, 'b, _) interpr_kind, 'm) gexpr ->
|
(('a, 'b, _) interpr_kind, 'm) gexpr ->
|
||||||
(('a, 'b, yes) interpr_kind, 'm) gexpr
|
(('a, 'b, yes) interpr_kind, 'm) gexpr
|
||||||
(** Evaluates an expression according to the semantics of the default calculus. *)
|
(** Evaluates an expression according to the semantics of the default calculus. *)
|
||||||
|
@ -184,7 +184,7 @@ let rec optimize_expr :
|
|||||||
feed the expression to the interpreter that will print the beautiful
|
feed the expression to the interpreter that will print the beautiful
|
||||||
right error message *)
|
right error message *)
|
||||||
let (_ : _ gexpr) =
|
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
|
(* Default language to English, no errors should be raised normally
|
||||||
so we don't care *)
|
so we don't care *)
|
||||||
e
|
e
|
||||||
|
@ -180,7 +180,7 @@ let lit (fmt : Format.formatter) (l : lit) : unit =
|
|||||||
| LUnit -> lit_style fmt "()"
|
| LUnit -> lit_style fmt "()"
|
||||||
| LRat i ->
|
| LRat i ->
|
||||||
lit_style fmt
|
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 ->
|
| LMoney e ->
|
||||||
lit_style fmt (Format.asprintf "¤%s" (Runtime.money_to_string e))
|
lit_style fmt (Format.asprintf "¤%s" (Runtime.money_to_string e))
|
||||||
| LDate d -> lit_style fmt (Runtime.date_to_string d)
|
| LDate d -> lit_style fmt (Runtime.date_to_string d)
|
||||||
@ -771,7 +771,7 @@ end
|
|||||||
|
|
||||||
module ExprDebug = ExprGen (ExprDebugParam)
|
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
|
if debug then ExprDebug.expr ppf e else ExprConcise.expr ppf e
|
||||||
|
|
||||||
let scope_let_kind ?debug:(_debug = true) _ctx fmt k =
|
let scope_let_kind ?debug:(_debug = true) _ctx fmt k =
|
||||||
@ -958,15 +958,15 @@ module UserFacing = struct
|
|||||||
(* Refs:
|
(* Refs:
|
||||||
https://en.wikipedia.org/wiki/Wikipedia:Manual_of_Style/Dates_and_numbers#Grouping_of_digits
|
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 *)
|
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
|
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 -> "."
|
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 =
|
let s =
|
||||||
match lang, b with
|
match lang, b with
|
||||||
| En, true -> "true"
|
| En, true -> "true"
|
||||||
@ -978,7 +978,7 @@ module UserFacing = struct
|
|||||||
in
|
in
|
||||||
Format.pp_print_string ppf s
|
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 sep, nsep = bigsep lang in
|
||||||
let nsep = Z.pow (Z.of_int 10) nsep in
|
let nsep = Z.pow (Z.of_int 10) nsep in
|
||||||
if Z.sign n < 0 then Format.pp_print_char ppf '-';
|
if Z.sign n < 0 then Format.pp_print_char ppf '-';
|
||||||
@ -991,7 +991,7 @@ module UserFacing = struct
|
|||||||
in
|
in
|
||||||
aux (Z.abs n)
|
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 num = Z.abs n in
|
||||||
let units, cents = Z.div_rem num (Z.of_int 100) in
|
let units, cents = Z.div_rem num (Z.of_int 100) in
|
||||||
if Z.sign n < 0 then Format.pp_print_char ppf '-';
|
if Z.sign n < 0 then Format.pp_print_char ppf '-';
|
||||||
@ -1004,7 +1004,7 @@ module UserFacing = struct
|
|||||||
| Fr -> Format.pp_print_string ppf " €"
|
| Fr -> Format.pp_print_string ppf " €"
|
||||||
| Pl -> Format.pp_print_string ppf " PLN"
|
| 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 den = Q.den r in
|
||||||
let num = Z.abs (Q.num r) in
|
let num = Z.abs (Q.num r) in
|
||||||
let int_part, rem = Z.div_rem num den in
|
let int_part, rem = Z.div_rem num den in
|
||||||
@ -1021,7 +1021,7 @@ module UserFacing = struct
|
|||||||
| None ->
|
| None ->
|
||||||
if Z.equal n Z.zero then None, false
|
if Z.equal n Z.zero then None, false
|
||||||
else
|
else
|
||||||
let r = Cli.globals.max_prec_digits in
|
let r = Global.options.max_prec_digits in
|
||||||
Some (r - 1), r <= 1
|
Some (r - 1), r <= 1
|
||||||
| Some r -> Some (r - 1), r <= 1
|
| Some r -> Some (r - 1), r <= 1
|
||||||
in
|
in
|
||||||
@ -1037,19 +1037,19 @@ module UserFacing = struct
|
|||||||
in
|
in
|
||||||
aux 0
|
aux 0
|
||||||
(if Z.equal int_part Z.zero then None
|
(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
|
rem
|
||||||
(* It would be nice to print ratios as % but that's impossible to guess.
|
(* 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 %
|
Trying would lead to inconsistencies where some comparable numbers are in %
|
||||||
and some others not, adding confusion. *)
|
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
|
let y, m, d = Dates_calc.Dates.date_to_ymd d in
|
||||||
match lang with
|
match lang with
|
||||||
| En | Pl -> Format.fprintf ppf "%04d-%02d-%02d" y m d
|
| En | Pl -> Format.fprintf ppf "%04d-%02d-%02d" y m d
|
||||||
| Fr -> Format.fprintf ppf "%02d/%02d/%04d" d m y
|
| 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 y, m, d = Dates_calc.Dates.period_to_ymds dr in
|
||||||
let rec filter0 = function
|
let rec filter0 = function
|
||||||
| (0, _) :: (_ :: _ as r) -> filter0 r
|
| (0, _) :: (_ :: _ as r) -> filter0 r
|
||||||
@ -1069,7 +1069,7 @@ module UserFacing = struct
|
|||||||
ppf;
|
ppf;
|
||||||
Format.pp_print_char 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
|
match lit with
|
||||||
| LUnit -> unit lang ppf ()
|
| LUnit -> unit lang ppf ()
|
||||||
| LBool b -> bool lang ppf b
|
| LBool b -> bool lang ppf b
|
||||||
@ -1079,20 +1079,20 @@ module UserFacing = struct
|
|||||||
| LDate d -> date lang ppf d
|
| LDate d -> date lang ppf d
|
||||||
| LDuration dr -> duration lang ppf dr
|
| 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 buf = Buffer.create 32 in
|
||||||
let ppf = Format.formatter_of_buffer buf in
|
let ppf = Format.formatter_of_buffer buf in
|
||||||
lit_raw lang ppf lit;
|
lit_raw lang ppf lit;
|
||||||
Format.pp_print_flush ppf ();
|
Format.pp_print_flush ppf ();
|
||||||
Buffer.contents buf
|
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
|
with_color (lit_raw lang) Ocolor_types.yellow ppf lit
|
||||||
|
|
||||||
let rec value :
|
let rec value :
|
||||||
type a.
|
type a.
|
||||||
?fallback:(Format.formatter -> (a, 't) gexpr -> unit) ->
|
?fallback:(Format.formatter -> (a, 't) gexpr -> unit) ->
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
Format.formatter ->
|
Format.formatter ->
|
||||||
(a, 't) gexpr ->
|
(a, 't) gexpr ->
|
||||||
unit =
|
unit =
|
||||||
@ -1132,7 +1132,7 @@ module UserFacing = struct
|
|||||||
fallback ppf e
|
fallback ppf e
|
||||||
|
|
||||||
let expr :
|
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 ->
|
fun lang ->
|
||||||
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
|
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
|
||||||
fun ppf e -> value ~fallback lang ppf e
|
fun ppf e -> value ~fallback lang ppf e
|
||||||
|
@ -96,22 +96,22 @@ val program : ?debug:bool -> Format.formatter -> ('a, 'm) gexpr program -> unit
|
|||||||
|
|
||||||
(** User-facing, localised printer *)
|
(** User-facing, localised printer *)
|
||||||
module UserFacing : sig
|
module UserFacing : sig
|
||||||
val unit : Cli.backend_lang -> Format.formatter -> Runtime.unit -> unit
|
val unit : Global.backend_lang -> Format.formatter -> Runtime.unit -> unit
|
||||||
val bool : Cli.backend_lang -> Format.formatter -> Runtime.bool -> unit
|
val bool : Global.backend_lang -> Format.formatter -> Runtime.bool -> unit
|
||||||
val integer : Cli.backend_lang -> Format.formatter -> Runtime.integer -> unit
|
val integer : Global.backend_lang -> Format.formatter -> Runtime.integer -> unit
|
||||||
val decimal : Cli.backend_lang -> Format.formatter -> Runtime.decimal -> unit
|
val decimal : Global.backend_lang -> Format.formatter -> Runtime.decimal -> unit
|
||||||
val money : Cli.backend_lang -> Format.formatter -> Runtime.money -> unit
|
val money : Global.backend_lang -> Format.formatter -> Runtime.money -> unit
|
||||||
val date : Cli.backend_lang -> Format.formatter -> Runtime.date -> unit
|
val date : Global.backend_lang -> Format.formatter -> Runtime.date -> unit
|
||||||
|
|
||||||
val duration :
|
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 : Global.backend_lang -> Format.formatter -> lit -> unit
|
||||||
val lit_to_string : Cli.backend_lang -> lit -> string
|
val lit_to_string : Global.backend_lang -> lit -> string
|
||||||
|
|
||||||
val value :
|
val value :
|
||||||
?fallback:(Format.formatter -> ('a, 't) gexpr -> unit) ->
|
?fallback:(Format.formatter -> ('a, 't) gexpr -> unit) ->
|
||||||
Cli.backend_lang ->
|
Global.backend_lang ->
|
||||||
Format.formatter ->
|
Format.formatter ->
|
||||||
('a, 't) gexpr ->
|
('a, 't) gexpr ->
|
||||||
unit
|
unit
|
||||||
@ -121,7 +121,7 @@ module UserFacing : sig
|
|||||||
is called upon non-value expressions (by default, [Invalid_argument] is
|
is called upon non-value expressions (by default, [Invalid_argument] is
|
||||||
raised) *)
|
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
|
(** This combines the user-facing value printer and the generic expression
|
||||||
printer to handle all AST nodes *)
|
printer to handle all AST nodes *)
|
||||||
end
|
end
|
||||||
|
@ -159,14 +159,14 @@ let rec format_typ
|
|||||||
")" (format_typ ~colors) t2
|
")" (format_typ ~colors) t2
|
||||||
| TArray t1 -> (
|
| TArray t1 -> (
|
||||||
match Mark.remove (UnionFind.get (UnionFind.find t1)) with
|
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)
|
| _ -> Format.fprintf fmt "@[list of@ %a@]" (format_typ ~colors) t1)
|
||||||
| TDefault t1 ->
|
| TDefault t1 ->
|
||||||
Format.pp_print_as fmt 1 "⟨";
|
Format.pp_print_as fmt 1 "⟨";
|
||||||
format_typ ~colors fmt t1;
|
format_typ ~colors fmt t1;
|
||||||
Format.pp_print_as fmt 1 "⟩"
|
Format.pp_print_as fmt 1 "⟩"
|
||||||
| TAny v ->
|
| 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>"
|
else Format.pp_print_string fmt "<any>"
|
||||||
| TClosureEnv -> Format.fprintf fmt "closure_env"
|
| TClosureEnv -> Format.fprintf fmt "closure_env"
|
||||||
|
|
||||||
@ -234,7 +234,7 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
|
|||||||
( (fun ppf ->
|
( (fun ppf ->
|
||||||
Format.fprintf ppf "@[<hv 2>@[<hov>%a@ %a@]:" Format.pp_print_text
|
Format.fprintf ppf "@[<hv 2>@[<hov>%a@ %a@]:" Format.pp_print_text
|
||||||
"This expression has type" (format_typ ctx) t1;
|
"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 ()),
|
else Format.pp_close_box ppf ()),
|
||||||
e_pos );
|
e_pos );
|
||||||
( (fun ppf ->
|
( (fun ppf ->
|
||||||
@ -248,7 +248,7 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
|
|||||||
( (fun ppf ->
|
( (fun ppf ->
|
||||||
Format.fprintf ppf "@[<hv 2>@[<hov>%a:@]" Format.pp_print_text
|
Format.fprintf ppf "@[<hv 2>@[<hov>%a:@]" Format.pp_print_text
|
||||||
"While typechecking the following expression";
|
"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 ()),
|
else Format.pp_close_box ppf ()),
|
||||||
e_pos );
|
e_pos );
|
||||||
( (fun ppf ->
|
( (fun ppf ->
|
||||||
|
@ -333,7 +333,7 @@ and program = {
|
|||||||
program_items : law_structure list;
|
program_items : law_structure list;
|
||||||
program_source_files : (string[@opaque]) list;
|
program_source_files : (string[@opaque]) list;
|
||||||
program_used_modules : module_use 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
|
and source_file = law_structure list
|
||||||
|
@ -198,14 +198,14 @@ module Parser_En = ParserAux (Lexer_en)
|
|||||||
module Parser_Fr = ParserAux (Lexer_fr)
|
module Parser_Fr = ParserAux (Lexer_fr)
|
||||||
module Parser_Pl = ParserAux (Lexer_pl)
|
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
|
| En -> Parser_En.commands_or_includes
|
||||||
| Fr -> Parser_Fr.commands_or_includes
|
| Fr -> Parser_Fr.commands_or_includes
|
||||||
| Pl -> Parser_Pl.commands_or_includes
|
| Pl -> Parser_Pl.commands_or_includes
|
||||||
|
|
||||||
(** Lightweight lexer for dependency *)
|
(** 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 =
|
let lex_line =
|
||||||
match language with
|
match language with
|
||||||
| En -> Lexer_en.lex_line
|
| En -> Lexer_en.lex_line
|
||||||
@ -387,12 +387,12 @@ let get_interface program =
|
|||||||
|
|
||||||
let with_sedlex_source source_file f =
|
let with_sedlex_source source_file f =
|
||||||
match source_file with
|
match source_file with
|
||||||
| Cli.FileName file -> with_sedlex_file file f
|
| Global.FileName file -> with_sedlex_file file f
|
||||||
| Cli.Contents (str, file) ->
|
| Global.Contents (str, file) ->
|
||||||
let lexbuf = Sedlexing.Utf8.from_string str in
|
let lexbuf = Sedlexing.Utf8.from_string str in
|
||||||
Sedlexing.set_filename lexbuf file;
|
Sedlexing.set_filename lexbuf file;
|
||||||
f lexbuf
|
f lexbuf
|
||||||
| Cli.Stdin file ->
|
| Global.Stdin file ->
|
||||||
let lexbuf = Sedlexing.Utf8.from_channel stdin in
|
let lexbuf = Sedlexing.Utf8.from_channel stdin in
|
||||||
Sedlexing.set_filename lexbuf file;
|
Sedlexing.set_filename lexbuf file;
|
||||||
f lexbuf
|
f lexbuf
|
||||||
@ -400,7 +400,7 @@ let with_sedlex_source source_file f =
|
|||||||
let check_modname program source_file =
|
let check_modname program source_file =
|
||||||
match program.Ast.program_module_name, source_file with
|
match program.Ast.program_module_name, source_file with
|
||||||
| ( Some (mname, pos),
|
| ( 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))) ->
|
when not File.(equal mname Filename.(remove_extension (basename file))) ->
|
||||||
Message.raise_spanned_error pos
|
Message.raise_spanned_error pos
|
||||||
"@[<hov>Module declared as@ @{<blue>%s@},@ which@ does@ not@ match@ the@ \
|
"@[<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;
|
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
|
let program = with_sedlex_source source_file parse_source in
|
||||||
check_modname program source_file;
|
check_modname program source_file;
|
||||||
{
|
{
|
||||||
|
@ -20,17 +20,17 @@
|
|||||||
open Catala_utils
|
open Catala_utils
|
||||||
|
|
||||||
val lines :
|
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
|
(** Raw file parser that doesn't interpret any includes and returns the flat law
|
||||||
structure as is *)
|
structure as is *)
|
||||||
|
|
||||||
val load_interface :
|
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
|
(** Reads only declarations in metadata in the supplied input file, and only
|
||||||
keeps type information. The list of submodules is initialised with names
|
keeps type information. The list of submodules is initialised with names
|
||||||
only and empty contents. *)
|
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.
|
(** Parses a catala file (handling file includes) and returns a program.
|
||||||
Interfaces of the used modules are returned empty, use [load_interface] to
|
Interfaces of the used modules are returned empty, use [load_interface] to
|
||||||
fill them. *)
|
fill them. *)
|
||||||
|
@ -139,7 +139,7 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
|
|||||||
Catala sources *)
|
Catala sources *)
|
||||||
| TUnit -> ""
|
| TUnit -> ""
|
||||||
| TInt -> Expr.to_string e
|
| 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 *)
|
(* TODO: Print the right money symbol according to language *)
|
||||||
| TMoney ->
|
| TMoney ->
|
||||||
let z3_str = Expr.to_string e in
|
let z3_str = Expr.to_string e in
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"name": "@catala-lang/rescript-catala",
|
"name": "@catala-lang/rescript-catala",
|
||||||
"version": "0.8.1-b.0",
|
"version": "0.9.0",
|
||||||
"description": "ReScript wrapper for the Catala runtime",
|
"description": "ReScript wrapper for the Catala runtime",
|
||||||
"scripts": {
|
"scripts": {
|
||||||
"clean": "rescript clean",
|
"clean": "rescript clean",
|
||||||
|
Loading…
Reference in New Issue
Block a user