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

Improve compiler messages dev interface (#470)

Browse Source
This commit is contained in:
Louis Gesbert 2023-06-02 11:45:10 +02:00 committed by GitHub
commit 17414808ce
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
80 changed files with 14827 additions and 13405 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
build_system/clerk_driver.ml
View File

@ -237,7 +237,7 @@ let [@ocamlformat "disable"] scan_for_inline_tests (file : string)
1
(String.sub file_str 0 pos)
in
Errors.raise_error "Bad inline-test format at %s line %d" file line
Messages.raise_error "Bad inline-test format at %s line %d" file line
in
let params =
List.filter (( <> ) "")
@ -305,7 +305,7 @@ let search_for_expected_outputs (file : string) : expected_output_descr list =
match Re.Group.get_opt groups 1 with
| Some x -> x
| None ->
Errors.raise_error
Messages.raise_error
"A test declaration is missing its identifier in the file %s"
file
in
@ -525,7 +525,7 @@ let collect_all_ninja_build
(reset_test_outputs : bool) : (string * ninja) option =
let expected_outputs = search_for_expected_outputs tested_file in
if expected_outputs = [] then (
Cli.debug_print "No expected outputs were found for test file %s"
Messages.emit_debug "No expected outputs were found for test file %s"
tested_file;
None)
else
@ -621,7 +621,7 @@ let run_inline_tests
(catala_exe : string)
(catala_opts : string list) =
match scan_for_inline_tests file with
| None -> Cli.warning_print "No inline tests found in %s" file
| None -> Messages.emit_warning "No inline tests found in %s" file
| Some file_tests ->
let run oc =
List.iter
@ -694,7 +694,7 @@ let run_file
(fun s -> s <> "")
[catala_exe; catala_opts; "-s " ^ scope; "Interpret"; file])
in
Cli.debug_print "Running: %s" command;
Messages.emit_debug "Running: %s" command;
Sys.command command
(** {1 Driver} *)
@ -705,7 +705,7 @@ let get_catala_files_in_folder (dir : string) : string list =
let f_is_dir =
try Sys.is_directory f
with Sys_error e ->
Cli.warning_print "skipping %s" e;
Messages.emit_warning "skipping %s" e;
false
in
if f_is_dir then
@ -905,7 +905,7 @@ let driver
in
match String.lowercase_ascii command with
| "test" -> (
Cli.debug_print "building ninja rules...";
Messages.emit_debug "building ninja rules...";
let ctx =
add_test_builds
(ninja_building_context_init (ninja_start catala_exe catala_opts))
@ -922,7 +922,7 @@ let driver
(fun f ->
f
|> Cli.with_style [ANSITerminal.magenta] "%s"
|> Cli.warning_print "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
@ -931,7 +931,7 @@ let driver
@@ fun nin ->
match
File.with_formatter_of_file nin (fun fmt ->
Cli.debug_print "writing %s..." nin;
Messages.emit_debug "writing %s..." nin;
Nj.format fmt
(add_root_test_build ninja ctx.all_file_names
ctx.all_test_builds))
@ -940,11 +940,9 @@ let driver
let ninja_cmd =
"ninja -k 0 -f " ^ nin ^ " " ^ ninja_flags ^ " test"
in
Cli.debug_print "executing '%s'..." ninja_cmd;
Messages.emit_debug "executing '%s'..." ninja_cmd;
Sys.command ninja_cmd
| exception Sys_error e ->
Cli.error_print "can not write in %s" e;
return_err)
| exception Sys_error e -> Messages.raise_error "can not write in %s" e)
| "run" -> (
match scope with
| Some scope ->
@ -955,22 +953,20 @@ let driver
in
if 0 <> res then return_err else return_ok
| None ->
Cli.error_print "Please provide a scope to run with the -s option";
return_err)
Messages.raise_error "Please provide a scope to run with the -s option")
| "runtest" -> (
match files_or_folders with
| [f] ->
run_inline_tests ~reset:reset_test_outputs f catala_exe
(List.filter (( <> ) "") (String.split_on_char ' ' catala_opts));
0
| _ ->
Cli.error_print "Please specify a single catala file to test";
return_err)
| _ -> Messages.raise_error "Please specify a single catala file to test")
| _ ->
Cli.error_print "The command \"%s\" is unknown to clerk." command;
return_err
with Errors.StructuredError (msg, pos) ->
Errors.print_structured_error msg pos;
Messages.raise_error "The command \"%s\" is unknown to clerk." command
with Messages.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Messages.emit_content content Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
return_err
let main () = exit (Cmdliner.Cmd.eval' (Cmdliner.Cmd.v info (clerk_t driver)))

79
compiler/catala_utils/cli.ml
View File

@ -479,12 +479,6 @@ let info =
let exits = Cmd.Exit.defaults @ [Cmd.Exit.info ~doc:"on error." 1] in
Cmd.info "catala" ~version ~doc ~exits ~man
(**{1 Terminal formatting}*)
(**{2 Markers}*)
let time : float ref = ref (Unix.gettimeofday ())
let with_style
(styles : ANSITerminal.style list)
(str : ('a, unit, string) format) =
@ -503,42 +497,6 @@ let call_unstyled f =
style_flag := prev;
res
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
format_with_style
[ANSITerminal.Bold; ANSITerminal.black]
ppf
(Format.sprintf "[TIME] %.0fms@\n" delta)
(** Prints [\[DEBUG\]] in purple on the terminal standard output *)
let debug_marker ppf () =
time_marker ppf ();
format_with_style [ANSITerminal.Bold; ANSITerminal.magenta] ppf "[DEBUG] "
(** Prints [\[ERROR\]] in red on the terminal error output *)
let error_marker ppf () =
format_with_style [ANSITerminal.Bold; ANSITerminal.red] ppf "[ERROR] "
(** Prints [\[WARNING\]] in yellow on the terminal standard output *)
let warning_marker ppf () =
format_with_style [ANSITerminal.Bold; ANSITerminal.yellow] ppf "[WARNING] "
(** Prints [\[RESULT\]] in green on the terminal standard output *)
let result_marker ppf () =
format_with_style [ANSITerminal.Bold; ANSITerminal.green] ppf "[RESULT] "
(** Prints [\[LOG\]] in red on the terminal error output *)
let log_marker ppf () =
format_with_style [ANSITerminal.Bold; ANSITerminal.black] ppf "[LOG] "
(**{2 Printers}*)
(** All the printers below print their argument after the correct marker *)
let concat_with_line_depending_prefix_and_suffix
(prefix : int -> string)
(suffix : int -> string)
@ -560,40 +518,3 @@ let add_prefix_to_each_line (s : string) (prefix : int -> string) =
(fun i -> prefix i)
(fun _ -> "\n")
(String.split_on_char '\n' s)
let debug_print format =
if !debug_flag then Format.printf ("%a" ^^ format ^^ "\n%!") debug_marker ()
else Format.ifprintf Format.std_formatter format
let debug_format (format : ('a, Format.formatter, unit) format) =
if !debug_flag then
Format.printf ("%a@[<hov>" ^^ format ^^ "@]@.") debug_marker ()
else Format.ifprintf Format.std_formatter format
let error_print format =
Format.print_flush ();
(* Flushes previous warnings *)
Format.eprintf ("%a" ^^ format ^^ "@\n") error_marker ()
let error_format (format : ('a, Format.formatter, unit) format) =
Format.print_flush ();
(* Flushes previous warnings *)
Format.printf ("%a" ^^ format ^^ "\n%!") error_marker ()
let warning_print format =
if !disable_warnings_flag then Format.ifprintf Format.std_formatter format
else Format.printf ("%a" ^^ format ^^ "@\n") warning_marker ()
let warning_format format =
Format.printf ("%a" ^^ format ^^ "\n%!") warning_marker ()
let result_print format =
Format.printf ("%a" ^^ format ^^ "\n%!") result_marker ()
let result_format format =
Format.printf ("%a" ^^ format ^^ "\n%!") result_marker ()
let log_print format = Format.printf ("%a" ^^ format ^^ "\n%!") log_marker ()
let log_format format =
Format.printf ("%a@[<hov>" ^^ format ^^ "@]@.") log_marker ()

19
compiler/catala_utils/cli.mli
View File

@ -147,29 +147,10 @@ val call_unstyled : (unit -> 'a) -> 'a
(** [call_unstyled f] calls the function [f] with the [style_flag] set to false
during the execution. *)
val debug_marker : Format.formatter -> unit -> unit
val error_marker : Format.formatter -> unit -> unit
val warning_marker : Format.formatter -> unit -> unit
val result_marker : Format.formatter -> unit -> unit
val log_marker : Format.formatter -> unit -> unit
(**{2 Printers}*)
(** All the printers below print their argument after the correct marker *)
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 debug_print : ('a, Format.formatter, unit) format -> 'a
val debug_format : ('a, Format.formatter, unit) format -> 'a
val error_print : ('a, Format.formatter, unit) format -> 'a
val error_format : ('a, Format.formatter, unit) format -> 'a
val warning_print : ('a, Format.formatter, unit) format -> 'a
val warning_format : ('a, Format.formatter, unit) format -> 'a
val result_print : ('a, Format.formatter, unit) format -> 'a
val result_format : ('a, Format.formatter, unit) format -> 'a
val log_print : ('a, Format.formatter, unit) format -> 'a
val log_format : ('a, Format.formatter, unit) format -> 'a

111
compiler/catala_utils/errors.ml
View File

@ -1,111 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Error formatting and helper functions *)
(** {1 Error exception and printing} *)
exception StructuredError of (string * (string option * Pos.t) list)
(** The payload of the expression is a main error message, with a list of
secondary positions related to the error, each carrying an optional
secondary message to describe what is pointed by the position. *)
let print_structured_error
?(is_warning : bool = false)
(msg : string)
(pos : (string option * Pos.t) list) : unit =
match !Cli.message_format_flag with
| Cli.Human ->
(if is_warning then Cli.warning_print else Cli.error_print)
"%s%s%s" msg
(if pos = [] then "" else "\n\n")
(String.concat "\n\n"
(List.map
(fun (msg, pos) ->
Printf.sprintf "%s%s"
(match msg with None -> "" | Some msg -> msg ^ "\n")
(Pos.retrieve_loc_text pos))
pos))
| 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"
(if is_warning then Cli.warning_marker else Cli.error_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. *)
(if is_warning then Format.printf else Format.eprintf)
"%s%s\n"
(if pos != [] && List.for_all (fun (msg', _) -> Option.is_some msg') pos
then
Format.asprintf "%a: %s %s\n"
(Cli.format_with_style [ANSITerminal.blue])
(Pos.to_string_short (snd (List.hd pos)))
severity (remove_new_lines msg)
else "")
(String.concat "\n"
(List.map
(fun (msg', pos) ->
Format.asprintf "%a: %s %s"
(Cli.format_with_style [ANSITerminal.blue])
(Pos.to_string_short pos) severity
(match msg' with
| None -> remove_new_lines msg
| Some msg' -> remove_new_lines msg'))
pos))
(** {1 Error exception and printing} *)
let raise_spanned_error ?(span_msg : string option) (span : Pos.t) format =
Format.kasprintf
(fun msg -> raise (StructuredError (msg, [span_msg, span])))
format
let raise_multispanned_error (spans : (string option * Pos.t) list) format =
Format.kasprintf (fun msg -> raise (StructuredError (msg, spans))) format
let raise_error format =
Format.kasprintf (fun msg -> raise (StructuredError (msg, []))) format
let raise_internal_error format =
raise_error
("Internal Error, please report to \
https://github.com/CatalaLang/catala/issues: "
^^ format)
(** {1 Warning printing}*)
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 format_multispanned_warning (pos : (string option * Pos.t) list) format =
Format.kasprintf
(fun msg -> print_structured_error ~is_warning:true msg pos)
format
let format_spanned_warning ?(span_msg : string option) (span : Pos.t) format =
format_multispanned_warning [span_msg, span] format
let format_warning format = format_multispanned_warning [] format

230
compiler/catala_utils/messages.ml Normal file
View File

@ -0,0 +1,230 @@
(** Error formatting and helper functions *)
(**{1 Terminal formatting}*)
(**{2 Markers}*)
let time : float ref = ref (Unix.gettimeofday ())
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)
(** 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] "
(** Prints [\[ERROR\]] in red on the terminal error output *)
let error_marker ppf () =
Cli.format_with_style [ANSITerminal.Bold; ANSITerminal.red] ppf "[ERROR] "
(** Prints [\[WARNING\]] in yellow on the terminal standard output *)
let warning_marker ppf () =
Cli.format_with_style
[ANSITerminal.Bold; ANSITerminal.yellow]
ppf "[WARNING] "
(** Prints [\[RESULT\]] in green on the terminal standard output *)
let result_marker ppf () =
Cli.format_with_style [ANSITerminal.Bold; ANSITerminal.green] ppf "[RESULT] "
(** Prints [\[LOG\]] in red on the terminal error output *)
let log_marker ppf () =
Cli.format_with_style [ANSITerminal.Bold; ANSITerminal.black] ppf "[LOG] "
(**{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 }
let of_message (s : string) : t = { message = s; positions = [] }
end
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 }
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
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))
| 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
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))
(** {1 Error exception} *)
exception CompilerError of Content.t
(** {1 Error printing} *)
let raise_spanned_error ?(span_msg : string option) (span : Pos.t) format =
Format.kasprintf
(fun msg ->
raise
(CompilerError
{
message = msg;
positions = [{ message = span_msg; position = span }];
}))
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;
}))
format
let raise_error format =
Format.kasprintf
(fun msg -> raise (CompilerError { message = msg; positions = [] }))
format
let raise_internal_error format =
raise_error ("%s" ^^ format) internal_error_prefix
(** {1 Warning printing}*)
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 ->
emit_content
{
message = msg;
positions =
List.map
(fun (msg, pos) -> { Content.message = msg; position = pos })
pos;
}
Warning)
format
let emit_spanned_warning ?(span_msg : string 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
let emit_debug format =
Format.kasprintf
(fun msg -> emit_content { message = msg; positions = [] } Debug)
format
let emit_result format =
Format.kasprintf
(fun msg -> emit_content { message = msg; positions = [] } Result)
format

51
compiler/catala_utils/errors.mli → compiler/catala_utils/messages.mli
View File

@ -1,5 +1,5 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
and social benefits computation rules. Copyright (C) 2023 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
@ -14,20 +14,29 @@
License for the specific language governing permissions and limitations under
the License. *)
(** Error formatting and helper functions *)
(** Interface for emitting compiler messages *)
(** {1 Error exception and printing} *)
(** {1 Message content} *)
exception StructuredError of (string * (string option * Pos.t) list)
(** The payload of the expression is a main error message, with a list of
secondary positions related to the error, each carrying an optional
secondary message to describe what is pointed by the position. *)
module Content : sig
type t
val print_structured_error :
?is_warning:bool -> string -> (string option * Pos.t) list -> unit
(** Emits error or warning if [is_warning] is set to [true]. *)
val of_message : string -> t
end
(** {1 Error exception and printing} *)
val to_internal_error : Content.t -> Content.t
type content_type = Error | Warning | Debug | Log | Result
val emit_content : Content.t -> content_type -> unit
(** This functions emits the message according to the emission type defined by
[Cli.message_format_flag]. *)
(** {1 Error exception} *)
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
@ -41,12 +50,24 @@ val raise_internal_error : ('a, Format.formatter, unit, 'b) format4 -> 'a
val assert_internal_error :
bool -> ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
(** {1 Warning printing}*)
(** {1 Common warning emission}*)
val format_multispanned_warning :
val emit_multispanned_warning :
(string option * Pos.t) list -> ('a, Format.formatter, unit) format -> 'a
val format_spanned_warning :
val emit_spanned_warning :
?span_msg:string -> Pos.t -> ('a, Format.formatter, unit) format -> 'a
val format_warning : ('a, Format.formatter, unit) format -> 'a
val emit_warning : ('a, Format.formatter, unit) format -> 'a
(** {1 Common log emission}*)
val emit_log : ('a, Format.formatter, unit) format -> 'a
(** {1 Common debug emission}*)
val emit_debug : ('a, Format.formatter, unit) format -> 'a
(* {1 Common result emission}*)
val emit_result : ('a, Format.formatter, unit) format -> 'a

14
compiler/dcalc/from_scopelang.ml
View File

@ -227,7 +227,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
let case_e =
try EnumConstructor.Map.find constructor e_cases
with Not_found ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"The constructor %a of enum %a is missing from this pattern \
matching"
EnumConstructor.format_t constructor EnumName.format_t name
@ -239,7 +239,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(EnumConstructor.Map.empty, e_cases)
in
if not (EnumConstructor.Map.is_empty remaining_e_cases) then
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Pattern matching is incomplete for enum %a: missing cases %a"
EnumName.format_t name
(Format.pp_print_list
@ -272,7 +272,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
| _ -> false)
var_ctx.scope_input_io (translate_expr ctx e) )
| Some var_ctx, None ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, pos;
( Some "Declaration of the missing input variable",
@ -281,7 +281,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
"Definition of input variable '%a' missing in this scope call"
ScopeVar.format_t var_name
| None, Some _ ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, pos;
( Some "Declaration of scope '%a'",
@ -493,12 +493,12 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
match typ with
| TArrow (tin, (tout, _)) -> List.map Mark.remove tin, tout
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Application of non-function toplevel variable")
| _ -> ListLabels.map new_args ~f:(fun _ -> TAny), TAny
in
(* Cli.debug_format "new_args %d, input_typs: %d, input_typs %a"
(* Messages.emit_debug "new_args %d, input_typs: %d, input_typs %a"
(List.length new_args) (List.length input_typs) (Format.pp_print_list
Print.typ_debug) (List.map (Mark.add Pos.no_pos) input_typs); *)
let new_args =
@ -567,7 +567,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
in
Expr.evar v m
with Not_found ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
Some "Incriminated variable usage:", Expr.pos e;
( Some "Incriminated subscope variable declaration:",

10
compiler/dcalc/invariants.ml
View File

@ -37,11 +37,8 @@ let check_invariant (inv : string * invariant_expr) (p : typed program) : bool =
match inv e with
| Ignore -> true
| Fail ->
Cli.error_format "%s failed in %s.\n\n %a" name
(Pos.to_string_short (Expr.pos e))
(Print.expr ()) e;
incr total;
false
Messages.raise_spanned_error (Expr.pos e) "%s failed\n\n%a" name
(Print.expr ()) e
| Pass ->
incr ok;
incr total;
@ -55,7 +52,8 @@ let check_invariant (inv : string * invariant_expr) (p : typed program) : bool =
e')
in
assert (Bindlib.free_vars p' = Bindlib.empty_ctxt);
Cli.result_print "Invariant %s\n checked. result: [%d/%d]" name !ok !total;
Messages.emit_result "Invariant %s\n checked. result: [%d/%d]" name !ok
!total;
!result
(* Structural invariant: no default can have as type A -> B *)

12
compiler/desugared/dependency.ml
View File

@ -151,7 +151,7 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
cycle
(List.tl cycle @ [List.hd cycle])
in
Errors.raise_multispanned_error spans
Messages.raise_multispanned_error spans
"@[<hov 2>Cyclic dependency detected between the following variables of \
scope %a:@ @[<hv>%a@]@]"
ScopeName.format_t scope.scope_uid
@ -204,7 +204,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
&& Option.equal StateName.equal s_used s_defined
then
(* variable definitions cannot be recursive *)
Errors.raise_spanned_error fv_def_pos
Messages.raise_spanned_error fv_def_pos
"The variable %a is used in one of its definitions, but \
recursion is forbidden in Catala"
Ast.ScopeDef.format_t def_key
@ -232,7 +232,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
another subscope *)
if SubScopeName.equal used defined then
(* subscopes are not recursive functions *)
Errors.raise_spanned_error fv_def_pos
Messages.raise_spanned_error fv_def_pos
"The subscope %a is used when defining one of its inputs, \
but recursion is forbidden in Catala"
SubScopeName.format_t defined
@ -450,12 +450,12 @@ let build_exceptions_graph
in
(* We check the consistency*)
if LabelName.compare label_from label_to = 0 then
Errors.raise_spanned_error edge_pos
Messages.raise_spanned_error edge_pos
"Cannot define rule as an exception to itself";
List.iter
(fun edge ->
if LabelName.compare edge.label_to label_to <> 0 then
Errors.raise_multispanned_error
Messages.raise_multispanned_error
(( Some
"This definition contradicts other exception \
definitions:",
@ -541,7 +541,7 @@ let check_for_exception_cycle
scc
in
let v, _ = RuleName.Map.choose (List.hd scc).rules in
Errors.raise_multispanned_error spans
Messages.raise_multispanned_error spans
"Exception cycle detected when defining %a: each of these %d exceptions \
applies over the previous one, and the first applies over the last"
RuleName.format_t v (List.length scc)

98
compiler/desugared/from_surface.ml
View File

@ -69,7 +69,7 @@ let translate_binop : Surface.Ast.binop -> Pos.t -> Ast.expr boxed =
| S.KDec -> [TLit TRat; TLit TRat]
| S.KMoney -> [TLit TMoney; TLit TRat]
| S.KDate ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"This operator doesn't exist, dates can't be multiplied"
| S.KDuration -> [TLit TDuration; TLit TInt])
| S.Div k ->
@ -80,7 +80,7 @@ let translate_binop : Surface.Ast.binop -> Pos.t -> Ast.expr boxed =
| S.KDec -> [TLit TRat; TLit TRat]
| S.KMoney -> [TLit TMoney; TLit TMoney]
| S.KDate ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"This operator doesn't exist, dates can't be divided"
| S.KDuration -> [TLit TDuration; TLit TDuration])
| S.Lt k | S.Lte k | S.Gt k | S.Gte k ->
@ -116,7 +116,7 @@ let translate_unop (op : Surface.Ast.unop) pos : Ast.expr boxed =
| S.KDec -> TLit TRat
| S.KMoney -> TLit TMoney
| S.KDate ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"This operator doesn't exist, dates can't be negative"
| S.KDuration -> TLit TDuration)
@ -128,20 +128,20 @@ let disambiguate_constructor
match constructor with
| [c] -> Mark.remove c
| _ ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"The deep pattern matching syntactic sugar is not yet supported"
in
let possible_c_uids =
try IdentName.Map.find (Mark.remove constructor) ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error (Mark.get constructor)
Messages.raise_spanned_error (Mark.get constructor)
"The name of this constructor has not been defined before, maybe it is \
a typo?"
in
match path with
| [] ->
if EnumName.Map.cardinal possible_c_uids > 1 then
Errors.raise_spanned_error (Mark.get constructor)
Messages.raise_spanned_error (Mark.get constructor)
"This constructor name is ambiguous, it can belong to %a. Disambiguate \
it by prefixing it with the enum name."
(Format.pp_print_list
@ -158,12 +158,13 @@ let disambiguate_constructor
let c_uid = EnumName.Map.find e_uid possible_c_uids in
e_uid, c_uid
with Not_found ->
Errors.raise_spanned_error pos "Enum %s does not contain case %s"
Messages.raise_spanned_error pos "Enum %s does not contain case %s"
(Mark.remove enum) (Mark.remove constructor)
with Not_found ->
Errors.raise_spanned_error (Mark.get enum)
Messages.raise_spanned_error (Mark.get enum)
"Enum %s has not been defined before" (Mark.remove enum))
| _ -> Errors.raise_spanned_error pos "Qualified paths are not supported yet"
| _ ->
Messages.raise_spanned_error pos "Qualified paths are not supported yet"
let int100 = Runtime.integer_of_int 100
let rat100 = Runtime.decimal_of_integer int100
@ -178,7 +179,7 @@ let rec check_formula (op, pos_op) e =
(* Xor is mathematically associative, but without a useful semantics ([a
xor b xor c] is most likely an error since it's true for [a = b = c =
true]) *)
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[None, pos_op; None, pos_op1]
"Please add parentheses to explicit which of these operators should be \
applied first";
@ -280,21 +281,21 @@ let rec translate_expr
| LNumber ((Int i, _), Some (Day, _)) ->
LDuration (Runtime.duration_of_numbers 0 0 (int_of_string i))
| LNumber ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"Impossible to specify decimal amounts of days, months or years"
| LDate date ->
if date.literal_date_month > 12 then
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"There is an error in this date: the month number is bigger than 12";
if date.literal_date_day > 31 then
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"There is an error in this date: the day number is bigger than 31";
LDate
(try
Runtime.date_of_numbers date.literal_date_year
date.literal_date_month date.literal_date_day
with Runtime.ImpossibleDate ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"There is an error in this date, it does not correspond to a \
correct calendar day")
in
@ -328,7 +329,7 @@ let rec translate_expr
no state but variable has states"
| Some inside_def_state ->
if StateName.compare inside_def_state (List.hd states) = 0 then
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"It is impossible to refer to the variable you are \
defining when defining its first state."
else
@ -361,7 +362,7 @@ let rec translate_expr
Name_resolution.raise_unknown_identifier
"for a local, scope-wide or global variable" (x, pos))))
| Ident (_path, _x) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
Messages.raise_spanned_error pos "Qualified paths are not supported yet"
| Dotted (e, ((path, x), _ppos)) -> (
match path, Mark.remove e with
| [], Ident ([], (y, _))
@ -389,17 +390,18 @@ let rec translate_expr
| [c] -> (
try Some (Name_resolution.get_struct ctxt c)
with Not_found ->
Errors.raise_spanned_error (Mark.get c)
Messages.raise_spanned_error (Mark.get c)
"Structure %s was not declared" (Mark.remove c))
| _ ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
Messages.raise_spanned_error pos
"Qualified paths are not supported yet"
in
Expr.edstructaccess e (Mark.remove x) str emark)
| FunCall (f, args) ->
Expr.eapp (rec_helper f) (List.map rec_helper args) emark
| ScopeCall ((([], sc_name), _), fields) ->
if scope = None then
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"Scope calls are not allowed outside of a scope";
let called_scope = Name_resolution.get_scope ctxt sc_name in
let scope_def = ScopeName.Map.find called_scope ctxt.scopes in
@ -412,7 +414,7 @@ let rec translate_expr
with
| Some (ScopeVar v) -> v
| Some (SubScope _) | None ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, Mark.get fld_id;
( Some
@ -427,7 +429,7 @@ let rec translate_expr
(function
| None -> Some (rec_helper e)
| Some _ ->
Errors.raise_spanned_error (Mark.get fld_id)
Messages.raise_spanned_error (Mark.get fld_id)
"Duplicate definition of scope input variable '%a'"
ScopeVar.format_t var)
acc)
@ -435,7 +437,7 @@ let rec translate_expr
in
Expr.escopecall called_scope in_struct emark
| ScopeCall (((_, _sc_name), _), _fields) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
Messages.raise_spanned_error pos "Qualified paths are not supported yet"
| LetIn (x, e1, e2) ->
let ctxt, v = Name_resolution.add_def_local_var ctxt (Mark.remove x) in
let tau = TAny, Mark.get x in
@ -451,7 +453,7 @@ let rec translate_expr
match IdentName.Map.find_opt (Mark.remove s_name) ctxt.typedefs with
| Some (Name_resolution.TStruct s_uid) -> s_uid
| _ ->
Errors.raise_spanned_error (Mark.get s_name)
Messages.raise_spanned_error (Mark.get s_name)
"This identifier should refer to a struct name"
in
@ -463,14 +465,14 @@ let rec translate_expr
StructName.Map.find s_uid
(IdentName.Map.find (Mark.remove f_name) ctxt.field_idmap)
with Not_found ->
Errors.raise_spanned_error (Mark.get f_name)
Messages.raise_spanned_error (Mark.get f_name)
"This identifier should refer to a field of struct %s"
(Mark.remove s_name)
in
(match StructField.Map.find_opt f_uid s_fields with
| None -> ()
| Some e_field ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[None, Mark.get f_e; None, Expr.pos e_field]
"The field %a has been defined twice:" StructField.format_t f_uid);
let f_e = translate_expr scope inside_definition_of ctxt f_e in
@ -481,19 +483,19 @@ let rec translate_expr
StructField.Map.iter
(fun expected_f _ ->
if not (StructField.Map.mem expected_f s_fields) then
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"Missing field for structure %a: \"%a\"" StructName.format_t s_uid
StructField.format_t expected_f)
expected_s_fields;
Expr.estruct s_uid s_fields emark
| StructLit (((_, _s_name), _), _fields) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
Messages.raise_spanned_error pos "Qualified paths are not supported yet"
| EnumInject (((path, (constructor, pos_constructor)), _), payload) -> (
let possible_c_uids =
try IdentName.Map.find constructor ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error pos_constructor
Messages.raise_spanned_error pos_constructor
"The name of this constructor has not been defined before, maybe it \
is a typo?"
in
@ -505,7 +507,7 @@ let rec translate_expr
(* No constructor name was specified *)
EnumName.Map.cardinal possible_c_uids > 1
then
Errors.raise_spanned_error pos_constructor
Messages.raise_spanned_error pos_constructor
"This constructor name is ambiguous, it can belong to %a. \
Desambiguate it by prefixing it with the enum name."
(Format.pp_print_list
@ -538,13 +540,13 @@ let rec translate_expr
| None -> Expr.elit LUnit mark_constructor)
c_uid e_uid emark
with Not_found ->
Errors.raise_spanned_error pos "Enum %s does not contain case %s"
Messages.raise_spanned_error pos "Enum %s does not contain case %s"
(Mark.remove enum) constructor
with Not_found ->
Errors.raise_spanned_error (Mark.get enum)
Messages.raise_spanned_error (Mark.get enum)
"Enum %s has not been defined before" (Mark.remove enum))
| _ ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet")
Messages.raise_spanned_error pos "Qualified paths are not supported yet")
| MatchWith (e1, (cases, _cases_pos)) ->
let e1 = translate_expr scope inside_definition_of ctxt e1 in
let cases_d, e_uid =
@ -556,7 +558,7 @@ let rec translate_expr
(match snd (Mark.remove pattern) with
| None -> ()
| Some binding ->
Errors.format_spanned_warning (Mark.get binding)
Messages.emit_spanned_warning (Mark.get binding)
"This binding will be ignored (remove it to suppress warning)");
let enum_uid, c_uid =
disambiguate_constructor ctxt
@ -694,7 +696,7 @@ let rec translate_expr
| S.Money -> LMoney (Runtime.money_of_cents_integer i0)
| S.Duration -> LDuration (Runtime.duration_of_numbers 0 0 0)
| t ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"It is impossible to sum values of type %a together"
SurfacePrint.format_primitive_typ t
in
@ -793,7 +795,7 @@ and disambiguate_match_and_build_expression
| Some e_uid ->
if e_uid = e_uid' then e_uid
else
Errors.raise_spanned_error
Messages.raise_spanned_error
(Mark.get case.Surface.Ast.match_case_pattern)
"This case matches a constructor of enumeration %a but previous \
case were matching constructors of enumeration %a"
@ -802,7 +804,7 @@ and disambiguate_match_and_build_expression
(match EnumConstructor.Map.find_opt c_uid cases_d with
| None -> ()
| Some e_case ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
"The constructor %a has been matched twice:" EnumConstructor.format_t
c_uid);
@ -819,7 +821,7 @@ and disambiguate_match_and_build_expression
| Surface.Ast.WildCard match_case_expr -> (
let nb_cases = List.length cases in
let raise_wildcard_not_last_case_err () =
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
Some "Not ending wildcard:", case_pos;
( Some "Next reachable case:",
@ -830,7 +832,7 @@ and disambiguate_match_and_build_expression
match e_uid with
| None ->
if 1 = nb_cases then
Errors.raise_spanned_error case_pos
Messages.raise_spanned_error case_pos
"Couldn't infer the enumeration name from lonely wildcard \
(wildcard cannot be used as single match case)"
else raise_wildcard_not_last_case_err ()
@ -844,7 +846,7 @@ and disambiguate_match_and_build_expression
| None -> Some c_uid)
in
if EnumConstructor.Map.is_empty missing_constructors then
Errors.format_spanned_warning case_pos
Messages.emit_spanned_warning case_pos
"Unreachable match case, all constructors of the enumeration %a \
are already specified"
EnumName.format_t e_uid;
@ -909,12 +911,12 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
match pdecl, pdefs with
| [], [] -> ()
| [], (arg, apos) :: _ ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[Some "Declared here:", pos_decl; Some "Extra argument:", apos]
"This definition has an extra, undeclared argument '%a'" Print.lit_style
arg
| (arg, apos) :: _, [] ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
Some "Argument declared here:", apos;
Some "Mismatching definition:", pos_def;
@ -923,7 +925,7 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
| decl :: pdecl, def :: pdefs when Uid.MarkedString.equal decl def ->
arglist_eq_check pos_decl pos_def pdecl pdefs
| (decl_arg, decl_apos) :: _, (def_arg, def_apos) :: _ ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
Some "Argument declared here:", decl_apos; Some "Defined here:", def_apos;
]
@ -942,14 +944,14 @@ let process_rule_parameters
match declared_params, def.S.definition_parameter with
| None, None -> ctxt, None
| None, Some (_, pos) ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
Some "Declared here without arguments", decl_pos;
Some "Unexpected arguments appearing here", pos;
]
"Extra arguments in this definition of %a" Ast.ScopeDef.format_t decl_name
| Some (_, pos), None ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
Some "Arguments declared here", pos;
( Some "Definition missing the arguments",
@ -1049,7 +1051,7 @@ let process_def
in
ExceptionToLabel (label_id, Mark.get label_str)
with Not_found ->
Errors.raise_spanned_error (Mark.get label_str)
Messages.raise_spanned_error (Mark.get label_str)
"Unknown label for the scope variable %a: \"%s\""
Ast.ScopeDef.format_t def_key (Mark.remove label_str))
in
@ -1159,7 +1161,7 @@ let process_scope_use_item
scope.scope_options
with
| Some (_, old_pos) ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[None, old_pos; None, Mark.get item]
"You cannot set multiple date rounding modes"
| None ->
@ -1212,10 +1214,10 @@ let check_unlabeled_exception
| Surface.Ast.UnlabeledException -> (
match scope_def_ctxt.default_exception_rulename with
| None ->
Errors.raise_spanned_error (Mark.get item)
Messages.raise_spanned_error (Mark.get item)
"This exception does not have a corresponding definition"
| Some (Ambiguous pos) ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
([Some "Ambiguous exception", Mark.get item]
@ List.map (fun p -> Some "Candidate definition", p) pos)
"This exception can refer to several definitions. Try using labels \

14
compiler/desugared/linting.ml
View File

@ -33,7 +33,7 @@ let detect_empty_definitions (p : program) : unit =
| NoInput -> true
| _ -> false
then
Errors.format_spanned_warning
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?"
@ -91,7 +91,7 @@ let detect_identical_rules (p : program) : unit =
RuleExpressionsMap.iter
(fun _ pos ->
if List.length pos > 1 then
Errors.format_multispanned_warning pos
Messages.emit_multispanned_warning pos
"These %s have identical justifications and consequences; is \
it a mistake?"
(if scope_def.scope_def_is_condition then "rules"
@ -121,7 +121,7 @@ let detect_unused_scope_vars (p : program) : unit =
| ScopeDef.Var (v, _)
when (not (ScopeVar.Set.mem v used_scope_vars))
&& not (Mark.remove scope_def.scope_def_io.io_output) ->
Errors.format_spanned_warning
Messages.emit_spanned_warning
(ScopeDef.get_position scope_def_key)
"In scope %a, the variable %a is never used anywhere; maybe it's \
unnecessary?"
@ -178,7 +178,7 @@ let detect_unused_struct_fields (p : program) : unit =
&& not (StructField.Set.mem field scope_out_structs_fields))
fields
then
Errors.format_spanned_warning
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])
@ -190,7 +190,7 @@ let detect_unused_struct_fields (p : program) : unit =
(not (StructField.Set.mem field struct_fields_used))
&& not (StructField.Set.mem field scope_out_structs_fields)
then
Errors.format_spanned_warning
Messages.emit_spanned_warning
(snd (StructField.get_info field))
"The field %a of struct %a is never used; maybe it's \
unnecessary?"
@ -234,7 +234,7 @@ let detect_unused_enum_constructors (p : program) : unit =
not (EnumConstructor.Set.mem cons enum_constructors_used))
constructors
then
Errors.format_spanned_warning
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])
@ -244,7 +244,7 @@ let detect_unused_enum_constructors (p : program) : unit =
(fun constructor _ ->
if not (EnumConstructor.Set.mem constructor enum_constructors_used)
then
Errors.format_spanned_warning
Messages.emit_spanned_warning
(snd (EnumConstructor.get_info constructor))
"The constructor %a of enumeration %a is never used; maybe \
it's unnecessary?"

50
compiler/desugared/name_resolution.ml
View File

@ -95,12 +95,12 @@ type context = {
(** Temporary function raising an error message saying that a feature is not
supported yet *)
let raise_unsupported_feature (msg : string) (pos : Pos.t) =
Errors.raise_spanned_error pos "Unsupported feature: %s" msg
Messages.raise_spanned_error pos "Unsupported feature: %s" msg
(** 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) =
Errors.raise_spanned_error (Mark.get ident) "\"%s\": unknown identifier %s"
Messages.raise_spanned_error (Mark.get ident) "\"%s\": unknown identifier %s"
(Cli.with_style [ANSITerminal.yellow] "%s" (Mark.remove ident))
msg
@ -188,56 +188,56 @@ let get_enum ctxt id =
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TEnum id -> id
| TStruct sid ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
"Expecting an enum, but found a structure"
| TScope (sid, _) ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, Mark.get id;
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
]
"Expecting an enum, but found a scope"
| exception Not_found ->
Errors.raise_spanned_error (Mark.get id) "No enum named %s found"
Messages.raise_spanned_error (Mark.get id) "No enum named %s found"
(Mark.remove id)
let get_struct ctxt id =
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
| TEnum eid ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
"Expecting an struct, but found an enum"
| exception Not_found ->
Errors.raise_spanned_error (Mark.get id) "No struct named %s found"
Messages.raise_spanned_error (Mark.get id) "No struct named %s found"
(Mark.remove id)
let get_scope ctxt id =
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TScope (id, _) -> id
| TEnum eid ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
"Expecting an scope, but found an enum"
| TStruct sid ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
"Expecting an scope, but found a structure"
| exception Not_found ->
Errors.raise_spanned_error (Mark.get id) "No scope named %s found"
Messages.raise_spanned_error (Mark.get id) "No scope named %s found"
(Mark.remove id)
(** {1 Declarations pass} *)
@ -257,7 +257,7 @@ let process_subscope_decl
| ScopeVar v -> ScopeVar.get_info v
| SubScope (ssc, _) -> SubScopeName.get_info ssc
in
Errors.raise_multispanned_error
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])
@ -313,13 +313,13 @@ let rec process_base_typ
| Some (TScope (_, scope_str)) ->
TStruct scope_str.out_struct_name, typ_pos
| None ->
Errors.raise_spanned_error typ_pos
Messages.raise_spanned_error typ_pos
"Unknown type \"%a\", not a struct or enum previously declared"
(Cli.format_with_style [ANSITerminal.yellow])
ident)
| Surface.Ast.Named (_path, (_ident, _pos)) ->
Errors.raise_spanned_error typ_pos "Qualified paths are not supported yet"
)
Messages.raise_spanned_error typ_pos
"Qualified paths are not supported yet")
(** Process a type (function or not) *)
let process_type (ctxt : context) ((naked_typ, typ_pos) : Surface.Ast.typ) : typ
@ -347,7 +347,7 @@ let process_data_decl
| ScopeVar v -> ScopeVar.get_info v
| SubScope (ssc, _) -> SubScopeName.get_info ssc
in
Errors.raise_multispanned_error
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])
@ -366,7 +366,7 @@ 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
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
( Some
(Format.asprintf "First instance of state %a:"
@ -427,7 +427,7 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
context =
let s_uid = get_struct ctxt sdecl.struct_decl_name in
if sdecl.struct_decl_fields = [] then
Errors.raise_spanned_error
Messages.raise_spanned_error
(Mark.get sdecl.struct_decl_name)
"The struct %s does not have any fields; give it some for Catala to be \
able to accept it."
@ -472,7 +472,7 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
=
let e_uid = get_enum ctxt edecl.enum_decl_name in
if List.length edecl.enum_decl_cases = 0 then
Errors.raise_spanned_error
Messages.raise_spanned_error
(Mark.get edecl.enum_decl_name)
"The enum %s does not have any cases; give it some for Catala to be able \
to accept it."
@ -605,7 +605,7 @@ 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 =
Errors.raise_multispanned_error
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])
@ -735,7 +735,7 @@ let get_def_key
(IdentName.Map.find (Mark.remove state)
var_sig.var_sig_states_idmap)
with Not_found ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, Mark.get state;
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
@ -744,7 +744,7 @@ let get_def_key
ScopeVar.format_t x_uid)
| None ->
if not (IdentName.Map.is_empty var_sig.var_sig_states_idmap) then
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, Mark.get x;
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
@ -758,17 +758,17 @@ let get_def_key
match IdentName.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with
| Some (SubScope (v, u)) -> v, u
| Some _ ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"Invalid access to input variable, %a is not a subscope"
Print.lit_style (Mark.remove y)
| None ->
Errors.raise_spanned_error pos "No definition found for subscope %a"
Messages.raise_spanned_error pos "No definition found for subscope %a"
Print.lit_style (Mark.remove y)
in
let x_uid = get_var_uid subscope_real_uid ctxt x in
Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid, pos)
| _ ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"This line is defining a quantity that is neither a scope variable nor a \
subscope variable. In particular, it is not possible to define struct \
fields individually in Catala."
@ -892,7 +892,7 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
with
| Some (TScope (sn, _)) -> sn
| _ ->
Errors.raise_spanned_error
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])

6
compiler/desugared/print.ml
View File

@ -90,7 +90,7 @@ let print_exceptions_graph
(scope : ScopeName.t)
(var : Ast.ScopeDef.t)
(g : Dependency.ExceptionsDependencies.t) =
Cli.result_format
Messages.emit_result
"Printing the tree of exceptions for the definitions of variable %a of \
scope %a."
(Cli.format_with_style [ANSITerminal.yellow])
@ -99,7 +99,7 @@ let print_exceptions_graph
(Format.asprintf "\"%a\"" ScopeName.format_t scope);
Dependency.ExceptionsDependencies.iter_vertex
(fun ex ->
Cli.result_format "Definitions with label %a:\n%a"
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)
@ -110,7 +110,7 @@ let print_exceptions_graph
(RuleName.Map.bindings ex.Dependency.ExceptionVertex.rules))
g;
let tree = build_exception_tree g in
Cli.result_format "The exception tree structure is as follows:\n\n%a"
Messages.emit_result "The exception tree structure is as follows:\n\n%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(fun fmt tree -> format_exception_tree fmt tree))

