CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-16 14:57:13 +03:00
Code Issues Projects Releases Wiki Activity

Pass exception positions to the HandleDefault operators

Browse Source 
This puts runtime exception info on par with what we had in the interpreter, and
repairs the regression on the interpreter which no longer had them.
This commit is contained in:
Louis Gesbert 2024-04-29 16:09:38 +02:00
parent 959bcb9ccd
commit 50d686f089
13 changed files with 137 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
compiler/catala_utils/message.ml
View File

@ -213,22 +213,21 @@ module Content = struct
content
| some -> some
in
pos, m
| Position { pos_message; pos } ->
let message =
match pos_message with Some m -> m | None -> fun _ -> ()
in
Some pos, message
| Outcome m -> None, m
| Suggestion sl -> None, fun ppf -> Suggestions.format ppf sl
pos, Some m
| Position { pos_message; pos } -> Some pos, pos_message
| Outcome m -> None, Some m
| Suggestion sl -> None, Some (fun ppf -> Suggestions.format ppf sl)
in
Option.iter
(fun pos ->
Format.fprintf ppf "@{<blue>%s@}: " (Pos.to_string_short pos))
pos;
pp_marker target ppf;
Format.pp_print_char ppf ' ';
Format.pp_print_string ppf (unformat message))
match message with
| Some message ->
Format.pp_print_char ppf ' ';
Format.pp_print_string ppf (unformat message)
| None -> ())
ppf content;
Format.pp_print_newline ppf ()
end

22
compiler/lcalc/to_ocaml.ml
View File

