Format trace to JSON format (#754)

compiler/catala_utils/cli.ml

@@ -26,7 +26,8 @@ let language_code =
   let rl = List.map (fun (a, b) -> b, a) languages in
   fun l -> List.assoc l rl
 
-let message_format_opt = ["human", Human; "gnu", GNU]
+let message_format_opt = ["human", (Human : message_format_enum); "gnu", GNU]
+let trace_format_opt = ["human", (Human : trace_format_enum); "json", JSON]
 
 open Cmdliner
 
@@ -146,13 +147,41 @@ module Flags = struct
              standards."
 
     let trace =
+      let converter =
+        conv ~docv:"FILE"
+          ( (fun s ->
+              if s = "-" then Ok `Stdout
+              else if
+                Filename.extension s |> String.starts_with ~prefix:".catala"
+              then
+                Error (`Msg "Output trace file cannot have a .catala extension")
+              else Ok (`FileName (Global.raw_file s))),
+            fun ppf -> function
+              | `Stdout -> Format.pp_print_string ppf "-"
+              | `FileName f -> Format.pp_print_string ppf (f :> string) )
+      in
       value
-      & flag
-      & info ["trace"; "t"]
+      & opt (some converter) None ~vopt:(Some `Stdout)
+      & info ["trace"; "t"] ~docv:"FILE"
           ~env:(Cmd.Env.info "CATALA_TRACE")
           ~doc:
             "Displays a trace of the interpreter's computation or generates \
-             logging instructions in translate programs."
+             logging instructions in translate programs. If set as a flag, \
+             outputs\n\
+            \             trace to stdout. If $(docv) is defined, outputs the \
+             trace to a file while interpreting.\n\
+            \             Defining a filename does not affect code generation. \
+             Cannot use .catala extension."
+
+    let trace_format =
+      value
+      & opt (some (enum trace_format_opt)) None
+      & info ["trace-format"]
+          ~doc:
+            "Selects the format of trace logs emitted by the interpreter. If \
+             set to $(i,human), the messages will be nicely displayed and \
+             meant to be read by a human. If set to $(i, json), the messages \
+             will be emitted as a JSON structured object."
 
     let plugins_dirs =
       let doc = "Set the given directory to be searched for backend plugins." in
@@ -223,6 +252,7 @@ module Flags = struct
           color
           message_format
           trace
+          trace_format
           plugins_dirs
           disable_warnings
           max_prec_digits
@@ -239,11 +269,34 @@ module Flags = struct
               | "-" -> "-"
               | f -> File.reverse_path ~to_dir f)
         in
+        let trace, trace_format =
+          match trace, trace_format with
+          | None, _ -> None, trace_format
+          | Some `Stdout, _ -> Some (lazy (Message.std_ppf ())), trace_format
+          | Some (`FileName f), Some _ ->
+            ( Some
+                (lazy
+                  (Message.formatter_of_out_channel
+                     (open_out (path_rewrite f))
+                     ())),
+              trace_format )
+          | Some (`FileName f), None ->
+            let trace_format =
+              if Filename.extension (f :> file) = ".json" then JSON else Human
+            in
+            ( Some
+                (lazy
+                  (Message.formatter_of_out_channel
+                     (open_out (path_rewrite f))
+                     ())),
+              Some trace_format )
+        in
+        let trace_format = Option.value trace_format ~default:Human in
         (* This sets some global refs for convenience, but most importantly
            returns the options record. *)
         Global.enforce_options ~language ~debug ~color ~message_format ~trace
-          ~plugins_dirs ~disable_warnings ~max_prec_digits ~path_rewrite
-          ~stop_on_error ~no_fail_on_assert ()
+          ~trace_format ~plugins_dirs ~disable_warnings ~max_prec_digits
+          ~path_rewrite ~stop_on_error ~no_fail_on_assert ()
       in
       Term.(
         const make
@@ -252,6 +305,7 @@ module Flags = struct
         $ color
         $ message_format
         $ trace
+        $ trace_format
         $ plugins_dirs
         $ disable_warnings
         $ max_prec_digits

compiler/catala_utils/global.ml

@@ -19,6 +19,7 @@ type raw_file = file
 type backend_lang = En | Fr | Pl
 type when_enum = Auto | Always | Never
 type message_format_enum = Human | GNU | Lsp
+type trace_format_enum = Human | JSON
 
 type 'file input_src =
   | FileName of 'file
@@ -32,7 +33,8 @@ type options = {
   mutable debug : bool;
   mutable color : when_enum;
   mutable message_format : message_format_enum;
-  mutable trace : bool;
+  mutable trace : Format.formatter Lazy.t option;
+  mutable trace_format : trace_format_enum;
   mutable plugins_dirs : file list;
   mutable disable_warnings : bool;
   mutable max_prec_digits : int;
@@ -53,7 +55,8 @@ let options =
     debug = false;
     color = Auto;
     message_format = Human;
-    trace = false;
+    trace = None;
+    trace_format = Human;
     plugins_dirs = [];
     disable_warnings = false;
     max_prec_digits = 20;
@@ -69,6 +72,7 @@ let enforce_options
     ?color
     ?message_format
     ?trace
+    ?trace_format
     ?plugins_dirs
     ?disable_warnings
     ?max_prec_digits
@@ -82,6 +86,7 @@ let enforce_options
   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.trace_format <- x) trace_format;
   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;

compiler/catala_utils/global.mli

@@ -32,6 +32,9 @@ type when_enum = Auto | Always | Never
 (** Format of error and warning messages output by the compiler. *)
 type message_format_enum = Human | GNU | Lsp
 
+(** Format of trace logs *)
+type trace_format_enum = Human | JSON
+
 (** Sources for program input *)
 type 'file input_src =
   | FileName of 'file  (** A file path to read from disk *)
@@ -50,7 +53,8 @@ type options = private {
   mutable debug : bool;
   mutable color : when_enum;
   mutable message_format : message_format_enum;
-  mutable trace : bool;
+  mutable trace : Format.formatter Lazy.t option;
+  mutable trace_format : trace_format_enum;
   mutable plugins_dirs : file list;
   mutable disable_warnings : bool;
   mutable max_prec_digits : int;
@@ -72,7 +76,8 @@ val enforce_options :
   ?debug:bool ->
   ?color:when_enum ->
   ?message_format:message_format_enum ->
-  ?trace:bool ->
+  ?trace:Format.formatter Lazy.t option ->
+  ?trace_format:trace_format_enum ->
   ?plugins_dirs:file list ->
   ?disable_warnings:bool ->
   ?max_prec_digits:int ->

compiler/catala_utils/hash.ml

@@ -49,7 +49,7 @@ end = struct
     % !(monomorphize_types : bool)
     % (* The following may not affect the call convention, but we want it set in
          an homogeneous way *)
-    !(Global.options.trace : bool)
+    !(Global.options.trace <> None: bool)
     % !(Global.options.max_prec_digits : int)
     |> k
 

compiler/catala_utils/message.ml

@@ -66,8 +66,13 @@ let formatter_of_out_channel oc =
     if Lazy.force tty then Format.pp_set_margin ppf (terminal_columns ());
     ppf
 
-let std_ppf = formatter_of_out_channel stdout
-let err_ppf = formatter_of_out_channel stderr
+let std_ppf =
+  let ppf = lazy (formatter_of_out_channel stdout ()) in
+  fun () -> Lazy.force ppf
+
+let err_ppf =
+  let ppf = lazy (formatter_of_out_channel stderr ()) in
+  fun () -> Lazy.force ppf
 
 let ignore_ppf =
   let ppf = lazy (Format.make_formatter (fun _ _ _ -> ()) (fun () -> ())) in

compiler/catala_utils/message.mli

@@ -93,6 +93,8 @@ val pad : int -> string -> Format.formatter -> unit
 
 (* {1 More general color-enabled formatting helpers}*)
 
+val std_ppf : unit -> Format.formatter
+val err_ppf : unit -> Format.formatter
 val formatter_of_out_channel : out_channel -> unit -> Format.formatter
 (** Creates a new formatter from the given out channel, with correct handling of
     the ocolor tags. Actual use of escape codes in the output depends on

compiler/catala_web_interpreter.ml

@@ -21,7 +21,7 @@ let () =
          let options =
            Global.enforce_options
              ~input_src:(Contents (contents, "-inline-"))
-             ~language:(Some language) ~debug:false ~color:Never ~trace ()
+             ~language:(Some language) ~debug:false ~color:Never ~trace: (if trace then Some (lazy Format.std_formatter) else None) ()
          in
          let prg, _type_order =
            Passes.dcalc options ~includes:[] ~optimize:false

compiler/dcalc/from_scopelang.ml

@@ -127,7 +127,7 @@ let tag_with_log_entry
     (markings : Uid.MarkedString.info list) : 'm Ast.expr boxed =
   let m = mark_tany (Mark.get e) (Expr.pos e) in
 
-  if Global.options.trace then
+  if Global.options.trace <> None then
     let pos = Expr.pos e in
     Expr.eappop ~op:(Log (l, markings), pos) ~tys:[TAny, pos] ~args:[e] m
   else e

compiler/lcalc/to_ocaml.ml

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

compiler/plugins/api_web.ml

@@ -475,7 +475,7 @@ let run
     keep_special_ops
     monomorphize_types
     _options =
-  let options = Global.enforce_options ~trace:true () in
+  let options = Global.enforce_options ~trace:(Some (lazy Format.std_formatter)) () in
   let prg, type_ordering, _ =
     Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
       ~autotest:false ~closure_conversion ~keep_special_ops ~typed:Expr.typed

compiler/scalc/to_python.ml

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

compiler/scopelang/from_desugared.ml

@@ -37,7 +37,7 @@ let tag_with_log_entry
     (e : untyped Ast.expr boxed)
     (l : log_entry)
     (markings : Uid.MarkedString.info list) : untyped Ast.expr boxed =
-  if Global.options.trace then
+  if Global.options.trace <> None then
     Expr.eappop
       ~op:(Log (l, markings), Expr.pos e)
       ~tys:[TAny, Expr.pos e]