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=src/french_law
|
||||||
|
|
||||||
$(FRENCH_LAW_LIB_DIR)/law_source/allocations_familiales.ml:
|
$(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 \
|
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/allocations_familiales.ml \
|
||||||
$(FRENCH_LAW_LIB_DIR)/law_source
|
$(FRENCH_LAW_LIB_DIR)/law_source
|
||||||
|
|
||||||
$(FRENCH_LAW_LIB_DIR)/law_source/unit_tests/tests_allocations_familiales.ml:
|
$(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 \
|
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/tests/tests_allocations_familiales.ml \
|
||||||
$(FRENCH_LAW_LIB_DIR)/law_source/unit_tests/
|
$(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 : Builds the OCaml French law library
|
||||||
build_french_law_library: generate_french_law_library format
|
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
|
run_french_law_library_benchmark: generate_french_law_library
|
||||||
dune exec $(FRENCH_LAW_LIB_DIR)/bench.exe
|
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 =
|
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"
|
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 =
|
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit =
|
||||||
match Pos.unmark op with
|
match Pos.unmark op with
|
||||||
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
|
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
|
||||||
| Not -> Format.fprintf fmt "%s" "not"
|
| Not -> Format.fprintf fmt "%s" "not"
|
||||||
| Log (entry, infos) ->
|
| Log (entry, infos) ->
|
||||||
Format.fprintf fmt "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry
|
Format.fprintf fmt "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry format_uid_list
|
||||||
(Format.pp_print_list
|
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
|
|
||||||
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
|
|
||||||
infos
|
infos
|
||||||
| Length -> Format.fprintf fmt "%s" "array_length"
|
| Length -> Format.fprintf fmt "%s" "array_length"
|
||||||
| IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer"
|
| 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 ]) ->
|
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
|
||||||
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
|
||||||
(op, Pos.no_pos) format_with_parens arg2
|
(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 (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_with_parens arg1
|
||||||
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
|
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
|
||||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens 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
|
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_cents_string (cents : string) : money = Z.of_string cents
|
||||||
|
|
||||||
let money_of_units_int (units : int) : money = Z.(of_int units * of_int 100)
|
let money_of_units_int (units : int) : money = Z.(of_int units * of_int 100)
|
||||||
|
@ -38,6 +38,35 @@ exception ImpossibleDate
|
|||||||
|
|
||||||
exception NoValueProvided
|
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} *)
|
(**{1 Constructors and conversions} *)
|
||||||
|
|
||||||
(**{2 Money}*)
|
(**{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 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 get_start_line (pos : t) : int =
|
||||||
let s, _ = pos.code_pos in
|
let s, _ = pos.code_pos in
|
||||||
s.Lexing.pos_lnum
|
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 overwrite_law_info : t -> string list -> t
|
||||||
|
|
||||||
|
val get_law_info : t -> string list
|
||||||
|
|
||||||
val get_start_line : t -> int
|
val get_start_line : t -> int
|
||||||
|
|
||||||
val get_start_column : 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