@ -408,14 +408,20 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
format_with_parens arg1
| EAppOp { op = Log _; args = [arg1]; _ } ->
Format.fprintf fmt "%a" format_with_parens arg1
| EAppOp { op = (HandleDefault | HandleDefaultOpt) as op; args; _ } ->
let pos = Expr.pos e in
Format.fprintf fmt "@[<hov 2>%s@ %a@ %a@]"
| EAppOp
{
op = (HandleDefault | HandleDefaultOpt) as op;
args = (EArray excs, _) :: _ as args;
_;
} ->
let pos = List.map Expr.pos excs in
Format.fprintf fmt "@[<hov 2>%s@ [|%a|]@ %a@]"
(Print.operator_to_string op)
format_pos pos
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
format_pos)
pos
(Format.pp_print_list ~pp_sep:Format.pp_print_space format_with_parens)
args
| EApp { f; args; _ } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
@ -442,12 +448,12 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
args
| EAssert e' ->
Format.fprintf fmt
"@[<hov 2>if@ %a@ then@ ()@ else@ raise (Error (%s, %a))@]"
"@[<hov 2>if@ %a@ then@ ()@ else@ raise (Error (%s, [%a]))@]"
format_with_parens e'
Runtime.(error_to_string AssertionFailed)
format_pos (Expr.pos e')
| EFatalError er ->
Format.fprintf fmt "raise@ (Runtime_ocaml.Runtime.Error (%a, %a))"
Format.fprintf fmt "raise@ (Runtime_ocaml.Runtime.Error (%a, [%a]))"
Print.runtime_error er format_pos (Expr.pos e)
| ERaiseEmpty -> Format.fprintf fmt "raise Empty"
| ECatchEmpty { body; handler } ->

42
compiler/shared_ast/interpreter.ml
View File

@ -370,13 +370,11 @@ let rec evaluate_operator
Expr.format just)
| [e] -> Mark.remove e
| es ->
(* FIXME REGRESSION: extra positions are lost *)
raise
Runtime.(
Error
( Conflict,
List.hd (List.map (fun e -> Expr.pos_to_runtime (Expr.pos e)) es)
)))
(Conflict, List.map (fun e -> Expr.pos_to_runtime (Expr.pos e)) es))
)
| HandleDefaultOpt, [(EArray exps, _); justification; conclusion] -> (
let valid_exceptions =
ListLabels.filter exps ~f:(function
@ -413,12 +411,10 @@ let rec evaluate_operator
e
| [_] -> err ()
| excs ->
(* FIXME REGRESSION *)
raise
Runtime.(
Error
( Conflict,
List.hd (List.map Expr.(fun e -> pos_to_runtime (pos e)) excs) )))
Error (Conflict, List.map Expr.(fun e -> pos_to_runtime (pos e)) excs))
)
| ( ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon
| ToMoney_rat | Round_rat | Round_mon | Add_int_int | Add_rat_rat
| Add_mon_mon | Add_dat_dur _ | Add_dur_dur | Sub_int_int | Sub_rat_rat
@ -754,21 +750,21 @@ let rec evaluate_expr :
match Mark.remove e with
| ELit (LBool true) -> Mark.add m (ELit LUnit)
| ELit (LBool false) ->
Message.result ~pos:(Expr.pos e') "Assertion failed:@\n%a"
Message.warning "Assertion failed:@ %a"
(Print.UserFacing.expr lang)
(partially_evaluate_expr_for_assertion_failure_message ctx lang
(Expr.skip_wrappers e'));
raise Runtime.(Error (AssertionFailed, Expr.pos_to_runtime pos))
raise Runtime.(Error (AssertionFailed, [Expr.pos_to_runtime pos]))
| _ ->
Message.error ~pos:(Expr.pos e') "%a" Format.pp_print_text
"Expected a boolean literal for the result of this assertion (should \
not happen if the term was well-typed)")
| EFatalError err -> raise (Runtime.Error (err, Expr.pos_to_runtime pos))
| EFatalError err -> raise (Runtime.Error (err, [Expr.pos_to_runtime pos]))
| EErrorOnEmpty e' -> (
match evaluate_expr ctx lang e' with
| EEmpty, _ -> raise Runtime.(Error (NoValue, Expr.pos_to_runtime pos))
| EEmpty, _ -> raise Runtime.(Error (NoValue, [Expr.pos_to_runtime pos]))
| exception Runtime.Empty ->
raise Runtime.(Error (NoValue, Expr.pos_to_runtime pos))
raise Runtime.(Error (NoValue, [Expr.pos_to_runtime pos]))
| e -> e)
| EDefault { excepts; just; cons } -> (
let excepts = List.map (evaluate_expr ctx lang) excepts in
@ -785,13 +781,14 @@ let rec evaluate_expr :
evaluation (should not happen if the term was well-typed")
| 1 -> List.find (fun sub -> not (is_empty_error sub)) excepts
| _ ->
let _poslist =
let poslist =
List.filter_map
(fun ex -> if is_empty_error ex then None else Some (Expr.pos ex))
(fun ex ->
if is_empty_error ex then None
else Some Expr.(pos_to_runtime (pos ex)))
excepts
in
(* FIXME REGRESSION *)
raise Runtime.(Error (Conflict, Expr.pos_to_runtime pos)))
raise Runtime.(Error (Conflict, poslist)))
| EPureDefault e -> evaluate_expr ctx lang e
| ERaiseEmpty -> raise Runtime.Empty
| ECatchEmpty { body; handler } -> (
@ -846,8 +843,9 @@ let evaluate_expr_safe :
fun ctx lang e ->
try evaluate_expr ctx lang e
with Runtime.Error (err, rpos) ->
Message.error ~pos:(Expr.runtime_to_pos rpos) "Error during evaluation: %a."
Format.pp_print_text
Message.error
~extra_pos:(List.map (fun rp -> "", Expr.runtime_to_pos rp) rpos)
"Error during evaluation: %a." Format.pp_print_text
(Runtime.error_message err)
(* Typing shenanigan to add custom terms to the AST type. *)
@ -985,8 +983,10 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
List.map
(fun (fld, e) -> StructField.get_info fld, e)
(StructField.Map.bindings fields)
| exception Runtime.Error (err, pos) ->
Message.error ~pos:(Expr.runtime_to_pos pos) "%a" Format.pp_print_text
| exception Runtime.Error (err, rpos) ->
Message.error
~extra_pos:(List.map (fun rp -> "", Expr.runtime_to_pos rp) rpos)
"%a" Format.pp_print_text
(Runtime.error_message err)
| _ ->
Message.error ~pos:(Expr.pos e) ~internal:true "%a" Format.pp_print_text

70
runtimes/ocaml/runtime.ml
View File

@ -73,7 +73,7 @@ let error_message = function
"comparing durations in different units (e.g. months vs. days)"
| IndivisibleDurations -> "dividing durations that are not in days"
exception Error of error * source_position
exception Error of error * source_position list
exception Empty
let error err pos = raise (Error (err, pos))
@ -84,10 +84,11 @@ let () =
Printf.sprintf "%s:%d.%d-%d.%d" p.filename p.start_line p.start_column
p.end_line p.end_column
in
let pposl () pl = String.concat ", " (List.map (ppos ()) pl) in
Printexc.register_printer
@@ function
| Error (err, pos) ->
Some (Printf.sprintf "At %a: %s" ppos pos (error_message err))
Some (Printf.sprintf "At %a: %s" pposl pos (error_message err))
| _ -> None
let () =
@ -721,43 +722,42 @@ end
let handle_default :
'a.
source_position ->
source_position array ->
(unit -> 'a) array ->
(unit -> bool) ->
(unit -> 'a) ->
'a =
fun pos exceptions just cons ->
let except =
Array.fold_left
(fun acc except ->
let new_val = try Some (except ()) with Empty -> None in
match acc, new_val with
| None, _ -> new_val
| Some _, None -> acc
| Some _, Some _ -> error Conflict pos)
None exceptions
let len = Array.length exceptions in
let rec filt_except i =
if i < len then
match exceptions.(i) () with
| new_val -> (new_val, i) :: filt_except (i + 1)
| exception Empty -> filt_except (i + 1)
else []
in
match except with
| Some x -> x
| None -> if just () then cons () else raise Empty
match filt_except 0 with
| [] -> if just () then cons () else raise Empty
| [(res, _)] -> res
| res -> error Conflict (List.map (fun (_, i) -> pos.(i)) res)
let handle_default_opt
(pos : source_position)
(pos : source_position array)
(exceptions : 'a Eoption.t array)
(just : unit -> bool)
(cons : unit -> 'a Eoption.t) : 'a Eoption.t =
let except =
Array.fold_left
(fun acc except ->
match acc, except with
| Eoption.ENone _, _ -> except
| Eoption.ESome _, Eoption.ENone _ -> acc
| Eoption.ESome _, Eoption.ESome _ -> error Conflict pos)
(Eoption.ENone ()) exceptions
let len = Array.length exceptions in
let rec filt_except i =
if i < len then
match exceptions.(i) with
| Eoption.ESome _ as new_val -> (new_val, i) :: filt_except (i + 1)
| Eoption.ENone () -> filt_except (i + 1)
else []
in
match except with
| Eoption.ESome _ -> except
| Eoption.ENone _ -> if just () then cons () else Eoption.ENone ()
match filt_except 0 with
| [] -> if just () then cons () else Eoption.ENone ()
| [(res, _)] -> res
| res -> error Conflict (List.map (fun (_, i) -> pos.(i)) res)
(* TODO: add a compare built-in to dates_calc. At the moment this fails on e.g.
[3 months, 4 months] *)
@ -767,7 +767,7 @@ let compare_periods pos (p1 : duration) (p2 : duration) : int =
let p2_days = Dates_calc.Dates.period_to_days p2 in
compare p1_days p2_days
with Dates_calc.Dates.AmbiguousComputation ->
error UncomparableDurations pos
error UncomparableDurations [pos]
(* TODO: same here, although it was tweaked to never fail on equal dates.
Comparing the difference to duration_0 is not a good idea because we still
@ -775,7 +775,7 @@ let compare_periods pos (p1 : duration) (p2 : duration) : int =
let equal_periods pos (p1 : duration) (p2 : duration) : bool =
try Dates_calc.Dates.period_to_days (Dates_calc.Dates.sub_periods p1 p2) = 0
with Dates_calc.Dates.AmbiguousComputation ->
error UncomparableDurations pos
error UncomparableDurations [pos]
module Oper = struct
let o_not = Stdlib.not
@ -801,7 +801,7 @@ module Oper = struct
let o_map = Array.map
let o_map2 pos f a b =
try Array.map2 f a b with Invalid_argument _ -> error NotSameLength pos
try Array.map2 f a b with Invalid_argument _ -> error NotSameLength [pos]
let o_reduce f dft a =
let len = Array.length a in
@ -838,18 +838,18 @@ module Oper = struct
let o_div_int_int pos i1 i2 =
(* It's not on the ocamldoc, but Q.div likely already raises this ? *)
if Z.zero = i2 then error DivisionByZero pos
if Z.zero = i2 then error DivisionByZero [pos]
else Q.div (Q.of_bigint i1) (Q.of_bigint i2)
let o_div_rat_rat pos i1 i2 =
if Q.zero = i2 then error DivisionByZero pos else Q.div i1 i2
if Q.zero = i2 then error DivisionByZero [pos] else Q.div i1 i2
let o_div_mon_mon pos m1 m2 =
if Z.zero = m2 then error DivisionByZero pos
if Z.zero = m2 then error DivisionByZero [pos]
else Q.div (Q.of_bigint m1) (Q.of_bigint m2)
let o_div_mon_rat pos m1 r1 =
if Q.zero = r1 then error DivisionByZero pos
if Q.zero = r1 then error DivisionByZero [pos]
else o_mult_mon_rat m1 (Q.inv r1)
let o_div_dur_dur pos d1 d2 =
@ -858,7 +858,7 @@ module Oper = struct
( integer_of_int (Dates_calc.Dates.period_to_days d1),
integer_of_int (Dates_calc.Dates.period_to_days d2) )
with Dates_calc.Dates.AmbiguousComputation ->
error IndivisibleDurations pos
error IndivisibleDurations [pos]
in
o_div_int_int pos i1 i2

16
runtimes/ocaml/runtime.mli
View File

@ -85,7 +85,7 @@ val error_to_string : error -> string
val error_message : error -> string
(** Returns a short explanation message about the error *)
exception Error of error * source_position
exception Error of error * source_position list
exception Empty
(** {1 Value Embedding} *)
@ -333,17 +333,21 @@ val duration_to_string : duration -> string
(**{1 Defaults} *)
val handle_default :
source_position -> (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> 'a
(** @raise EmptyError
@raise ConflictError *)
source_position array ->
(unit -> 'a) array ->
(unit -> bool) ->
(unit -> 'a) ->
'a
(** @raise Empty
@raise Error Conflict *)
val handle_default_opt :
source_position ->
source_position array ->
'a Eoption.t array ->
(unit -> bool) ->
(unit -> 'a Eoption.t) ->
'a Eoption.t
(** @raise ConflictError *)
(** @raise Error Conflict *)
(**{1 Operators} *)

6
tests/default/bad/conflict.catala_en
View File

@ -11,8 +11,8 @@ scope A:
```catala-test-inline
$ catala Interpret -s A --message=gnu
tests/default/bad/conflict.catala_en:8.56-8.57: [ERROR] There is a conflict between multiple valid consequences for assigning the same variable.
tests/default/bad/conflict.catala_en:8.56-8.57: [ERROR] This consequence has a valid justification:
tests/default/bad/conflict.catala_en:9.56-9.57: [ERROR] This consequence has a valid justification:
tests/default/bad/conflict.catala_en:8.56-8.57: [ERROR] Error during evaluation: two or more concurring valid computations.
tests/default/bad/conflict.catala_en:8.56-8.57: [ERROR]
tests/default/bad/conflict.catala_en:9.56-9.57: [ERROR]
#return code 123#
```

3
tests/default/bad/empty.catala_en
View File

@ -19,8 +19,7 @@ $ catala test-scope A
6 │ output y content boolean
│ ‾
└─ Article
[ERROR] This variable evaluated to an empty term (no rule that defined it
applied in this situation)
[ERROR] Error during evaluation: no computation with valid conditions found.
┌─⯈ tests/default/bad/empty.catala_en:6.10-6.11:
└─┐

3
tests/default/bad/empty_with_rules.catala_en
View File

@ -14,8 +14,7 @@ scope A:
```catala-test-inline
$ catala interpret -s A
[ERROR] This variable evaluated to an empty term (no rule that defined it
applied in this situation)
[ERROR] Error during evaluation: no computation with valid conditions found.
┌─⯈ tests/default/bad/empty_with_rules.catala_en:5.10-5.11:
└─┐

5
tests/exception/bad/two_exceptions.catala_en
View File

@ -19,17 +19,14 @@ Note: ideally this could use test-scope but some positions are lost during trans
```catala-test-inline
$ catala interpret -s A
[ERROR] There is a conflict between multiple valid consequences for assigning
the same variable.
[ERROR] Error during evaluation: two or more concurring valid computations.
This consequence has a valid justification:
┌─⯈ tests/exception/bad/two_exceptions.catala_en:12.23-12.24:
└──┐
12 │ definition x equals 1
│ ‾
└─ Test
This consequence has a valid justification:
┌─⯈ tests/exception/bad/two_exceptions.catala_en:15.23-15.24:
└──┐
15 │ definition x equals 2

5
tests/func/bad/bad_func.catala_en
View File

@ -31,17 +31,14 @@ Note: ideally this could use test-scope but some positions are lost during trans
```catala-test-inline
$ catala interpret -s S
[ERROR] There is a conflict between multiple valid consequences for assigning
the same variable.
[ERROR] Error during evaluation: two or more concurring valid computations.
This consequence has a valid justification:
┌─⯈ tests/func/bad/bad_func.catala_en:14.65-14.70:
└──┐
14 │ definition f of x under condition (x >= x) consequence equals x + x
│ ‾‾‾‾‾
└─ Article
This consequence has a valid justification:
┌─⯈ tests/func/bad/bad_func.catala_en:15.62-15.67:
└──┐
15 │ definition f of x under condition not b consequence equals x * x

49
tests/modules/good/output/mod_def.ml
View File

@ -29,43 +29,36 @@ let s (s_in: S_in.t) : S.t =
let sr_: money =
try
(handle_default
{filename="tests/modules/good/mod_def.catala_en";
start_line=16; start_column=10; end_line=16; end_column=12;
law_headings=["Test modules + inclusions 1"]}
[|{filename="tests/modules/good/mod_def.catala_en";
start_line=16; start_column=10; end_line=16; end_column=12;
law_headings=["Test modules + inclusions 1"]}|]
([|(fun (_: unit) ->
handle_default
{filename="tests/modules/good/mod_def.catala_en";
start_line=16; start_column=10; end_line=16; end_column=12;
law_headings=["Test modules + inclusions 1"]} ([||])
(fun (_: unit) -> true)
handle_default [||] ([||]) (fun (_: unit) -> true)
(fun (_: unit) -> money_of_cents_string "100000"))|])
(fun (_: unit) -> false) (fun (_: unit) -> raise Empty))
with
Empty -> (raise
(Runtime_ocaml.Runtime.Error (NoValue, {filename="tests/modules/good/mod_def.catala_en";
start_line=16; start_column=10;
end_line=16; end_column=12;
law_headings=["Test modules + inclusions 1"]})))
with Empty ->
(raise
(Runtime_ocaml.Runtime.Error (NoValue, [{filename="tests/modules/good/mod_def.catala_en";
start_line=16; start_column=10;
end_line=16; end_column=12;
law_headings=["Test modules + inclusions 1"]}])))
in
let e1_: Enum1.t =
try
(handle_default
{filename="tests/modules/good/mod_def.catala_en";
start_line=17; start_column=10; end_line=17; end_column=12;
law_headings=["Test modules + inclusions 1"]}
[|{filename="tests/modules/good/mod_def.catala_en";
start_line=17; start_column=10; end_line=17; end_column=12;
law_headings=["Test modules + inclusions 1"]}|]
([|(fun (_: unit) ->
handle_default
{filename="tests/modules/good/mod_def.catala_en";
start_line=17; start_column=10; end_line=17; end_column=12;
law_headings=["Test modules + inclusions 1"]} ([||])
(fun (_: unit) -> true) (fun (_: unit) -> Enum1.Maybe ()))|])
handle_default [||] ([||]) (fun (_: unit) -> true)
(fun (_: unit) -> Enum1.Maybe ()))|])
(fun (_: unit) -> false) (fun (_: unit) -> raise Empty))
with
Empty -> (raise
(Runtime_ocaml.Runtime.Error (NoValue, {filename="tests/modules/good/mod_def.catala_en";
start_line=17; start_column=10;
end_line=17; end_column=12;
law_headings=["Test modules + inclusions 1"]})))
with Empty ->
(raise
(Runtime_ocaml.Runtime.Error (NoValue, [{filename="tests/modules/good/mod_def.catala_en";
start_line=17; start_column=10;
end_line=17; end_column=12;
law_headings=["Test modules + inclusions 1"]}])))
in
{S.sr = sr_; S.e1 = e1_}

43
tests/name_resolution/good/let_in2.catala_en
View File

@ -51,40 +51,35 @@ let s (s_in: S_in.t) : S.t =
let a_: bool =
try
(handle_default
{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18; end_line=7; end_column=19;
law_headings=["Article"]} ([|(fun (_: unit) -> a_ ())|])
[|{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18; end_line=7; end_column=19;
law_headings=["Article"]}|] ([|(fun (_: unit) -> a_ ())|])
(fun (_: unit) -> true)
(fun (_: unit) ->
try
(handle_default
{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18; end_line=7; end_column=19;
law_headings=["Article"]}
[|{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18; end_line=7; end_column=19;
law_headings=["Article"]}|]
([|(fun (_: unit) ->
handle_default
{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18;
end_line=7; end_column=19;
law_headings=["Article"]} ([||])
(fun (_: unit) -> true)
handle_default [||] ([||]) (fun (_: unit) -> true)
(fun (_: unit) -> (let a_ : bool = false
in
(let a_ : bool = (o_or a_ true) in
a_))))|]) (fun (_: unit) -> false)
(fun (_: unit) -> raise Empty))
with
Empty -> (raise
(Runtime_ocaml.Runtime.Error (NoValue, {filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18;
end_line=7; end_column=19;
law_headings=["Article"]})))))
with
Empty -> (raise
(Runtime_ocaml.Runtime.Error (NoValue, {filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18;
end_line=7; end_column=19;
law_headings=["Article"]}))) in
with Empty ->
(raise
(Runtime_ocaml.Runtime.Error (NoValue, [{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18;
end_line=7; end_column=19;
law_headings=["Article"]}])))))
with Empty ->
(raise
(Runtime_ocaml.Runtime.Error (NoValue, [{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18;
end_line=7; end_column=19;
law_headings=["Article"]}]))) in
{S.a = a_}
let () =

5
tests/scope/bad/scope.catala_en
View File

@ -18,17 +18,14 @@ Note: ideally this could use test-scope but some positions are lost during trans
```catala-test-inline
$ catala interpret -s A
[ERROR] There is a conflict between multiple valid consequences for assigning
the same variable.
[ERROR] Error during evaluation: two or more concurring valid computations.
This consequence has a valid justification:
┌─⯈ tests/scope/bad/scope.catala_en:13.57-13.61:
└──┐
13 │ definition b under condition not c consequence equals 1337
│ ‾‾‾‾
└─ Article
This consequence has a valid justification:
┌─⯈ tests/scope/bad/scope.catala_en:14.57-14.58:
└──┐
14 │ definition b under condition not c consequence equals 0