diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 958771fe..a5690f7a 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -411,7 +411,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : Format.fprintf fmt "%a" format_with_parens arg1 | EAppOp { - op = ((HandleDefault | HandleDefaultOpt) as op), _; + op = (HandleDefaultOpt as op), _; args = (EArray excs, _) :: _ as args; _; } -> diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index 29610223..dd18be61 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -1085,7 +1085,6 @@ let expr_to_dot_label0 : | Reduce -> xlang () ~en:"reduce" ~fr:"réunion" | Filter -> xlang () ~en:"filter" ~fr:"filtre" | Fold -> xlang () ~en:"fold" ~fr:"pliage" - | HandleDefault -> "" | HandleDefaultOpt -> "" | ToClosureEnv -> "" | FromClosureEnv -> "" diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 4869ca14..b71047fe 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -313,7 +313,6 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit = | Reduce -> Format.pp_print_string fmt "catala_list_reduce" | Filter -> Format.pp_print_string fmt "catala_list_filter" | Fold -> Format.pp_print_string fmt "catala_list_fold_left" - | HandleDefault -> Format.pp_print_string fmt "catala_handle_default" | HandleDefaultOpt | FromClosureEnv | ToClosureEnv | Map2 -> failwith "unimplemented" @@ -368,7 +367,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 | EAppOp { op; args = [arg1] } -> Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1 - | EAppOp { op = (HandleDefaultOpt | HandleDefault), _; args = _ } -> + | EAppOp { op = HandleDefaultOpt, _; args = _ } -> failwith "should not happen because of keep_special_ops" | EApp { f; args } -> Format.fprintf fmt "%a(@[%a)@]" (format_expression ctx) f diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index c76a26c2..d3b7a79d 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -88,7 +88,6 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit = | Reduce -> Format.pp_print_string fmt "list_reduce" | Filter -> Format.pp_print_string fmt "list_filter" | Fold -> Format.pp_print_string fmt "list_fold_left" - | HandleDefault -> Format.pp_print_string fmt "handle_default" | HandleDefaultOpt -> Format.pp_print_string fmt "handle_default_opt" | FromClosureEnv | ToClosureEnv -> failwith "unimplemented" @@ -349,7 +348,7 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit = Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 | EAppOp { op; args = [arg1] } -> Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1 - | EAppOp { op = ((HandleDefault | HandleDefaultOpt), _) as op; args } -> + | EAppOp { op = (HandleDefaultOpt, _) as op; args } -> let pos = Mark.get e in Format.fprintf fmt "%a(@[SourcePosition(filename=\"%s\",@ start_line=%d,@ \ diff --git a/compiler/scalc/to_r.ml b/compiler/scalc/to_r.ml index eb1e82b9..b8352b7a 100644 --- a/compiler/scalc/to_r.ml +++ b/compiler/scalc/to_r.ml @@ -103,7 +103,6 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit = | Reduce -> Format.pp_print_string fmt "catala_list_reduce" | Filter -> Format.pp_print_string fmt "catala_list_filter" | Fold -> Format.pp_print_string fmt "catala_list_fold_left" - | HandleDefault -> Format.pp_print_string fmt "catala_handle_default" | HandleDefaultOpt | FromClosureEnv | ToClosureEnv -> failwith "unimplemented" let format_string_list (fmt : Format.formatter) (uids : string list) : unit = @@ -324,18 +323,19 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : | EAppOp { op = HandleDefaultOpt, _; _ } -> Message.error ~internal:true "R compilation does not currently support the avoiding of exceptions" - | EAppOp { op = (HandleDefault as op), _; args; _ } -> - let pos = Mark.get e in - Format.fprintf fmt - "%a(@[catala_position(filename=\"%s\",@ start_line=%d,@ \ - start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]" - format_op (op, pos) (Pos.get_file pos) (Pos.get_start_line pos) - (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) - format_string_list (Pos.get_law_info pos) - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") - (format_expression ctx)) - args + (* TODO: port the following to avoid-exceptions + * | EAppOp { op = (HandleDefault as op), _; args; _ } -> + * let pos = Mark.get e in + * Format.fprintf fmt + * "%a(@[catala_position(filename=\"%s\",@ start_line=%d,@ \ + * start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]" + * format_op (op, pos) (Pos.get_file pos) (Pos.get_start_line pos) + * (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) + * format_string_list (Pos.get_law_info pos) + * (Format.pp_print_list + * ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") + * (format_expression ctx)) + * args *) | EApp { f = EFunc x, pos; args } when Ast.FuncName.compare x Ast.handle_default = 0 || Ast.FuncName.compare x Ast.handle_default_opt = 0 -> diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 278b7d5c..5af7e43a 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -372,7 +372,6 @@ module Op = struct (* * polymorphic *) | Reduce : < polymorphic ; .. > t | Fold : < polymorphic ; .. > t - | HandleDefault : < polymorphic ; .. > t | HandleDefaultOpt : < polymorphic ; .. > t end diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 171dce2d..bd4a6341 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -422,35 +422,6 @@ let rec evaluate_operator ELit (LBool (o_eq_dat_dat x y)) | Eq_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] -> ELit (LBool (o_eq_dur_dur (rpos ()) x y)) - | HandleDefault, [(EArray excepts, _); just; cons] -> ( - (* This case is for lcalc with exceptions: we rely OCaml exception handling - here *) - match - List.filter_map - (fun e -> - try Some (evaluate_expr (Expr.unthunk_term_nobox e)) - with Runtime.Empty -> None) - excepts - with - | [] -> ( - let just = evaluate_expr (Expr.unthunk_term_nobox just) in - match Mark.remove just with - | ELit (LBool true) -> - Mark.remove (evaluate_expr (Expr.unthunk_term_nobox cons)) - | ELit (LBool false) -> raise Runtime.Empty - | _ -> - Message.error ~pos - "Default justification has not been reduced to a boolean at@ \ - evaluation@ (should not happen if the term was well-typed@\n\ - %a@." - Expr.format just) - | [e] -> Mark.remove e - | es -> - raise - Runtime.( - Error - (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 @@ -501,8 +472,7 @@ let rec evaluate_operator | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat - | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur | HandleDefault | HandleDefaultOpt - ), + | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur | HandleDefaultOpt ), _ ) -> err () diff --git a/compiler/shared_ast/operator.ml b/compiler/shared_ast/operator.ml index 79970768..0ce7d4fa 100644 --- a/compiler/shared_ast/operator.ml +++ b/compiler/shared_ast/operator.ml @@ -108,7 +108,6 @@ let name : type a. a t -> string = function | Eq_dur_dur -> "o_eq_dur_dur" | Eq_dat_dat -> "o_eq_dat_dat" | Fold -> "o_fold" - | HandleDefault -> "o_handledefault" | HandleDefaultOpt -> "o_handledefaultopt" | ToClosureEnv -> "o_toclosureenv" | FromClosureEnv -> "o_fromclosureenv" @@ -232,7 +231,6 @@ let compare (type a1 a2) (t1 : a1 t) (t2 : a2 t) = | Eq_dat_dat, Eq_dat_dat | Eq_dur_dur, Eq_dur_dur | Fold, Fold - | HandleDefault, HandleDefault | HandleDefaultOpt, HandleDefaultOpt | FromClosureEnv, FromClosureEnv | ToClosureEnv, ToClosureEnv -> 0 | Not, _ -> -1 | _, Not -> 1 @@ -318,7 +316,6 @@ let compare (type a1 a2) (t1 : a1 t) (t2 : a2 t) = | Eq_mon_mon, _ -> -1 | _, Eq_mon_mon -> 1 | Eq_dat_dat, _ -> -1 | _, Eq_dat_dat -> 1 | Eq_dur_dur, _ -> -1 | _, Eq_dur_dur -> 1 - | HandleDefault, _ -> -1 | _, HandleDefault -> 1 | HandleDefaultOpt, _ -> -1 | _, HandleDefaultOpt -> 1 | FromClosureEnv, _ -> -1 | _, FromClosureEnv -> 1 | ToClosureEnv, _ -> -1 | _, ToClosureEnv -> 1 @@ -344,7 +341,7 @@ let kind_dispatch : _ ) as op -> monomorphic op | ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold - | HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ), + | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ), _ ) as op -> polymorphic op | ( ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt @@ -377,19 +374,19 @@ type 'a no_overloads = let translate (t : 'a no_overloads t Mark.pos) : 'b no_overloads t Mark.pos = match t with | ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth - | And | Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq - | Map | Map2 | Concat | Filter | Reduce | Fold | 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 | Sub_mon_mon | Sub_dat_dat - | Sub_dat_dur | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat - | Mult_dur_int | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat - | Div_dur_dur | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat - | Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat - | Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat - | Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat - | Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat - | Eq_dur_dur | FromClosureEnv | ToClosureEnv ), + | And | Or | Xor | HandleDefaultOpt | Log _ | Length | Eq | Map | Map2 + | Concat | Filter | Reduce | Fold | 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 | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur + | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat | Mult_dur_int + | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur + | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur + | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur + | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur + | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur + | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur + | FromClosureEnv | ToClosureEnv ), _ ) as op -> op diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index 3d82ff1c..8aed0af7 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -280,7 +280,6 @@ let operator_to_string : type a. a Op.t -> string = | Eq_dur_dur -> "=^" | Eq_dat_dat -> "=@" | Fold -> "fold" - | HandleDefault -> "handle_default" | HandleDefaultOpt -> "handle_default_opt" | ToClosureEnv -> "to_closure_env" | FromClosureEnv -> "from_closure_env" @@ -325,7 +324,6 @@ let operator_to_shorter_string : type a. a Op.t -> string = | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dur_dur | Gte_dat_dat | Gte -> ">=" | Fold -> "fold" - | HandleDefault -> "handle_default" | HandleDefaultOpt -> "handle_default_opt" | ToClosureEnv -> "to_closure_env" | FromClosureEnv -> "from_closure_env" @@ -402,8 +400,8 @@ module Precedence = struct | Div | Div_int_int | Div_rat_rat | Div_mon_rat | Div_mon_mon | Div_dur_dur -> Op Div - | HandleDefault | HandleDefaultOpt | Map | Map2 | Concat | Filter | Reduce - | Fold | ToClosureEnv | FromClosureEnv -> + | HandleDefaultOpt | Map | Map2 | Concat | Filter | Reduce | Fold + | ToClosureEnv | FromClosureEnv -> App) | EApp _ -> App | EArray _ -> Contained diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index aa167519..554a4039 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -314,7 +314,6 @@ let polymorphic_op_type (op : Operator.polymorphic A.operator Mark.pos) : | Log (PosRecordIfTrueBool, _) -> [bt] @-> bt | Log _ -> [any] @-> any | Length -> [array any] @-> it - | HandleDefault -> [array ([ut] @-> any); [ut] @-> bt; [ut] @-> any] @-> any | HandleDefaultOpt -> [array (option any); [ut] @-> bt; [ut] @-> option any] @-> option any | ToClosureEnv -> [any] @-> cet @@ -348,7 +347,7 @@ let polymorphic_op_return_type | Log (PosRecordIfTrueBool, _), _ -> uf (TLit TBool) | Log _, [tau] -> tau | Length, _ -> uf (TLit TInt) - | (HandleDefault | HandleDefaultOpt), [_; _; tf] -> return_type tf 1 + | HandleDefaultOpt, [_; _; tf] -> return_type tf 1 | ToClosureEnv, _ -> uf TClosureEnv | FromClosureEnv, _ -> any () | _ -> Message.error ~pos "Mismatched operator arguments" diff --git a/runtimes/ocaml/runtime.ml b/runtimes/ocaml/runtime.ml index 6721a850..b8b8a5ea 100644 --- a/runtimes/ocaml/runtime.ml +++ b/runtimes/ocaml/runtime.ml @@ -716,27 +716,6 @@ module EventParser = struct ctx.events end -let handle_default : - 'a. - source_position array -> - (unit -> 'a) array -> - (unit -> bool) -> - (unit -> 'a) -> - 'a = - fun pos exceptions just cons -> - 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 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 array) (exceptions : 'a Eoption.t array) diff --git a/runtimes/ocaml/runtime.mli b/runtimes/ocaml/runtime.mli index 2fe2965a..abdb7d42 100644 --- a/runtimes/ocaml/runtime.mli +++ b/runtimes/ocaml/runtime.mli @@ -335,15 +335,6 @@ val duration_to_string : duration -> string (**{1 Defaults} *) -val handle_default : - source_position array -> - (unit -> 'a) array -> - (unit -> bool) -> - (unit -> 'a) -> - 'a -(** @raise Empty - @raise Error Conflict *) - val handle_default_opt : source_position array -> 'a Eoption.t array -> diff --git a/runtimes/python/src/catala/runtime.py b/runtimes/python/src/catala/runtime.py index 20a9a3f5..30401772 100644 --- a/runtimes/python/src/catala/runtime.py +++ b/runtimes/python/src/catala/runtime.py @@ -606,34 +606,6 @@ def list_length(l: List[Alpha]) -> Integer: # ======== -def handle_default( - pos: SourcePosition, - exceptions: List[Callable[[Unit], Alpha]], - just: Callable[[Unit], Alpha], - cons: Callable[[Unit], Alpha] -) -> Alpha: - acc: Optional[Alpha] = None - for exception in exceptions: - new_val: Optional[Alpha] - try: - new_val = exception(Unit()) - except Empty: - new_val = None - if acc is None: - acc = new_val - elif not (acc is None) and new_val is None: - pass # acc stays the same - elif not (acc is None) and not (new_val is None): - raise Conflict(pos) - if acc is None: - if just(Unit()): - return cons(Unit()) - else: - raise Empty - else: - return acc - - def handle_default_opt( pos: SourcePosition, exceptions: List[Optional[Any]], diff --git a/runtimes/r/NAMESPACE b/runtimes/r/NAMESPACE index 0e0baee4..ab044451 100644 --- a/runtimes/r/NAMESPACE +++ b/runtimes/r/NAMESPACE @@ -16,7 +16,6 @@ export(catala_decimal_to_numeric) export(catala_duration_from_ymd) export(catala_duration_to_ymd) export(catala_empty_error) -export(catala_handle_default) export(catala_integer_from_numeric) export(catala_integer_from_string) export(catala_integer_to_numeric) diff --git a/runtimes/r/R/runtime.R b/runtimes/r/R/runtime.R index d32fbe6c..006d80fc 100644 --- a/runtimes/r/R/runtime.R +++ b/runtimes/r/R/runtime.R @@ -363,36 +363,6 @@ catala_assertion_failure <- function(pos) { ################ Defaults ################# -#' @export -catala_handle_default <- function(pos, exceptions, just, cons) { - acc <- Reduce(function(acc, exception) { - new_val <- tryCatch( - exception(new("catala_unit", v = 0)), - catala_empty_error = function(e) { - NULL - } - ) - if (is.null(acc)) { - new_val - } else { - if (is.null(new_val)) { - acc - } else { - stop(catala_conflict_error(pos)) - } - } - }, exceptions, NULL) - if (is.null(acc)) { - if (just(new("catala_unit", v = 0))) { - cons(new("catala_unit", v = 0)) - } else { - stop(catala_empty_error()) - } - } else { - acc - } -} - # This value is used for the R code generation to trump R and forcing # it to accept dead code. Indeed, when raising an exception during a variable # definition, R could complains that the later dead code will not know what