CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Switch from ANSITerminal to ocolor (#474)

Browse Source
This commit is contained in:
Louis Gesbert 2023-06-09 14:06:22 +02:00 committed by GitHub
commit 9577d57a9b
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
62 changed files with 806 additions and 907 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
build_release.sh
View File

@ -18,7 +18,6 @@ CUSTOM_LINKING_CATALA_Z3="\
-cclib -lzarith
-cclib -lgmp
-cclib -lcamlstr
-cclib -lANSITerminal_stubs
-cclib -lalcotest_stubs
-cclib -lunix)"

5
build_system/clerk_driver.ml
View File

@ -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 @{<magenta>%s@}")
ctx.all_failed_names;
if 0 = List.compare_lengths ctx.all_failed_names files_or_folders then
return_ok

2
build_system/dune
View File

@ -13,7 +13,7 @@
ninja_utils
cmdliner
re
ANSITerminal)
ocolor)
(modules clerk_driver))
(rule

2
catala.opam
View File

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

2
clerk.opam
View File

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

52
compiler/catala_utils/cli.ml
View File

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

29
compiler/catala_utils/cli.mli
View File

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

2
compiler/catala_utils/dune
View File

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

2
compiler/catala_utils/file.ml
View File

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

338
compiler/catala_utils/messages.ml
View File

@ -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 "@{<bold;black>[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@[<hov>" ^^ 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@[<hov>" ^^ 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 "@[<v>@[<hov 0>%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 "@{<blue>%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 "@{<blue>%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

49
compiler/catala_utils/messages.mli
View File

@ -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. ["@{<blue>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. *)

135
compiler/catala_utils/pos.ml
View File

@ -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 "@{<bold;blue>%*d │@} %s@," nspaces line_no line;
if line_no >= sline && line_no <= eline then
Format.fprintf ppf "@{<bold;blue>%s │@} %s@{<bold;red>%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 "@{<bold;blue>┌─⯈ %s:@}@," (to_string_short pos);
Format.fprintf ppf "@{<bold;blue>└%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 "@{<bold;blue>%*s└─ %s@}" nspaces "" last
| l :: lines ->
Format.fprintf ppf "@{<bold;blue>%*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 =

2
compiler/catala_utils/pos.mli
View File

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

45
compiler/desugared/linting.ml
View File

@ -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 @{<yellow>\"%a\"@}, the variable @{<yellow>\"%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 @{<yellow>\"%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 @{<yellow>\"%a\"@} of struct @{<yellow>\"%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 @{<yellow>\"%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 @{<yellow>\"%a\"@} of enumeration \
@{<yellow>\"%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 @{<yellow>\"%s\"@} outputs. Did you forget \
something?"
(Mark.remove (ScopeName.get_info scope_name))
in
match states with
| WholeVar ->

49
compiler/desugared/name_resolution.ml
View File

@ -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)
"@{<yellow>\"%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 @{<yellow>\"%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 @{<yellow>\"%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 @{<yellow>\"%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 @{<yellow>\"%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 @{<yellow>\"%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 @{<yellow>\"%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])
"@{<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

63
compiler/desugared/print.ml
View File

@ -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 "@{<blue>%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 "@{<yellow>\"%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 \
@{<yellow>\"%a\"@} of scope @{<yellow>\"%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
"@[<v>Definitions with label @{<yellow>\"%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

53
compiler/driver.ml
View File

@ -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 @{<yellow>\"%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 @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%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 \
\".<var>\" where <var> 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 @{<yellow>\"%a\"@} of scope @{<yellow>\"%a\"@} cannot be \
selected by itself, please add \".<var>\" where <var> 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 @{<yellow>\"%s\"@} of subscope @{<yellow>\"%a\"@} in scope \
@{<yellow>\"%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 @{<yellow>\"%s\"@} is not found for variable \
@{<yellow>\"%s\"@} of scope @{<yellow>\"%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

26
compiler/lcalc/to_ocaml.ml
View File

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

21
compiler/literate/literate_common.ml
View File

@ -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
"@[<v>The line @{<bold;yellow>%d@} in @{<bold;magenta>%s@} is \
exceeding @{<bold;red}%d@} characters:@,\
%s@{<red>%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 =

50
compiler/plugins/api_web.ml
View File

@ -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\
@[<v 2>let _ =@ @[<hov 2> Js.export \"%a\"@\n\
@[<v 2>(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\
@[<v 2>let _ =@ @[<hov 2> Js.export \"%a\"@\n\
@[<v 2>(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

27
compiler/plugins/json_schema.ml
View File

@ -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
"{@[<hov 2>@\n\
\"type\": \"object\",@\n\
\"@[<hov 2>definitions\": {%a@]@\n\
},@\n\
\"@[<hov 2>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
"{@[<hov 2>@\n\
\"type\": \"object\",@\n\
\"@[<hov 2>definitions\": {%a@]@\n\
},@\n\
\"@[<hov 2>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

57
compiler/scalc/to_python.ml
View File

@ -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\
@[<v>%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 "@[<hv 4>%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 "@[<hv 4>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
"@[<v># 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@,\
@,\
@[<v>%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 "@[<hv 4>%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 "@[<hv 4>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

8
compiler/scopelang/from_desugared.ml
View File

@ -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 @{<yellow>\"%s\"@} does not belong to structure \
@{<yellow>\"%a\"@}"
field StructName.format_t name
in
Expr.estructaccess e' field name m
| ETuple es -> Expr.etuple (List.map (translate_expr ctx) es) m

34
compiler/shared_ast/interpreter.ml
View File

@ -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: @{<green>%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@[<v>%a@{<green>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

183
compiler/shared_ast/optimizations.ml
View File

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

73
compiler/shared_ast/print.ml
View File

@ -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 "@{<red>%s@}"
else "%s")
(Uid.MarkedString.to_string info))
fmt infos
let with_color f color fmt x =
(* equivalent to [Format.fprintf fmt "@{<color>%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 "@{<magenta>%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 "@{<magenta>%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 "@{<blue>@<1>%s @}" "≔"
| BeginCall -> Format.fprintf fmt "@{<yellow>@<1>%s @}" "→"
| EndCall -> Format.fprintf fmt "@{<yellow>@<1>%s @}" "←"
| PosRecordIfTrueBool -> Format.fprintf fmt "@{<green>@<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 "@{<blue>#{@}%a%a@{<blue>}@}" 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 "@{<blue>%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)

64
compiler/shared_ast/typing.ml
View File

@ -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 @{<yellow>%a@} coming from expression:"
(format_typ ctx) t1),
t1_pos );
( Some
(fun ppf ->
Format.fprintf ppf "Type @{<yellow>%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 ()
"@[<v>Error during typechecking, incompatible types:@,\
@{<bold;blue>-->@} @[<hov>%a@]@,\
@{<bold;blue>-->@} @[<hov>%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 @{<yellow>\"%s\"@} does not belong to structure \
@{<yellow>\"%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)
"@[<hov>Field @{<yellow>\"%s\"@}@ does not belong to@ structure \
@{<yellow>\"%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 "@{<yellow>\"%a\"@}" A.StructName.format_t
s_name))
(List.map fst (A.StructName.Map.bindings candidate_structs))
in
A.StructField.Map.find field str

53
compiler/surface/parser_driver.ml
View File

@ -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 "@{<yellow>\"%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 );
]))
"@[<v>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: @{<yellow>unexpected token@}"
| msg ->
"Message: "
^ Cli.with_style syntax_hints_style "%s"
(String.trim (String.uncapitalize_ascii msg))
Format.fprintf ppf "Message: @{<yellow>%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 "@[<v>%t@,@[<hov 4>Autosuggestion: %t@]@]"
custom_menhir_message similar_token_msg
in
raise_parser_error
(Pos.from_lpos (lexing_positions lexbuf))

45
compiler/verification/io.ml
View File

@ -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
"@[<v>@{<yellow>[%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))
"@[<v>@{<yellow>[%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 "@[<v>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])
"@[<v>This verification condition was generated for @{<yellow>%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 "@[<v>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
"@[<v>@{<yellow>[%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

10
compiler/verification/z3backend.real.ml
View File

@ -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 "@{<blue>-->@} @{<yellow>%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 "@{<blue>-->@} @{<yellow>%s@} : %s\n"
(Bindlib.name_of v)
(* TODO: Model of a Z3 function should be pretty-printed *)
(Model.FuncInterp.to_string f)))
decls

16
examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en
View File

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

24
french_law/catala_legifrance/catala_legifrance.ml
View File

@ -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 "@[<v>%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 "@{<green>(+) %s@}" (String.concat " " words)
| Diff.Deleted words ->
Format.fprintf ppf "@{<red>(-) %s@}" (String.concat " " words)))
diff
in
let* _checl =
match law_article_text.current_version with

2
french_law/catala_legifrance/dune
View File

@ -10,7 +10,7 @@
cohttp-lwt-unix
yojson
re
ANSITerminal))
ocolor))
(documentation
(package catala_legifrance))

2
french_law/ocaml/law_source/unit_tests/dune
View File

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

8
french_law/ocaml/law_source/unit_tests/run_tests.ml
View File

@ -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 "@{<green>PASS@} @{<magenta>%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 "@{<red>FAIL@} @{<magenta>%s@}\n" msg
let _ =
try_test "Allocations familiales #1" Tests_allocations_familiales.test1;

3
tests/test_array/bad/fold_error.catala_en
View File

@ -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:
└──┐

6
tests/test_array/good/aggregation_2.catala_en
View File

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

6
tests/test_array/good/concatenation.catala_en
View File

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

6
tests/test_array/good/fold.catala_en
View File

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

4
tests/test_bool/bad/bad_assert.catala_en
View File

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

4
tests/test_bool/bad/test_xor_with_int.catala_en
View File

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

6
tests/test_dec/good/infinite_precision.catala_en
View File

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

4
tests/test_enum/bad/quick_pattern_2.catala_en
View File

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

4
tests/test_enum/bad/quick_pattern_3.catala_en
View File

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

4
tests/test_enum/bad/quick_pattern_4.catala_en
View File

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

15
tests/test_exception/good/groups_of_exceptions.catala_en
View File

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

3
tests/test_money/bad/no_mingle.catala_en
View File

@ -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:
└──┐

3
tests/test_name_resolution/good/let_in.catala_en
View File

@ -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.; }
```

3
tests/test_name_resolution/good/out_of_order.catala_en
View File

@ -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.; }
```

2
tests/test_scope/bad/cycle_in_scope.catala_en
View File

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

2
tests/test_scope/bad/cyclic_scope_calls.catala_en
View File

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

3
tests/test_scope/bad/cyclic_scopes.catala_en
View File

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

53
tests/test_scope/good/scope_call3.catala_en
View File

@ -20,47 +20,47 @@ scope RentComputation:
$ catala Interpret -t -s HousingComputation
[LOG] ≔ HousingComputation.f: <function>
[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: <function>
[LOG] ≔ RentComputation.f: <function>
[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 = <function>; }
[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 =

12
tests/test_scope/good/scope_call4.catala_en
View File

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

6
tests/test_struct/good/nested3.catala_en
View File

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

4
tests/test_typing/bad/err1.catala_en
View File

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

4
tests/test_typing/bad/err2.catala_en
View File

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

8
tests/test_typing/bad/err3.catala_en
View File

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

4
tests/test_typing/bad/err4.catala_en
View File

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

4
tests/test_typing/bad/err5.catala_en
View File

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

4
tests/test_typing/bad/err6.catala_en
View File

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

2
tests/test_variable_state/bad/state_cycle.catala_en
View File

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