diff --git a/build_release.sh b/build_release.sh index 9bc21ced..2f249054 100755 --- a/build_release.sh +++ b/build_release.sh @@ -18,7 +18,6 @@ CUSTOM_LINKING_CATALA_Z3="\ -cclib -lzarith -cclib -lgmp -cclib -lcamlstr - -cclib -lANSITerminal_stubs -cclib -lalcotest_stubs -cclib -lunix)" diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 4cc2bf53..6cf2c529 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -919,10 +919,7 @@ let driver in if there_is_some_fails then List.iter - (fun f -> - f - |> Cli.with_style [ANSITerminal.magenta] "%s" - |> Messages.emit_warning "No test case found for %s") + (Messages.emit_warning "No test case found for @{%s@}") ctx.all_failed_names; if 0 = List.compare_lengths ctx.all_failed_names files_or_folders then return_ok diff --git a/build_system/dune b/build_system/dune index 50c30752..acd36da3 100644 --- a/build_system/dune +++ b/build_system/dune @@ -13,7 +13,7 @@ ninja_utils cmdliner re - ANSITerminal) + ocolor) (modules clerk_driver)) (rule diff --git a/catala.opam b/catala.opam index 3d68ef5d..a98e0124 100644 --- a/catala.opam +++ b/catala.opam @@ -18,7 +18,7 @@ license: "Apache-2.0" homepage: "https://github.com/CatalaLang/catala" bug-reports: "https://github.com/CatalaLang/catala/issues" depends: [ - "ANSITerminal" {>= "0.8.2"} + "ocolor" {>= "1.3.0"} "benchmark" {>= "1.6"} "bindlib" {>= "5.0.1"} "cmdliner" {>= "1.1.0"} diff --git a/clerk.opam b/clerk.opam index 05ee3727..b70e2497 100644 --- a/clerk.opam +++ b/clerk.opam @@ -14,7 +14,7 @@ depends: [ "ocaml" {>= "4.11.0"} "cmdliner" {>= "1.1.0"} "re" {>= "1.9.0"} - "ANSITerminal" {>= "0.8.2"} + "ocolor" {>= "1.3.0"} "alcotest" {with-test & >= "1.5.0"} "catala" {= version} "ninja_utils" {= version} diff --git a/compiler/catala_utils/cli.ml b/compiler/catala_utils/cli.ml index 20e463d1..88c28fb0 100644 --- a/compiler/catala_utils/cli.ml +++ b/compiler/catala_utils/cli.ml @@ -86,8 +86,10 @@ let contents : string ref = ref "" (** Prints debug information *) let debug_flag = ref false +type when_enum = Auto | Always | Never + (* Styles the terminal output *) -let style_flag = ref true +let style_flag = ref Auto (* Max number of digits to show for decimal results *) let max_prec_digits = ref 20 @@ -113,8 +115,6 @@ let file = let debug = Arg.(value & flag & info ["debug"; "d"] ~doc:"Prints debug information.") -type when_enum = Auto | Always | Never - let when_opt = Arg.enum ["auto", Auto; "always", Always; "never", Never] let color = @@ -370,11 +370,7 @@ let catala_t f = Term.(const f $ file $ options) let set_option_globals options : unit = debug_flag := options.debug; - (style_flag := - match options.color with - | Always -> true - | Never -> false - | Auto -> Unix.isatty Unix.stdout); + style_flag := options.color; (match options.max_prec_digits with | None -> () | Some i -> max_prec_digits := i); @@ -478,43 +474,3 @@ let info = in let exits = Cmd.Exit.defaults @ [Cmd.Exit.info ~doc:"on error." 1] in Cmd.info "catala" ~version ~doc ~exits ~man - -let with_style - (styles : ANSITerminal.style list) - (str : ('a, unit, string) format) = - if !style_flag then ANSITerminal.sprintf styles str else Printf.sprintf str - -let format_with_style (styles : ANSITerminal.style list) fmt (str : string) = - if !style_flag then - Format.pp_print_as fmt (String.length str) - (ANSITerminal.sprintf styles "%s" str) - else Format.pp_print_string fmt str - -let call_unstyled f = - let prev = !style_flag in - style_flag := false; - let res = f () in - style_flag := prev; - res - -let concat_with_line_depending_prefix_and_suffix - (prefix : int -> string) - (suffix : int -> string) - (ss : string list) = - match ss with - | [] -> prefix 0 - | _ :: _ -> - let len = List.length ss in - let suffix i = if i < len - 1 then suffix i else "" in - String.concat "" - @@ List.concat - @@ List.mapi - (fun i s -> [prefix i; (if s = "" then "" else " "); s; suffix i]) - ss - -(** The int argument of the prefix corresponds to the line number, starting at 0 *) -let add_prefix_to_each_line (s : string) (prefix : int -> string) = - concat_with_line_depending_prefix_and_suffix - (fun i -> prefix i) - (fun _ -> "\n") - (String.split_on_char '\n' s) diff --git a/compiler/catala_utils/cli.mli b/compiler/catala_utils/cli.mli index f461dc66..cf7c8cc8 100644 --- a/compiler/catala_utils/cli.mli +++ b/compiler/catala_utils/cli.mli @@ -35,6 +35,9 @@ type backend_option_builtin = type 'a backend_option = [ backend_option_builtin | `Plugin of 'a ] +(** The usual auto/always/never option argument *) +type when_enum = Auto | Always | Never + val languages : (string * backend_lang) list val language_code : backend_lang -> string @@ -57,7 +60,7 @@ val locale_lang : backend_lang ref val contents : string ref val debug_flag : bool ref -val style_flag : bool ref +val style_flag : when_enum ref (** Styles the terminal output *) val optimize_flag : bool ref @@ -99,9 +102,6 @@ val max_prec_digits_opt : int option Cmdliner.Term.t val ex_scope : string option Cmdliner.Term.t val output : string option Cmdliner.Term.t -(** The usual auto/always/never option argument *) -type when_enum = Auto | Always | Never - type options = { debug : bool; color : when_enum; @@ -136,21 +136,10 @@ val info : Cmdliner.Cmd.info (**{1 Terminal formatting}*) -(**{2 Markers}*) - -val with_style : ANSITerminal.style list -> ('a, unit, string) format -> 'a - -val format_with_style : - ANSITerminal.style list -> Format.formatter -> string -> unit - -val call_unstyled : (unit -> 'a) -> 'a -(** [call_unstyled f] calls the function [f] with the [style_flag] set to false - during the execution. *) - (**{2 Printers}*) -val concat_with_line_depending_prefix_and_suffix : - (int -> string) -> (int -> string) -> string list -> string - -val add_prefix_to_each_line : string -> (int -> string) -> string -(** The int argument of the prefix corresponds to the line number, starting at 0 *) +(* val concat_with_line_depending_prefix_and_suffix : + * (int -> string) -> (int -> string) -> string list -> string + * + * val add_prefix_to_each_line : string -> (int -> string) -> string + * (\** The int argument of the prefix corresponds to the line number, starting at 0 *\) *) diff --git a/compiler/catala_utils/dune b/compiler/catala_utils/dune index a5bebf6e..09148892 100644 --- a/compiler/catala_utils/dune +++ b/compiler/catala_utils/dune @@ -1,7 +1,7 @@ (library (name catala_utils) (public_name catala.catala_utils) - (libraries cmdliner ubase ANSITerminal re bindlib catala.runtime_ocaml)) + (libraries unix cmdliner ubase ocolor re bindlib catala.runtime_ocaml)) (documentation (package catala) diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index ce6bd57a..ee31a3ab 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -41,7 +41,7 @@ let with_in_channel filename f = finally (fun () -> close_in oc) (fun () -> f oc) let with_formatter_of_out_channel oc f = - let fmt = Format.formatter_of_out_channel oc in + let fmt = Messages.formatter_of_out_channel oc in finally (fun () -> Format.pp_print_flush fmt ()) @@ fun () -> f fmt let with_formatter_of_file filename f = diff --git a/compiler/catala_utils/messages.ml b/compiler/catala_utils/messages.ml index 990b18c4..ea5c8ec2 100644 --- a/compiler/catala_utils/messages.ml +++ b/compiler/catala_utils/messages.ml @@ -2,153 +2,182 @@ (**{1 Terminal formatting}*) -(**{2 Markers}*) +(* Adds handling of color tags in the formatter *) +let color_formatter ppf = + Ocolor_format.prettify_formatter ppf; + ppf -let time : float ref = ref (Unix.gettimeofday ()) +(* Sets handling of tags in the formatter to ignore them (don't print any color + codes) *) +let unstyle_formatter ppf = + Format.pp_set_mark_tags ppf false; + ppf +(* Format.pp_set_formatter_stag_functions ppf { + * Format.mark_open_stag = (fun _ -> ""); + * mark_close_stag = (fun _ -> ""); + * print_open_stag = ignore; + * print_close_stag = ignore; + * }; + * ppf *) -let time_marker ppf () = - let new_time = Unix.gettimeofday () in - let old_time = !time in - time := new_time; - let delta = (new_time -. old_time) *. 1000. in - if delta > 50. then - Cli.format_with_style - [ANSITerminal.Bold; ANSITerminal.black] - ppf - (Format.sprintf "[TIME] %.0fms@\n" delta) +(* SIDE EFFECT AT MODULE LOAD: this turns on handling of tags in + [Format.sprintf] etc. functions (ignoring them) *) +let () = ignore (unstyle_formatter Format.str_formatter) -(** Prints [\[DEBUG\]] in purple on the terminal standard output *) -let debug_marker ppf () = - time_marker ppf (); - Cli.format_with_style [ANSITerminal.Bold; ANSITerminal.magenta] ppf "[DEBUG] " +(* Note: we could do the same for std_formatter, err_formatter... but we'd + rather promote the use of the formatting functions of this module and the + below std_ppf / err_ppf *) -(** Prints [\[ERROR\]] in red on the terminal error output *) -let error_marker ppf () = - Cli.format_with_style [ANSITerminal.Bold; ANSITerminal.red] ppf "[ERROR] " +let has_color oc = + match !Cli.style_flag with + | Cli.Never -> false + | Always -> true + | Auto -> Unix.(isatty (descr_of_out_channel oc)) -(** Prints [\[WARNING\]] in yellow on the terminal standard output *) -let warning_marker ppf () = - Cli.format_with_style - [ANSITerminal.Bold; ANSITerminal.yellow] - ppf "[WARNING] " +(* Here we create new formatters to stderr/stdout that remain separate from the + ones used by [Format.printf] / [Format.eprintf] (which remain unchanged) *) -(** Prints [\[RESULT\]] in green on the terminal standard output *) -let result_marker ppf () = - Cli.format_with_style [ANSITerminal.Bold; ANSITerminal.green] ppf "[RESULT] " +let formatter_of_out_channel oc = + let ppf = Format.formatter_of_out_channel oc in + if has_color oc then color_formatter ppf else unstyle_formatter ppf -(** Prints [\[LOG\]] in red on the terminal error output *) -let log_marker ppf () = - Cli.format_with_style [ANSITerminal.Bold; ANSITerminal.black] ppf "[LOG] " +let std_ppf = lazy (formatter_of_out_channel stdout) +let err_ppf = lazy (formatter_of_out_channel stderr) +let ignore_ppf = lazy (Format.make_formatter (fun _ _ _ -> ()) (fun () -> ())) + +let unformat (f : Format.formatter -> unit) : string = + let buf = Buffer.create 1024 in + let ppf = unstyle_formatter (Format.formatter_of_buffer buf) in + Format.pp_set_margin ppf max_int; + (* We won't print newlines anyways, but better not have them in the first + place (this wouldn't remove cuts in a vbox for example) *) + let out_funs = Format.pp_get_formatter_out_functions ppf () in + Format.pp_set_formatter_out_functions ppf + { + out_funs with + Format.out_newline = (fun () -> out_funs.out_string " " 0 1); + Format.out_indent = (fun _ -> ()); + }; + f ppf; + Format.pp_print_flush ppf (); + Buffer.contents buf + +(**{2 Message types and output helpers *) + +type content_type = Error | Warning | Debug | Log | Result + +let get_ppf = function + | Result -> Lazy.force std_ppf + | Debug when not !Cli.debug_flag -> Lazy.force ignore_ppf + | Warning when !Cli.disable_warnings_flag -> Lazy.force ignore_ppf + | Error | Log | Debug | Warning -> Lazy.force err_ppf + +(**{3 Markers}*) + +let print_time_marker = + let time : float ref = ref (Unix.gettimeofday ()) in + fun ppf () -> + let new_time = Unix.gettimeofday () in + let old_time = !time in + time := new_time; + let delta = (new_time -. old_time) *. 1000. in + if delta > 50. then + Format.fprintf ppf "@{[TIME] %.0fms@}@," delta + +let pp_marker target ppf = + let open Ocolor_types in + let tags, str = + match target with + | Debug -> [Bold; Fg (C4 magenta)], "[DEBUG]" + | Error -> [Bold; Fg (C4 red)], "[ERROR]" + | Warning -> [Bold; Fg (C4 yellow)], "[WARNING]" + | Result -> [Bold; Fg (C4 green)], "[RESULT]" + | Log -> [Bold; Fg (C4 black)], "[LOG]" + in + if target = Debug then print_time_marker ppf (); + Format.pp_open_stag ppf (Ocolor_format.Ocolor_styles_tag tags); + Format.pp_print_string ppf str; + Format.pp_close_stag ppf () (**{2 Printers}*) -(** All the printers below print their argument after the correct marker *) - -let debug_format (format : ('a, Format.formatter, unit) format) = - if !Cli.debug_flag then - Format.printf ("%a@[" ^^ format ^^ "@]@.") debug_marker () - else Format.ifprintf Format.std_formatter format - -let error_format (format : ('a, Format.formatter, unit) format) = - Format.print_flush (); - (* Flushes previous warnings *) - Format.printf ("%a" ^^ format ^^ "\n%!") error_marker () - -let warning_format format = - if !Cli.disable_warnings_flag then Format.ifprintf Format.std_formatter format - else Format.printf ("%a" ^^ format ^^ "\n%!") warning_marker () - -let result_format format = - Format.printf ("%a" ^^ format ^^ "\n%!") result_marker () - -let log_format format = - Format.printf ("%a@[" ^^ format ^^ "@]@.") log_marker () - (** {1 Message content} *) module Content = struct - type position = { message : string option; position : Pos.t } - type t = { message : string; positions : position list } + type message = Format.formatter -> unit + type position = { pos_message : message option; pos : Pos.t } + type t = { message : message; positions : position list } - let of_message (s : string) : t = { message = s; positions = [] } + let of_message (message : message) : t = { message; positions = [] } + + let of_string (s : string) : t = + { message = (fun ppf -> Format.pp_print_string ppf s); positions = [] } end +open Content + let internal_error_prefix = "Internal Error, please report to \ https://github.com/CatalaLang/catala/issues: " let to_internal_error (content : Content.t) : Content.t = - { content with message = internal_error_prefix ^ content.message } + { + content with + message = + (fun ppf -> + Format.fprintf ppf "%s@,%t" internal_error_prefix content.message); + } -type content_type = Error | Warning | Debug | Log | Result - -let emit_content (content : Content.t) (typ : content_type) : unit = - let { Content.message = msg; positions = pos } = content in +let emit_content (content : Content.t) (target : content_type) : unit = + let { message; positions } = content in match !Cli.message_format_flag with | Cli.Human -> - (match typ with - | Warning -> warning_format - | Error -> error_format - | Debug -> debug_format - | Log -> log_format - | Result -> result_format) - "%s%s%s" msg - (if pos = [] then "" else "\n\n") - (String.concat "\n\n" - (List.map - (fun (pos : Content.position) -> - Printf.sprintf "%s%s" - (match pos.message with None -> "" | Some msg -> msg ^ "\n") - (Pos.retrieve_loc_text pos.position)) - pos)) + let ppf = get_ppf target in + Format.fprintf ppf "@[@[%t%t%t@]%a@]@." (pp_marker target) + (fun ppf -> + match target with + | Log | Error | Warning -> Format.pp_print_char ppf ' ' + | Result | Debug -> Format.pp_print_space ppf ()) + message + (fun ppf l -> + Format.pp_print_list + ~pp_sep:(fun _ () -> ()) + (fun ppf pos -> + Format.pp_print_cut ppf (); + Format.pp_print_cut ppf (); + Option.iter + (fun msg -> Format.fprintf ppf "%t@," msg) + pos.pos_message; + Pos.format_loc_text ppf pos.pos) + ppf l) + positions | Cli.GNU -> - let remove_new_lines s = - Re.replace ~all:true - (Re.compile (Re.seq [Re.char '\n'; Re.rep Re.blank])) - ~f:(fun _ -> " ") - s - in - let severity = - Format.asprintf "%a" - (match typ with - | Warning -> warning_marker - | Error -> error_marker - | Debug -> debug_marker - | Log -> log_marker - | Result -> result_marker) - () - in (* 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 message everywhere there is not a more precise message. If we can'r find a position without a more precise message, we just take the first position in the list to pair with the message. *) - (match typ with - | Error -> Format.eprintf - | Warning | Log | Debug | Result -> Format.printf) - "%s%s\n" - (if - pos != [] - && List.for_all - (fun (pos' : Content.position) -> Option.is_some pos'.message) - pos + let ppf = get_ppf target in + let () = + if + positions != [] + && List.for_all + (fun (pos' : Content.position) -> Option.is_some pos'.pos_message) + positions then - Format.asprintf "%a: %s %s\n" - (Cli.format_with_style [ANSITerminal.blue]) - (Pos.to_string_short (List.hd pos).position) - severity (remove_new_lines msg) - else "") - (String.concat "\n" - (List.map - (fun pos' -> - Format.asprintf "%a: %s %s" - (Cli.format_with_style [ANSITerminal.blue]) - (Pos.to_string_short pos'.Content.position) - severity - (match pos'.message with - | None -> remove_new_lines msg - | Some msg' -> remove_new_lines msg')) - pos)) + Format.fprintf ppf "@{%s@}: %t %s@\n" + (Pos.to_string_short (List.hd positions).pos) + (pp_marker target) (unformat message) + in + Format.pp_print_list ~pp_sep:Format.pp_print_newline + (fun ppf pos' -> + Format.fprintf ppf "@{%s@}: %t %s" + (Pos.to_string_short pos'.pos) + (pp_marker target) + (match pos'.pos_message with + | None -> unformat message + | Some msg' -> unformat msg')) + ppf positions (** {1 Error exception} *) @@ -156,34 +185,42 @@ exception CompilerError of Content.t (** {1 Error printing} *) -let raise_spanned_error ?(span_msg : string option) (span : Pos.t) format = - Format.kasprintf - (fun msg -> +let raise_spanned_error + ?(span_msg : Content.message option) + (span : Pos.t) + format = + Format.kdprintf + (fun message -> + raise + (CompilerError + { message; positions = [{ pos_message = span_msg; pos = span }] })) + format + +let raise_multispanned_error_full + (spans : (Content.message option * Pos.t) list) + format = + Format.kdprintf + (fun message -> raise (CompilerError { - message = msg; - positions = [{ message = span_msg; position = span }]; + message; + positions = + List.map (fun (pos_message, pos) -> { pos_message; pos }) spans; })) format -let raise_multispanned_error (spans : (string option * Pos.t) list) format = - Format.kasprintf - (fun msg -> - raise - (CompilerError - { - message = msg; - positions = - List.map - (fun (message, position) -> { Content.message; position }) - spans; - })) +let raise_multispanned_error spans format = + raise_multispanned_error_full + (List.map + (fun (msg, pos) -> + Option.map (fun s ppf -> Format.pp_print_string ppf s) msg, pos) + spans) format let raise_error format = - Format.kasprintf - (fun msg -> raise (CompilerError { message = msg; positions = [] })) + Format.kdprintf + (fun message -> raise (CompilerError { message; positions = [] })) format let raise_internal_error format = @@ -195,36 +232,39 @@ let assert_internal_error condition fmt = if condition then raise_internal_error ("assertion failed: " ^^ fmt) else Format.ifprintf (Format.formatter_of_out_channel stdout) fmt -let emit_multispanned_warning (pos : (string option * Pos.t) list) format = - Format.kasprintf - (fun msg -> +let emit_multispanned_warning + (pos : (Content.message option * Pos.t) list) + format = + Format.kdprintf + (fun message -> emit_content { - message = msg; + message; positions = - List.map - (fun (msg, pos) -> { Content.message = msg; position = pos }) - pos; + List.map (fun (pos_message, pos) -> { pos_message; pos }) pos; } Warning) format -let emit_spanned_warning ?(span_msg : string option) (span : Pos.t) format = +let emit_spanned_warning + ?(span_msg : Content.message option) + (span : Pos.t) + format = emit_multispanned_warning [span_msg, span] format let emit_warning format = emit_multispanned_warning [] format let emit_log format = - Format.kasprintf - (fun msg -> emit_content { message = msg; positions = [] } Log) + Format.kdprintf + (fun message -> emit_content { message; positions = [] } Log) format let emit_debug format = - Format.kasprintf - (fun msg -> emit_content { message = msg; positions = [] } Debug) + Format.kdprintf + (fun message -> emit_content { message; positions = [] } Debug) format let emit_result format = - Format.kasprintf - (fun msg -> emit_content { message = msg; positions = [] } Result) + Format.kdprintf + (fun message -> emit_content { message; positions = [] } Result) format diff --git a/compiler/catala_utils/messages.mli b/compiler/catala_utils/messages.mli index 6c94e044..2b533fcf 100644 --- a/compiler/catala_utils/messages.mli +++ b/compiler/catala_utils/messages.mli @@ -14,14 +14,25 @@ License for the specific language governing permissions and limitations under the License. *) -(** Interface for emitting compiler messages *) +(** Interface for emitting compiler messages. + + All messages are expected to use the [Format] module. Flush, ["@?"], ["@."], + ["%!"] etc. are not supposed to be used outside of this module. + + WARNING: this module performs side-effects at load time, adding support for + ocolor tags (e.g. ["@{text@}"]) to the standard string formatter used + by e.g. [Format.sprintf]. (In this case, the tags are ignored, for color + output you should use the functions of this module that toggle support + depending on cli flags and terminal support). *) (** {1 Message content} *) module Content : sig + type message = Format.formatter -> unit type t - val of_message : string -> t + val of_message : (Format.formatter -> unit) -> t + val of_string : string -> t end val to_internal_error : Content.t -> Content.t @@ -39,7 +50,15 @@ exception CompilerError of Content.t (** {1 Common error raising} *) val raise_spanned_error : - ?span_msg:string -> Pos.t -> ('a, Format.formatter, unit, 'b) format4 -> 'a + ?span_msg:Content.message -> + Pos.t -> + ('a, Format.formatter, unit, 'b) format4 -> + 'a + +val raise_multispanned_error_full : + (Content.message option * Pos.t) list -> + ('a, Format.formatter, unit, 'b) format4 -> + 'a val raise_multispanned_error : (string option * Pos.t) list -> ('a, Format.formatter, unit, 'b) format4 -> 'a @@ -53,10 +72,15 @@ val assert_internal_error : (** {1 Common warning emission}*) val emit_multispanned_warning : - (string option * Pos.t) list -> ('a, Format.formatter, unit) format -> 'a + (Content.message option * Pos.t) list -> + ('a, Format.formatter, unit) format -> + 'a val emit_spanned_warning : - ?span_msg:string -> Pos.t -> ('a, Format.formatter, unit) format -> 'a + ?span_msg:Content.message -> + Pos.t -> + ('a, Format.formatter, unit) format -> + 'a val emit_warning : ('a, Format.formatter, unit) format -> 'a @@ -68,6 +92,19 @@ val emit_log : ('a, Format.formatter, unit) format -> 'a val emit_debug : ('a, Format.formatter, unit) format -> 'a -(* {1 Common result emission}*) +(** {1 Common result emission}*) val emit_result : ('a, Format.formatter, unit) format -> 'a + +(** {1 Some formatting helpers}*) + +val unformat : (Format.formatter -> unit) -> string +(** Converts [f] to a string, discarding formatting and skipping newlines and + indents *) + +(* {1 More general color-enabled formatting helpers}*) + +val formatter_of_out_channel : out_channel -> 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 + [Cli.style_flag] -- and wether the channel is a tty if that is set to auto. *) diff --git a/compiler/catala_utils/pos.ml b/compiler/catala_utils/pos.ml index 6dc5e101..d5de0f14 100644 --- a/compiler/catala_utils/pos.ml +++ b/compiler/catala_utils/pos.ml @@ -136,15 +136,14 @@ let utf8_byte_index s ui0 = in aux 0 0 -let retrieve_loc_text (pos : t) : string = +let format_loc_text ppf (pos : t) = try let filename = get_file pos in - let blue_style = [ANSITerminal.Bold; ANSITerminal.blue] in - if filename = "" then "No position information" + if filename = "" then Format.pp_print_string ppf "No position information" else let sline = get_start_line pos in let eline = get_end_line pos in - let oc, input_line_opt = + let ic, input_line_opt = if filename = "stdin" then let line_index = ref 0 in let lines = String.split_on_char '\n' !Cli.contents in @@ -157,15 +156,36 @@ let retrieve_loc_text (pos : t) : string = in None, input_line_opt else - let oc = open_in filename in + let ic = open_in filename in let input_line_opt () : string option = - try Some (input_line oc) with End_of_file -> None + try Some (input_line ic) with End_of_file -> None in - Some oc, input_line_opt + Some ic, input_line_opt in - let print_matched_line (line : string) (line_no : int) : string = + let include_extra_count = 0 in + let rec get_lines (n : int) : (int * string) list = + match input_line_opt () with + | Some line -> + if n < sline - include_extra_count then get_lines (n + 1) + else if + n >= sline - include_extra_count && n <= eline + include_extra_count + then (n, line) :: get_lines (n + 1) + else [] + | None -> [] + in + let pos_lines = get_lines 1 in + let nspaces = int_of_float (log10 (float_of_int eline)) + 1 in + let legal_pos_lines = + List.rev_map + (fun s -> + Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*") + ~subst:(fun _ -> " ") + s) + pos.law_pos + in + (match ic with None -> () | Some ic -> close_in ic); + let print_matched_line ppf ((line_no, line) : int * string) = let line_indent = indent_number line in - let error_indicator_style = [ANSITerminal.red; ANSITerminal.Bold] in let match_start_index = utf8_byte_index line (if line_no = sline then get_start_column pos - 1 else line_indent) @@ -181,88 +201,27 @@ let retrieve_loc_text (pos : t) : string = in let match_start_col = string_columns unmatched_prefix in let match_num_cols = string_columns matched_substring in - String.concat "" - (line - :: "\n" - :: - (if line_no >= sline && line_no <= eline then - [ - string_repeat match_start_col " "; - Cli.with_style error_indicator_style "%s" - (string_repeat match_num_cols "‾"); - ] - else [])) + Format.fprintf ppf "@{%*d │@} %s@," nspaces line_no line; + if line_no >= sline && line_no <= eline then + Format.fprintf ppf "@{%s │@} %s@{%s@}" + (string_repeat nspaces " ") + (string_repeat match_start_col " ") + (string_repeat match_num_cols "‾") in - let include_extra_count = 0 in - let rec get_lines (n : int) : string list = - match input_line_opt () with - | Some line -> - if n < sline - include_extra_count then get_lines (n + 1) - else if - n >= sline - include_extra_count && n <= eline + include_extra_count - then print_matched_line line n :: get_lines (n + 1) - else [] - | None -> [] - in - let pos_lines = get_lines 1 in - let spaces = int_of_float (log10 (float_of_int eline)) + 1 in - let legal_pos_lines = - List.rev - (List.map - (fun s -> - Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*") - ~subst:(fun _ -> " ") - s) - pos.law_pos) - in - (match oc with None -> () | Some oc -> close_in oc); - let buf = Buffer.create 73 in - Buffer.add_string buf - (Cli.with_style blue_style "┌─⯈ %s:" (to_string_short pos)); - Buffer.add_char buf '\n'; - (* should be outside of [Cli.with_style] *) - Buffer.add_string buf - (Cli.with_style blue_style "└%s┐" (string_repeat spaces "─")); - Buffer.add_char buf '\n'; - Buffer.add_string buf - (Cli.add_prefix_to_each_line (String.concat "\n" pos_lines) (fun i -> - let cur_line = sline - include_extra_count + i in - if - cur_line >= sline - && cur_line <= sline + (2 * (eline - sline)) - && cur_line mod 2 = sline mod 2 - then - Cli.with_style blue_style "%*d │" spaces - (sline + ((cur_line - sline) / 2)) - else if cur_line >= sline - include_extra_count && cur_line < sline - then Cli.with_style blue_style "%*d │" spaces (cur_line + 1) - else if - cur_line - <= sline + (2 * (eline - sline)) + 1 + include_extra_count - && cur_line > sline + (2 * (eline - sline)) + 1 - then - Cli.with_style blue_style "%*d │" spaces - (cur_line - (eline - sline + 1)) - else Cli.with_style blue_style "%*s │" spaces "")); - Buffer.add_char buf '\n'; - let () = - match legal_pos_lines with + Format.pp_open_vbox ppf 0; + Format.fprintf ppf "@{┌─⯈ %s:@}@," (to_string_short pos); + Format.fprintf ppf "@{└%s┐@}@," (string_repeat nspaces "─"); + Format.pp_print_list print_matched_line ppf pos_lines; + Format.pp_print_cut ppf (); + let rec pp_legal nspaces = function + | [last] -> Format.fprintf ppf "@{%*s└─ %s@}" nspaces "" last + | l :: lines -> + Format.fprintf ppf "@{%*s└┬ %s@}@," nspaces "" l; + pp_legal (nspaces + 1) lines | [] -> () - | _ -> - let last = List.length legal_pos_lines - 1 in - Buffer.add_string buf - (Cli.add_prefix_to_each_line - (String.concat "\n" - (List.map - (fun l -> Cli.with_style blue_style "%s" l) - legal_pos_lines)) - (fun i -> - if i = last then - Cli.with_style blue_style "%*s└─" (spaces + i + 1) "" - else Cli.with_style blue_style "%*s└┬" (spaces + i + 1) "")) in - Buffer.contents buf - with Sys_error _ -> "Location:" ^ to_string pos + pp_legal (nspaces + 1) legal_pos_lines + with Sys_error _ -> Format.fprintf ppf "Location: %s" (to_string pos) let no_pos : t = let zero_pos = diff --git a/compiler/catala_utils/pos.mli b/compiler/catala_utils/pos.mli index c832025a..69be2f5d 100644 --- a/compiler/catala_utils/pos.mli +++ b/compiler/catala_utils/pos.mli @@ -57,7 +57,7 @@ val to_string_short : t -> string {{:https://www.gnu.org/prep/standards/standards.html#Errors} GNU coding standards}. *) -val retrieve_loc_text : t -> string +val format_loc_text : Format.formatter -> t -> unit (** Open the file corresponding to the position and retrieves the text concerned by the position *) diff --git a/compiler/desugared/linting.ml b/compiler/desugared/linting.ml index d501da2a..6dbe4309 100644 --- a/compiler/desugared/linting.ml +++ b/compiler/desugared/linting.ml @@ -35,12 +35,9 @@ let detect_empty_definitions (p : program) : unit = then Messages.emit_spanned_warning (ScopeDef.get_position scope_def_key) - "In scope %a, the variable %a is declared but never defined; did \ - you forget something?" - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" ScopeName.format_t scope_name) - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" Ast.ScopeDef.format_t scope_def_key)) + "In scope @{\"%a\"@}, the variable @{\"%a\"@} is \ + declared but never defined; did you forget something?" + ScopeName.format_t scope_name Ast.ScopeDef.format_t scope_def_key) scope.scope_defs) p.program_scopes @@ -147,9 +144,9 @@ let detect_unused_struct_fields (p : program) : unit = then Messages.emit_spanned_warning (snd (StructName.get_info s_name)) - "The structure %a is never used; maybe it's unnecessary?" - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" StructName.format_t s_name) + "The structure @{\"%a\"@} is never used; maybe it's \ + unnecessary?" + StructName.format_t s_name else StructField.Map.iter (fun field _ -> @@ -159,12 +156,9 @@ let detect_unused_struct_fields (p : program) : unit = then Messages.emit_spanned_warning (snd (StructField.get_info field)) - "The field %a of struct %a is never used; maybe it's \ - unnecessary?" - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" StructField.format_t field) - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" StructName.format_t s_name)) + "The field @{\"%a\"@} of struct @{\"%a\"@} is \ + never used; maybe it's unnecessary?" + StructField.format_t field StructName.format_t s_name) fields) p.program_ctx.ctx_structs @@ -203,9 +197,9 @@ let detect_unused_enum_constructors (p : program) : unit = then Messages.emit_spanned_warning (snd (EnumName.get_info e_name)) - "The enumeration %a is never used; maybe it's unnecessary?" - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" EnumName.format_t e_name) + "The enumeration @{\"%a\"@} is never used; maybe it's \ + unnecessary?" + EnumName.format_t e_name else EnumConstructor.Map.iter (fun constructor _ -> @@ -213,12 +207,9 @@ let detect_unused_enum_constructors (p : program) : unit = then Messages.emit_spanned_warning (snd (EnumConstructor.get_info constructor)) - "The constructor %a of enumeration %a is never used; maybe \ - it's unnecessary?" - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" EnumConstructor.format_t constructor) - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" EnumName.format_t e_name)) + "The constructor @{\"%a\"@} of enumeration \ + @{\"%a\"@} is never used; maybe it's unnecessary?" + EnumConstructor.format_t constructor EnumName.format_t e_name) constructors) p.program_ctx.ctx_enums @@ -263,9 +254,9 @@ let detect_dead_code (p : program) : unit = Messages.emit_spanned_warning (Mark.get (ScopeVar.get_info var)) "This variable is dead code; it does not contribute to computing \ - any of scope %a outputs. Did you forget something?" - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ Mark.remove (ScopeName.get_info scope_name) ^ "\"") + any of scope @{\"%s\"@} outputs. Did you forget \ + something?" + (Mark.remove (ScopeName.get_info scope_name)) in match states with | WholeVar -> diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index 067ee5a8..151b6519 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -100,9 +100,8 @@ let raise_unsupported_feature (msg : string) (pos : Pos.t) = (** Function to call whenever an identifier used somewhere has not been declared in the program previously *) let raise_unknown_identifier (msg : string) (ident : IdentName.t Mark.pos) = - Messages.raise_spanned_error (Mark.get ident) "\"%s\": unknown identifier %s" - (Cli.with_style [ANSITerminal.yellow] "%s" (Mark.remove ident)) - msg + Messages.raise_spanned_error (Mark.get ident) + "@{\"%s\"@}: unknown identifier %s" (Mark.remove ident) msg (** Gets the type associated to an uid *) let get_var_typ (ctxt : context) (uid : ScopeVar.t) : typ = @@ -259,9 +258,7 @@ let process_subscope_decl in Messages.raise_multispanned_error [Some "first use", Mark.get info; Some "second use", s_pos] - "Subscope name \"%a\" already used" - (Cli.format_with_style [ANSITerminal.yellow]) - subscope + "Subscope name @{\"%s\"@} already used" subscope | None -> let sub_scope_uid = SubScopeName.fresh (name, name_pos) in let original_subscope_uid = @@ -314,8 +311,8 @@ let rec process_base_typ TStruct scope_str.out_struct_name, typ_pos | None -> Messages.raise_spanned_error typ_pos - "Unknown type \"%a\", not a struct or enum previously declared" - (Cli.format_with_style [ANSITerminal.yellow]) + "Unknown type @{\"%s\"@}, not a struct or enum previously \ + declared" ident) | Surface.Ast.Named (_path, (_ident, _pos)) -> Messages.raise_spanned_error typ_pos @@ -349,9 +346,7 @@ let process_data_decl in Messages.raise_multispanned_error [Some "First use:", Mark.get info; Some "Second use:", pos] - "Variable name \"%a\" already used" - (Cli.format_with_style [ANSITerminal.yellow]) - name + "Variable name @{\"%s\"@} already used" name | None -> let uid = ScopeVar.fresh (name, pos) in let scope_ctxt = @@ -366,17 +361,19 @@ let process_data_decl ((states_idmap : StateName.t IdentName.Map.t), states_list) -> let state_id_name = Mark.remove state_id in if IdentName.Map.mem state_id_name states_idmap then - Messages.raise_multispanned_error + Messages.raise_multispanned_error_full [ ( Some - (Format.asprintf "First instance of state %a:" - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ state_id_name ^ "\"")), + (fun ppf -> + Format.fprintf ppf + "First instance of state @{\"%s\"@}:" + state_id_name), Mark.get state_id ); ( Some - (Format.asprintf "Second instance of state %a:" - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ state_id_name ^ "\"")), + (fun ppf -> + Format.fprintf ppf + "Second instance of state @{\"%s\"@}:" + state_id_name), Mark.get (IdentName.Map.find state_id_name states_idmap |> StateName.get_info) ); @@ -605,11 +602,13 @@ let typedef_info = function let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) : context = let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg = - Messages.raise_multispanned_error - [Some "First definition:", Mark.get use; Some "Second definition:", pos] - "%s name \"%a\" already defined" msg - (Cli.format_with_style [ANSITerminal.yellow]) - name + Messages.raise_multispanned_error_full + [ + ( Some (fun ppf -> Format.pp_print_string ppf "First definition:"), + Mark.get use ); + Some (fun ppf -> Format.pp_print_string ppf "Second definition:"), pos; + ] + "%s name @{\"%s\"@} already defined" msg name in match Mark.remove item with | ScopeDecl decl -> @@ -894,8 +893,8 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context | _ -> Messages.raise_spanned_error (Mark.get suse.Surface.Ast.scope_use_name) - "\"%a\": this scope has not been declared anywhere, is it a typo?" - (Cli.format_with_style [ANSITerminal.yellow]) + "@{\"%s\"@}: this scope has not been declared anywhere, is it \ + a typo?" (Mark.remove suse.Surface.Ast.scope_use_name) in List.fold_left diff --git a/compiler/desugared/print.ml b/compiler/desugared/print.ml index 73c10f53..8e2c1dc8 100644 --- a/compiler/desugared/print.ml +++ b/compiler/desugared/print.ml @@ -25,47 +25,41 @@ open Format (* Original credits for this printing code: Jean-Christophe Filiâtre *) let format_exception_tree (fmt : Format.formatter) (t : exception_tree) = - let blue s = - Format.asprintf "%a" (Cli.format_with_style [ANSITerminal.blue]) s - in + let blue fmt s = Format.fprintf fmt "@{%s@}" s in let rec print_node pref (t : exception_tree) = - let (s, w), sons = - let print_s s = - ( Format.asprintf "%a" - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" LabelName.format_t - s.Dependency.ExceptionVertex.label), - String.length - (Format.asprintf "\"%a\"" LabelName.format_t - s.Dependency.ExceptionVertex.label) ) - in - match t with Leaf s -> print_s s, [] | Node (sons, s) -> print_s s, sons + let label, sons = + match t with + | Leaf l -> l.Dependency.ExceptionVertex.label, [] + | Node (sons, l) -> l.Dependency.ExceptionVertex.label, sons in - pp_print_string fmt s; + Format.fprintf fmt "@{\"%a\"@}" LabelName.format_t label; + let w = String.length (fst (LabelName.get_info label)) + 2 in if sons != [] then let pref' = pref ^ String.make (w + 1) ' ' in match sons with | [t'] -> - pp_print_string fmt (blue "───"); + blue fmt "───"; print_node (pref' ^ " ") t' | _ -> - pp_print_string fmt (blue "──"); + blue fmt "──"; print_sons pref' "─┬──" sons and print_sons pref start = function | [] -> assert false | [s] -> - pp_print_string fmt (blue " └──"); + blue fmt " └──"; print_node (pref ^ " ") s | s :: sons -> - pp_print_string fmt (blue start); + blue fmt start; print_node (pref ^ "| ") s; - pp_force_newline fmt (); - pp_print_string fmt (blue (pref ^ " │")); - pp_force_newline fmt (); - pp_print_string fmt (blue pref); + pp_print_cut fmt (); + blue fmt (pref ^ " │"); + pp_print_cut fmt (); + blue fmt pref; print_sons pref " ├──" sons in - print_node "" t + Format.pp_open_vbox fmt 0; + print_node "" t; + Format.pp_close_box fmt () let build_exception_tree exc_graph = let base_cases = @@ -91,22 +85,15 @@ let print_exceptions_graph (var : Ast.ScopeDef.t) (g : Dependency.ExceptionsDependencies.t) = Messages.emit_result - "Printing the tree of exceptions for the definitions of variable %a of \ - scope %a." - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" Ast.ScopeDef.format_t var) - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" ScopeName.format_t scope); + "Printing the tree of exceptions for the definitions of variable \ + @{\"%a\"@} of scope @{\"%a\"@}." + Ast.ScopeDef.format_t var ScopeName.format_t scope; Dependency.ExceptionsDependencies.iter_vertex (fun ex -> - Messages.emit_result "Definitions with label %a:\n%a" - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" LabelName.format_t - ex.Dependency.ExceptionVertex.label) - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n") - (fun fmt (_, pos) -> - Format.fprintf fmt "%s" (Pos.retrieve_loc_text pos))) + Messages.emit_result + "@[Definitions with label @{\"%a\"@}:@,%a@]" + LabelName.format_t ex.Dependency.ExceptionVertex.label + (Format.pp_print_list (fun fmt (_, pos) -> Pos.format_loc_text fmt pos)) (RuleName.Map.bindings ex.Dependency.ExceptionVertex.rules)) g; let tree = build_exception_tree g in diff --git a/compiler/driver.ml b/compiler/driver.ml index 1f657869..e58416ba 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -45,9 +45,8 @@ let get_scope_uid match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with | Some (Desugared.Name_resolution.TScope (uid, _)) -> uid | _ -> - Messages.raise_error "There is no scope %a inside the program." - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ name ^ "\"")) + Messages.raise_error + "There is no scope @{\"%s\"@} inside the program." name) let get_variable_uid (options : Cli.options) @@ -80,24 +79,20 @@ let get_variable_uid (Shared_ast.ScopeName.Map.find scope_uid ctxt.scopes).var_idmap with | None -> - Messages.raise_error "Variable %a not found inside scope %a" - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ name ^ "\"") - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t scope_uid) + Messages.raise_error + "Variable @{\"%s\"@} not found inside scope @{\"%a\"@}" + name Shared_ast.ScopeName.format_t scope_uid | Some (Desugared.Name_resolution.SubScope (subscope_var_name, subscope_name)) -> ( match second_part with | None -> Messages.raise_error - "Subscope %a of scope %a cannot be selected by itself, please add \ - \".\" where is a subscope variable." - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" Shared_ast.SubScopeName.format_t - subscope_var_name) - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t scope_uid) + "Subscope @{\"%a\"@} of scope @{\"%a\"@} cannot be \ + selected by itself, please add \".\" where is a subscope \ + variable." + Shared_ast.SubScopeName.format_t subscope_var_name + Shared_ast.ScopeName.format_t scope_uid | Some second_part -> ( match Shared_ast.IdentName.Map.find_opt second_part @@ -109,15 +104,11 @@ let get_variable_uid (subscope_var_name, v, Pos.no_pos)) | _ -> Messages.raise_error - "Var %a of subscope %a in scope %a does not exist, please check \ - your command line arguments." - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ second_part ^ "\"") - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" Shared_ast.SubScopeName.format_t - subscope_var_name) - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t scope_uid))) + "Var @{\"%s\"@} of subscope @{\"%a\"@} in scope \ + @{\"%a\"@} does not exist, please check your command line \ + arguments." + second_part Shared_ast.SubScopeName.format_t subscope_var_name + Shared_ast.ScopeName.format_t scope_uid)) | Some (Desugared.Name_resolution.ScopeVar v) -> Some (Desugared.Ast.ScopeDef.Var @@ -132,14 +123,10 @@ let get_variable_uid | Some state -> state | None -> Messages.raise_error - "State %a is not found for variable %a of scope %a" - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ second_part ^ "\"") - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ first_part ^ "\"") - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t - scope_uid)) + "State @{\"%s\"@} is not found for variable \ + @{\"%s\"@} of scope @{\"%a\"@}" + second_part first_part Shared_ast.ScopeName.format_t + scope_uid) second_part ))) (** Entry function for the executable. Returns a negative number in case of @@ -570,7 +557,7 @@ let driver source_file (options : Cli.options) : int = | Sys_error msg -> let bt = Printexc.get_raw_backtrace () in Messages.emit_content - (Messages.Content.of_message ("System error: " ^ msg)) + (Messages.Content.of_string ("System error: " ^ msg)) Error; if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt; -1 diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 4b4f7e36..0169ca3d 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -543,17 +543,15 @@ let format_program (fmt : Format.formatter) (p : 'm Ast.program) (type_ordering : Scopelang.Dependency.TVertex.t list) : unit = - Cli.call_unstyled (fun _ -> - Format.fprintf fmt - "(** This file has been generated by the Catala compiler, do not edit! \ - *)@\n\ - @\n\ - open Runtime_ocaml.Runtime@\n\ - @\n\ - [@@@@@@ocaml.warning \"-4-26-27-32-41-42\"]@\n\ - @\n\ - %a%a@\n\ - @?" - (format_ctx type_ordering) p.decl_ctx - (format_code_items p.decl_ctx) - p.code_items) + Format.fprintf fmt + "(** This file has been generated by the Catala compiler, do not edit! *)@\n\ + @\n\ + open Runtime_ocaml.Runtime@\n\ + @\n\ + [@@@@@@ocaml.warning \"-4-26-27-32-41-42\"]@\n\ + @\n\ + %a%a@\n\ + @?" + (format_ctx type_ordering) p.decl_ctx + (format_code_items p.decl_ctx) + p.code_items diff --git a/compiler/literate/literate_common.ml b/compiler/literate/literate_common.ml index 66870e77..ef68561d 100644 --- a/compiler/literate/literate_common.ml +++ b/compiler/literate/literate_common.ml @@ -111,19 +111,14 @@ let check_exceeding_lines let len_s = Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s in - if len_s > max_len then ( - Messages.emit_warning "The line %s in %s is exceeding %s characters:" - (Cli.with_style - ANSITerminal.[Bold; yellow] - "%d" - (start_line + i + 1)) - (Cli.with_style ANSITerminal.[Bold; magenta] "%s" filename) - (Cli.with_style ANSITerminal.[Bold; red] "%d" max_len); - Messages.emit_warning "%s%s" (String.sub s 0 max_len) - (Cli.with_style - ANSITerminal.[red] - "%s" - String.(sub s max_len (len_s - max_len))))) + if len_s > max_len then + Messages.emit_warning + "@[The line @{%d@} in @{%s@} is \ + exceeding @{%s@}@]" + (start_line + i + 1) + filename max_len (String.sub s 0 max_len) + (String.sub s max_len (len_s - max_len))) let with_pygmentize_lexer lang f = let lexer_py = diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index aa362e83..3431a739 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -402,32 +402,30 @@ module To_jsoo = struct module_name) in - Cli.call_unstyled (fun _ -> - Format.fprintf fmt - "(** This file has been generated by the Catala compiler, do not \ - edit! *)@\n\ - @\n\ - open Runtime_ocaml.Runtime@\n\ - open Runtime_jsoo.Runtime@\n\ - open Js_of_ocaml@\n\ - %s@\n\ - @\n\ - [@@@@@@ocaml.warning \"-4-26-27-32-41-42\"]@\n\ - @\n\ - (* Generated API *)@\n\ - @\n\ - %a@\n\ - %a@\n\ - @\n\ - @[let _ =@ @[ Js.export \"%a\"@\n\ - @[(object%%js@ %a@]@\n\ - end)@]@]@?" - (Option.fold ~none:"" ~some:(fun name -> name) module_name) - (format_ctx type_ordering) prgm.decl_ctx - (format_scopes_to_fun prgm.decl_ctx) - prgm.code_items fmt_lib_name () - (format_scopes_to_callbacks prgm.decl_ctx) - prgm.code_items) + Format.fprintf fmt + "(** This file has been generated by the Catala compiler, do not edit! *)@\n\ + @\n\ + open Runtime_ocaml.Runtime@\n\ + open Runtime_jsoo.Runtime@\n\ + open Js_of_ocaml@\n\ + %s@\n\ + @\n\ + [@@@@@@ocaml.warning \"-4-26-27-32-41-42\"]@\n\ + @\n\ + (* Generated API *)@\n\ + @\n\ + %a@\n\ + %a@\n\ + @\n\ + @[let _ =@ @[ Js.export \"%a\"@\n\ + @[(object%%js@ %a@]@\n\ + end)@]@]@?" + (Option.fold ~none:"" ~some:(fun name -> name) module_name) + (format_ctx type_ordering) prgm.decl_ctx + (format_scopes_to_fun prgm.decl_ctx) + prgm.code_items fmt_lib_name () + (format_scopes_to_callbacks prgm.decl_ctx) + prgm.code_items end let apply diff --git a/compiler/plugins/json_schema.ml b/compiler/plugins/json_schema.ml index 60a4e301..66dba11d 100644 --- a/compiler/plugins/json_schema.ml +++ b/compiler/plugins/json_schema.ml @@ -197,20 +197,19 @@ module To_json = struct (scope : ScopeName.t) (prgm : 'm Lcalc.Ast.program) = let scope_body = Program.get_scope_body prgm scope in - Cli.call_unstyled (fun _ -> - Format.fprintf fmt - "{@[@\n\ - \"type\": \"object\",@\n\ - \"@[definitions\": {%a@]@\n\ - },@\n\ - \"@[properties\": {@\n\ - %a@]@\n\ - }@]@\n\ - }" - (fmt_definitions prgm.decl_ctx) - (scope, scope_body) - (fmt_struct_properties prgm.decl_ctx) - scope_body.scope_body_input_struct) + Format.fprintf fmt + "{@[@\n\ + \"type\": \"object\",@\n\ + \"@[definitions\": {%a@]@\n\ + },@\n\ + \"@[properties\": {@\n\ + %a@]@\n\ + }@]@\n\ + }" + (fmt_definitions prgm.decl_ctx) + (scope, scope_body) + (fmt_struct_properties prgm.decl_ctx) + scope_body.scope_body_input_struct end let apply diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index e8b08a6b..c592546f 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -590,33 +590,30 @@ let format_program (* We disable the style flag in order to enjoy formatting from the pretty-printers of Dcalc and Lcalc but without the color terminal markers. *) - Cli.call_unstyled (fun () -> - Format.fprintf fmt - "# This file has been generated by the Catala compiler, do not edit!\n\ - @\n\ - from catala.runtime import *@\n\ - from typing import Any, List, Callable, Tuple\n\ - from enum import Enum\n\ - @\n\ - @[%a@]@\n\ - @\n\ - %a@?" - (format_ctx type_ordering) p.decl_ctx - (Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun fmt -> - function - | SVar { var; expr } -> - Format.fprintf fmt "@[%a = (@,%a@,@])@," format_var var - (format_expression p.decl_ctx) - expr - | SFunc { var; func } - | SScope { scope_body_var = var; scope_body_func = func; _ } -> - let { Ast.func_params; Ast.func_body } = func in - Format.fprintf fmt "@[def %a(%a):@\n%a@]@," format_func_name - var - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") - (fun fmt (var, typ) -> - Format.fprintf fmt "%a:%a" format_var (Mark.remove var) - format_typ typ)) - func_params (format_block p.decl_ctx) func_body)) - p.code_items) + Format.fprintf fmt + "@[# This file has been generated by the Catala compiler, do not edit!@,\ + @,\ + from catala.runtime import *@,\ + from typing import Any, List, Callable, Tuple@,\ + from enum import Enum@,\ + @,\ + @[%a@]@,\ + @,\ + %a@]@?" + (format_ctx type_ordering) p.decl_ctx + (Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun fmt -> function + | SVar { var; expr } -> + Format.fprintf fmt "@[%a = (@,%a@,@])@," format_var var + (format_expression p.decl_ctx) + expr + | SFunc { var; func } + | SScope { scope_body_var = var; scope_body_func = func; _ } -> + let { Ast.func_params; Ast.func_body } = func in + Format.fprintf fmt "@[def %a(%a):@\n%a@]@," format_func_name var + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") + (fun fmt (var, typ) -> + Format.fprintf fmt "%a:%a" format_var (Mark.remove var) + format_typ typ)) + func_params (format_block p.decl_ctx) func_body)) + p.code_items diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index 7a33aa3d..0cb2ac02 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -88,11 +88,9 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) : with Not_found -> (* Should not happen after disambiguation *) Messages.raise_spanned_error (Expr.mark_pos m) - "Field %a does not belong to structure %a" - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ field ^ "\"") - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" StructName.format_t name) + "Field @{\"%s\"@} does not belong to structure \ + @{\"%a\"@}" + field StructName.format_t name in Expr.estructaccess e' field name m | ETuple es -> Expr.etuple (List.map (translate_expr ctx) es) m diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 20e01820..4aec7537 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -43,45 +43,33 @@ let propagate_empty_error_list elist f = in aux [] elist -let log_indent = ref 0 - (* TODO: we should provide a generic way to print logs, that work across the different backends: python, ocaml, javascript, and interpreter *) +let indent_str = ref "" + (** {1 Evaluation} *) let print_log entry infos pos e = if !Cli.trace_flag then match entry with | VarDef _ -> - (* TODO: this usage of Format is broken, Formatting requires that all is - formatted in one pass, without going through intermediate "%s" *) - Messages.emit_log "%*s%a %a: %s" (!log_indent * 2) "" Print.log_entry + Messages.emit_log "%s%a %a: @{%s@}" !indent_str Print.log_entry entry Print.uid_list infos - (let expr_str = - Format.asprintf "%a" (Print.expr ~hide_function_body:true ()) e - in - let expr_str = - Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*") - ~subst:(fun _ -> " ") - expr_str - in - Cli.with_style [ANSITerminal.green] "%s" expr_str) + (Messages.unformat (fun ppf -> + Print.expr ~hide_function_body:true () ppf e)) | PosRecordIfTrueBool -> ( match pos <> Pos.no_pos, Mark.remove e with | true, ELit (LBool true) -> - Messages.emit_log "%*s%a%s:\n%s" (!log_indent * 2) "" Print.log_entry - entry - (Cli.with_style [ANSITerminal.green] "Definition applied") - (Cli.add_prefix_to_each_line (Pos.retrieve_loc_text pos) (fun _ -> - Format.asprintf "%*s" (!log_indent * 2) "")) + Messages.emit_log "%s@[%a@{Definition applied@}:@,%a@]" + !indent_str Print.log_entry entry Pos.format_loc_text pos | _ -> ()) | BeginCall -> - Messages.emit_log "%*s%a %a" (!log_indent * 2) "" Print.log_entry entry + Messages.emit_log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list infos; - log_indent := !log_indent + 1 + indent_str := !indent_str ^ " " | EndCall -> - log_indent := !log_indent - 1; - Messages.emit_log "%*s%a %a" (!log_indent * 2) "" Print.log_entry entry + indent_str := String.sub !indent_str 0 (String.length !indent_str - 2); + Messages.emit_log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list infos exception CatalaException of except diff --git a/compiler/shared_ast/optimizations.ml b/compiler/shared_ast/optimizations.ml index aebd99a6..293ae9d8 100644 --- a/compiler/shared_ast/optimizations.ml +++ b/compiler/shared_ast/optimizations.ml @@ -310,45 +310,44 @@ let optimize_program (p : 'm program) : 'm program = (Program.map_exprs ~f:(optimize_expr p.decl_ctx) ~varf:(fun v -> v) p) let test_iota_reduction_1 () = - Cli.call_unstyled (fun _ -> - let x = Var.make "x" in - let enumT = EnumName.fresh ("t", Pos.no_pos) in - let consA = EnumConstructor.fresh ("A", Pos.no_pos) in - let consB = EnumConstructor.fresh ("B", Pos.no_pos) in - let consC = EnumConstructor.fresh ("C", Pos.no_pos) in - let consD = EnumConstructor.fresh ("D", Pos.no_pos) in - let nomark = Untyped { pos = Pos.no_pos } in - let injA = Expr.einj (Expr.evar x nomark) consA enumT nomark in - let injC = Expr.einj (Expr.evar x nomark) consC enumT nomark in - let injD = Expr.einj (Expr.evar x nomark) consD enumT nomark in - let cases : ('a, 't) boxed_gexpr EnumConstructor.Map.t = - EnumConstructor.Map.of_seq - @@ List.to_seq - @@ [ - consA, Expr.eabs (Expr.bind [| x |] injC) [TAny, Pos.no_pos] nomark; - consB, Expr.eabs (Expr.bind [| x |] injD) [TAny, Pos.no_pos] nomark; - ] - in - let matchA = Expr.ematch injA enumT cases nomark in - Alcotest.(check string) - "same string" - "before=match (A x)\n\ - \ with\n\ - \ | A → (λ (x: any) → C x)\n\ - \ | B → (λ (x: any) → D x)\n\ - after=C\n\ - x" - (Format.asprintf "before=%a\nafter=%a" Expr.format (Expr.unbox matchA) - Expr.format - (Expr.unbox - (optimize_expr - { - ctx_enums = EnumName.Map.empty; - ctx_structs = StructName.Map.empty; - ctx_struct_fields = IdentName.Map.empty; - ctx_scopes = ScopeName.Map.empty; - } - (Expr.unbox matchA))))) + let x = Var.make "x" in + let enumT = EnumName.fresh ("t", Pos.no_pos) in + let consA = EnumConstructor.fresh ("A", Pos.no_pos) in + let consB = EnumConstructor.fresh ("B", Pos.no_pos) in + let consC = EnumConstructor.fresh ("C", Pos.no_pos) in + let consD = EnumConstructor.fresh ("D", Pos.no_pos) in + let nomark = Untyped { pos = Pos.no_pos } in + let injA = Expr.einj (Expr.evar x nomark) consA enumT nomark in + let injC = Expr.einj (Expr.evar x nomark) consC enumT nomark in + let injD = Expr.einj (Expr.evar x nomark) consD enumT nomark in + let cases : ('a, 't) boxed_gexpr EnumConstructor.Map.t = + EnumConstructor.Map.of_seq + @@ List.to_seq + @@ [ + consA, Expr.eabs (Expr.bind [| x |] injC) [TAny, Pos.no_pos] nomark; + consB, Expr.eabs (Expr.bind [| x |] injD) [TAny, Pos.no_pos] nomark; + ] + in + let matchA = Expr.ematch injA enumT cases nomark in + Alcotest.(check string) + "same string" + "before=match (A x)\n\ + \ with\n\ + \ | A → (λ (x: any) → C x)\n\ + \ | B → (λ (x: any) → D x)\n\ + after=C\n\ + x" + (Format.asprintf "before=%a\nafter=%a" Expr.format (Expr.unbox matchA) + Expr.format + (Expr.unbox + (optimize_expr + { + ctx_enums = EnumName.Map.empty; + ctx_structs = StructName.Map.empty; + ctx_struct_fields = IdentName.Map.empty; + ctx_scopes = ScopeName.Map.empty; + } + (Expr.unbox matchA)))) let cases_of_list l : ('a, 't) boxed_gexpr EnumConstructor.Map.t = EnumConstructor.Map.of_seq @@ -362,62 +361,60 @@ let cases_of_list l : ('a, 't) boxed_gexpr EnumConstructor.Map.t = (Untyped { pos = Pos.no_pos }) )) let test_iota_reduction_2 () = - Cli.call_unstyled (fun _ -> - let enumT = EnumName.fresh ("t", Pos.no_pos) in - let consA = EnumConstructor.fresh ("A", Pos.no_pos) in - let consB = EnumConstructor.fresh ("B", Pos.no_pos) in - let consC = EnumConstructor.fresh ("C", Pos.no_pos) in - let consD = EnumConstructor.fresh ("D", Pos.no_pos) in + let enumT = EnumName.fresh ("t", Pos.no_pos) in + let consA = EnumConstructor.fresh ("A", Pos.no_pos) in + let consB = EnumConstructor.fresh ("B", Pos.no_pos) in + let consC = EnumConstructor.fresh ("C", Pos.no_pos) in + let consD = EnumConstructor.fresh ("D", Pos.no_pos) in - let nomark = Untyped { pos = Pos.no_pos } in + let nomark = Untyped { pos = Pos.no_pos } in - let num n = Expr.elit (LInt (Runtime.integer_of_int n)) nomark in + let num n = Expr.elit (LInt (Runtime.integer_of_int n)) nomark in - let injAe e = Expr.einj e consA enumT nomark in - let injBe e = Expr.einj e consB enumT nomark in - let injCe e = Expr.einj e consC enumT nomark in - let injDe e = Expr.einj e consD enumT nomark in + let injAe e = Expr.einj e consA enumT nomark in + let injBe e = Expr.einj e consB enumT nomark in + let injCe e = Expr.einj e consC enumT nomark in + let injDe e = Expr.einj e consD enumT nomark in - (* let injA x = injAe (Expr.evar x nomark) in *) - let injB x = injBe (Expr.evar x nomark) in - let injC x = injCe (Expr.evar x nomark) in - let injD x = injDe (Expr.evar x nomark) in + (* let injA x = injAe (Expr.evar x nomark) in *) + let injB x = injBe (Expr.evar x nomark) in + let injC x = injCe (Expr.evar x nomark) in + let injD x = injDe (Expr.evar x nomark) in - let matchA = - Expr.ematch - (Expr.ematch (num 1) enumT - (cases_of_list - [ - (consB, fun x -> injBe (injB x)); - (consA, fun _x -> injAe (num 20)); - ]) - nomark) - enumT - (cases_of_list [consA, injC; consB, injD]) - nomark - in - Alcotest.(check string) - "same string " - "before=match\n\ - \ (match 1\n\ - \ with\n\ - \ | A → (λ (x: any) → A 20)\n\ - \ | B → (λ (x: any) → B B x))\n\ - \ with\n\ - \ | A → (λ (x: any) → C x)\n\ - \ | B → (λ (x: any) → D x)\n\ - after=match 1\n\ - \ with\n\ - \ | A → (λ (x: any) → C 20)\n\ - \ | B → (λ (x: any) → D B x)\n" - (Format.asprintf "before=@[%a@]@.after=%a@." Expr.format - (Expr.unbox matchA) Expr.format - (Expr.unbox - (optimize_expr - { - ctx_enums = EnumName.Map.empty; - ctx_structs = StructName.Map.empty; - ctx_struct_fields = IdentName.Map.empty; - ctx_scopes = ScopeName.Map.empty; - } - (Expr.unbox matchA))))) + let matchA = + Expr.ematch + (Expr.ematch (num 1) enumT + (cases_of_list + [ + (consB, fun x -> injBe (injB x)); (consA, fun _x -> injAe (num 20)); + ]) + nomark) + enumT + (cases_of_list [consA, injC; consB, injD]) + nomark + in + Alcotest.(check string) + "same string " + "before=match\n\ + \ (match 1\n\ + \ with\n\ + \ | A → (λ (x: any) → A 20)\n\ + \ | B → (λ (x: any) → B B x))\n\ + \ with\n\ + \ | A → (λ (x: any) → C x)\n\ + \ | B → (λ (x: any) → D x)\n\ + after=match 1\n\ + \ with\n\ + \ | A → (λ (x: any) → C 20)\n\ + \ | B → (λ (x: any) → D B x)\n" + (Format.asprintf "before=@[%a@]@.after=%a@." Expr.format (Expr.unbox matchA) + Expr.format + (Expr.unbox + (optimize_expr + { + ctx_enums = EnumName.Map.empty; + ctx_structs = StructName.Map.empty; + ctx_struct_fields = IdentName.Map.empty; + ctx_scopes = ScopeName.Map.empty; + } + (Expr.unbox matchA)))) diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index 6ce17762..08325fea 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -25,28 +25,34 @@ let uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) : Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_char fmt '.') (fun fmt info -> - Cli.format_with_style - (if String.begins_with_uppercase (Mark.remove info) then - [ANSITerminal.red] - else []) - fmt + Format.fprintf fmt + (if String.begins_with_uppercase (Mark.remove info) then "@{%s@}" + else "%s") (Uid.MarkedString.to_string info)) fmt infos +let with_color f color fmt x = + (* equivalent to [Format.fprintf fmt "@{%s@}" s] *) + Format.pp_open_stag fmt Ocolor_format.(Ocolor_style_tag (Fg (C4 color))); + f fmt x; + Format.pp_close_stag fmt () + +let pp_color_string = with_color Format.pp_print_string + let keyword (fmt : Format.formatter) (s : string) : unit = - Cli.format_with_style [ANSITerminal.red] fmt s + pp_color_string Ocolor_types.red fmt s let base_type (fmt : Format.formatter) (s : string) : unit = - Cli.format_with_style [ANSITerminal.yellow] fmt s + pp_color_string Ocolor_types.yellow fmt s let punctuation (fmt : Format.formatter) (s : string) : unit = - Format.pp_print_as fmt 1 (Cli.with_style [ANSITerminal.cyan] "%s" s) + with_color (fun fmt -> Format.pp_print_as fmt 1) Ocolor_types.cyan fmt s let op_style (fmt : Format.formatter) (s : string) : unit = - Cli.format_with_style [ANSITerminal.green] fmt s + pp_color_string Ocolor_types.green fmt s let lit_style (fmt : Format.formatter) (s : string) : unit = - Cli.format_with_style [ANSITerminal.yellow] fmt s + pp_color_string Ocolor_types.yellow fmt s let tlit (fmt : Format.formatter) (l : typ_lit) : unit = base_type fmt @@ -69,12 +75,10 @@ let location (type a) (fmt : Format.formatter) (l : a glocation) : unit = | ToplevelVar v -> TopdefName.format_t fmt (Mark.remove v) let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit = - Cli.format_with_style [ANSITerminal.magenta] fmt - (Format.asprintf "%a" EnumConstructor.format_t c) + Format.fprintf fmt "@{%a@}" EnumConstructor.format_t c let struct_field (fmt : Format.formatter) (c : StructField.t) : unit = - Cli.format_with_style [ANSITerminal.magenta] fmt - (Format.asprintf "%a" StructField.format_t c) + Format.fprintf fmt "@{%a@}" StructField.format_t c let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit = let typ = typ ctx in @@ -152,14 +156,11 @@ let lit (fmt : Format.formatter) (l : lit) : unit = | LDuration d -> lit_style fmt (Runtime.duration_to_string d) let log_entry (fmt : Format.formatter) (entry : log_entry) : unit = - Format.fprintf fmt "@<2>%a" - (fun fmt -> function - | VarDef _ -> Cli.format_with_style [ANSITerminal.blue] fmt "≔ " - | BeginCall -> Cli.format_with_style [ANSITerminal.yellow] fmt "→ " - | EndCall -> Cli.format_with_style [ANSITerminal.yellow] fmt "← " - | PosRecordIfTrueBool -> - Cli.format_with_style [ANSITerminal.green] fmt "☛ ") - entry + match entry with + | VarDef _ -> Format.fprintf fmt "@{@<1>%s @}" "≔" + | BeginCall -> Format.fprintf fmt "@{@<1>%s @}" "→" + | EndCall -> Format.fprintf fmt "@{@<1>%s @}" "←" + | PosRecordIfTrueBool -> Format.fprintf fmt "@{@<1>%s @}" "☛" let operator_to_string : type a. a Op.t -> string = let open Op in @@ -299,17 +300,12 @@ let operator : type a. ?debug:bool -> Format.formatter -> a operator -> unit = let open Op in match op with | Log (entry, infos) -> - Format.fprintf fmt "%a%a%a%a" - (Cli.format_with_style [ANSITerminal.blue]) - "#{" log_entry entry + Format.fprintf fmt "@{#{@}%a%a@{}@}" log_entry entry (Format.pp_print_list ~pp_sep:(fun fmt () -> punctuation fmt ".") (fun fmt info -> - Cli.format_with_style [ANSITerminal.blue] fmt - (Uid.MarkedString.to_string info))) + Format.fprintf fmt "@{%s@}" (Uid.MarkedString.to_string info))) infos - (Cli.format_with_style [ANSITerminal.blue]) - "}" | op -> op_style fmt (if debug then operator_to_string op else operator_to_shorter_string op) @@ -434,7 +430,7 @@ let rec expr_aux : hide_function_body:bool -> debug:bool -> Bindlib.ctxt -> - ANSITerminal.style list -> + Ocolor_types.color4 list -> Format.formatter -> (a, 't) gexpr -> unit = @@ -454,15 +450,13 @@ let rec expr_aux : let paren ~rhs ?(colors = colors) expr fmt e1 = if Precedence.needs_parens ~rhs ~context:e (skip_log e1) then ( Format.pp_open_hvbox fmt 1; - Cli.format_with_style [List.hd colors] fmt "("; + pp_color_string (List.hd colors) fmt "("; expr (List.tl colors) fmt e1; Format.pp_close_box fmt (); - Cli.format_with_style [List.hd colors] fmt ")") + pp_color_string (List.hd colors) fmt ")") else expr colors fmt e1 in - let default_punct color fmt s = - Format.pp_print_as fmt 1 (Cli.with_style [color] "%s" s) - in + let default_punct = with_color (fun fmt -> Format.pp_print_as fmt 1) in let lhs ?(colors = colors) ex = paren ~colors ~rhs:false ex in let rhs ex = paren ~rhs:true ex in match Mark.remove e with @@ -673,13 +667,8 @@ let rec expr_aux : Format.pp_close_box fmt () let rec colors = - ANSITerminal.blue - :: ANSITerminal.cyan - :: ANSITerminal.green - :: ANSITerminal.yellow - :: ANSITerminal.red - :: ANSITerminal.magenta - :: colors + let open Ocolor_types in + blue :: cyan :: green :: yellow :: red :: magenta :: colors let typ_debug = typ None let typ ctx = typ (Some ctx) diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 0bc11d56..08c69c42 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -177,35 +177,27 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 = let t2_repr = UnionFind.get (UnionFind.find t2) in let t1_pos = Mark.get t1_repr in let t2_pos = Mark.get t2_repr in - let unformat_typ typ = - let buf = Buffer.create 59 in - let ppf = Format.formatter_of_buffer buf in - (* set infinite width to disable line cuts *) - Format.pp_set_margin ppf max_int; - format_typ ctx ppf typ; - Format.pp_print_flush ppf (); - Buffer.contents buf - in - let t1_s fmt () = - Cli.format_with_style [ANSITerminal.yellow] fmt (unformat_typ t1) - in - let t2_s fmt () = - Cli.format_with_style [ANSITerminal.yellow] fmt (unformat_typ t2) - in - Messages.raise_multispanned_error + Messages.raise_multispanned_error_full [ ( Some - (Format.asprintf - "Error coming from typechecking the following expression:"), + (fun ppf -> + Format.pp_print_string ppf + "Error coming from typechecking the following expression:"), Expr.pos e ); - Some (Format.asprintf "Type %a coming from expression:" t1_s ()), t1_pos; - Some (Format.asprintf "Type %a coming from expression:" t2_s ()), t2_pos; + ( Some + (fun ppf -> + Format.fprintf ppf "Type @{%a@} coming from expression:" + (format_typ ctx) t1), + t1_pos ); + ( Some + (fun ppf -> + Format.fprintf ppf "Type @{%a@} coming from expression:" + (format_typ ctx) t2), + t2_pos ); ] - "Error during typechecking, incompatible types:\n%a %a\n%a %a" - (Cli.format_with_style [ANSITerminal.blue; ANSITerminal.Bold]) - "-->" t1_s () - (Cli.format_with_style [ANSITerminal.blue; ANSITerminal.Bold]) - "-->" t2_s () + "@[Error during typechecking, incompatible types:@,\ + @{-->@} @[%a@]@,\ + @{-->@} @[%a@]@]" (format_typ ctx) t1 (format_typ ctx) t2 let lit_type (lit : A.lit) : naked_typ = match lit with @@ -470,28 +462,22 @@ and typecheck_expr_top_down : with Not_found -> Messages.raise_spanned_error (Expr.mark_pos context_mark) - "Field %a does not belong to structure %a (no structure defines \ - it)" - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ field ^ "\"") - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" A.StructName.format_t name) + "Field @{\"%s\"@} does not belong to structure \ + @{\"%a\"@} (no structure defines it)" + field A.StructName.format_t name in try A.StructName.Map.find name candidate_structs with Not_found -> Messages.raise_spanned_error (Expr.mark_pos context_mark) - "Field %a does not belong to structure %a, but to %a" - (Cli.format_with_style [ANSITerminal.yellow]) - ("\"" ^ field ^ "\"") - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" A.StructName.format_t name) + "@[Field @{\"%s\"@}@ does not belong to@ structure \ + @{\"%a\"@},@ but to %a@]" + field A.StructName.format_t name (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ or@ ") (fun fmt s_name -> - Format.fprintf fmt "%a" - (Cli.format_with_style [ANSITerminal.yellow]) - (Format.asprintf "\"%a\"" A.StructName.format_t s_name))) + Format.fprintf fmt "@{\"%a\"@}" A.StructName.format_t + s_name)) (List.map fst (A.StructName.Map.bindings candidate_structs)) in A.StructField.Map.find field str diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index 4e1e48cb..d501abda 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -98,7 +98,7 @@ let rec law_struct_list_to_tree (f : Ast.law_structure list) : LawHeading (heading, gobbled) :: rest_out)) (** Style with which to display syntax hints in the terminal output *) -let syntax_hints_style = [ANSITerminal.yellow] +let pp_hint ppf s = Format.fprintf ppf "@{\"%s\"@}" s (** Usage: [raise_parser_error error_loc last_good_loc token msg] @@ -110,17 +110,18 @@ let raise_parser_error (error_loc : Pos.t) (last_good_loc : Pos.t option) (token : string) - (msg : string) : 'a = - Messages.raise_multispanned_error - ((Some "Error token:", error_loc) + (msg : Format.formatter -> unit) : 'a = + Messages.raise_multispanned_error_full + ((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc) :: (match last_good_loc with | None -> [] - | Some last_good_loc -> [Some "Last good token:", last_good_loc])) - "Syntax error at token %a\n%s" - (Cli.format_with_style syntax_hints_style) - (Printf.sprintf "\"%s\"" token) - msg + | Some last_good_loc -> + [ + ( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"), + last_good_loc ); + ])) + "@[Syntax error at token %a@,%t@]" pp_hint token msg module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct include Parser.Make (LocalisedLexer) @@ -179,32 +180,32 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct acceptable_tokens in let similar_token_msg = - if List.length similar_acceptable_tokens = 0 then None - else + match similar_acceptable_tokens with + | [] -> None + | tokens -> Some - (Printf.sprintf "did you mean %s?" - (String.concat ", or maybe " - (List.map - (fun (ts, _) -> - Cli.with_style syntax_hints_style "\"%s\"" ts) - similar_acceptable_tokens))) + (fun ppf -> + Format.fprintf ppf "did you mean %a?" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ or@ maybe@ ") + (fun ppf (ts, _) -> pp_hint ppf ts)) + tokens) in (* The parser has suspended itself because of a syntax error. Stop. *) - let custom_menhir_message = + let custom_menhir_message ppf = match Parser_errors.message (state env) with | exception Not_found -> - "Message: " ^ Cli.with_style syntax_hints_style "%s" "unexpected token" + Format.fprintf ppf "Message: @{unexpected token@}" | msg -> - "Message: " - ^ Cli.with_style syntax_hints_style "%s" - (String.trim (String.uncapitalize_ascii msg)) + Format.fprintf ppf "Message: @{%s@}" + (String.trim (String.uncapitalize_ascii msg)) in - let msg = + let msg ppf = match similar_token_msg with - | None -> custom_menhir_message + | None -> custom_menhir_message ppf | Some similar_token_msg -> - Printf.sprintf "%s\nAutosuggestion: %s" custom_menhir_message - similar_token_msg + Format.fprintf ppf "@[%t@,@[Autosuggestion: %t@]@]" + custom_menhir_message similar_token_msg in raise_parser_error (Pos.from_lpos (lexing_positions lexbuf)) diff --git a/compiler/verification/io.ml b/compiler/verification/io.ml index 853d054b..143782ee 100644 --- a/compiler/verification/io.ml +++ b/compiler/verification/io.ml @@ -99,18 +99,20 @@ module MakeBackendIO (B : Backend) = struct let var_and_pos = match vc.Conditions.vc_kind with | Conditions.NoEmptyError -> - Format.asprintf "%s This variable might return an empty error:\n%s" - (Cli.with_style [ANSITerminal.yellow] "[%s.%s]" - (Format.asprintf "%a" ScopeName.format_t vc.vc_scope) - (Bindlib.name_of (Mark.remove vc.vc_variable))) - (Pos.retrieve_loc_text (Mark.get vc.vc_variable)) + Format.asprintf + "@[@{[%a.%s]@} This variable might return an empty error:@,\ + %a@]" + ScopeName.format_t vc.vc_scope + (Bindlib.name_of (Mark.remove vc.vc_variable)) + Pos.format_loc_text (Mark.get vc.vc_variable) | Conditions.NoOverlappingExceptions -> Format.asprintf - "%s At least two exceptions overlap for this variable:\n%s" - (Cli.with_style [ANSITerminal.yellow] "[%s.%s]" - (Format.asprintf "%a" ScopeName.format_t vc.vc_scope) - (Bindlib.name_of (Mark.remove vc.vc_variable))) - (Pos.retrieve_loc_text (Mark.get vc.vc_variable)) + "@[@{[%a.%s]@} At least two exceptions overlap for this \ + variable:@,\ + %a@]" + ScopeName.format_t vc.vc_scope + (Bindlib.name_of (Mark.remove vc.vc_variable)) + Pos.format_loc_text (Mark.get vc.vc_variable) in let counterexample : string option = if !Cli.disable_counterexamples then @@ -142,14 +144,13 @@ module MakeBackendIO (B : Backend) = struct (vc : Conditions.verification_condition * vc_encoding_result) : bool = let vc, z3_vc = vc in - Messages.emit_debug "For this variable:\n%s\n" - (Pos.retrieve_loc_text (Expr.pos vc.Conditions.vc_guard)); + Messages.emit_debug "@[For this variable:@,%a@,@]" Pos.format_loc_text + (Expr.pos vc.Conditions.vc_guard); Messages.emit_debug - "This verification condition was generated for %a:@\n\ - %a@\n\ - with assertions:@\n\ - %a" - (Cli.format_with_style [ANSITerminal.yellow]) + "@[This verification condition was generated for @{%s@}:@,\ + %a@,\ + with assertions:@,\ + %a@]" (match vc.vc_kind with | Conditions.NoEmptyError -> "the variable definition never to return an empty error" @@ -158,7 +159,7 @@ module MakeBackendIO (B : Backend) = struct match z3_vc with | Success (encoding, backend_ctx) -> ( - Messages.emit_debug "The translation to Z3 is the following:\n%s" + Messages.emit_debug "@[The translation to Z3 is the following:@,%s@]" (B.print_encoding encoding); match B.solve_vc_encoding backend_ctx encoding with | ProvenTrue -> true @@ -167,10 +168,10 @@ module MakeBackendIO (B : Backend) = struct false | Unknown -> failwith "The solver failed at proving or disproving the VC") | Fail msg -> - Messages.emit_warning "%s The translation to Z3 failed:\n%s" - (Cli.with_style [ANSITerminal.yellow] "[%s.%s]" - (Format.asprintf "%a" ScopeName.format_t vc.vc_scope) - (Bindlib.name_of (Mark.remove vc.vc_variable))) + Messages.emit_warning + "@[@{[%a.%s]@} The translation to Z3 failed:@,%s@]" + ScopeName.format_t vc.vc_scope + (Bindlib.name_of (Mark.remove vc.vc_variable)) msg; false end diff --git a/compiler/verification/z3backend.real.ml b/compiler/verification/z3backend.real.ml index bad2d8bc..d1a3a31e 100644 --- a/compiler/verification/z3backend.real.ml +++ b/compiler/verification/z3backend.real.ml @@ -229,9 +229,8 @@ let print_model (ctx : context) (model : Model.model) : string = match StringMap.find_opt symbol_name ctx.ctx_z3vars with | None -> () | Some (v, ty) -> - Format.fprintf fmt "%s %s : %s\n" - (Cli.with_style [ANSITerminal.blue] "%s" "-->") - (Cli.with_style [ANSITerminal.yellow] "%s" (Bindlib.name_of v)) + Format.fprintf fmt "@{-->@} @{%s@} : %s\n" + (Bindlib.name_of v) (print_z3model_expr ctx ty e)) else (* Declaration d is a function *) @@ -244,9 +243,8 @@ let print_model (ctx : context) (model : Model.model) : string = | Some f -> let symbol_name = Symbol.to_string (FuncDecl.get_name d) in let v, _ = StringMap.find symbol_name ctx.ctx_z3vars in - Format.fprintf fmt "%s %s : %s" - (Cli.with_style [ANSITerminal.blue] "%s" "-->") - (Cli.with_style [ANSITerminal.yellow] "%s" (Bindlib.name_of v)) + Format.fprintf fmt "@{-->@} @{%s@} : %s\n" + (Bindlib.name_of v) (* TODO: Model of a Z3 function should be pretty-printed *) (Model.FuncInterp.to_string f))) decls diff --git a/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en b/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en index 5c2e2463..c2972880 100644 --- a/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en +++ b/examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en @@ -29,8 +29,8 @@ scope Test1: ```catala-test-inline $ catala Interpret -s Test1 [ERROR] Syntax error at token "scope" -Message: expected either 'condition', or 'content' followed by the expected variable type -Autosuggestion: did you mean "content", or maybe "condition"? + Message: expected either 'condition', or 'content' followed by the expected variable type + Autosuggestion: did you mean "content", or maybe "condition"? Error token: ┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.21-11.26: @@ -73,8 +73,8 @@ scope Test2: ```catala-test-inline $ catala Interpret -s Test2 [ERROR] Syntax error at token "scope" -Message: expected either 'condition', or 'content' followed by the expected variable type -Autosuggestion: did you mean "content", or maybe "condition"? + Message: expected either 'condition', or 'content' followed by the expected variable type + Autosuggestion: did you mean "content", or maybe "condition"? Error token: ┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.21-11.26: @@ -117,8 +117,8 @@ scope Test3: ```catala-test-inline $ catala Interpret -s Test3 [ERROR] Syntax error at token "scope" -Message: expected either 'condition', or 'content' followed by the expected variable type -Autosuggestion: did you mean "content", or maybe "condition"? + Message: expected either 'condition', or 'content' followed by the expected variable type + Autosuggestion: did you mean "content", or maybe "condition"? Error token: ┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.21-11.26: @@ -163,8 +163,8 @@ scope Test4: ```catala-test-inline $ catala Interpret -s Test4 [ERROR] Syntax error at token "scope" -Message: expected either 'condition', or 'content' followed by the expected variable type -Autosuggestion: did you mean "content", or maybe "condition"? + Message: expected either 'condition', or 'content' followed by the expected variable type + Autosuggestion: did you mean "content", or maybe "condition"? Error token: ┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.21-11.26: diff --git a/french_law/catala_legifrance/catala_legifrance.ml b/french_law/catala_legifrance/catala_legifrance.ml index 92eda991..a0070fe0 100644 --- a/french_law/catala_legifrance/catala_legifrance.ml +++ b/french_law/catala_legifrance/catala_legifrance.ml @@ -113,20 +113,16 @@ let compare_to_versions (law_article_text : law_article_text) (access_token : Api.access_token) : unit Lwt.t = let print_diff msg diff = - Messages.emit_warning "%s\n%s" msg - (String.concat "\n" - (List.map - (fun chunk -> - match chunk with - | Diff.Equal words -> - ANSITerminal.sprintf [] " %s" (String.concat " " words) - | Diff.Added words -> - ANSITerminal.sprintf [ANSITerminal.green] "(+) %s" - (String.concat " " words) - | Diff.Deleted words -> - ANSITerminal.sprintf [ANSITerminal.red] "(-) %s" - (String.concat " " words)) - diff)) + Messages.emit_warning "@[%s@,%a@]" msg + (Format.pp_print_list (fun ppf chunk -> + match chunk with + | Diff.Equal words -> + Format.fprintf ppf " %s" (String.concat " " words) + | Diff.Added words -> + Format.fprintf ppf "@{(+) %s@}" (String.concat " " words) + | Diff.Deleted words -> + Format.fprintf ppf "@{(-) %s@}" (String.concat " " words))) + diff in let* _checl = match law_article_text.current_version with diff --git a/french_law/catala_legifrance/dune b/french_law/catala_legifrance/dune index 61bff043..a63a7a45 100644 --- a/french_law/catala_legifrance/dune +++ b/french_law/catala_legifrance/dune @@ -10,7 +10,7 @@ cohttp-lwt-unix yojson re - ANSITerminal)) + ocolor)) (documentation (package catala_legifrance)) diff --git a/french_law/ocaml/law_source/unit_tests/dune b/french_law/ocaml/law_source/unit_tests/dune index cb7cc2a4..a3b5a5c3 100644 --- a/french_law/ocaml/law_source/unit_tests/dune +++ b/french_law/ocaml/law_source/unit_tests/dune @@ -1,7 +1,7 @@ (executable (name run_tests) (modes native) - (libraries catala.runtime_ocaml ANSITerminal)) + (libraries catala.runtime_ocaml ocolor)) (copy_files# ../../../../examples/allocations_familiales/tests/tests_allocations_familiales.ml) diff --git a/french_law/ocaml/law_source/unit_tests/run_tests.ml b/french_law/ocaml/law_source/unit_tests/run_tests.ml index 95476666..556a30a8 100644 --- a/french_law/ocaml/law_source/unit_tests/run_tests.ml +++ b/french_law/ocaml/law_source/unit_tests/run_tests.ml @@ -3,14 +3,10 @@ let failure = ref false let try_test msg test = try test (); - Format.printf "%s %s\n" - (ANSITerminal.sprintf [ANSITerminal.green] "PASS") - (ANSITerminal.sprintf [ANSITerminal.magenta] msg) + Format.printf "@{PASS@} @{%s@}\n" msg with Runtime_ocaml.Runtime.AssertionFailed _ -> failure := true; - Format.printf "%s %s\n" - (ANSITerminal.sprintf [ANSITerminal.red] "FAIL") - (ANSITerminal.sprintf [ANSITerminal.magenta] msg) + Format.printf "@{FAIL@} @{%s@}\n" msg let _ = try_test "Allocations familiales #1" Tests_allocations_familiales.test1; diff --git a/tests/test_array/bad/fold_error.catala_en b/tests/test_array/bad/fold_error.catala_en index 9c399559..9755a2cf 100644 --- a/tests/test_array/bad/fold_error.catala_en +++ b/tests/test_array/bad/fold_error.catala_en @@ -12,8 +12,7 @@ scope A: ```catala-test-inline $ catala Interpret -s A -[ERROR] I don't know how to apply operator >= on types integer and -money +[ERROR] I don't know how to apply operator >= on types integer and money ┌─⯈ tests/test_array/bad/fold_error.catala_en:10.50-10.52: └──┐ diff --git a/tests/test_array/good/aggregation_2.catala_en b/tests/test_array/good/aggregation_2.catala_en index 13686fd3..0e0c7128 100644 --- a/tests/test_array/good/aggregation_2.catala_en +++ b/tests/test_array/good/aggregation_2.catala_en @@ -32,7 +32,8 @@ scope B: ```catala-test-inline $ catala Interpret -s A [RESULT] Computation successful! Results: -[RESULT] x = +[RESULT] +x = [ { S id = 0; income = $0.00; }; { S id = 1; income = $9.00; }; { S id = 2; income = $5.20; } ] @@ -47,7 +48,8 @@ $ catala Interpret -s B ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = +[RESULT] +x = ESome [ ESome { S id = ESome 0; income = ESome $0.00; }; ESome { S id = ESome 1; income = ESome $9.00; }; diff --git a/tests/test_array/good/concatenation.catala_en b/tests/test_array/good/concatenation.catala_en index 12e187ec..6568f705 100644 --- a/tests/test_array/good/concatenation.catala_en +++ b/tests/test_array/good/concatenation.catala_en @@ -19,8 +19,10 @@ $ catala Interpret -s A ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = ESome [ ESome 0; ESome 1; ESome 2; ESome 3; ESome 4; ESome 5; ESome 6 ] -[RESULT] y = +[RESULT] +x = ESome [ ESome 0; ESome 1; ESome 2; ESome 3; ESome 4; ESome 5; ESome 6 ] +[RESULT] +y = ESome [ ESome 0; ESome 1; diff --git a/tests/test_array/good/fold.catala_en b/tests/test_array/good/fold.catala_en index 13686fd3..0e0c7128 100644 --- a/tests/test_array/good/fold.catala_en +++ b/tests/test_array/good/fold.catala_en @@ -32,7 +32,8 @@ scope B: ```catala-test-inline $ catala Interpret -s A [RESULT] Computation successful! Results: -[RESULT] x = +[RESULT] +x = [ { S id = 0; income = $0.00; }; { S id = 1; income = $9.00; }; { S id = 2; income = $5.20; } ] @@ -47,7 +48,8 @@ $ catala Interpret -s B ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] x = +[RESULT] +x = ESome [ ESome { S id = ESome 0; income = ESome $0.00; }; ESome { S id = ESome 1; income = ESome $9.00; }; diff --git a/tests/test_bool/bad/bad_assert.catala_en b/tests/test_bool/bad/bad_assert.catala_en index fe95049d..8bb4eb4d 100644 --- a/tests/test_bool/bad/bad_assert.catala_en +++ b/tests/test_bool/bad/bad_assert.catala_en @@ -13,8 +13,8 @@ scope Foo: ```catala-test-inline $ catala Interpret -s Foo [ERROR] Error during typechecking, incompatible types: ---> integer ---> bool + --> integer + --> bool Error coming from typechecking the following expression: ┌─⯈ tests/test_bool/bad/bad_assert.catala_en:9.13-9.14: diff --git a/tests/test_bool/bad/test_xor_with_int.catala_en b/tests/test_bool/bad/test_xor_with_int.catala_en index 99816caf..8cf7e0da 100644 --- a/tests/test_bool/bad/test_xor_with_int.catala_en +++ b/tests/test_bool/bad/test_xor_with_int.catala_en @@ -11,8 +11,8 @@ scope TestXorWithInt: ```catala-test-inline $ catala Typecheck [ERROR] Error during typechecking, incompatible types: ---> integer ---> bool + --> integer + --> bool Error coming from typechecking the following expression: ┌─⯈ tests/test_bool/bad/test_xor_with_int.catala_en:8.30-8.32: diff --git a/tests/test_dec/good/infinite_precision.catala_en b/tests/test_dec/good/infinite_precision.catala_en index c73ea8b0..86a03ec5 100644 --- a/tests/test_dec/good/infinite_precision.catala_en +++ b/tests/test_dec/good/infinite_precision.catala_en @@ -17,7 +17,8 @@ scope A: ```catala-test-inline $ catala Interpret -s A [RESULT] Computation successful! Results: -[RESULT] a = +[RESULT] +a = -0.000000000000000000000000000000000000000000000000000000000078695580959228473468… [RESULT] x = 84.64866565265689623 [RESULT] y = -4.3682977870532065498 @@ -26,7 +27,8 @@ $ catala Interpret -s A ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] a = +[RESULT] +a = ESome -0.000000000000000000000000000000000000000000000000000000000078695580959228473468… [RESULT] x = ESome 84.64866565265689623 diff --git a/tests/test_enum/bad/quick_pattern_2.catala_en b/tests/test_enum/bad/quick_pattern_2.catala_en index 967df6ce..cd61ebab 100644 --- a/tests/test_enum/bad/quick_pattern_2.catala_en +++ b/tests/test_enum/bad/quick_pattern_2.catala_en @@ -31,8 +31,8 @@ scope B: ```catala-test-inline $ catala Interpret -s A [ERROR] Error during typechecking, incompatible types: ---> E ---> F + --> E + --> F Error coming from typechecking the following expression: ┌─⯈ tests/test_enum/bad/quick_pattern_2.catala_en:28.23-28.24: diff --git a/tests/test_enum/bad/quick_pattern_3.catala_en b/tests/test_enum/bad/quick_pattern_3.catala_en index d5b2f13f..b7f5a54a 100644 --- a/tests/test_enum/bad/quick_pattern_3.catala_en +++ b/tests/test_enum/bad/quick_pattern_3.catala_en @@ -21,8 +21,8 @@ definition y equals x with pattern Case3 ```catala-test-inline $ catala Interpret -s A [ERROR] Error during typechecking, incompatible types: ---> E ---> F + --> E + --> F Error coming from typechecking the following expression: ┌─⯈ tests/test_enum/bad/quick_pattern_3.catala_en:18.21-18.22: diff --git a/tests/test_enum/bad/quick_pattern_4.catala_en b/tests/test_enum/bad/quick_pattern_4.catala_en index 689ac8f0..40789fc3 100644 --- a/tests/test_enum/bad/quick_pattern_4.catala_en +++ b/tests/test_enum/bad/quick_pattern_4.catala_en @@ -20,8 +20,8 @@ definition y equals x with pattern Case3 ```catala-test-inline $ catala Interpret -s A [ERROR] Error during typechecking, incompatible types: ---> E ---> F + --> E + --> F Error coming from typechecking the following expression: ┌─⯈ tests/test_enum/bad/quick_pattern_4.catala_en:17.21-17.22: diff --git a/tests/test_exception/good/groups_of_exceptions.catala_en b/tests/test_exception/good/groups_of_exceptions.catala_en index 830e3a3c..6084643e 100644 --- a/tests/test_exception/good/groups_of_exceptions.catala_en +++ b/tests/test_exception/good/groups_of_exceptions.catala_en @@ -46,8 +46,10 @@ let scope Foo (y: integer|input) (x: integer|internal|output) = ```catala-test-inline $ catala Exceptions -s Foo -v x -[RESULT] Printing the tree of exceptions for the definitions of variable "x" of scope "Foo". -[RESULT] Definitions with label "base": +[RESULT] +Printing the tree of exceptions for the definitions of variable "x" of scope "Foo". +[RESULT] +Definitions with label "base": ┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:9.3-9.26: └─┐ 9 │ label base definition x under condition @@ -58,7 +60,8 @@ $ catala Exceptions -s Foo -v x 13 │ label base definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test -[RESULT] Definitions with label "intermediate": +[RESULT] +Definitions with label "intermediate": ┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:17.3-17.49: └──┐ 17 │ label intermediate exception base definition x under condition @@ -69,7 +72,8 @@ $ catala Exceptions -s Foo -v x 21 │ label intermediate exception base definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test -[RESULT] Definitions with label "exception_to_intermediate": +[RESULT] +Definitions with label "exception_to_intermediate": ┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:25.3-25.38: └──┐ 25 │ exception intermediate definition x under condition @@ -80,7 +84,8 @@ $ catala Exceptions -s Foo -v x 29 │ exception intermediate definition x under condition │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └─ Test -[RESULT] The exception tree structure is as follows: +[RESULT] +The exception tree structure is as follows: "base"───"intermediate"───"exception_to_intermediate" ``` diff --git a/tests/test_money/bad/no_mingle.catala_en b/tests/test_money/bad/no_mingle.catala_en index 776f6ef7..f24c5cb5 100644 --- a/tests/test_money/bad/no_mingle.catala_en +++ b/tests/test_money/bad/no_mingle.catala_en @@ -14,8 +14,7 @@ scope A: ```catala-test-inline $ catala Interpret -s A -[ERROR] I don't know how to apply operator * on types money and -money +[ERROR] I don't know how to apply operator * on types money and money ┌─⯈ tests/test_money/bad/no_mingle.catala_en:12.26-12.27: └──┐ diff --git a/tests/test_name_resolution/good/let_in.catala_en b/tests/test_name_resolution/good/let_in.catala_en index 04282d27..e12dc28a 100644 --- a/tests/test_name_resolution/good/let_in.catala_en +++ b/tests/test_name_resolution/good/let_in.catala_en @@ -53,7 +53,8 @@ $ catala Interpret -s S2 ```catala-test-inline $ catala Interpret_Lcalc -s S --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] a = +[RESULT] +a = ESome { A x = ESome -2.; y = ESome { B y = ESome false; z = ESome -1.; }; } [RESULT] b = ESome { B y = ESome true; z = ESome 42.; } ``` diff --git a/tests/test_name_resolution/good/out_of_order.catala_en b/tests/test_name_resolution/good/out_of_order.catala_en index 17a4e3a1..aa281581 100644 --- a/tests/test_name_resolution/good/out_of_order.catala_en +++ b/tests/test_name_resolution/good/out_of_order.catala_en @@ -27,6 +27,7 @@ $ catala Interpret -s S ```catala-test-inline $ catala Interpret_Lcalc -s S --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] a = ESome { A x = ESome 0; y = ESome { B y = ESome true; z = ESome 0.; }; } +[RESULT] +a = ESome { A x = ESome 0; y = ESome { B y = ESome true; z = ESome 0.; }; } [RESULT] b = ESome { B y = ESome true; z = ESome 0.; } ``` diff --git a/tests/test_scope/bad/cycle_in_scope.catala_en b/tests/test_scope/bad/cycle_in_scope.catala_en index 423116b8..00b4119a 100644 --- a/tests/test_scope/bad/cycle_in_scope.catala_en +++ b/tests/test_scope/bad/cycle_in_scope.catala_en @@ -17,7 +17,7 @@ scope A: ```catala-test-inline $ catala Interpret -s A [ERROR] Cyclic dependency detected between the following variables of scope A: - z → x → y → z + z → x → y → z z is used here in the definition of x: ┌─⯈ tests/test_scope/bad/cycle_in_scope.catala_en:14.23-14.24: diff --git a/tests/test_scope/bad/cyclic_scope_calls.catala_en b/tests/test_scope/bad/cyclic_scope_calls.catala_en index 50391b75..073a6c07 100644 --- a/tests/test_scope/bad/cyclic_scope_calls.catala_en +++ b/tests/test_scope/bad/cyclic_scope_calls.catala_en @@ -29,7 +29,7 @@ scope S4: ```catala-test-inline $ catala typecheck [ERROR] Cyclic dependency detected between the following scopes: - S4 → S3 → S2 → S4 + S4 → S3 → S2 → S4 S4 is used here in the definition of S3: ┌─⯈ tests/test_scope/bad/cyclic_scope_calls.catala_en:21.24-21.36: diff --git a/tests/test_scope/bad/cyclic_scopes.catala_en b/tests/test_scope/bad/cyclic_scopes.catala_en index 32f258fa..e4eff437 100644 --- a/tests/test_scope/bad/cyclic_scopes.catala_en +++ b/tests/test_scope/bad/cyclic_scopes.catala_en @@ -18,7 +18,8 @@ scope B: ```catala-test-inline $ catala Interpret -s A -[ERROR] Cyclic dependency detected between the following scopes: B → A → B +[ERROR] Cyclic dependency detected between the following scopes: + B → A → B B is used here in the definition of A: ┌─⯈ tests/test_scope/bad/cyclic_scopes.catala_en:5.3-5.4: diff --git a/tests/test_scope/good/scope_call3.catala_en b/tests/test_scope/good/scope_call3.catala_en index 36f86f8a..c5931ac7 100644 --- a/tests/test_scope/good/scope_call3.catala_en +++ b/tests/test_scope/good/scope_call3.catala_en @@ -20,47 +20,47 @@ scope RentComputation: $ catala Interpret -t -s HousingComputation [LOG] ≔ HousingComputation.f: [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:8.14-8.20: - └─┐ - 8 │ definition result equals f of 1 - │ ‾‾‾‾‾‾ - + ┌─⯈ tests/test_scope/good/scope_call3.catala_en:8.14-8.20: + └─┐ + 8 │ definition result equals f of 1 + │ ‾‾‾‾‾‾ + [LOG] → HousingComputation.f [LOG] ≔ HousingComputation.f.input0: 1 [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:7.14-7.15: - └─┐ - 7 │ definition f of x equals (output of RentComputation).f of x - │ ‾ - + ┌─⯈ tests/test_scope/good/scope_call3.catala_en:7.14-7.15: + └─┐ + 7 │ definition f of x equals (output of RentComputation).f of x + │ ‾ + [LOG] → RentComputation.direct [LOG] ≔ RentComputation.direct.input: {RentComputation_in} [LOG] ≔ RentComputation.g: [LOG] ≔ RentComputation.f: [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:7.29-7.54: - └─┐ - 7 │ definition f of x equals (output of RentComputation).f of x - │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ - + ┌─⯈ tests/test_scope/good/scope_call3.catala_en:7.29-7.54: + └─┐ + 7 │ definition f of x equals (output of RentComputation).f of x + │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + [LOG] ≔ RentComputation.direct.output: { RentComputation f = ; } [LOG] ← RentComputation.direct [LOG] → RentComputation.f [LOG] ≔ RentComputation.f.input0: 1 [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:16.14-16.15: - └──┐ - 16 │ definition f of x equals g of (x + 1) - │ ‾ - + ┌─⯈ tests/test_scope/good/scope_call3.catala_en:16.14-16.15: + └──┐ + 16 │ definition f of x equals g of (x + 1) + │ ‾ + [LOG] → RentComputation.g [LOG] ≔ RentComputation.g.input0: 2 [LOG] ☛ Definition applied: - ┌─⯈ tests/test_scope/good/scope_call3.catala_en:15.14-15.15: - └──┐ - 15 │ definition g of x equals x + 1 - │ ‾ - + ┌─⯈ tests/test_scope/good/scope_call3.catala_en:15.14-15.15: + └──┐ + 15 │ definition g of x equals x + 1 + │ ‾ + [LOG] ≔ RentComputation.g.output: 3 [LOG] ← RentComputation.g [LOG] ≔ RentComputation.f.output: 3 @@ -69,7 +69,8 @@ $ catala Interpret -t -s HousingComputation [LOG] ← HousingComputation.f [LOG] ≔ HousingComputation.result: 3 [RESULT] Computation successful! Results: -[RESULT] f = λ (x: integer) → +[RESULT] +f = λ (x: integer) → error_empty ⟨true ⊢ (let result : RentComputation = diff --git a/tests/test_scope/good/scope_call4.catala_en b/tests/test_scope/good/scope_call4.catala_en index 695a8fe7..c1a0a6b4 100644 --- a/tests/test_scope/good/scope_call4.catala_en +++ b/tests/test_scope/good/scope_call4.catala_en @@ -25,10 +25,12 @@ scope RentComputation: ```catala-test-inline $ catala Interpret -s RentComputation [RESULT] Computation successful! Results: -[RESULT] f1 = λ (x: integer) → +[RESULT] +f1 = λ (x: integer) → error_empty ⟨true ⊢ let x1 : integer = x + 1 in error_empty ⟨true ⊢ x1 + 1⟩⟩ -[RESULT] f2 = λ (x: integer) → +[RESULT] +f2 = λ (x: integer) → error_empty ⟨true ⊢ let x1 : integer = x + 1 in error_empty ⟨true ⊢ x1 + 1⟩⟩ ``` @@ -36,7 +38,8 @@ $ catala Interpret -s RentComputation ```catala-test-inline $ catala Interpret_Lcalc -s RentComputation --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] f1 = +[RESULT] +f1 = ESome (λ (x: integer) → ESome @@ -47,7 +50,8 @@ $ catala Interpret_Lcalc -s RentComputation --avoid_exceptions --optimize with | ENone f1 → raise NoValueProvided | ESome x1 → x1) -[RESULT] f2 = +[RESULT] +f2 = ESome (λ (x: integer) → ESome diff --git a/tests/test_struct/good/nested3.catala_en b/tests/test_struct/good/nested3.catala_en index 13f4f7a8..8b023377 100644 --- a/tests/test_struct/good/nested3.catala_en +++ b/tests/test_struct/good/nested3.catala_en @@ -49,7 +49,8 @@ $ catala Interpret -s B ```catala-test-inline $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize [RESULT] Computation successful! Results: -[RESULT] t = +[RESULT] +t = ESome { T a = ESome { S x = ESome 0; y = ESome false; }; @@ -60,7 +61,8 @@ $ catala Interpret_Lcalc -s A --avoid_exceptions --optimize $ catala Interpret_Lcalc -s B --avoid_exceptions --optimize [RESULT] Computation successful! Results: [RESULT] out = ESome 1 -[RESULT] t = +[RESULT] +t = ESome { T a = ESome { S x = ESome 0; y = ESome false; }; diff --git a/tests/test_typing/bad/err1.catala_en b/tests/test_typing/bad/err1.catala_en index 231881d4..701b64d3 100644 --- a/tests/test_typing/bad/err1.catala_en +++ b/tests/test_typing/bad/err1.catala_en @@ -13,8 +13,8 @@ scope S: ```catala-test-inline $ catala Typecheck [ERROR] Error during typechecking, incompatible types: ---> decimal ---> integer + --> decimal + --> integer Error coming from typechecking the following expression: ┌─⯈ tests/test_typing/bad/err1.catala_en:7.23-7.26: diff --git a/tests/test_typing/bad/err2.catala_en b/tests/test_typing/bad/err2.catala_en index e1f4fa92..2a0a2e70 100644 --- a/tests/test_typing/bad/err2.catala_en +++ b/tests/test_typing/bad/err2.catala_en @@ -13,8 +13,8 @@ scope S: ```catala-test-inline $ catala Typecheck [ERROR] Error during typechecking, incompatible types: ---> decimal ---> collection + --> decimal + --> collection Error coming from typechecking the following expression: ┌─⯈ tests/test_typing/bad/err2.catala_en:10.39-10.42: diff --git a/tests/test_typing/bad/err3.catala_en b/tests/test_typing/bad/err3.catala_en index a93dcae7..faf420a2 100644 --- a/tests/test_typing/bad/err3.catala_en +++ b/tests/test_typing/bad/err3.catala_en @@ -20,8 +20,8 @@ $ catala Typecheck │ ‾‾‾ [ERROR] Error during typechecking, incompatible types: ---> integer ---> decimal + --> integer + --> decimal Error coming from typechecking the following expression: ┌─⯈ tests/test_typing/bad/err3.catala_en:10.42-10.43: @@ -58,8 +58,8 @@ $ catala ocaml │ ‾‾‾ [ERROR] Error during typechecking, incompatible types: ---> integer ---> decimal + --> integer + --> decimal Error coming from typechecking the following expression: ┌─⯈ tests/test_typing/bad/err3.catala_en:10.42-10.43: diff --git a/tests/test_typing/bad/err4.catala_en b/tests/test_typing/bad/err4.catala_en index 26d33243..935612c7 100644 --- a/tests/test_typing/bad/err4.catala_en +++ b/tests/test_typing/bad/err4.catala_en @@ -32,8 +32,8 @@ $ catala ocaml │ ‾‾‾ [ERROR] Error during typechecking, incompatible types: ---> Enum ---> Structure + --> Enum + --> Structure Error coming from typechecking the following expression: ┌─⯈ tests/test_typing/bad/err4.catala_en:5.25-5.38: diff --git a/tests/test_typing/bad/err5.catala_en b/tests/test_typing/bad/err5.catala_en index 5bbafb91..c7baf456 100644 --- a/tests/test_typing/bad/err5.catala_en +++ b/tests/test_typing/bad/err5.catala_en @@ -13,8 +13,8 @@ scope S: ```catala-test-inline $ catala Typecheck [ERROR] Error during typechecking, incompatible types: ---> integer ---> Structure + --> integer + --> Structure Error coming from typechecking the following expression: ┌─⯈ tests/test_typing/bad/err5.catala_en:8.5-8.9: diff --git a/tests/test_typing/bad/err6.catala_en b/tests/test_typing/bad/err6.catala_en index 69ea3669..f072d57d 100644 --- a/tests/test_typing/bad/err6.catala_en +++ b/tests/test_typing/bad/err6.catala_en @@ -29,8 +29,8 @@ Should be "catala Typecheck", see test err3 ```catala-test-inline $ catala ocaml [ERROR] Error during typechecking, incompatible types: ---> decimal ---> integer + --> decimal + --> integer Error coming from typechecking the following expression: ┌─⯈ tests/test_typing/bad/err6.catala_en:20.27-20.30: diff --git a/tests/test_variable_state/bad/state_cycle.catala_en b/tests/test_variable_state/bad/state_cycle.catala_en index bc399a49..9d491093 100644 --- a/tests/test_variable_state/bad/state_cycle.catala_en +++ b/tests/test_variable_state/bad/state_cycle.catala_en @@ -22,7 +22,7 @@ scope A: ```catala-test-inline $ catala Typecheck [ERROR] Cyclic dependency detected between the following variables of scope A: - foofoo@bar → foofoo@baz → foo@bar → foo@baz → foofoo@bar + foofoo@bar → foofoo@baz → foo@bar → foo@baz → foofoo@bar foofoo@bar is used here in the definition of foofoo@baz: ┌─⯈ tests/test_variable_state/bad/state_cycle.catala_en:19.38-19.44: