mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-20 00:41:05 +03:00
Logging into OCaml backend
This commit is contained in:
parent
eaf00d34df
commit
14edecb92d
6
Makefile
6
Makefile
@ -159,12 +159,12 @@ tests_ml: run_french_law_library_tests
|
||||
FRENCH_LAW_LIB_DIR=src/french_law
|
||||
|
||||
$(FRENCH_LAW_LIB_DIR)/law_source/allocations_familiales.ml:
|
||||
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.ml
|
||||
CATALA_OPTS="-O -t" $(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.ml
|
||||
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/allocations_familiales.ml \
|
||||
$(FRENCH_LAW_LIB_DIR)/law_source
|
||||
|
||||
$(FRENCH_LAW_LIB_DIR)/law_source/unit_tests/tests_allocations_familiales.ml:
|
||||
$(MAKE) -s -C $(ALLOCATIONS_FAMILIALES_DIR) tests/tests_allocations_familiales.ml
|
||||
CATALA_OPTS="-O -t" $(MAKE) -s -C $(ALLOCATIONS_FAMILIALES_DIR) tests/tests_allocations_familiales.ml
|
||||
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/tests/tests_allocations_familiales.ml \
|
||||
$(FRENCH_LAW_LIB_DIR)/law_source/unit_tests/
|
||||
|
||||
@ -176,7 +176,7 @@ generate_french_law_library:\
|
||||
|
||||
#> build_french_law_library : Builds the OCaml French law library
|
||||
build_french_law_library: generate_french_law_library format
|
||||
dune build $(FRENCH_LAW_LIB_DIR)
|
||||
dune build $(FRENCH_LAW_LIB_DIR)/french_law.a
|
||||
|
||||
run_french_law_library_benchmark: generate_french_law_library
|
||||
dune exec $(FRENCH_LAW_LIB_DIR)/bench.exe
|
||||
|
@ -67,15 +67,26 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : un
|
||||
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : unit =
|
||||
match Pos.unmark op with Fold -> Format.fprintf fmt "Array.fold_left"
|
||||
|
||||
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) : unit =
|
||||
Format.fprintf fmt "@[<hov 2>[%a]@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
||||
(fun fmt info -> Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info))
|
||||
uids
|
||||
|
||||
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
||||
Format.fprintf fmt "@[<hov 2>[%a]@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
||||
(fun fmt info -> Format.fprintf fmt "\"%s\"" info))
|
||||
uids
|
||||
|
||||
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit =
|
||||
match Pos.unmark op with
|
||||
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
|
||||
| Not -> Format.fprintf fmt "%s" "not"
|
||||
| Log (entry, infos) ->
|
||||
Format.fprintf fmt "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
|
||||
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
|
||||
Format.fprintf fmt "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry format_uid_list
|
||||
infos
|
||||
| Length -> Format.fprintf fmt "%s" "array_length"
|
||||
| IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer"
|
||||
@ -296,6 +307,22 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp
|
||||
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
|
||||
(op, Pos.no_pos) format_with_parens arg2
|
||||
| EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ])
|
||||
when !Cli.trace_flag ->
|
||||
Format.fprintf fmt "(log_begin_call@ %a@ %a@ %a)" format_uid_list info format_with_parens f
|
||||
format_with_parens arg
|
||||
| EApp ((EOp (Unop (D.Log (D.VarDef, info))), _), [ arg1 ]) when !Cli.trace_flag ->
|
||||
Format.fprintf fmt "(log_variable_definition@ %a@ %a)" format_uid_list info format_with_parens
|
||||
arg1
|
||||
| EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) when !Cli.trace_flag ->
|
||||
Format.fprintf fmt
|
||||
"(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ \
|
||||
end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a)"
|
||||
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
|
||||
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos)
|
||||
format_with_parens arg1
|
||||
| EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) when !Cli.trace_flag ->
|
||||
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info format_with_parens arg1
|
||||
| EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_with_parens arg1
|
||||
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1
|
||||
|
@ -34,6 +34,35 @@ exception UncomparableDurations
|
||||
|
||||
exception ImpossibleDate
|
||||
|
||||
type source_position = {
|
||||
filename : string;
|
||||
start_line : int;
|
||||
start_column : int;
|
||||
end_line : int;
|
||||
end_column : int;
|
||||
law_headings : string list;
|
||||
}
|
||||
|
||||
type event =
|
||||
| BeginCall of string list
|
||||
| EndCall of string list
|
||||
| VariableDefinition of string list
|
||||
| DecisionTaken of source_position
|
||||
|
||||
let log_ref : event list ref = ref []
|
||||
|
||||
let reset_log () = log_ref := []
|
||||
|
||||
let retrieve_log () = !log_ref
|
||||
|
||||
let log_begin_call _ f x = f x
|
||||
|
||||
let log_end_call _ x = x
|
||||
|
||||
let log_variable_definition _ x = x
|
||||
|
||||
let log_decision_taken _ x = x
|
||||
|
||||
let money_of_cents_string (cents : string) : money = Z.of_string cents
|
||||
|
||||
let money_of_units_int (units : int) : money = Z.(of_int units * of_int 100)
|
||||
|
@ -38,6 +38,35 @@ exception ImpossibleDate
|
||||
|
||||
exception NoValueProvided
|
||||
|
||||
(** {1 Logging} *)
|
||||
|
||||
type source_position = {
|
||||
filename : string;
|
||||
start_line : int;
|
||||
start_column : int;
|
||||
end_line : int;
|
||||
end_column : int;
|
||||
law_headings : string list;
|
||||
}
|
||||
|
||||
type event =
|
||||
| BeginCall of string list
|
||||
| EndCall of string list
|
||||
| VariableDefinition of string list
|
||||
| DecisionTaken of source_position
|
||||
|
||||
val reset_log : unit -> unit
|
||||
|
||||
val retrieve_log : unit -> event list
|
||||
|
||||
val log_begin_call : string list -> ('a -> 'b) -> 'a -> 'b
|
||||
|
||||
val log_end_call : string list -> 'a -> 'a
|
||||
|
||||
val log_variable_definition : string list -> 'a -> 'a
|
||||
|
||||
val log_decision_taken : source_position -> bool -> bool
|
||||
|
||||
(**{1 Constructors and conversions} *)
|
||||
|
||||
(**{2 Money}*)
|
||||
|
@ -27,6 +27,8 @@ let from_info (file : string) (sline : int) (scol : int) (eline : int) (ecol : i
|
||||
|
||||
let overwrite_law_info (pos : t) (law_pos : string list) : t = { pos with law_pos }
|
||||
|
||||
let get_law_info (pos : t) : string list = pos.law_pos
|
||||
|
||||
let get_start_line (pos : t) : int =
|
||||
let s, _ = pos.code_pos in
|
||||
s.Lexing.pos_lnum
|
||||
|
@ -27,6 +27,8 @@ val from_info : string -> int -> int -> int -> int -> t
|
||||
|
||||
val overwrite_law_info : t -> string list -> t
|
||||
|
||||
val get_law_info : t -> string list
|
||||
|
||||
val get_start_line : t -> int
|
||||
|
||||
val get_start_column : t -> int
|
||||
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user