Logging into OCaml backend

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

src/catala/lcalc/to_ocaml.ml

@@ -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.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
   | 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

src/catala/runtime.ml

@@ -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)

src/catala/runtime.mli

@@ -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}*)

src/catala/utils/pos.ml

@@ -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

src/catala/utils/pos.mli

@@ -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