143
compiler/driver.ml
View File

@ -27,7 +27,7 @@ let get_scope_uid
(ctxt : Desugared.Name_resolution.context) =
match options.ex_scope, backend with
| None, `Interpret ->
Errors.raise_error "No scope was provided for execution."
Messages.raise_error "No scope was provided for execution."
| None, _ ->
let _, scope =
try
@ -38,14 +38,14 @@ let get_scope_uid
ctxt.typedefs
|> Shared_ast.IdentName.Map.choose
with Not_found ->
Errors.raise_error "There isn't any scope inside the program."
Messages.raise_error "There isn't any scope inside the program."
in
scope
| Some name, _ -> (
match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with
| Some (Desugared.Name_resolution.TScope (uid, _)) -> uid
| _ ->
Errors.raise_error "There is no scope %a inside the program."
Messages.raise_error "There is no scope %a inside the program."
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ name ^ "\""))
@ -56,7 +56,7 @@ let get_variable_uid
(scope_uid : Shared_ast.ScopeName.t) =
match options.ex_variable, backend with
| None, `Exceptions ->
Errors.raise_error
Messages.raise_error
"Please specify a variable with the -v option to print its exception \
tree."
| None, _ -> None
@ -80,7 +80,7 @@ let get_variable_uid
(Shared_ast.ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
with
| None ->
Errors.raise_error "Variable %a not found inside scope %a"
Messages.raise_error "Variable %a not found inside scope %a"
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ name ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
@ -90,7 +90,7 @@ let get_variable_uid
-> (
match second_part with
| None ->
Errors.raise_error
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])
@ -108,7 +108,7 @@ let get_variable_uid
(Desugared.Ast.ScopeDef.SubScopeVar
(subscope_var_name, v, Pos.no_pos))
| _ ->
Errors.raise_error
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])
@ -131,7 +131,7 @@ let get_variable_uid
with
| Some state -> state
| None ->
Errors.raise_error
Messages.raise_error
"State %a is not found for variable %a of scope %a"
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ second_part ^ "\"")
@ -155,7 +155,7 @@ let driver source_file (options : Cli.options) : int =
options.plugins_dirs;
Cli.set_option_globals options;
if options.debug then Printexc.record_backtrace true;
Cli.debug_print "Reading files...";
Messages.emit_debug "Reading files...";
let filename = ref "" in
(match source_file with
| Pos.FileName f -> filename := f
@ -167,7 +167,7 @@ let driver source_file (options : Cli.options) : int =
(* Try to infer the language from the intput file extension. *)
let ext = Filename.extension !filename in
if ext = "" then
Errors.raise_error
Messages.raise_error
"No file extension found for the file '%s'. (Try to add one or to \
specify the -l flag)"
!filename;
@ -176,7 +176,7 @@ let driver source_file (options : Cli.options) : int =
let language =
try List.assoc l Cli.languages
with Not_found ->
Errors.raise_error
Messages.raise_error
"The selected language (%s) is not supported by Catala" l
in
Cli.locale_lang := language;
@ -187,7 +187,7 @@ let driver source_file (options : Cli.options) : int =
| `Plugin s -> (
try `Plugin (Plugin.find s)
with Not_found ->
Errors.raise_error
Messages.raise_error
"The selected backend (%s) is not supported by Catala, nor was a \
plugin by this name found under %a"
backend
@ -216,11 +216,11 @@ let driver source_file (options : Cli.options) : int =
match source_file with
| FileName f -> f
| Contents _ ->
Errors.raise_error
Messages.raise_error
"The Makefile backend does not work if the input is not a file"
in
let output_file, with_output = get_output ~ext:".d" () in
Cli.debug_print "Writing list of dependencies to %s..."
Messages.emit_debug "Writing list of dependencies to %s..."
(Option.value ~default:"stdout" output_file);
with_output
@@ fun oc ->
@ -233,7 +233,7 @@ let driver source_file (options : Cli.options) : int =
(String.concat "\\\n" prgm.program_source_files)
(String.concat "\\\n" prgm.program_source_files)
| (`Latex | `Html) as backend ->
Cli.debug_print "Weaving literate program into %s"
Messages.emit_debug "Weaving literate program into %s"
(match backend with `Latex -> "LaTeX" | `Html -> "HTML");
let output_file, with_output =
get_output_format ()
@ -249,7 +249,7 @@ let driver source_file (options : Cli.options) : int =
Literate.Html.ast_to_html language
~print_only_law:options.print_only_law
in
Cli.debug_print "Writing to %s"
Messages.emit_debug "Writing to %s"
(Option.value ~default:"stdout" output_file);
if options.wrap_weaved_output then
match backend with
@ -263,18 +263,18 @@ let driver source_file (options : Cli.options) : int =
| ( `Interpret | `Interpret_Lcalc | `Typecheck | `OCaml | `Python | `Scalc
| `Lcalc | `Dcalc | `Scopelang | `Exceptions | `Proof | `Plugin _ ) as
backend -> (
Cli.debug_print "Name resolution...";
Messages.emit_debug "Name resolution...";
let ctxt = Desugared.Name_resolution.form_context prgm in
let scope_uid = get_scope_uid options backend ctxt in
(* This uid is a Desugared identifier *)
let variable_uid = get_variable_uid options backend ctxt scope_uid in
Cli.debug_print "Desugaring...";
Messages.emit_debug "Desugaring...";
let prgm = Desugared.From_surface.translate_program ctxt prgm in
Cli.debug_print "Disambiguating...";
Messages.emit_debug "Disambiguating...";
let prgm = Desugared.Disambiguate.program prgm in
Cli.debug_print "Linting...";
Messages.emit_debug "Linting...";
Desugared.Linting.lint_program prgm;
Cli.debug_print "Collecting rules...";
Messages.emit_debug "Collecting rules...";
let exceptions_graphs =
Scopelang.From_desugared.build_exceptions_graph prgm
in
@ -287,7 +287,7 @@ let driver source_file (options : Cli.options) : int =
match variable_uid with
| Some variable_uid -> variable_uid
| None ->
Errors.raise_error
Messages.raise_error
"Please provide a scope variable to analyze with the -v option."
in
Desugared.Print.print_exceptions_graph scope_uid variable_uid
@ -307,38 +307,35 @@ let driver source_file (options : Cli.options) : int =
prgm
| ( `Interpret | `Interpret_Lcalc | `Typecheck | `OCaml | `Python | `Scalc
| `Lcalc | `Dcalc | `Proof | `Plugin _ ) as backend -> (
Cli.debug_print "Typechecking...";
Messages.emit_debug "Typechecking...";
let type_ordering =
Scopelang.Dependency.check_type_cycles prgm.program_ctx.ctx_structs
prgm.program_ctx.ctx_enums
in
let prgm = Scopelang.Ast.type_program prgm in
Cli.debug_print "Translating to default calculus...";
Messages.emit_debug "Translating to default calculus...";
let prgm = Dcalc.From_scopelang.translate_program prgm in
let prgm =
if options.optimize then begin
Cli.debug_print "Optimizing default calculus...";
Messages.emit_debug "Optimizing default calculus...";
Shared_ast.Optimizations.optimize_program prgm
end
else prgm
in
(* Cli.debug_print (Format.asprintf "Typechecking results :@\n%a"
(* Messages.emit_debug (Format.asprintf "Typechecking results :@\n%a"
(Print.typ prgm.decl_ctx) typ); *)
match backend with
| `Typecheck ->
Cli.debug_print "Typechecking again...";
Messages.emit_debug "Typechecking again...";
let _ =
try Shared_ast.Typing.program prgm ~leave_unresolved:false
with Errors.StructuredError (msg, details) ->
let msg =
"Typing error occured during re-typing on the 'default \
calculus'. This is a bug in the Catala compiler.\n"
^ msg
in
raise (Errors.StructuredError (msg, details))
with Messages.CompilerError error_content ->
raise
(Messages.CompilerError
(Messages.to_internal_error error_content))
in
(* That's it! *)
Cli.result_print "Typechecking successful!"
Messages.emit_result "Typechecking successful!"
| `Dcalc ->
let _output_file, with_output = get_output_format () in
with_output
@ -365,23 +362,21 @@ let driver source_file (options : Cli.options) : int =
prgrm_dcalc_expr
| ( `Interpret | `OCaml | `Python | `Scalc | `Lcalc | `Proof | `Plugin _
| `Interpret_Lcalc ) as backend -> (
Cli.debug_print "Typechecking again...";
Messages.emit_debug "Typechecking again...";
let prgm =
try Shared_ast.Typing.program ~leave_unresolved:false prgm
with Errors.StructuredError (msg, details) ->
let msg =
"Typing error occured during re-typing on the 'default \
calculus'. This is a bug in the Catala compiler.\n"
^ msg
in
raise (Errors.StructuredError (msg, details))
with Messages.CompilerError error_content ->
raise
(Messages.CompilerError
(Messages.to_internal_error error_content))
in
if !Cli.check_invariants_flag then (
Cli.debug_format "Checking invariants...";
Messages.emit_debug "Checking invariants...";
let result = Dcalc.Invariants.check_all_invariants prgm in
if not result then
raise
(Errors.raise_internal_error "Some Dcalc invariants are invalid"));
(Messages.raise_internal_error
"Some Dcalc invariants are invalid"));
match backend with
| `Proof ->
let vcs =
@ -393,7 +388,7 @@ let driver source_file (options : Cli.options) : int =
Verification.Solver.solve_vc prgm.decl_ctx vcs
| `Interpret ->
Cli.debug_print "Starting interpretation (dcalc)...";
Messages.emit_debug "Starting interpretation (dcalc)...";
let results =
Shared_ast.Interpreter.interpret_program_dcalc prgm scope_uid
in
@ -402,18 +397,18 @@ let driver source_file (options : Cli.options) : int =
(fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2)
results
in
Cli.debug_print "End of interpretation";
Cli.result_print "Computation successful!%s"
Messages.emit_debug "End of interpretation";
Messages.emit_result "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
List.iter
(fun ((var, _), result) ->
Cli.result_format "@[<hov 2>%s@ =@ %a@]" var
Messages.emit_result "@[<hov 2>%s@ =@ %a@]" var
(Shared_ast.Print.expr ~debug:options.debug ())
result)
results
| `Plugin (Plugin.Dcalc p) ->
let output_file, _ = get_output_format ~ext:p.Plugin.extension () in
Cli.debug_print "Compiling program through backend \"%s\"..."
Messages.emit_debug "Compiling program through backend \"%s\"..."
p.Plugin.name;
p.Plugin.apply ~source_file ~output_file
~scope:
@ -424,10 +419,10 @@ let driver source_file (options : Cli.options) : int =
type_ordering
| (`OCaml | `Interpret_Lcalc | `Python | `Lcalc | `Scalc | `Plugin _)
as backend -> (
Cli.debug_print "Compiling program into lambda calculus...";
Messages.emit_debug "Compiling program into lambda calculus...";
let prgm =
if options.trace && options.avoid_exceptions then
Errors.raise_error
Messages.raise_error
"Option --avoid_exceptions is not compatible with option \
--trace";
if options.avoid_exceptions then
@ -439,7 +434,7 @@ let driver source_file (options : Cli.options) : int =
in
let prgm =
if options.optimize then begin
Cli.debug_print "Optimizing lambda calculus...";
Messages.emit_debug "Optimizing lambda calculus...";
Shared_ast.Optimizations.optimize_program prgm
end
else Shared_ast.Program.untype prgm
@ -447,19 +442,19 @@ let driver source_file (options : Cli.options) : int =
let prgm =
if options.closure_conversion then (
if not options.avoid_exceptions then
Errors.raise_error
Messages.raise_error
"Option --avoid_exceptions must be enabled for \
--closure_conversion";
Cli.debug_print "Performing closure conversion...";
Messages.emit_debug "Performing closure conversion...";
let prgm = Lcalc.Closure_conversion.closure_conversion prgm in
let prgm = Bindlib.unbox prgm in
let prgm =
if options.optimize then (
Cli.debug_print "Optimizing lambda calculus...";
Messages.emit_debug "Optimizing lambda calculus...";
Shared_ast.Optimizations.optimize_program prgm)
else prgm
in
Cli.debug_print "Retyping lambda calculus...";
Messages.emit_debug "Retyping lambda calculus...";
let prgm =
Shared_ast.Program.untype
(Shared_ast.Typing.program ~leave_unresolved:true prgm)
@ -481,7 +476,7 @@ let driver source_file (options : Cli.options) : int =
(Shared_ast.Print.program ~debug:options.debug)
prgm
| `Interpret_Lcalc ->
Cli.debug_print "Starting interpretation (lcalc)...";
Messages.emit_debug "Starting interpretation (lcalc)...";
let results =
Shared_ast.Interpreter.interpret_program_lcalc prgm scope_uid
in
@ -490,12 +485,12 @@ let driver source_file (options : Cli.options) : int =
(fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2)
results
in
Cli.debug_print "End of interpretation";
Cli.result_print "Computation successful!%s"
Messages.emit_debug "End of interpretation";
Messages.emit_result "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
List.iter
(fun ((var, _), result) ->
Cli.result_format "@[<hov 2>%s@ =@ %a@]" var
Messages.emit_result "@[<hov 2>%s@ =@ %a@]" var
(Shared_ast.Print.expr ~debug:options.debug ())
result)
results
@ -507,8 +502,8 @@ let driver source_file (options : Cli.options) : int =
in
with_output
@@ fun fmt ->
Cli.debug_print "Compiling program into OCaml...";
Cli.debug_print "Writing to %s..."
Messages.emit_debug "Compiling program into OCaml...";
Messages.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
Lcalc.To_ocaml.format_program fmt prgm type_ordering
| `Plugin (Plugin.Dcalc _) -> assert false
@ -516,8 +511,8 @@ let driver source_file (options : Cli.options) : int =
let output_file, _ =
get_output_format ~ext:p.Plugin.extension ()
in
Cli.debug_print "Compiling program through backend \"%s\"..."
p.Plugin.name;
Messages.emit_debug
"Compiling program through backend \"%s\"..." p.Plugin.name;
p.Plugin.apply ~source_file ~output_file
~scope:
(match options.ex_scope with
@ -546,8 +541,8 @@ let driver source_file (options : Cli.options) : int =
let output_file, with_output =
get_output_format ~ext:".py" ()
in
Cli.debug_print "Compiling program into Python...";
Cli.debug_print "Writing to %s..."
Messages.emit_debug "Compiling program into Python...";
Messages.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
with_output
@@ fun fmt ->
@ -555,9 +550,9 @@ let driver source_file (options : Cli.options) : int =
| `Plugin (Plugin.Dcalc _ | Plugin.Lcalc _) -> assert false
| `Plugin (Plugin.Scalc p) ->
let output_file, _ = get_output ~ext:p.Plugin.extension () in
Cli.debug_print "Compiling program through backend \"%s\"..."
p.Plugin.name;
Cli.debug_print "Writing to %s..."
Messages.emit_debug
"Compiling program through backend \"%s\"..." p.Plugin.name;
Messages.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
p.Plugin.apply ~source_file ~output_file
~scope:
@ -567,14 +562,16 @@ let driver source_file (options : Cli.options) : int =
prgm type_ordering)))))));
0
with
| Errors.StructuredError (msg, pos) ->
| Messages.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Errors.print_structured_error msg pos;
Messages.emit_content content Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-1
| Sys_error msg ->
let bt = Printexc.get_raw_backtrace () in
Cli.error_print "System error: %s" msg;
Messages.emit_content
(Messages.Content.of_message ("System error: " ^ msg))
Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-1

14
compiler/lcalc/compile_without_exceptions.ml
View File

@ -57,7 +57,7 @@ let rec trans_typ_keep (tau : typ) : typ =
| TStruct s -> TStruct s
| TEnum en -> TEnum en
| TOption _ ->
Errors.raise_internal_error
Messages.raise_internal_error
"The type option should not appear before the dcalc -> lcalc \
translation step."
| TAny -> TAny
@ -101,7 +101,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
let m = Mark.get e in
let mark = m in
let pos = Expr.pos e in
(* Cli.debug_format "%a" (Print.expr ~debug:true ()) e; *)
(* Messages.emit_debug "%a" (Print.expr ~debug:true ()) e; *)
match Mark.remove e with
| EVar x ->
if (Var.Map.find x ctx.ctx_vars).info_pure then
@ -210,7 +210,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
in
Ast.OptionMonad.bind_var (trans ctx' body) var' (trans ctx arg) ~mark
| EApp { f = EApp { f = EOp { op = Op.Log _; _ }, _; args = _ }, _; _ } ->
Errors.raise_internal_error
Messages.raise_internal_error
"Parameter trace is incompatible with parameter avoid_exceptions: some \
tracing logs were added while they are not supported."
(* Encoding of Fold, Filter, Map and Reduce is non trivial because we don't
@ -337,7 +337,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
| EApp { f = EOp { op = Op.Fold as op; _ }, _; _ }
| EApp { f = EOp { op = Op.Reduce as op; _ }, _; _ } ->
(* Cannot happend: list operator must be fully determined *)
Errors.raise_internal_error
Messages.raise_internal_error
"List operator %a was not fully determined: some partial evaluation was \
found while compiling."
(Print.operator ~debug:false)
@ -436,12 +436,12 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
Ast.OptionMonad.return ~mark (Expr.eassert (Expr.evar e mark) mark))
(trans ctx e) ~mark
| EApp _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Internal Error: found an EApp that does not satisfy the invariants when \
translating Dcalc to Lcalc without exceptions."
(* invalid invariant *)
| EOp _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Internal Error: found an EOp that does not satisfy the invariants when \
translating Dcalc to Lcalc without exceptions."
| ELocation _ -> .
@ -568,7 +568,7 @@ let rec trans_scope_let (ctx : typed ctx) (s : typed D.expr scope_let) =
})
scope_let_expr scope_let_next
| { scope_let_kind = SubScopeVarDefinition; scope_let_pos = pos; _ } ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"Internal Error: found an SubScopeVarDefinition that does not satisfy \
the invariants when translating Dcalc to Lcalc without exceptions."
| {

4
compiler/lcalc/to_ocaml.ml
View File

@ -23,7 +23,7 @@ let find_struct (s : StructName.t) (ctx : decl_ctx) : typ StructField.Map.t =
try StructName.Map.find s ctx.ctx_structs
with Not_found ->
let s_name, pos = StructName.get_info s in
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"Internal Error: Structure %s was not found in the current environment."
s_name
@ -31,7 +31,7 @@ let find_enum (en : EnumName.t) (ctx : decl_ctx) : typ EnumConstructor.Map.t =
try EnumName.Map.find en ctx.ctx_enums
with Not_found ->
let en_name, pos = EnumName.get_info en in
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"Internal Error: Enumeration %s was not found in the current environment."
en_name

3
compiler/literate/html.ml
View File

@ -100,7 +100,8 @@ let wrap_html
(** Performs syntax highlighting on a piece of code by using Pygments and the
special Catala lexer. *)
let pygmentize_code (c : string Mark.pos) (lang : C.backend_lang) : string =
C.debug_print "Pygmenting the code chunk %s" (Pos.to_string (Mark.get c));
Messages.emit_debug "Pygmenting the code chunk %s"
(Pos.to_string (Mark.get c));
let output =
File.with_temp_file "catala_html_pygments" "in" ~contents:(Mark.remove c)
@@ fun temp_file_in ->

2
compiler/literate/latex.ml
View File

@ -306,5 +306,5 @@ let ast_to_latex
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_latex language print_only_law)
fmt program.program_items;
Cli.debug_print "Lines of Catala inside literate source code: %d"
Messages.emit_debug "Lines of Catala inside literate source code: %d"
!lines_of_code

8
compiler/literate/literate_common.ml
View File

@ -64,7 +64,7 @@ let get_language_extension = function
| Pl -> "catala_pl"
let raise_failed_pandoc (command : string) (error_code : int) : 'a =
Errors.raise_error
Messages.raise_error
"Weaving failed: pandoc command \"%s\" returned with error code %d" command
error_code
@ -112,14 +112,14 @@ let check_exceeding_lines
Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s
in
if len_s > max_len then (
Cli.warning_print "The line %s in %s is exceeding %s characters:"
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);
Cli.warning_print "%s%s" (String.sub s 0 max_len)
Messages.emit_warning "%s%s" (String.sub s 0 max_len)
(Cli.with_style
ANSITerminal.[red]
"%s"
@ -139,7 +139,7 @@ let call_pygmentize ?lang args =
let cmd = "pygmentize" in
let check_exit n =
if n <> 0 then
Errors.raise_error
Messages.raise_error
"Weaving failed: pygmentize command %S returned with error code %d"
(String.concat " " (cmd :: args))
n

4
compiler/plugin.ml
View File

@ -59,9 +59,9 @@ let find name = Hashtbl.find backend_plugins (String.lowercase_ascii name)
let load_file f =
try
Dynlink.loadfile f;
Cli.debug_print "Plugin %S loaded" f
Messages.emit_debug "Plugin %S loaded" f
with e ->
Errors.format_warning "Could not load plugin %S: %s" f
Messages.emit_warning "Could not load plugin %S: %s" f
(Printexc.to_string e)
let rec load_dir d =

8
compiler/plugins/api_web.ml
View File

@ -248,7 +248,7 @@ module To_jsoo = struct
(fun fmt (cname, typ) ->
match Mark.remove typ with
| TTuple _ ->
Cli.error_print
Messages.raise_spanned_error (Mark.get typ)
"Tuples aren't supported yet in the conversion to JS"
| _ ->
Format.fprintf fmt
@ -273,7 +273,7 @@ module To_jsoo = struct
(fun fmt (cname, typ) ->
match Mark.remove typ with
| TTuple _ ->
Cli.error_print
Messages.raise_spanned_error (Mark.get typ)
"Tuples aren't yet supported in the conversion to JS..."
| TLit TUnit ->
Format.fprintf fmt "@[<hv 2>| \"%a\" ->@ %a.%a ()@]"
@ -439,7 +439,7 @@ let apply
ignore scope;
File.with_formatter_of_opt_file output_file (fun fmt ->
Cli.trace_flag := true;
Cli.debug_print "Writing OCaml code to %s..."
Messages.emit_debug "Writing OCaml code to %s..."
(Option.value ~default:"stdout" output_file);
To_ocaml.format_program fmt prgm type_ordering);
@ -466,7 +466,7 @@ let apply
filename_without_ext
in
with_formatter (fun fmt ->
Cli.debug_print "Writing JSOO API code to %s..."
Messages.emit_debug "Writing JSOO API code to %s..."
(Option.value ~default:"stdout" jsoo_output_file);
To_jsoo.format_program fmt module_name prgm type_ordering)

5
compiler/plugins/json_schema.ml
View File

@ -224,12 +224,13 @@ let apply
match scope with
| Some s ->
File.with_formatter_of_opt_file output_file (fun fmt ->
Cli.debug_print
Messages.emit_debug
"Writing JSON schema corresponding to the scope '%a' to the file \
%s..."
ScopeName.format_t s
(Option.value ~default:"stdout" output_file);
To_json.format_program fmt s prgm)
| None -> Cli.error_print "A scope must be specified for the plugin: %s" name
| None ->
Messages.raise_error "A scope must be specified for the plugin: %s" name
let () = Driver.Plugin.register_lcalc ~name ~extension apply

6
compiler/plugins/lazy_interp.ml
View File

@ -20,7 +20,7 @@ open Shared_ast
(* -- Definition of the lazy interpreter -- *)
let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n")
let error e = Errors.raise_spanned_error (Expr.pos e)
let error e = Messages.raise_spanned_error (Expr.pos e)
let noassert = true
type laziness_level = {
@ -186,7 +186,7 @@ let rec lazy_eval :
log "@[<hov 5>EVAL %a@]" Expr.format e;
lazy_eval ctx env llevel e
| _ :: _ :: _ ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
((None, Expr.mark_pos m)
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
"Conflicting exceptions")
@ -257,7 +257,7 @@ let extension = ".out" (* unused *)
let apply ~source_file ~output_file ~scope prg _type_ordering =
let scope =
match scope with
| None -> Errors.raise_error "A scope must be specified"
| None -> Messages.raise_error "A scope must be specified"
| Some s -> s
in
ignore source_file;

2
compiler/scalc/from_lcalc.ml
View File

@ -38,7 +38,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
with Not_found -> (
try A.EFunc (Var.Map.find v ctxt.func_dict)
with Not_found ->
Errors.raise_spanned_error (Expr.pos expr)
Messages.raise_spanned_error (Expr.pos expr)
"Var not found in lambda→scalc: %a@\nknown: @[<hov>%a@]@\n"
Print.var_debug v
(Format.pp_print_list ~pp_sep:Format.pp_print_space

12
compiler/scopelang/dependency.ml
View File

@ -115,7 +115,7 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
(fun glo_name (expr, _) g ->
let used_defs = expr_used_defs expr in
if VMap.mem (Topdef glo_name) used_defs then
Errors.raise_spanned_error
Messages.raise_spanned_error
(Mark.get (TopdefName.get_info glo_name))
"The Topdef %a has a definition that refers to itself, which is \
forbidden since Catala does not provide recursion"
@ -133,7 +133,7 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
(fun g rule ->
let used_defs = rule_used_defs rule in
if VMap.mem (Scope scope_name) used_defs then
Errors.raise_spanned_error
Messages.raise_spanned_error
(Mark.get (ScopeName.get_info scope.Ast.scope_decl_name))
"The scope %a is calling into itself as a subscope, which is \
forbidden since Catala does not provide recursion"
@ -188,7 +188,7 @@ let check_for_cycle_in_defs (g : SDependencies.t) : unit =
cycle
(List.tl cycle @ [List.hd cycle])
in
Errors.raise_multispanned_error spans
Messages.raise_multispanned_error spans
"@[<hov 2>Cyclic dependency detected between the following scopes:@ \
@[<hv>%a@]@]"
(Format.pp_print_list
@ -279,7 +279,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Errors.raise_spanned_error (Mark.get typ)
Messages.raise_spanned_error (Mark.get typ)
"The type %a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
TVertex.format_t used
@ -301,7 +301,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Errors.raise_spanned_error (Mark.get typ)
Messages.raise_spanned_error (Mark.get typ)
"The type %a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
TVertex.format_t used
@ -344,6 +344,6 @@ let check_type_cycles (structs : struct_ctx) (enums : enum_ctx) : TVertex.t list
])
scc)
in
Errors.raise_multispanned_error spans
Messages.raise_multispanned_error spans
"Cyclic dependency detected between types!");
List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])

10
compiler/scopelang/from_desugared.ml
View File

@ -77,7 +77,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
(* Note: this could only happen if disambiguation was disabled. If we want
to support it, we should still allow this case when the field has only
one possible matching structure *)
Errors.raise_spanned_error (Expr.mark_pos m)
Messages.raise_spanned_error (Expr.mark_pos m)
"Ambiguous structure field access"
| EDStructAccess { e; field; name_opt = Some name } ->
let e' = translate_expr ctx e in
@ -87,7 +87,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
(IdentName.Map.find field ctx.decl_ctx.ctx_struct_fields)
with Not_found ->
(* Should not happen after disambiguation *)
Errors.raise_spanned_error (Expr.mark_pos m)
Messages.raise_spanned_error (Expr.mark_pos m)
"Field %a does not belong to structure %a"
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ field ^ "\"")
@ -192,7 +192,7 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
match Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input with
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be redefined. *)
Errors.raise_multispanned_error
Messages.raise_multispanned_error
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
:: List.map
(fun (rule, _) ->
@ -245,7 +245,7 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| NoInput ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
(( Some "Incriminated subscope:",
Mark.get (SubScopeName.get_info sscope) )
:: ( Some "Incriminated variable:",
@ -260,7 +260,7 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
(* If the subscope variable is tagged as input, then it shall be
defined. *)
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
( Some "Incriminated subscope:",
Mark.get (SubScopeName.get_info sscope) );

6
compiler/shared_ast/expr.ml
View File

@ -89,12 +89,12 @@ module Box = struct
match fv b with
| [] -> ()
| [h] ->
Errors.raise_internal_error
Messages.raise_internal_error
"The boxed term is not closed the variable %s is free in the global \
context"
h
| l ->
Errors.raise_internal_error
Messages.raise_internal_error
"The boxed term is not closed the variables %a is free in the global \
context"
(Format.pp_print_list
@ -792,7 +792,7 @@ let make_app e args pos =
tr
| TAny -> fty.ty
| _ ->
Errors.raise_internal_error
Messages.raise_internal_error
"wrong type: found %a while expecting either an Arrow or Any"
Print.typ_debug fty.ty))
(List.map Mark.get (e :: args))

67
compiler/shared_ast/interpreter.ml
View File

@ -55,8 +55,8 @@ let print_log entry infos pos e =
| VarDef _ ->
(* TODO: this usage of Format is broken, Formatting requires that all is
formatted in one pass, without going through intermediate "%s" *)
Cli.log_format "%*s%a %a: %s" (!log_indent * 2) "" Print.log_entry entry
Print.uid_list infos
Messages.emit_log "%*s%a %a: %s" (!log_indent * 2) "" Print.log_entry
entry Print.uid_list infos
(let expr_str =
Format.asprintf "%a" (Print.expr ~hide_function_body:true ()) e
in
@ -69,18 +69,19 @@ let print_log entry infos pos e =
| PosRecordIfTrueBool -> (
match pos <> Pos.no_pos, Mark.remove e with
| true, ELit (LBool true) ->
Cli.log_format "%*s%a%s:\n%s" (!log_indent * 2) "" Print.log_entry entry
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) ""))
| _ -> ())
| BeginCall ->
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.log_entry entry
Messages.emit_log "%*s%a %a" (!log_indent * 2) "" Print.log_entry entry
Print.uid_list infos;
log_indent := !log_indent + 1
| EndCall ->
log_indent := !log_indent - 1;
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.log_entry entry
Messages.emit_log "%*s%a %a" (!log_indent * 2) "" Print.log_entry entry
Print.uid_list infos
exception CatalaException of except
@ -145,19 +146,19 @@ let rec evaluate_operator
in
try f x y with
| Division_by_zero ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
Some "The division operator:", pos;
Some "The null denominator:", Expr.pos (List.nth args 1);
]
"division by zero at runtime"
| Runtime.UncomparableDurations ->
Errors.raise_multispanned_error (get_binop_args_pos args)
Messages.raise_multispanned_error (get_binop_args_pos args)
"Cannot compare together durations that cannot be converted to a \
precise number of days"
in
let err () =
Errors.raise_multispanned_error
Messages.raise_multispanned_error
([Some "Operator:", pos]
@ List.mapi
(fun i arg ->
@ -202,7 +203,7 @@ let rec evaluate_operator
match evaluate_expr (Mark.copy e' (EApp { f; args = [e'] })) with
| ELit (LBool b), _ -> b
| _ ->
Errors.raise_spanned_error
Messages.raise_spanned_error
(Expr.pos (List.nth args 0))
"This predicate evaluated to something else than a boolean \
(should not happen if the term was well-typed)")
@ -395,7 +396,7 @@ let rec evaluate_expr :
let pos = Expr.mark_pos m in
match Mark.remove e with
| EVar _ ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"free variable found at evaluation (should not happen if term was \
well-typed)"
| EApp { f = e1; args } -> (
@ -409,13 +410,13 @@ let rec evaluate_expr :
evaluate_expr ctx
(Bindlib.msubst binder (Array.of_list (List.map Mark.remove args)))
else
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"wrong function call, expected %d arguments, got %d"
(Bindlib.mbinder_arity binder)
(List.length args)
| EOp { op; _ } -> evaluate_operator (evaluate_expr ctx) op m args
| _ ->
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"function has not been reduced to a lambda at evaluation (should not \
happen if the term was well-typed")
| (EAbs _ | ELit _ | EOp _) as e -> Mark.add m e (* these are values *)
@ -438,19 +439,19 @@ let rec evaluate_expr :
match Mark.remove e with
| EStruct { fields = es; name } -> (
if not (StructName.equal s name) then
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[None, pos; None, Expr.pos e]
"Error during struct access: not the same structs (should not happen \
if the term was well-typed)";
match StructField.Map.find_opt field es with
| Some e' -> e'
| None ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Invalid field access %a in struct %a (should not happen if the term \
was well-typed)"
StructField.format_t field StructName.format_t s)
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"The expression %a should be a struct %a but is not (should not happen \
if the term was well-typed)"
(Print.expr ()) e StructName.format_t s)
@ -459,7 +460,7 @@ let rec evaluate_expr :
match evaluate_expr ctx e1 with
| ETuple es, _ when List.length es = size -> List.nth es index
| e ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"The expression %a was expected to be a tuple of size %d (should not \
happen if the term was well-typed)"
(Print.expr ()) e size)
@ -472,7 +473,7 @@ let rec evaluate_expr :
match Mark.remove e with
| EInj { e = e1; cons; name = name' } ->
if not (EnumName.equal name name') then
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[None, Expr.pos e; None, Expr.pos e1]
"Error during match: two different enums found (should not happen if \
the term was well-typed)";
@ -480,14 +481,14 @@ let rec evaluate_expr :
match EnumConstructor.Map.find_opt cons cases with
| Some es_n -> es_n
| None ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"sum type index error (should not happen if the term was \
well-typed)"
in
let new_e = Mark.add m (EApp { f = es_n; args = [e1] }) in
evaluate_expr ctx new_e
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Expected a term having a sum type as an argument to a match (should \
not happen if the term was well-typed")
| EIfThenElse { cond; etrue; efalse } -> (
@ -497,7 +498,7 @@ let rec evaluate_expr :
| ELit (LBool true) -> evaluate_expr ctx etrue
| ELit (LBool false) -> evaluate_expr ctx efalse
| _ ->
Errors.raise_spanned_error (Expr.pos cond)
Messages.raise_spanned_error (Expr.pos cond)
"Expected a boolean literal for the result of this condition (should \
not happen if the term was well-typed)")
| EArray es ->
@ -514,22 +515,22 @@ let rec evaluate_expr :
f = EOp { op; _ }, _;
args = [((ELit _, _) as e1); ((ELit _, _) as e2)];
} ->
Errors.raise_spanned_error (Expr.pos e')
Messages.raise_spanned_error (Expr.pos e')
"Assertion failed: %a %a %a" (Print.expr ()) e1
(Print.operator ~debug:!Cli.debug_flag)
op (Print.expr ()) e2
| _ ->
Cli.debug_format "%a" (Print.expr ()) e';
Errors.raise_spanned_error (Expr.mark_pos m) "Assertion failed")
Messages.emit_debug "%a" (Print.expr ()) e';
Messages.raise_spanned_error (Expr.mark_pos m) "Assertion failed")
| _ ->
Errors.raise_spanned_error (Expr.pos e')
Messages.raise_spanned_error (Expr.pos e')
"Expected a boolean literal for the result of this assertion \
(should not happen if the term was well-typed)")
| EEmptyError -> Mark.copy e EEmptyError
| EErrorOnEmpty e' -> (
match evaluate_expr ctx e' with
| EEmptyError, _ ->
Errors.raise_spanned_error (Expr.pos e')
Messages.raise_spanned_error (Expr.pos e')
"This variable evaluated to an empty term (no rule that defined it \
applied in this situation)"
| e -> e)
@ -544,12 +545,12 @@ let rec evaluate_expr :
| ELit (LBool true) -> evaluate_expr ctx cons
| ELit (LBool false) -> Mark.copy e EEmptyError
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Default justification has not been reduced to a boolean at \
evaluation (should not happen if the term was well-typed")
| 1 -> List.find (fun sub -> not (is_empty_error sub)) excepts
| _ ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
(List.map
(fun except ->
Some "This consequence has a valid justification:", Expr.pos except)
@ -584,7 +585,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
Expr.option_enum mark_e
: (_, _) boxed_gexpr)
| _ ->
Errors.raise_spanned_error (Mark.get ty)
Messages.raise_spanned_error (Mark.get ty)
"This scope needs input arguments to be executed. But the Catala \
built-in interpreter does not have a way to retrieve input \
values from the command line, so it cannot execute this scope. \
@ -603,12 +604,12 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(fun (fld, e) -> StructField.get_info fld, e)
(StructField.Map.bindings fields)
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"The interpretation of a program should always yield a struct \
corresponding to the scope variables"
end
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"The interpreter can only interpret terms starting with functions having \
thunked arguments"
@ -635,7 +636,7 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(Bindlib.box EEmptyError, Expr.with_ty mark_e ty_out)
ty_in (Expr.mark_pos mark_e)
| _ ->
Errors.raise_spanned_error (Mark.get ty)
Messages.raise_spanned_error (Mark.get ty)
"This scope needs input arguments to be executed. But the Catala \
built-in interpreter does not have a way to retrieve input \
values from the command line, so it cannot execute this scope. \
@ -654,11 +655,11 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(fun (fld, e) -> StructField.get_info fld, e)
(StructField.Map.bindings fields)
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"The interpretation of a program should always yield a struct \
corresponding to the scope variables"
end
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"The interpreter can only interpret terms starting with functions having \
thunked arguments"

2
compiler/shared_ast/operator.ml
View File

@ -538,7 +538,7 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
in
resolve_overload_aux (Mark.remove op) operands
with Not_found ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
((None, Mark.get op)
:: List.map
(fun ty ->

34
compiler/shared_ast/typing.ml
View File

@ -64,7 +64,7 @@ let rec typ_to_ast ~leave_unresolved (ty : unionfind_typ) : A.typ =
(* No polymorphism in Catala: type inference should return full types
without wildcards, and this function is used to recover the types after
typing. *)
Errors.raise_spanned_error pos
Messages.raise_spanned_error pos
"Internal error: typing at this point could not be resolved"
let rec ast_to_typ (ty : A.typ) : unionfind_typ =
@ -138,8 +138,8 @@ let rec unify
(t1 : unionfind_typ)
(t2 : unionfind_typ) : unit =
let unify = unify ctx in
(* Cli.debug_format "Unifying %a and %a" (format_typ ctx) t1 (format_typ ctx)
t2; *)
(* Messages.emit_debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ
ctx) t2; *)
let t1_repr = UnionFind.get (UnionFind.find t1) in
let t2_repr = UnionFind.get (UnionFind.find t2) in
let raise_type_error () = raise (Type_error (A.AnyExpr e, t1, t2)) in
@ -192,7 +192,7 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
let t2_s fmt () =
Cli.format_with_style [ANSITerminal.yellow] fmt (unformat_typ t2)
in
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
( Some
(Format.asprintf
@ -356,8 +356,8 @@ and typecheck_expr_top_down :
(a, m) A.gexpr ->
(a, unionfind_typ A.custom) A.boxed_gexpr =
fun ~leave_unresolved ctx env tau e ->
(* Cli.debug_format "Propagating type %a for naked_expr %a" (format_typ ctx)
tau (Expr.format ctx) e; *)
(* Messages.emit_debug "Propagating type %a for naked_expr %a" (format_typ
ctx) tau (Expr.format ctx) e; *)
let pos_e = Expr.pos e in
let () =
(* If there already is a type annotation on the given expr, ensure it
@ -389,7 +389,7 @@ and typecheck_expr_top_down :
match ty_opt with
| Some ty -> ty
| None ->
Errors.raise_spanned_error pos_e "Reference to %a not found"
Messages.raise_spanned_error pos_e "Reference to %a not found"
(Print.expr ()) e
in
Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty))
@ -424,7 +424,7 @@ and typecheck_expr_top_down :
(A.StructField.Map.bindings extra_fields)
in
if errs <> [] then
Errors.raise_multispanned_error errs
Messages.raise_multispanned_error errs
"Mismatching field definitions for structure %a" A.StructName.format_t
name
in
@ -453,7 +453,7 @@ and typecheck_expr_top_down :
Printf.ksprintf failwith
"Disambiguation failed before reaching field %s" field
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"This is not a structure, cannot access field %s (%a)" field
(format_typ ctx) (ty e_struct')
in
@ -461,14 +461,14 @@ and typecheck_expr_top_down :
let str =
try A.StructName.Map.find name env.structs
with Not_found ->
Errors.raise_spanned_error pos_e "No structure %a found"
Messages.raise_spanned_error pos_e "No structure %a found"
A.StructName.format_t name
in
let field =
let candidate_structs =
try A.IdentName.Map.find field ctx.ctx_struct_fields
with Not_found ->
Errors.raise_spanned_error
Messages.raise_spanned_error
(Expr.mark_pos context_mark)
"Field %a does not belong to structure %a (no structure defines \
it)"
@ -479,7 +479,7 @@ and typecheck_expr_top_down :
in
try A.StructName.Map.find name candidate_structs
with Not_found ->
Errors.raise_spanned_error
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])
@ -503,12 +503,12 @@ and typecheck_expr_top_down :
let str =
try A.StructName.Map.find name env.structs
with Not_found ->
Errors.raise_spanned_error pos_e "No structure %a found"
Messages.raise_spanned_error pos_e "No structure %a found"
A.StructName.format_t name
in
try A.StructField.Map.find field str
with Not_found ->
Errors.raise_multispanned_error
Messages.raise_multispanned_error
[
None, pos_e;
( Some "Structure %a declared here",
@ -620,7 +620,7 @@ and typecheck_expr_top_down :
match Env.get env v with
| Some t -> t
| None ->
Errors.raise_spanned_error pos_e
Messages.raise_spanned_error pos_e
"Variable %s not found in the current context" (Bindlib.name_of v)
in
Expr.evar (Var.translate v) (mark_with_tau_and_unify tau')
@ -634,7 +634,7 @@ and typecheck_expr_top_down :
Expr.etuple es' mark
| A.ETupleAccess { e = e1; index; size } ->
if index >= size then
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Tuple access out of bounds (%d/%d)" index size;
let tuple_ty =
TTuple
@ -649,7 +649,7 @@ and typecheck_expr_top_down :
Expr.etupleaccess e1' index size context_mark
| A.EAbs { binder; tys = t_args } ->
if Bindlib.mbinder_arity binder <> List.length t_args then
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"function has %d variables but was supplied %d types"
(Bindlib.mbinder_arity binder)
(List.length t_args)

2
compiler/surface/lexer_common.ml
View File

@ -60,7 +60,7 @@ let update_acc (lexbuf : lexbuf) : unit =
(** Error-generating helper *)
let raise_lexer_error (loc : Pos.t) (token : string) =
Errors.raise_spanned_error loc
Messages.raise_spanned_error loc
"Parsing error after token \"%s\": what comes after is unknown" token
(** Associative list matching each punctuation string part of the Catala syntax

6
compiler/surface/parser.mly
View File

@ -130,7 +130,7 @@ let lident :=
| i = LIDENT ; {
match Localisation.lex_builtin i with
| Some _ ->
Errors.raise_spanned_error
Messages.raise_spanned_error
(Pos.from_lpos $sloc)
"Reserved builtin name"
| None ->
@ -502,8 +502,8 @@ let scope_item :=
match Localisation.lex_builtin i with
| Some Round ->
DateRounding(v), Mark.get v
| _ ->
Errors.raise_spanned_error
| _ ->
Messages.raise_spanned_error
(Pos.from_lpos $loc(i))
"Expected the form 'date round increasing' or 'date round decreasing'"
}

6
compiler/surface/parser_driver.ml
View File

@ -111,7 +111,7 @@ let raise_parser_error
(last_good_loc : Pos.t option)
(token : string)
(msg : string) : 'a =
Errors.raise_multispanned_error
Messages.raise_multispanned_error
((Some "Error token:", error_loc)
::
(match last_good_loc with
@ -270,7 +270,7 @@ let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function
let rec parse_source_file
(source_file : Pos.input_file)
(language : Cli.backend_lang) : Ast.program =
Cli.debug_print "Parsing %s"
Messages.emit_debug "Parsing %s"
(match source_file with FileName s | Contents s -> s);
let lexbuf, input =
match source_file with
@ -278,7 +278,7 @@ let rec parse_source_file
try
let input = open_in source_file in
Sedlexing.Utf8.from_channel input, Some input
with Sys_error msg -> Errors.raise_error "System error: %s" msg)
with Sys_error msg -> Messages.raise_error "System error: %s" msg)
| Contents contents -> Sedlexing.Utf8.from_string contents, None
in
let source_file_name =

6
compiler/verification/conditions.ml
View File

@ -135,7 +135,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
match Mark.remove body with
| EErrorOnEmpty e -> e
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Internal error: this expression does not have the structure expected \
by the VC generator:\n\
%a"
@ -143,7 +143,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
| EErrorOnEmpty d ->
d (* input subscope variables and non-input scope variable *)
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Internal error: this expression does not have the structure expected by \
the VC generator:\n\
%a"
@ -327,7 +327,7 @@ let rec generate_verification_conditions_scope_body_expr
let e = match_and_ignore_outer_reentrant_default ctx e in
ctx, [], [e]
| _ ->
Errors.raise_spanned_error (Expr.pos e)
Messages.raise_spanned_error (Expr.pos e)
"Internal error: this assertion does not have the structure \
expected by the VC generator:\n\
%a"

10
compiler/verification/io.ml
View File

@ -142,9 +142,9 @@ module MakeBackendIO (B : Backend) = struct
(vc : Conditions.verification_condition * vc_encoding_result) : bool =
let vc, z3_vc = vc in
Cli.debug_print "For this variable:\n%s\n"
Messages.emit_debug "For this variable:\n%s\n"
(Pos.retrieve_loc_text (Expr.pos vc.Conditions.vc_guard));
Cli.debug_format
Messages.emit_debug
"This verification condition was generated for %a:@\n\
%a@\n\
with assertions:@\n\
@ -158,16 +158,16 @@ module MakeBackendIO (B : Backend) = struct
match z3_vc with
| Success (encoding, backend_ctx) -> (
Cli.debug_print "The translation to Z3 is the following:\n%s"
Messages.emit_debug "The translation to Z3 is the following:\n%s"
(B.print_encoding encoding);
match B.solve_vc_encoding backend_ctx encoding with
| ProvenTrue -> true
| ProvenFalse model ->
Cli.error_print "%s" (print_negative_result vc backend_ctx model);
Messages.emit_warning "%s" (print_negative_result vc backend_ctx model);
false
| Unknown -> failwith "The solver failed at proving or disproving the VC")
| Fail msg ->
Cli.error_print "%s The translation to Z3 failed:\n%s"
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)))

2
compiler/verification/solver.ml
View File

@ -49,4 +49,4 @@ let solve_vc
true z3_vcs
in
if all_proven then
Cli.result_format "No errors found during the proof mode run."
Messages.emit_result "No errors found during the proof mode run."

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

@ -827,7 +827,7 @@ module Backend = struct
add_z3constraint vc ctx
let init_backend () =
Cli.debug_print "Running Z3 version %s" Version.to_string
Messages.emit_debug "Running Z3 version %s" Version.to_string
let make_context (decl_ctx : decl_ctx) : backend_context =
let cfg =

31
french_law/catala_legifrance/api.ml
View File

@ -48,7 +48,7 @@ let get_token_aux (client_id : string) (client_secret : string) :
let get_token (client_id : string) (client_secret : string) : string Lwt.t =
let rec retry count =
if count = 0 then (
Cli.debug_format "Too many retries, giving up\n";
Messages.emit_debug "Too many retries, giving up\n";
exit 1)
else
let* resp, body = get_token_aux client_id client_secret in
@ -59,16 +59,16 @@ let get_token (client_id : string) (client_secret : string) : string Lwt.t =
|> Yojson.Basic.Util.member "access_token"
|> Yojson.Basic.Util.to_string
in
Cli.debug_format "The LegiFrance API access token is %s" token;
Messages.emit_debug "The LegiFrance API access token is %s" token;
Lwt.return token
end
else if Cohttp.Code.code_of_status resp = 400 then begin
Cli.debug_format "The API access request returned code 400%s\n"
Messages.emit_debug "The API access request returned code 400%s\n"
(if count > 1 then ", retrying..." else "");
retry (count - 1)
end
else begin
Cli.debug_format
Messages.emit_debug
"The API access token request went wrong ; status is %s and the body \
is\n\
%s"
@ -121,7 +121,7 @@ let run_request (request : unit -> (string * string) Lwt.t) :
if resp = "200 OK" then
try body |> Yojson.Basic.from_string with
| Yojson.Basic.Util.Type_error (msg, obj) ->
Cli.error_print
Messages.raise_error
"Error while parsing JSON answer from API: %s\n\
Specific JSON:\n\
%s\n\
@ -129,8 +129,7 @@ let run_request (request : unit -> (string * string) Lwt.t) :
%s"
msg
(Yojson.Basic.to_string obj)
body;
exit (-1)
body
| _ -> raise (Failure "")
else raise (Failure "")
in
@ -140,13 +139,12 @@ let run_request (request : unit -> (string * string) Lwt.t) :
with Failure _ ->
if n > 0 then (
Unix.sleep 2;
Cli.debug_format "Retrying request...";
Messages.emit_debug "Retrying request...";
try_n_times (n - 1))
else (
Cli.error_print
else
Messages.raise_error
"The API request went wrong ; status is %s and the body is\n%s" resp
body;
exit (-1))
body
in
try_n_times 5
@ -165,7 +163,7 @@ let parse_id (id : string) : article_id =
else if Re.execp ceta_tex id then CETATEXT
else if Re.execp jorf_rex id then JORFARTI
else
Errors.raise_error
Messages.raise_error
"LégiFrance ID \"%s\" does not correspond to an ID format recognized \
by the LégiFrance API"
id
@ -174,7 +172,7 @@ let parse_id (id : string) : article_id =
let retrieve_article (access_token : string) (obj : article_id) : article Lwt.t
=
Cli.debug_format "Accessing article %s" obj.id;
Messages.emit_debug "Accessing article %s" obj.id;
let* content =
run_request
(make_request access_token
@ -191,7 +189,7 @@ let raise_article_parsing_error
(json : Yojson.Basic.t)
(msg : string)
(obj : Yojson.Basic.t) =
Cli.error_print
Messages.raise_error
"Error while manipulating JSON answer from API: %s\n\
Specific JSON:\n\
%s\n\
@ -199,8 +197,7 @@ let raise_article_parsing_error
%s"
msg
(Yojson.Basic.to_string obj)
(Yojson.Basic.to_string json);
exit 1
(Yojson.Basic.to_string json)
let get_article_id (article : article) : string =
try

20
french_law/catala_legifrance/catala_legifrance.ml
View File

@ -50,7 +50,7 @@ let check_article_expiration
Some new_version
else None
in
Cli.warning_print
Messages.emit_warning
"%s %s has expired! Its expiration date is %s according to \
LégiFrance.%s"
(Mark.remove law_heading.Surface.Ast.law_heading_name)
@ -113,7 +113,7 @@ let compare_to_versions
(law_article_text : law_article_text)
(access_token : Api.access_token) : unit Lwt.t =
let print_diff msg diff =
Cli.warning_print "%s\n%s" msg
Messages.emit_warning "%s\n%s" msg
(String.concat "\n"
(List.map
(fun chunk ->
@ -175,13 +175,13 @@ let include_legislative_text
let* article = Api.retrieve_article access_token id in
let text_to_return = Api.get_article_text article in
let to_insert = text_to_return in
Cli.debug_format "Position: %s" (Pos.to_string_short pos);
Messages.emit_debug "Position: %s" (Pos.to_string_short pos);
let file = Pos.get_file pos in
let include_line = Pos.get_start_line pos in
let ic = open_in file in
let new_file = file ^ ".new" in
Cli.warning_print "LégiFrance inclusion detected, writing new contents to %s"
new_file;
Messages.emit_warning
"LégiFrance inclusion detected, writing new contents to %s" new_file;
let oc = open_out new_file in
(* Pos.t lines start at 1 *)
let counter = ref 1 in
@ -260,7 +260,7 @@ let driver_lwt
try
if debug then Cli.debug_flag := true;
if not (expiration || diff) then
Errors.raise_error
Messages.raise_error
"You have to check at least something, see the list of options with \
--help";
let* access_token = Api.get_token client_id client_secret in
@ -285,9 +285,9 @@ let driver_lwt
in
prerr_endline "0";
Lwt.return 0
with Errors.StructuredError (msg, pos) ->
with Messages.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Errors.print_structured_error msg pos;
Messages.emit_content content Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
Lwt.return (-1)
@ -295,9 +295,9 @@ let driver file debug diff expiration custom_date client_id client_secret =
try
Lwt_main.run
(driver_lwt file debug diff expiration custom_date client_id client_secret)
with Errors.StructuredError (msg, pos) ->
with Messages.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Errors.print_structured_error msg pos;
Messages.emit_content content Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-1

2
french_law/catala_legifrance/date.ml
View File

@ -55,7 +55,7 @@ let parse_expiration_date (date_format : date_format) (expiration_date : string)
Unix.tm_isdst = false;
})
with _ ->
Errors.raise_error "Error while parsing expiration date argument (%s)"
Messages.raise_error "Error while parsing expiration date argument (%s)"
expiration_date
(** Prints an [Unix.tm] under the ISO formatting [YYYY-MM-DD] *)

26820
french_law/js/src/french_law.js generated
View File

File diff suppressed because one or more lines are too long

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

@ -33,9 +33,9 @@ scope B:
$ catala Interpret -s A
[RESULT] Computation successful! Results:
[RESULT] x =
[ { S id = 0; income = $0.00; };
{ S id = 1; income = $9.00; };
{ S id = 2; income = $5.20; } ]
[ { S id = 0; income = $0.00; };
{ S id = 1; income = $9.00; };
{ S id = 2; income = $5.20; } ]
```
```catala-test-inline
@ -48,10 +48,10 @@ $ catala Interpret -s B
$ catala Interpret_Lcalc -s A --avoid_exceptions --optimize
[RESULT] Computation successful! Results:
[RESULT] x =
ESome
[ ESome { S id = ESome 0; income = ESome $0.00; };
ESome { S id = ESome 1; income = ESome $9.00; };
ESome { S id = ESome 2; income = ESome $5.20; } ]
ESome
[ ESome { S id = ESome 0; income = ESome $0.00; };
ESome { S id = ESome 1; income = ESome $9.00; };
ESome { S id = ESome 2; income = ESome $5.20; } ]
```
```catala-test-inline
$ catala Interpret_Lcalc -s B --avoid_exceptions --optimize

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

@ -19,20 +19,18 @@ $ 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] x = ESome [ ESome 0; ESome 1; ESome 2; ESome 3; ESome 4; ESome 5; ESome 6 ]
[RESULT] y =
ESome
[ ESome 0;
ESome 1;
ESome 2;
ESome 3;
ESome 4;
ESome 5;
ESome 6;
ESome 7;
ESome 8;
ESome 9;
ESome 10 ]
ESome
[ ESome 0;
ESome 1;
ESome 2;
ESome 3;
ESome 4;
ESome 5;
ESome 6;
ESome 7;
ESome 8;
ESome 9;
ESome 10 ]
```

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

@ -33,9 +33,9 @@ scope B:
$ catala Interpret -s A
[RESULT] Computation successful! Results:
[RESULT] x =
[ { S id = 0; income = $0.00; };
{ S id = 1; income = $9.00; };
{ S id = 2; income = $5.20; } ]
[ { S id = 0; income = $0.00; };
{ S id = 1; income = $9.00; };
{ S id = 2; income = $5.20; } ]
```
```catala-test-inline
@ -48,10 +48,10 @@ $ catala Interpret -s B
$ catala Interpret_Lcalc -s A --avoid_exceptions --optimize
[RESULT] Computation successful! Results:
[RESULT] x =
ESome
[ ESome { S id = ESome 0; income = ESome $0.00; };
ESome { S id = ESome 1; income = ESome $9.00; };
ESome { S id = ESome 2; income = ESome $5.20; } ]
ESome
[ ESome { S id = ESome 0; income = ESome $0.00; };
ESome { S id = ESome 1; income = ESome $9.00; };
ESome { S id = ESome 2; income = ESome $5.20; } ]
```
```catala-test-inline
$ catala Interpret_Lcalc -s B --avoid_exceptions --optimize

6
tests/test_date/bad/rounding_option.catala_en
View File

@ -12,9 +12,6 @@ scope Test:
```catala-test-inline
$ catala Interpret -s Test
catala: internal error, uncaught exception:
Dates_calc.Dates.AmbiguousComputation
[WARNING] In scope "Test", the variable "ambiguous" is never used anywhere; maybe it's unnecessary?
┌─⯈ tests/test_date/bad/rounding_option.catala_en:5.11-5.20:
@ -22,5 +19,8 @@ catala: internal error, uncaught exception:
5 │ context ambiguous content boolean
│ ‾‾‾‾‾‾‾‾‾
catala: internal error, uncaught exception:
Dates_calc.Dates.AmbiguousComputation
#return code 125#
```

6
tests/test_date/bad/rounding_option.catala_fr
View File

@ -12,9 +12,6 @@ champ d'application Test:
```catala-test-inline
$ catala Interpret -s Test
catala: internal error, uncaught exception:
Dates_calc.Dates.AmbiguousComputation
[WARNING] In scope "Test", the variable "ambiguité" is never used anywhere; maybe it's unnecessary?
┌─⯈ tests/test_date/bad/rounding_option.catala_fr:5.12-5.21:
@ -22,5 +19,8 @@ catala: internal error, uncaught exception:
5 │ contexte ambiguité contenu booléen
│ ‾‾‾‾‾‾‾‾‾
catala: internal error, uncaught exception:
Dates_calc.Dates.AmbiguousComputation
#return code 125#
```

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

@ -18,7 +18,7 @@ scope A:
$ catala Interpret -s A
[RESULT] Computation successful! Results:
[RESULT] a =
-0.000000000000000000000000000000000000000000000000000000000078695580959228473468…
-0.000000000000000000000000000000000000000000000000000000000078695580959228473468…
[RESULT] x = 84.64866565265689623
[RESULT] y = -4.3682977870532065498
[RESULT] z = 654265429805103220650980650.570540510654
@ -27,8 +27,8 @@ $ catala Interpret -s A
$ catala Interpret_Lcalc -s A --avoid_exceptions --optimize
[RESULT] Computation successful! Results:
[RESULT] a =
ESome
-0.000000000000000000000000000000000000000000000000000000000078695580959228473468…
ESome
-0.000000000000000000000000000000000000000000000000000000000078695580959228473468…
[RESULT] x = ESome 84.64866565265689623
[RESULT] y = ESome -4.3682977870532065498
[RESULT] z = ESome 654265429805103220650980650.570540510654

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

@ -54,11 +54,7 @@ $ catala Interpret -s S2
$ catala Interpret_Lcalc -s S --avoid_exceptions --optimize
[RESULT] Computation successful! Results:
[RESULT] a =
ESome
{ A
x = ESome -2.;
y = ESome { B y = ESome false; z = ESome -1.; };
}
ESome { A x = ESome -2.; y = ESome { B y = ESome false; z = ESome -1.; }; }
[RESULT] b = ESome { B y = ESome true; z = ESome 42.; }
```
```catala-test-inline

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

@ -27,11 +27,6 @@ $ 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_proof/bad/array_length-empty.catala_en
View File

@ -19,7 +19,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/array_length-empty.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/array_length-overlap.catala_en
View File

@ -20,7 +20,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/array_length-overlap.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/assert-empty.catala_en
View File

@ -24,7 +24,7 @@ scope Foo:
```catala-test-inline
$ catala Proof --disable_counterexamples
[ERROR] [Foo.x] This variable might return an empty error:
[WARNING] [Foo.x] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/assert-empty.catala_en:4.11-4.12:
└─┐
4 │ output x content integer

2
tests/test_proof/bad/dates_get_year-empty.catala_en
View File

@ -22,7 +22,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/dates_get_year-empty.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/dates_get_year-overlap.catala_en
View File

@ -22,7 +22,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/dates_get_year-overlap.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/dates_simple-empty.catala_en
View File

@ -21,7 +21,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/dates_simple-empty.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/dates_simple-overlap.catala_en
View File

@ -22,7 +22,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/dates_simple-overlap.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/duration-empty.catala_en
View File

@ -19,7 +19,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/duration-empty.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/duration-overlap.catala_en
View File

@ -20,7 +20,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/duration-overlap.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/enums-empty.catala_en
View File

@ -37,7 +37,7 @@ $ catala Proof --disable_counterexamples
7 │ -- C content boolean
│ ‾
└─ Test
[ERROR] [A.x] This variable might return an empty error:
[WARNING] [A.x] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/enums-empty.catala_en:15.11-15.12:
└──┐
15 │ context x content integer

2
tests/test_proof/bad/enums-nonbool-empty.catala_en
View File

@ -35,7 +35,7 @@ $ catala Proof --disable_counterexamples
5 │ -- C content boolean
│ ‾
└─ Test
[ERROR] [A.x] This variable might return an empty error:
[WARNING] [A.x] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/enums-nonbool-empty.catala_en:13.11-13.12:
└──┐
13 │ context x content integer

2
tests/test_proof/bad/enums-nonbool-overlap.catala_en
View File

@ -35,7 +35,7 @@ $ catala Proof --disable_counterexamples
5 │ -- C content boolean
│ ‾
└─ Test
[ERROR] [A.x] At least two exceptions overlap for this variable:
[WARNING] [A.x] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/enums-nonbool-overlap.catala_en:13.11-13.12:
└──┐
13 │ context x content integer

2
tests/test_proof/bad/enums-overlap.catala_en
View File

@ -37,7 +37,7 @@ $ catala Proof --disable_counterexamples
7 │ -- C content boolean
│ ‾
└─ Test
[ERROR] [A.x] At least two exceptions overlap for this variable:
[WARNING] [A.x] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/enums-overlap.catala_en:15.11-15.12:
└──┐
15 │ context x content integer

2
tests/test_proof/bad/enums_inj-empty.catala_en
View File

@ -30,7 +30,7 @@ $ catala Proof --disable_counterexamples
6 │ -- C2
│ ‾‾
└─ Article
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/enums_inj-empty.catala_en:10.11-10.12:
└──┐
10 │ context y content integer

2
tests/test_proof/bad/enums_inj-overlap.catala_en
View File

@ -25,7 +25,7 @@ $ catala Proof --disable_counterexamples
10 │ context y content integer
│ ‾
└─ Article
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/enums_inj-overlap.catala_en:10.11-10.12:
└──┐
10 │ context y content integer

2
tests/test_proof/bad/enums_unit-empty.catala_en
View File

@ -28,7 +28,7 @@ $ catala Proof --disable_counterexamples
10 │ context y content integer
│ ‾
└─ Article
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/enums_unit-empty.catala_en:10.11-10.12:
└──┐
10 │ context y content integer

2
tests/test_proof/bad/enums_unit-overlap.catala_en
View File

@ -28,7 +28,7 @@ $ catala Proof --disable_counterexamples
10 │ context y content integer
│ ‾
└─ Article
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/enums_unit-overlap.catala_en:10.11-10.12:
└──┐
10 │ context y content integer

2
tests/test_proof/bad/let_in_condition-empty.catala_en
View File

@ -20,7 +20,7 @@ $ catala Proof --disable_counterexamples
5 │ context x content boolean
│ ‾
└─ Test
[ERROR] [A.x] This variable might return an empty error:
[WARNING] [A.x] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/let_in_condition-empty.catala_en:5.11-5.12:
└─┐
5 │ context x content boolean

2
tests/test_proof/bad/money-empty.catala_en
View File

@ -23,7 +23,7 @@ $ catala Proof --disable_counterexamples
8 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/money-empty.catala_en:8.11-8.12:
└─┐
8 │ context y content boolean

2
tests/test_proof/bad/money-overlap.catala_en
View File

@ -24,7 +24,7 @@ $ catala Proof --disable_counterexamples
8 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/money-overlap.catala_en:8.11-8.12:
└─┐
8 │ context y content boolean

2
tests/test_proof/bad/no_vars-conflict.catala_en
View File

@ -24,7 +24,7 @@ $ catala Proof --disable_counterexamples
8 │ context y content integer
│ ‾
└─ Test
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/no_vars-conflict.catala_en:8.11-8.12:
└─┐
8 │ context y content integer

2
tests/test_proof/bad/no_vars-empty.catala_en
View File

@ -23,7 +23,7 @@ $ catala Proof --disable_counterexamples
7 │ context y content integer
│ ‾
└─ Test
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/no_vars-empty.catala_en:7.11-7.12:
└─┐
7 │ context y content integer

6
tests/test_proof/bad/prolala_motivating_example.catala_en
View File

@ -139,7 +139,7 @@ $ catala Proof --disable_counterexamples
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└┬ ProLaLa 2022 Super Cash Bonus
└─ Amount
[ERROR] [Amount.amount] This variable might return an empty error:
[WARNING] [Amount.amount] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/prolala_motivating_example.catala_en:60.11-60.17:
└──┐
60 │ context amount content integer
@ -147,7 +147,7 @@ $ catala Proof --disable_counterexamples
└┬ ProLaLa 2022 Super Cash Bonus
└─ Amount
Counterexample generation is disabled so none was generated.
[ERROR] [Eligibility.is_eligible] This variable might return an empty error:
[WARNING] [Eligibility.is_eligible] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/prolala_motivating_example.catala_en:11.10-11.21:
└──┐
11 │ output is_eligible content boolean
@ -155,7 +155,7 @@ Counterexample generation is disabled so none was generated.
└┬ ProLaLa 2022 Super Cash Bonus
└─ Eligibility
Counterexample generation is disabled so none was generated.
[ERROR] [Eligibility.is_eligible] At least two exceptions overlap for this variable:
[WARNING] [Eligibility.is_eligible] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/prolala_motivating_example.catala_en:11.10-11.21:
└──┐
11 │ output is_eligible content boolean

2
tests/test_proof/bad/rationals-empty.catala_en
View File

@ -19,7 +19,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] This variable might return an empty error:
[WARNING] [A.y] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/rationals-empty.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/rationals-overlap.catala_en
View File

@ -20,7 +20,7 @@ $ catala Proof --disable_counterexamples
6 │ context y content boolean
│ ‾
└─ Test
[ERROR] [A.y] At least two exceptions overlap for this variable:
[WARNING] [A.y] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/rationals-overlap.catala_en:6.11-6.12:
└─┐
6 │ context y content boolean

2
tests/test_proof/bad/sat_solving.catala_en
View File

@ -47,7 +47,7 @@ $ catala Proof --disable_counterexamples
15 │ context x10 content boolean
│ ‾‾‾
└─ Test
[ERROR] [A.x10] This variable might return an empty error:
[WARNING] [A.x10] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/sat_solving.catala_en:15.11-15.14:
└──┐
15 │ context x10 content boolean

2
tests/test_proof/bad/structs-empty.catala_en
View File

@ -28,7 +28,7 @@ $ catala Proof --disable_counterexamples
13 │ context x content integer
│ ‾
└─ Test
[ERROR] [A.x] This variable might return an empty error:
[WARNING] [A.x] This variable might return an empty error:
┌─⯈ tests/test_proof/bad/structs-empty.catala_en:13.11-13.12:
└──┐
13 │ context x content integer

2
tests/test_proof/bad/structs-overlap.catala_en
View File

@ -28,7 +28,7 @@ $ catala Proof --disable_counterexamples
13 │ context x content integer
│ ‾
└─ Test
[ERROR] [A.x] At least two exceptions overlap for this variable:
[WARNING] [A.x] At least two exceptions overlap for this variable:
┌─⯈ tests/test_proof/bad/structs-overlap.catala_en:13.11-13.12:
└──┐
13 │ context x content integer

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

@ -70,28 +70,26 @@ $ catala Interpret -t -s HousingComputation
[LOG] ≔ HousingComputation.result: 3
[RESULT] Computation successful! Results:
[RESULT] f = λ (x: integer) →
error_empty
⟨true
⊢ (let result : RentComputation =
(λ (RentComputation_in: RentComputation_in) →
let g : integer → integer =
λ (x1: integer) →
error_empty ⟨true ⊢ x1 + 1⟩
in
let f : integer → integer =
λ (x1: integer) →
error_empty ⟨true ⊢ g (x1 + 1)⟩
in
{ RentComputation f = f; })
{RentComputation_in}
in
let result1 : RentComputation =
{ RentComputation
f = λ (param0: integer) → result.f param0;
}
in
if true then result1 else result1).
f
x⟩
error_empty
⟨true
⊢ (let result : RentComputation =
(λ (RentComputation_in: RentComputation_in) →
let g : integer → integer =
λ (x1: integer) →
error_empty ⟨true ⊢ x1 + 1⟩
in
let f : integer → integer =
λ (x1: integer) →
error_empty ⟨true ⊢ g (x1 + 1)⟩
in
{ RentComputation f = f; })
{RentComputation_in}
in
let result1 : RentComputation =
{ RentComputation f = λ (param0: integer) → result.f param0; }
in
if true then result1 else result1).
f
x⟩
[RESULT] result = 3
```

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

@ -26,38 +26,36 @@ scope RentComputation:
$ catala Interpret -s RentComputation
[RESULT] Computation successful! Results:
[RESULT] f1 = λ (x: integer) →
error_empty
⟨true ⊢ let x1 : integer = x + 1 in
error_empty ⟨true ⊢ x1 + 1⟩⟩
error_empty ⟨true ⊢ let x1 : integer = x + 1 in
error_empty ⟨true ⊢ x1 + 1⟩⟩
[RESULT] f2 = λ (x: integer) →
error_empty
⟨true ⊢ let x1 : integer = x + 1 in
error_empty ⟨true ⊢ x1 + 1⟩⟩
error_empty ⟨true ⊢ let x1 : integer = x + 1 in
error_empty ⟨true ⊢ x1 + 1⟩⟩
```
```catala-test-inline
$ catala Interpret_Lcalc -s RentComputation --avoid_exceptions --optimize
[RESULT] Computation successful! Results:
[RESULT] f1 =
ESome
(λ (x: integer) →
ESome
match
(match (ESome (λ (x1: integer) → ESome (x1 + 1))) with
| ENone _ → ENone _
| ESome f1 → f1 (x + 1))
with
| ENone f1 → raise NoValueProvided
| ESome x1 → x1)
ESome
(λ (x: integer) →
ESome
match
(match (ESome (λ (x1: integer) → ESome (x1 + 1))) with
| ENone _ → ENone _
| ESome f1 → f1 (x + 1))
with
| ENone f1 → raise NoValueProvided
| ESome x1 → x1)
[RESULT] f2 =
ESome
(λ (x: integer) →
ESome
match
(match (ESome (λ (x1: integer) → ESome (x1 + 1))) with
| ENone _ → ENone _
| ESome f2 → f2 (x + 1))
with
| ENone f2 → raise NoValueProvided
| ESome x1 → x1)
ESome
(λ (x: integer) →
ESome
match
(match (ESome (λ (x1: integer) → ESome (x1 + 1))) with
| ENone _ → ENone _
| ESome f2 → f2 (x + 1))
with
| ENone f2 → raise NoValueProvided
| ESome x1 → x1)
```

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

@ -50,20 +50,20 @@ $ catala Interpret -s B
$ catala Interpret_Lcalc -s A --avoid_exceptions --optimize
[RESULT] Computation successful! Results:
[RESULT] t =
ESome
{ T
a = ESome { S x = ESome 0; y = ESome false; };
b = ESome { S x = ESome 1; y = ESome true; };
}
ESome
{ T
a = ESome { S x = ESome 0; y = ESome false; };
b = ESome { S x = ESome 1; y = ESome true; };
}
```
```catala-test-inline
$ catala Interpret_Lcalc -s B --avoid_exceptions --optimize
[RESULT] Computation successful! Results:
[RESULT] out = ESome 1
[RESULT] t =
ESome
{ T
a = ESome { S x = ESome 0; y = ESome false; };
b = ESome { S x = ESome 1; y = ESome true; };
}
ESome
{ T
a = ESome { S x = ESome 0; y = ESome false; };
b = ESome { S x = ESome 1; y = ESome true; };
}
```