diff --git a/Makefile b/Makefile index 7e777d80..fd641d71 100644 --- a/Makefile +++ b/Makefile @@ -217,7 +217,7 @@ tests: test TEST_FLAGS_LIST = ""\ -O \ --lcalc \ ---lcalc,--avoid-exceptions,-O +--lcalc,--closure-conversion,-O # Does not include running dune (to avoid duplication when run among bigger rules) testsuite-base: .FORCE diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 5b8a0122..c62d5c43 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -75,8 +75,8 @@ module Cli = struct tests. Comma-separated list. A subset may also be applied to the \ compilation of modules, as needed.\n\ WARNING: flag shortcuts are not allowed here (i.e. don't use \ - non-ambiguous prefixes such as $(b,--avoid-ex) for \ - $(b,--avoid-exceptions))\n\ + non-ambiguous prefixes such as $(b,--closure) for \ + $(b,--closure-conversion))\n\ NOTE: if this is set, all inline tests that are $(i,not) \ $(b,catala test-scope) are skipped to avoid redundant testing.") @@ -481,17 +481,13 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags = let catala_flags_ocaml = List.filter (function - | "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" -> - true - | _ -> false) + | "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false) test_flags in let catala_flags_python = List.filter (function - | "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" -> - true - | _ -> false) + | "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false) test_flags in let ocaml_flags = Lazy.force Poll.ocaml_include_flags in diff --git a/build_system/clerk_report.ml b/build_system/clerk_report.ml index 38419dc0..fc8808c4 100644 --- a/build_system/clerk_report.ml +++ b/build_system/clerk_report.ml @@ -69,16 +69,68 @@ let has_command cmd = let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in Sys.command check_cmd = 0 -let longuest_common_prefix_length s1 s2 = - let len = min (String.length s1) (String.length s2) in - let rec aux i = - if i >= len then i - else - let c1 = String.get_utf_8_uchar s1 i in - let c2 = String.get_utf_8_uchar s2 i in - if c1 = c2 then aux (i + Uchar.utf_decode_length c1) else i +type 'a diff = Eq of 'a | Subs of 'a * 'a | Del of 'a | Add of 'a + +let colordiff_str s1 s2 = + let split_re = + Re.(compile (alt [set "=()[]{};-,"; rep1 space; rep1 digit])) in - aux 0 + let split s = + Re.Seq.split_full split_re s + |> Seq.map (function `Text t -> t | `Delim g -> Re.Group.get g 0) + in + let a1 = Array.of_seq (split s1) in + let n1 = Array.length a1 in + let a2 = Array.of_seq (split s2) in + let n2 = Array.length a2 in + let d = Array.make_matrix n1 n2 (0, []) in + let get i1 i2 = + if i1 < 0 then + ( i2 + 1, + Array.fold_left (fun acc c -> Add c :: acc) [] (Array.sub a2 0 (i2 + 1)) + ) + else if i2 < 0 then + ( i1 + 1, + Array.fold_left (fun acc c -> Del c :: acc) [] (Array.sub a1 0 (i1 + 1)) + ) + else d.(i1).(i2) + in + for i1 = 0 to n1 - 1 do + for i2 = 0 to n2 - 1 do + if a1.(i1) = a2.(i2) then + let eq, eqops = get (i1 - 1) (i2 - 1) in + d.(i1).(i2) <- eq, Eq a1.(i1) :: eqops + else + let del, delops = get (i1 - 1) i2 in + let add, addops = get i1 (i2 - 1) in + let subs, subsops = get (i1 - 1) (i2 - 1) in + if subs <= del && subs <= add then + d.(i1).(i2) <- subs + 1, Subs (a1.(i1), a2.(i2)) :: subsops + else if del <= add then d.(i1).(i2) <- del + 1, Del a1.(i1) :: delops + else d.(i1).(i2) <- add + 1, Add a2.(i2) :: addops + done + done; + let _, rops = get (n1 - 1) (n2 - 1) in + let ops = List.rev rops in + let pr_left ppf () = + Format.pp_print_list + ~pp_sep:(fun _ () -> ()) + (fun ppf -> function + | Eq w -> Format.fprintf ppf "%s" w + | Subs (w, _) | Del w -> Format.fprintf ppf "@{%s@}" w + | Add _ -> ()) + ppf ops + in + let pr_right ppf () = + Format.pp_print_list + ~pp_sep:(fun _ () -> ()) + (fun ppf -> function + | Eq w -> Format.fprintf ppf "%s" w + | Subs (_, w) | Add w -> Format.fprintf ppf "@{%s@}" w + | Del _ -> ()) + ppf ops + in + pr_left, pr_right let diff_command = let has_gnu_diff () = @@ -139,10 +191,8 @@ let diff_command = else Format.fprintf ppf "%s@{│@}@{%s@}" l r | '<' -> Format.fprintf ppf "%s@{│@}@{-@}" l | '|' -> - let w = longuest_common_prefix_length (" " ^ l) r in - Format.fprintf ppf "%s@{│@}%s@{%s@}" l - (String.sub r 0 w) - (String.sub r w (String.length r - w)) + let ppleft, ppright = colordiff_str l r in + Format.fprintf ppf "%a@{│@}%a" ppleft () ppright () | _ -> Format.pp_print_string ppf li)) ppf ) | Some cmd_opt | (None as cmd_opt) -> @@ -287,7 +337,7 @@ let print_box tcolor ppf title (pcontents : box -> unit) = (fun ppf -> Format.pp_print_tab ppf (); Format.fprintf ppf "%t┃@}@," tcolor) - ppf ("%t@<1>%s@} " ^^ fmt) tcolor "┃"); + ppf ("%t@<1>%s@} " ^^ fmt) tcolor "┃"); } in pcontents box; diff --git a/compiler/catala_utils/cli.ml b/compiler/catala_utils/cli.ml index 3eddd739..961131c7 100644 --- a/compiler/catala_utils/cli.ml +++ b/compiler/catala_utils/cli.ml @@ -334,13 +334,6 @@ module Flags = struct ~env:(Cmd.Env.info "CATALA_OPTIMIZE") ~doc:"Run compiler optimizations." - let avoid_exceptions = - value - & flag - & info ["avoid-exceptions"] - ~env:(Cmd.Env.info "CATALA_AVOID_EXCEPTIONS") - ~doc:"Compiles the default calculus without exceptions." - let keep_special_ops = value & flag @@ -381,9 +374,7 @@ module Flags = struct value & flag & info ["closure-conversion"] - ~doc: - "Performs closure conversion on the lambda calculus. Implies \ - $(b,--avoid-exceptions)." + ~doc:"Performs closure conversion on the lambda calculus." let disable_counterexamples = value diff --git a/compiler/catala_utils/cli.mli b/compiler/catala_utils/cli.mli index fe1b723d..d9928c29 100644 --- a/compiler/catala_utils/cli.mli +++ b/compiler/catala_utils/cli.mli @@ -55,7 +55,6 @@ module Flags : sig val ex_variable : string Term.t val output : raw_file option Term.t val optimize : bool Term.t - val avoid_exceptions : bool Term.t val closure_conversion : bool Term.t val keep_special_ops : bool Term.t val monomorphize_types : bool Term.t diff --git a/compiler/catala_utils/hash.ml b/compiler/catala_utils/hash.ml index d92e790f..59fd8f35 100644 --- a/compiler/catala_utils/hash.ml +++ b/compiler/catala_utils/hash.ml @@ -36,22 +36,16 @@ module Flags : sig type nonrec t = private t val pass : - (t -> 'a) -> - avoid_exceptions:bool -> - closure_conversion:bool -> - monomorphize_types:bool -> - 'a + (t -> 'a) -> closure_conversion:bool -> monomorphize_types:bool -> 'a val of_t : int -> t end = struct type nonrec t = t - let pass k ~avoid_exceptions ~closure_conversion ~monomorphize_types = - let avoid_exceptions = avoid_exceptions || closure_conversion in + let pass k ~closure_conversion ~monomorphize_types = (* Should not affect the call convention or actual interfaces: include, optimize, check_invariants, typed *) - !(avoid_exceptions : bool) - % !(closure_conversion : bool) + !(closure_conversion : bool) % !(monomorphize_types : bool) % (* The following may not affect the call convention, but we want it set in an homogeneous way *) diff --git a/compiler/catala_utils/hash.mli b/compiler/catala_utils/hash.mli index b70ba2f1..4d18aba6 100644 --- a/compiler/catala_utils/hash.mli +++ b/compiler/catala_utils/hash.mli @@ -58,12 +58,7 @@ val map : first argument is expected to be a [Foo.Map.fold] function. The result is independent of the ordering of the map. *) -val finalise : - t -> - avoid_exceptions:bool -> - closure_conversion:bool -> - monomorphize_types:bool -> - full +val finalise : t -> closure_conversion:bool -> monomorphize_types:bool -> full (** Turns a raw interface hash into a full hash, ready for printing *) val to_string : full -> string diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index 19594a57..9b1a8656 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -111,8 +111,7 @@ let print_time_marker = let old_time = !time in time := new_time; let delta = (new_time -. old_time) *. 1000. in - if delta > 50. then - Format.fprintf ppf "@{[TIME] %.0fms@}@\n" delta + if delta > 50. then Format.fprintf ppf " @{%.0fms@}" delta let pp_marker ?extra_label target ppf = let open Ocolor_types in @@ -129,10 +128,10 @@ let pp_marker ?extra_label target ppf = | None -> str | Some lbl -> Printf.sprintf "%s %s" str lbl in - if target = Debug then print_time_marker ppf (); Format.pp_open_stag ppf (Ocolor_format.Ocolor_styles_tag tags); Format.pp_print_string ppf str; - Format.pp_close_stag ppf () + Format.pp_close_stag ppf (); + if target = Debug then print_time_marker ppf () (**{2 Printers}*) diff --git a/compiler/driver.ml b/compiler/driver.ml index a87bbbe0..f4efd0a9 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -227,7 +227,6 @@ module Passes = struct ~optimize ~check_invariants ~(typed : ty mark) - ~avoid_exceptions ~closure_conversion ~monomorphize_types : typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list = @@ -235,23 +234,11 @@ module Passes = struct dcalc options ~includes ~optimize ~check_invariants ~typed in debug_pass_name "lcalc"; - let avoid_exceptions = avoid_exceptions || closure_conversion in - (* --closure-conversion implies --avoid-exceptions *) let prg = - if avoid_exceptions && options.trace then - Message.warning - "It is discouraged to use option @{--avoid-exceptions@} if \ - you@ also@ need@ @{--trace@},@ the@ resulting@ trace@ may@ \ - be@ unreliable@ at@ the@ moment."; - match avoid_exceptions, typed with - | true, Untyped _ -> - Lcalc.From_dcalc.translate_program_without_exceptions prg - | true, Typed _ -> - Lcalc.From_dcalc.translate_program_without_exceptions prg - | false, Typed _ -> Lcalc.From_dcalc.translate_program_with_exceptions prg - | false, Untyped _ -> - Lcalc.From_dcalc.translate_program_with_exceptions prg - | _, Custom _ -> invalid_arg "Driver.Passes.lcalc" + match typed with + | Untyped _ -> Lcalc.From_dcalc.translate_program prg + | Typed _ -> Lcalc.From_dcalc.translate_program prg + | Custom _ -> invalid_arg "Driver.Passes.lcalc" in let prg = if optimize then begin @@ -295,7 +282,6 @@ module Passes = struct ~includes ~optimize ~check_invariants - ~avoid_exceptions ~closure_conversion ~keep_special_ops ~dead_value_assignment @@ -304,7 +290,7 @@ module Passes = struct Scalc.Ast.program * Scopelang.Dependency.TVertex.t list = let prg, type_ordering = lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed - ~avoid_exceptions ~closure_conversion ~monomorphize_types + ~closure_conversion ~monomorphize_types in debug_pass_name "scalc"; ( Scalc.From_lcalc.translate_program @@ -710,10 +696,7 @@ module Commands = struct Passes.dcalc options ~includes ~optimize ~check_invariants ~typed in Interpreter.load_runtime_modules - ~hashf: - Hash.( - finalise ~avoid_exceptions:false ~closure_conversion:false - ~monomorphize_types:false) + ~hashf:Hash.(finalise ~closure_conversion:false ~monomorphize_types:false) prg; print_interpretation_results options Interpreter.interpret_program_dcalc prg (get_scopeopt_uid prg.decl_ctx ex_scope_opt) @@ -725,13 +708,12 @@ module Commands = struct output optimize check_invariants - avoid_exceptions closure_conversion monomorphize_types ex_scope_opt = let prg, _ = Passes.lcalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions ~closure_conversion ~typed ~monomorphize_types + ~closure_conversion ~typed ~monomorphize_types in let _output_file, with_output = get_output_format options output in with_output @@ -764,14 +746,12 @@ module Commands = struct $ Cli.Flags.output $ Cli.Flags.optimize $ Cli.Flags.check_invariants - $ Cli.Flags.avoid_exceptions $ Cli.Flags.closure_conversion $ Cli.Flags.monomorphize_types $ Cli.Flags.ex_scope_opt) let interpret_lcalc typed - avoid_exceptions closure_conversion monomorphize_types options @@ -781,32 +761,27 @@ module Commands = struct ex_scope_opt = let prg, _ = Passes.lcalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions ~closure_conversion ~monomorphize_types ~typed + ~closure_conversion ~monomorphize_types ~typed in Interpreter.load_runtime_modules - ~hashf: - (Hash.finalise ~avoid_exceptions ~closure_conversion ~monomorphize_types) + ~hashf:(Hash.finalise ~closure_conversion ~monomorphize_types) prg; print_interpretation_results options Interpreter.interpret_program_lcalc prg (get_scopeopt_uid prg.decl_ctx ex_scope_opt) let interpret_cmd = - let f lcalc avoid_exceptions closure_conversion monomorphize_types no_typing - = + let f lcalc closure_conversion monomorphize_types no_typing = if not lcalc then - if avoid_exceptions || closure_conversion || monomorphize_types then + if closure_conversion || monomorphize_types then Message.error - "The flags @{--avoid-exceptions@}, \ - @{--closure-conversion@} and @{--monomorphize-types@} \ - only make sense with the @{--lcalc@} option" + "The flags @{--closure-conversion@} and \ + @{--monomorphize-types@} only make sense with the \ + @{--lcalc@} option" else if no_typing then interpret_dcalc Expr.untyped else interpret_dcalc Expr.typed else if no_typing then - interpret_lcalc Expr.untyped avoid_exceptions closure_conversion - monomorphize_types - else - interpret_lcalc Expr.typed avoid_exceptions closure_conversion - monomorphize_types + interpret_lcalc Expr.untyped closure_conversion monomorphize_types + else interpret_lcalc Expr.typed closure_conversion monomorphize_types in Cmd.v (Cmd.info "interpret" @@ -817,7 +792,6 @@ module Commands = struct Term.( const f $ Cli.Flags.lcalc - $ Cli.Flags.avoid_exceptions $ Cli.Flags.closure_conversion $ Cli.Flags.monomorphize_types $ Cli.Flags.no_typing @@ -833,13 +807,11 @@ module Commands = struct output optimize check_invariants - avoid_exceptions closure_conversion ex_scope_opt = let prg, type_ordering = Passes.lcalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions ~typed:Expr.typed ~closure_conversion - ~monomorphize_types:false + ~typed:Expr.typed ~closure_conversion ~monomorphize_types:false in let output_file, with_output = get_output_format options ~ext:".ml" output @@ -850,10 +822,7 @@ module Commands = struct Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file); let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in - let hashf = - Hash.finalise ~avoid_exceptions ~closure_conversion - ~monomorphize_types:false - in + let hashf = Hash.finalise ~closure_conversion ~monomorphize_types:false in Lcalc.To_ocaml.format_program fmt prg ?exec_scope ~hashf type_ordering let ocaml_cmd = @@ -867,7 +836,6 @@ module Commands = struct $ Cli.Flags.output $ Cli.Flags.optimize $ Cli.Flags.check_invariants - $ Cli.Flags.avoid_exceptions $ Cli.Flags.closure_conversion $ Cli.Flags.ex_scope_opt) @@ -877,7 +845,6 @@ module Commands = struct output optimize check_invariants - avoid_exceptions closure_conversion keep_special_ops dead_value_assignment @@ -886,8 +853,8 @@ module Commands = struct ex_scope_opt = let prg, _ = Passes.scalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions ~closure_conversion ~keep_special_ops - ~dead_value_assignment ~no_struct_literals ~monomorphize_types + ~closure_conversion ~keep_special_ops ~dead_value_assignment + ~no_struct_literals ~monomorphize_types in let _output_file, with_output = get_output_format options output in with_output @@ -919,7 +886,6 @@ module Commands = struct $ Cli.Flags.output $ Cli.Flags.optimize $ Cli.Flags.check_invariants - $ Cli.Flags.avoid_exceptions $ Cli.Flags.closure_conversion $ Cli.Flags.keep_special_ops $ Cli.Flags.dead_value_assignment @@ -933,13 +899,11 @@ module Commands = struct output optimize check_invariants - avoid_exceptions closure_conversion = let prg, type_ordering = Passes.scalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions ~closure_conversion ~keep_special_ops:false - ~dead_value_assignment:true ~no_struct_literals:false - ~monomorphize_types:false + ~closure_conversion ~keep_special_ops:false ~dead_value_assignment:true + ~no_struct_literals:false ~monomorphize_types:false in let output_file, with_output = @@ -962,15 +926,13 @@ module Commands = struct $ Cli.Flags.output $ Cli.Flags.optimize $ Cli.Flags.check_invariants - $ Cli.Flags.avoid_exceptions $ Cli.Flags.closure_conversion) let r options includes output optimize check_invariants closure_conversion = let prg, type_ordering = Passes.scalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions:false ~closure_conversion ~keep_special_ops:false - ~dead_value_assignment:false ~no_struct_literals:false - ~monomorphize_types:false + ~closure_conversion ~keep_special_ops:false ~dead_value_assignment:false + ~no_struct_literals:false ~monomorphize_types:false in let output_file, with_output = get_output_format options ~ext:".r" output in @@ -994,7 +956,7 @@ module Commands = struct let c options includes output optimize check_invariants = let prg, type_ordering = Passes.scalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions:true ~closure_conversion:true ~keep_special_ops:true + ~closure_conversion:true ~keep_special_ops:true ~dead_value_assignment:false ~no_struct_literals:true ~monomorphize_types:true in diff --git a/compiler/driver.mli b/compiler/driver.mli index f6109ba6..3184a8e7 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -51,7 +51,6 @@ module Passes : sig optimize:bool -> check_invariants:bool -> typed:'m Shared_ast.mark -> - avoid_exceptions:bool -> closure_conversion:bool -> monomorphize_types:bool -> Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list @@ -61,7 +60,6 @@ module Passes : sig includes:Global.raw_file list -> optimize:bool -> check_invariants:bool -> - avoid_exceptions:bool -> closure_conversion:bool -> keep_special_ops:bool -> dead_value_assignment:bool -> diff --git a/compiler/lcalc/closure_conversion.ml b/compiler/lcalc/closure_conversion.ml index 8940e944..961861f9 100644 --- a/compiler/lcalc/closure_conversion.ml +++ b/compiler/lcalc/closure_conversion.ml @@ -30,6 +30,10 @@ type 'm ctx = { let new_var ?(pfx = "") name_context = name_context.counter <- name_context.counter + 1; Var.make (pfx ^ name_context.prefix ^ string_of_int name_context.counter) +(* TODO: Closures end up as a toplevel names. However for now we assume toplevel + names are unique, this is a temporary workaround to avoid name wrangling in + the backends. We need to have a better system for name disambiguation when + for instance printing to Dcalc/Lcalc/Scalc but also OCaml, Python, etc. *) let new_context prefix = { prefix; counter = 0 } @@ -142,8 +146,7 @@ let rec transform_closures_expr : let m = Mark.get e in match Mark.remove e with | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _ - | ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ | ERaiseEmpty - | ECatchEmpty _ -> + | ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ -> Expr.map_gather ~acc:Var.Map.empty ~join:join_vars ~f:(transform_closures_expr ctx) e @@ -217,7 +220,7 @@ let rec transform_closures_expr : EnumConstructor.Map.add cons (Expr.eabs new_binder tys (Mark.get e1)) new_cases ) - | _ -> failwith "should not happen") + | _ -> assert false) cases (free_vars, EnumConstructor.Map.empty) in @@ -253,7 +256,7 @@ let rec transform_closures_expr : free_vars, build_closure ctx (Var.Map.bindings free_vars) body vars tys m | EAppOp { - op = ((HandleDefaultOpt | Fold | Map | Map2 | Filter | Reduce), _) as op; + op = ((HandleExceptions | Fold | Map | Map2 | Filter | Reduce), _) as op; tys; args; } -> @@ -270,6 +273,9 @@ let rec transform_closures_expr : | EAbs { binder; tys } -> let vars, arg = Bindlib.unmbind binder in let new_free_vars, new_arg = (transform_closures_expr ctx) arg in + let new_free_vars = + Array.fold_left (fun m v -> Var.Map.remove v m) new_free_vars vars + in let new_arg = Expr.make_abs vars new_arg tys (Expr.mark_pos m_arg) in @@ -507,7 +513,7 @@ let rec hoist_closures_expr : EnumConstructor.Map.add cons (Expr.eabs new_binder tys (Mark.get e1)) new_cases ) - | _ -> failwith "should not happen") + | _ -> assert false) cases (collected_closures, EnumConstructor.Map.empty) in @@ -530,12 +536,7 @@ let rec hoist_closures_expr : in ( collected_closures, Expr.eapp ~f:(Expr.eabs new_binder tys e1_pos) ~args:new_args ~tys m ) - | EAppOp - { - op = ((HandleDefaultOpt | Fold | Map | Filter | Reduce), _) as op; - tys; - args; - } -> + | EAppOp { op = ((Fold | Map | Filter | Reduce), _) as op; tys; args } -> (* Special case for some operators: its arguments closures thunks because if you want to extract it as a function you need these closures to preserve evaluation order, but backends that don't support closures will simply @@ -562,21 +563,21 @@ let rec hoist_closures_expr : args ([], []) in collected_closures, Expr.eappop ~op ~args:new_args ~tys (Mark.get e) - | EAbs { tys; _ } -> + | EAbs { binder; tys } -> (* this is the closure we want to hoist *) let closure_var = new_var ~pfx:"closure_" name_context in - (* TODO: This will end up as a toplevel name. However for now we assume - toplevel names are unique, but this breaks this assertions and can lead - to name wrangling in the backends. We need to have a better system for - name disambiguation when for instance printing to Dcalc/Lcalc/Scalc but - also OCaml, Python, etc. *) let pos = Expr.mark_pos m in let ty = Expr.maybe_ty ~typ:(TArrow (tys, (TAny, pos))) m in - ( [{ name = closure_var; ty; closure = Expr.rebox e }], + let vars, body = Bindlib.unmbind binder in + let collected_closures, new_body = + (hoist_closures_expr name_context) body + in + let closure = Expr.make_abs vars new_body tys pos in + ( { name = closure_var; ty; closure } :: collected_closures, Expr.make_var closure_var m ) | EApp _ | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _ | ELit _ | EAssert _ | EFatalError _ | EAppOp _ | EIfThenElse _ - | ERaiseEmpty | ECatchEmpty _ | EVar _ -> + | EVar _ -> Expr.map_gather ~acc:[] ~join:( @ ) ~f:(hoist_closures_expr name_context) e | EExternal { name } -> [], Expr.box (EExternal { name }, m) | _ -> . diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml deleted file mode 100644 index d3450c13..00000000 --- a/compiler/lcalc/compile_with_exceptions.ml +++ /dev/null @@ -1,95 +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 - - 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. *) - -open Catala_utils -open Shared_ast -module D = Dcalc.Ast -module A = Ast - -let rec translate_typ (tau : typ) : typ = - Mark.map - (function - | TDefault t -> Mark.remove (translate_typ t) - | TLit l -> TLit l - | TTuple ts -> TTuple (List.map translate_typ ts) - | TStruct s -> TStruct s - | TEnum en -> TEnum en - | TOption _ -> - Message.error ~internal:true - "The types option should not appear before the dcalc -> lcalc \ - translation step." - | TClosureEnv -> - Message.error ~internal:true - "The types closure_env should not appear before the dcalc -> lcalc \ - translation step." - | TAny -> TAny - | TArray ts -> TArray (translate_typ ts) - | TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2)) - tau - -let translate_mark m = Expr.map_ty translate_typ m - -let rec translate_default - (exceptions : 'm D.expr list) - (just : 'm D.expr) - (cons : 'm D.expr) - (mark_default : 'm mark) : 'm A.expr boxed = - let pos = Expr.mark_pos mark_default in - let exceptions = - List.map (fun except -> Expr.thunk_term (translate_expr except)) exceptions - in - Expr.eappop - ~op:(Op.HandleDefault, Expr.pos cons) - ~tys: - [ - TArray (TArrow ([TLit TUnit, pos], (TAny, pos)), pos), pos; - TArrow ([TLit TUnit, pos], (TLit TBool, pos)), pos; - TArrow ([TLit TUnit, pos], (TAny, pos)), pos; - ] - ~args: - [ - Expr.earray exceptions - (Expr.map_ty - (fun ty -> TArray (TArrow ([TLit TUnit, pos], ty), pos), pos) - mark_default); - Expr.thunk_term (translate_expr just); - Expr.thunk_term (translate_expr cons); - ] - mark_default - -and translate_expr (e : 'm D.expr) : 'm A.expr boxed = - match e with - | EEmpty, m -> Expr.eraiseempty (translate_mark m) - | EErrorOnEmpty arg, m -> - let m = translate_mark m in - Expr.ecatchempty (translate_expr arg) (Expr.efatalerror Runtime.NoValue m) m - | EDefault { excepts; just; cons }, m -> - translate_default excepts just cons (translate_mark m) - | EPureDefault e, _ -> translate_expr e - | EAppOp { op; args; tys }, m -> - Expr.eappop ~op:(Operator.translate op) - ~args:(List.map translate_expr args) - ~tys:(List.map translate_typ tys) - (translate_mark m) - | ( ( ELit _ | EArray _ | EVar _ | EAbs _ | EApp _ | EExternal _ - | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _ - | EFatalError _ | EStruct _ | EStructAccess _ | EMatch _ ), - _ ) as e -> - Expr.map ~f:translate_expr ~typ:translate_typ e - | _ -> . - -let translate_program (prg : 'm D.program) : 'm A.program = - Program.map_exprs prg ~typ:translate_typ ~varf:Var.translate ~f:translate_expr diff --git a/compiler/lcalc/compile_with_exceptions.mli b/compiler/lcalc/compile_with_exceptions.mli deleted file mode 100644 index da0f4d78..00000000 --- a/compiler/lcalc/compile_with_exceptions.mli +++ /dev/null @@ -1,20 +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 - - 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. *) - -(** Translation from the default calculus to the lambda calculus. This - translation uses exceptions to handle empty default terms. *) - -val translate_program : 'm Dcalc.Ast.program -> 'm Ast.program diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml deleted file mode 100644 index 3f23af4a..00000000 --- a/compiler/lcalc/compile_without_exceptions.ml +++ /dev/null @@ -1,126 +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: - Alain Delaët-Tixeuil - - 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. *) - -open Catala_utils -open Shared_ast -module D = Dcalc.Ast -module A = Ast - -(** We make use of the strong invriants on the structure of programs: - Defaultable values can only appear in certin positions. This information is - given by the type structure of expressions. In particular this mean we don't - need to use the monadic bind while computing arithmetic opertions or - function calls. The resulting function is not more difficult than what we - had when translating without exceptions. - - The typing translation is to simply trnsform default type into option types. *) - -let rec translate_typ (tau : typ) : typ = - Mark.copy tau - begin - match Mark.remove tau with - | TDefault t -> TOption (translate_typ t) - | TLit l -> TLit l - | TTuple ts -> TTuple (List.map translate_typ ts) - | TStruct s -> TStruct s - | TEnum en -> TEnum en - | TOption _ -> - Message.error ~internal:true - "The types option should not appear before the dcalc -> lcalc \ - translation step." - | TClosureEnv -> - Message.error ~internal:true - "The types closure_env should not appear before the dcalc -> lcalc \ - translation step." - | TAny -> TAny - | TArray ts -> TArray (translate_typ ts) - | TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2) - end - -let translate_mark m = Expr.map_ty translate_typ m - -let rec translate_default - (exceptions : 'm D.expr list) - (just : 'm D.expr) - (cons : 'm D.expr) - (mark_default : 'm mark) : 'm A.expr boxed = - (* Since the program is well typed, all exceptions have as type [option 't] *) - let pos = Expr.mark_pos mark_default in - let exceptions = List.map translate_expr exceptions in - let exceptions_and_cons_ty = Expr.maybe_ty mark_default in - Expr.eappop - ~op:(Op.HandleDefaultOpt, Expr.pos cons) - ~tys: - [ - TArray exceptions_and_cons_ty, pos; - TArrow ([TLit TUnit, pos], (TLit TBool, pos)), pos; - TArrow ([TLit TUnit, pos], exceptions_and_cons_ty), pos; - ] - ~args: - [ - Expr.earray exceptions - (Expr.map_ty (fun ty -> TArray ty, pos) mark_default); - (* In call-by-value programming languages, as lcalc, arguments are - evalulated before calling the function. Since we don't want to - execute the justification and conclusion while before checking every - exceptions, we need to thunk them. *) - Expr.thunk_term (translate_expr just); - Expr.thunk_term (translate_expr cons); - ] - mark_default - -and translate_expr (e : 'm D.expr) : 'm A.expr boxed = - match e with - | EEmpty, m -> - let m = translate_mark m in - let pos = Expr.mark_pos m in - Expr.einj - ~e:(Expr.elit LUnit (Expr.with_ty m (TLit TUnit, pos))) - ~cons:Expr.none_constr ~name:Expr.option_enum m - | EErrorOnEmpty arg, m -> - let m = translate_mark m in - let pos = Expr.mark_pos m in - let cases = - EnumConstructor.Map.of_list - [ - ( Expr.none_constr, - let x = Var.make "_" in - Expr.make_abs [| x |] (Expr.efatalerror NoValue m) [TAny, pos] pos - ); - (* | None x -> raise NoValueProvided *) - Expr.some_constr, Expr.fun_id ~var_name:"arg" m (* | Some x -> x *); - ] - in - Expr.ematch ~e:(translate_expr arg) ~name:Expr.option_enum ~cases m - | EDefault { excepts; just; cons }, m -> - translate_default excepts just cons (translate_mark m) - | EPureDefault e, m -> - Expr.einj ~e:(translate_expr e) ~cons:Expr.some_constr - ~name:Expr.option_enum (translate_mark m) - | EAppOp { op; tys; args }, m -> - Expr.eappop ~op:(Operator.translate op) - ~tys:(List.map translate_typ tys) - ~args:(List.map translate_expr args) - (translate_mark m) - | ( ( ELit _ | EArray _ | EVar _ | EApp _ | EAbs _ | EExternal _ - | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _ - | EFatalError _ | EStruct _ | EStructAccess _ | EMatch _ ), - _ ) as e -> - Expr.map ~f:translate_expr ~typ:translate_typ e - | _ -> . - -let translate_program (prg : 'm D.program) : 'm A.program = - Program.map_exprs prg ~typ:translate_typ ~varf:Var.translate ~f:translate_expr diff --git a/compiler/lcalc/compile_without_exceptions.mli b/compiler/lcalc/compile_without_exceptions.mli deleted file mode 100644 index 6bb2b18d..00000000 --- a/compiler/lcalc/compile_without_exceptions.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* This file is part of the Catala compiler, a specification language for tax - and social benefits computation rules. Copyright (C) 2020-2022 Inria, - contributor: Alain Delaët-Tixeuil - - 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. *) - -(** Translation from the default calculus to the lambda calculus. This - translation uses an option monad to handle empty defaults terms. This - transformation is one piece to permit to compile toward legacy languages - that does not contains exceptions. *) - -val translate_program : 'm Dcalc.Ast.program -> 'm Ast.program diff --git a/compiler/lcalc/from_dcalc.ml b/compiler/lcalc/from_dcalc.ml index 98e49b4b..f147a38e 100644 --- a/compiler/lcalc/from_dcalc.ml +++ b/compiler/lcalc/from_dcalc.ml @@ -1,6 +1,6 @@ (* 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 + Alain Delaët-Tixeuil 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 @@ -14,7 +14,130 @@ License for the specific language governing permissions and limitations under the License. *) +open Catala_utils open Shared_ast +module D = Dcalc.Ast +module A = Ast + +(** We make use of the strong invriants on the structure of programs: + Defaultable values can only appear in certin positions. This information is + given by the type structure of expressions. In particular this mean we don't + need to use the monadic bind while computing arithmetic opertions or + function calls. The resulting function is not more difficult than what we + had when translating without exceptions. + + The typing translation is to simply trnsform default type into option types. *) + +let rec translate_typ (tau : typ) : typ = + Mark.copy tau + begin + match Mark.remove tau with + | TDefault t -> TOption (translate_typ t) + | TLit l -> TLit l + | TTuple ts -> TTuple (List.map translate_typ ts) + | TStruct s -> TStruct s + | TEnum en -> TEnum en + | TOption _ -> + Message.error ~internal:true + "The types option should not appear before the dcalc -> lcalc \ + translation step." + | TClosureEnv -> + Message.error ~internal:true + "The types closure_env should not appear before the dcalc -> lcalc \ + translation step." + | TAny -> TAny + | TArray ts -> TArray (translate_typ ts) + | TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2) + end + +let translate_mark m = Expr.map_ty translate_typ m + +let rec translate_default + (exceptions : 'm D.expr list) + (just : 'm D.expr) + (cons : 'm D.expr) + (mark_default : 'm mark) : 'm A.expr boxed = + (* Since the program is well typed, all exceptions have as type [option 't] *) + let pos = Expr.mark_pos mark_default in + let exceptions = List.map translate_expr exceptions in + let ty_option = Expr.maybe_ty mark_default in + let ty_array = TArray ty_option, pos in + let ty_alpha = + match ty_option with + | TOption ty, _ -> ty + | (TAny, _) as ty -> ty + | _ -> assert false + in + let mark_alpha = Expr.with_ty mark_default ty_alpha in + Expr.ematch ~name:Expr.option_enum + ~e: + (Expr.eappop + ~op:(Op.HandleExceptions, Expr.pos cons) + ~tys:[ty_array] + ~args:[Expr.earray exceptions (Expr.with_ty mark_default ty_array)] + mark_default) + ~cases: + (EnumConstructor.Map.of_list + [ + (* Some x -> Some x *) + ( Expr.some_constr, + let x = Var.make "x" in + Expr.make_abs [| x |] + (Expr.einj ~name:Expr.option_enum ~cons:Expr.some_constr + ~e:(Expr.evar x mark_alpha) mark_default) + [ty_alpha] pos ); + (* None -> if just then cons else None *) + ( Expr.none_constr, + Expr.thunk_term + (Expr.eifthenelse (translate_expr just) (translate_expr cons) + (Expr.einj + ~e: + (Expr.elit LUnit + (Expr.with_ty mark_default (TLit TUnit, pos))) + ~cons:Expr.none_constr ~name:Expr.option_enum mark_default) + mark_default) ); + ]) + mark_default + +and translate_expr (e : 'm D.expr) : 'm A.expr boxed = + match e with + | EEmpty, m -> + let m = translate_mark m in + let pos = Expr.mark_pos m in + Expr.einj + ~e:(Expr.elit LUnit (Expr.with_ty m (TLit TUnit, pos))) + ~cons:Expr.none_constr ~name:Expr.option_enum m + | EErrorOnEmpty arg, m -> + let m = translate_mark m in + let pos = Expr.mark_pos m in + let cases = + EnumConstructor.Map.of_list + [ + ( Expr.none_constr, + let x = Var.make "_" in + Expr.make_abs [| x |] (Expr.efatalerror NoValue m) [TAny, pos] pos + ); + (* | None x -> raise NoValueProvided *) + Expr.some_constr, Expr.fun_id ~var_name:"arg" m (* | Some x -> x *); + ] + in + Expr.ematch ~e:(translate_expr arg) ~name:Expr.option_enum ~cases m + | EDefault { excepts; just; cons }, m -> + translate_default excepts just cons (translate_mark m) + | EPureDefault e, m -> + Expr.einj ~e:(translate_expr e) ~cons:Expr.some_constr + ~name:Expr.option_enum (translate_mark m) + | EAppOp { op; tys; args }, m -> + Expr.eappop ~op:(Operator.translate op) + ~tys:(List.map translate_typ tys) + ~args:(List.map translate_expr args) + (translate_mark m) + | ( ( ELit _ | EArray _ | EVar _ | EApp _ | EAbs _ | EExternal _ + | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _ + | EFatalError _ | EStruct _ | EStructAccess _ | EMatch _ ), + _ ) as e -> + Expr.map ~f:translate_expr ~typ:translate_typ e + | _ -> . let add_option_type ctx = { @@ -26,9 +149,7 @@ let add_option_type ctx = let add_option_type_program prg = { prg with decl_ctx = add_option_type prg.decl_ctx } -let translate_program_with_exceptions = - Compile_with_exceptions.translate_program - -let translate_program_without_exceptions prg = - let prg = add_option_type_program prg in - Compile_without_exceptions.translate_program prg +let translate_program (prg : 'm D.program) : 'm A.program = + Program.map_exprs + (add_option_type_program prg) + ~typ:translate_typ ~varf:Var.translate ~f:translate_expr diff --git a/compiler/lcalc/from_dcalc.mli b/compiler/lcalc/from_dcalc.mli index fb4ba11b..6bb2b18d 100644 --- a/compiler/lcalc/from_dcalc.mli +++ b/compiler/lcalc/from_dcalc.mli @@ -1,6 +1,6 @@ (* 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 + and social benefits computation rules. Copyright (C) 2020-2022 Inria, + contributor: Alain Delaët-Tixeuil 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 @@ -14,13 +14,9 @@ License for the specific language governing permissions and limitations under the License. *) -val translate_program_with_exceptions : 'm Dcalc.Ast.program -> 'm Ast.program -(** Translation from the default calculus to the lambda calculus. This - translation uses exceptions to handle empty default terms. *) - -val translate_program_without_exceptions : - 'm Dcalc.Ast.program -> 'm Ast.program (** Translation from the default calculus to the lambda calculus. This translation uses an option monad to handle empty defaults terms. This transformation is one piece to permit to compile toward legacy languages - that does not contains catchable exceptions. *) + that does not contains exceptions. *) + +val translate_program : 'm Dcalc.Ast.program -> 'm Ast.program diff --git a/compiler/lcalc/monomorphize.ml b/compiler/lcalc/monomorphize.ml index 9c6eda89..80fb040f 100644 --- a/compiler/lcalc/monomorphize.ml +++ b/compiler/lcalc/monomorphize.ml @@ -78,7 +78,7 @@ let collect_monomorphized_instances (prg : typed program) : args; name = StructName.fresh [] - ( "tuple_" ^ string_of_int !option_instances_counter, + ( "tuple_" ^ string_of_int !tuple_instances_counter, Pos.no_pos ); }) acc.tuples; @@ -90,7 +90,7 @@ let collect_monomorphized_instances (prg : typed program) : { acc with arrays = - Type.Map.update t + Type.Map.update typ (fun monomorphized_name -> match monomorphized_name with | Some e -> Some e @@ -118,7 +118,7 @@ let collect_monomorphized_instances (prg : typed program) : { acc with options = - Type.Map.update t + Type.Map.update typ (fun monomorphized_name -> match monomorphized_name with | Some e -> Some e @@ -173,8 +173,9 @@ let rec monomorphize_typ (typ : typ) : typ = match Mark.remove typ with | TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> typ - | TArray t1 -> - TStruct (Type.Map.find t1 monomorphized_instances.arrays).name, Mark.get typ + | TArray _ -> + ( TStruct (Type.Map.find typ monomorphized_instances.arrays).name, + Mark.get typ ) | TDefault t1 -> TDefault (monomorphize_typ monomorphized_instances t1), Mark.get typ | TArrow (t1s, t2) -> @@ -185,8 +186,8 @@ let rec monomorphize_typ | TTuple _ -> ( TStruct (Type.Map.find typ monomorphized_instances.tuples).name, Mark.get typ ) - | TOption t1 -> - TEnum (Type.Map.find t1 monomorphized_instances.options).name, Mark.get typ + | TOption _ -> + TEnum (Type.Map.find typ monomorphized_instances.options).name, Mark.get typ let is_some c = EnumConstructor.equal Expr.some_constr c @@ -233,7 +234,12 @@ let rec monomorphize_expr field = fst (List.nth tuple_instance.fields index); } | EMatch { name; e; cases } when EnumName.equal name Expr.option_enum -> - let option_instance = Type.Map.find ty0 monomorphized_instances.options in + let opt_ty = + match e0 with EMatch { e; _ }, _ -> Expr.ty e | _ -> assert false + in + let option_instance = + Type.Map.find opt_ty monomorphized_instances.options + in EMatch { name = option_instance.name; @@ -247,11 +253,7 @@ let rec monomorphize_expr cases EnumConstructor.Map.empty; } | EInj { name; e; cons } when EnumName.equal name Expr.option_enum -> - let option_instance = - Type.Map.find - (match Mark.remove ty0 with TOption t -> t | _ -> assert false) - monomorphized_instances.options - in + let option_instance = Type.Map.find ty0 monomorphized_instances.options in EInj { name = option_instance.name; @@ -264,7 +266,7 @@ let rec monomorphize_expr let elt_ty = match Mark.remove ty0 with TArray t -> t | _ -> assert false in - let array_instance = Type.Map.find elt_ty monomorphized_instances.arrays in + let array_instance = Type.Map.find ty0 monomorphized_instances.arrays in EStruct { name = array_instance.name; diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 958771fe..fe6dd665 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -409,21 +409,6 @@ 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 = (EArray excs, _) :: _ as args; - _; - } -> - let pos = List.map Expr.pos excs in - Format.fprintf fmt "@[%s@ [|%a|]@ %a@]" - (Print.operator_to_string op) - (Format.pp_print_list - ~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 "@[%a@ %a@]" format_with_parens f (Format.pp_print_list @@ -443,6 +428,12 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : Format.fprintf ppf "%a@ " format_pos pos | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur -> Format.fprintf ppf "%a@ " format_pos (Expr.pos (List.nth args 1)) + | HandleExceptions -> + Format.fprintf ppf "[|@[%a@]|]@ " + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ") + format_pos) + (List.map Expr.pos args) | _ -> ()) (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") @@ -457,10 +448,6 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : | EFatalError er -> 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 } -> - Format.fprintf fmt "@[@[try@ %a@]@ with Empty ->@]@ @[%a@]" - format_with_parens body format_with_parens handler | _ -> . let format_struct_embedding diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index 73d1a22a..b7fb1e74 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -471,15 +471,13 @@ let run output optimize check_invariants - avoid_exceptions closure_conversion monomorphize_types _options = let options = Global.enforce_options ~trace:true () in let prg, type_ordering = Driver.Passes.lcalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions ~closure_conversion ~typed:Expr.typed - ~monomorphize_types + ~closure_conversion ~typed:Expr.typed ~monomorphize_types in let jsoo_output_file, with_formatter = Driver.Commands.get_output_format options ~ext:"_api_web.ml" output @@ -506,7 +504,6 @@ let term = $ Cli.Flags.output $ Cli.Flags.optimize $ Cli.Flags.check_invariants - $ Cli.Flags.avoid_exceptions $ Cli.Flags.closure_conversion $ Cli.Flags.monomorphize_types diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index 929f15f9..afed754b 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -1085,8 +1085,7 @@ 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 -> "" + | HandleExceptions -> "" | ToClosureEnv -> "" | FromClosureEnv -> "" in @@ -1382,9 +1381,7 @@ let run includes optimize ex_scope explain_options global_options = ~check_invariants:false ~typed:Expr.typed in Interpreter.load_runtime_modules prg - ~hashf: - (Hash.finalise ~avoid_exceptions:false ~closure_conversion:false - ~monomorphize_types:false); + ~hashf:(Hash.finalise ~closure_conversion:false ~monomorphize_types:false); let scope = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in (* let result_expr, env = interpret_program prg scope in *) let g, base_vars, env = program_to_graph explain_options prg scope in diff --git a/compiler/plugins/json_schema.ml b/compiler/plugins/json_schema.ml index 70779512..d187e59e 100644 --- a/compiler/plugins/json_schema.ml +++ b/compiler/plugins/json_schema.ml @@ -210,15 +210,13 @@ let run output optimize check_invariants - avoid_exceptions closure_conversion monomorphize_types ex_scope options = let prg, _ = Driver.Passes.lcalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions ~closure_conversion ~typed:Expr.typed - ~monomorphize_types + ~closure_conversion ~typed:Expr.typed ~monomorphize_types in let output_file, with_output = Driver.Commands.get_output_format options ~ext:"_schema.json" output @@ -239,7 +237,6 @@ let term = $ Cli.Flags.output $ Cli.Flags.optimize $ Cli.Flags.check_invariants - $ Cli.Flags.avoid_exceptions $ Cli.Flags.closure_conversion $ Cli.Flags.monomorphize_types $ Cli.Flags.ex_scope diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index 7a2d4d02..52d549c9 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -272,9 +272,7 @@ let run includes optimize check_invariants ex_scope options = ~typed:Expr.typed in Interpreter.load_runtime_modules prg - ~hashf: - (Hash.finalise ~avoid_exceptions:false ~closure_conversion:false - ~monomorphize_types:false); + ~hashf:(Hash.finalise ~closure_conversion:false ~monomorphize_types:false); let scope = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in let result_expr, _env = interpret_program prg scope in let fmt = Format.std_formatter in diff --git a/compiler/plugins/python.ml b/compiler/plugins/python.ml index 3ec2c558..1c167290 100644 --- a/compiler/plugins/python.ml +++ b/compiler/plugins/python.ml @@ -22,20 +22,12 @@ open Catala_utils -let run - includes - output - optimize - check_invariants - avoid_exceptions - closure_conversion - options = +let run includes output optimize check_invariants closure_conversion options = let open Driver.Commands in let prg, type_ordering = Driver.Passes.scalc options ~includes ~optimize ~check_invariants - ~avoid_exceptions ~closure_conversion ~keep_special_ops:false - ~dead_value_assignment:true ~no_struct_literals:false - ~monomorphize_types:false + ~closure_conversion ~keep_special_ops:false ~dead_value_assignment:true + ~no_struct_literals:false ~monomorphize_types:false in let output_file, with_output = get_output_format options ~ext:".py" output in @@ -50,7 +42,6 @@ let term = $ Cli.Flags.output $ Cli.Flags.optimize $ Cli.Flags.check_invariants - $ Cli.Flags.avoid_exceptions $ Cli.Flags.closure_conversion let () = diff --git a/compiler/scalc/ast.ml b/compiler/scalc/ast.ml index 48c2b2da..b5908a2e 100644 --- a/compiler/scalc/ast.ml +++ b/compiler/scalc/ast.ml @@ -33,10 +33,6 @@ module VarName = end) () -let dead_value = VarName.fresh ("dead_value", Pos.no_pos) -let handle_default = FuncName.fresh ("handle_default", Pos.no_pos) -let handle_default_opt = FuncName.fresh ("handle_default_opt", Pos.no_pos) - type operator = Shared_ast.lcalc Shared_ast.operator type expr = naked_expr Mark.pos diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index ca4933eb..a5d08406 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -35,13 +35,6 @@ type 'm ctxt = { program_ctx : A.ctx; } -let unthunk e = - match Mark.remove e with - | EAbs { binder; tys = [(TLit TUnit, _)] } -> - let _, e = Bindlib.unmbind binder in - e - | _ -> failwith "should not happen" - (* Expressions can spill out side effect, hence this function also returns a list of statements to be prepended before the expression is evaluated *) @@ -138,15 +131,6 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr = | ETupleAccess { e = e1; index; _ } -> let e1_stmts, new_e1 = translate_expr ctxt e1 in e1_stmts, (A.ETupleAccess { e1 = new_e1; index }, Expr.pos expr) - | EAppOp - { - op = Op.HandleDefaultOpt, _; - args = [_exceptions; _just; _cons]; - tys = _; - } - when ctxt.config.keep_special_ops -> - (* This should be translated as a statement *) - raise (NotAnExpr { needs_a_local_decl = true }) | EAppOp { op; args; tys = _ } -> let args_stmts, new_args = translate_expr_list ctxt args in (* FIXME: what happens if [arg] is not a tuple but reduces to one ? *) @@ -227,8 +211,7 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr = Expr.pos expr ) in RevBlock.empty, (EExternal { modname; name }, Expr.pos expr) - | ECatchEmpty _ | EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ - | EFatalError _ | ERaiseEmpty -> + | EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ | EFatalError _ -> raise (NotAnExpr { needs_a_local_decl = true }) | _ -> . with NotAnExpr { needs_a_local_decl } -> @@ -274,60 +257,60 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block = ~tail:[A.SAssert (Mark.remove new_e), Expr.pos block_expr] e_stmts | EFatalError err -> [SFatalError err, Expr.pos block_expr] - | EAppOp - { op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] } - when ctxt.config.keep_special_ops -> - let exceptions = - match Mark.remove exceptions with - | EStruct { fields; _ } -> ( - let _, exceptions = - List.find - (fun (field, _) -> - String.equal (Mark.remove (StructField.get_info field)) "content") - (StructField.Map.bindings fields) - in - match Mark.remove exceptions with - | EArray exceptions -> exceptions - | _ -> failwith "should not happen") - | _ -> failwith "should not happen" - in - let just = unthunk just in - let cons = unthunk cons in - let exceptions_stmts, new_exceptions = - translate_expr_list ctxt exceptions - in - let just_stmts, new_just = translate_expr ctxt just in - let cons_stmts, new_cons = translate_expr ctxt cons in - RevBlock.rebuild exceptions_stmts - ~tail: - (RevBlock.rebuild just_stmts - ~tail: - [ - ( A.SSpecialOp - (OHandleDefaultOpt - { - exceptions = new_exceptions; - just = new_just; - cons = - RevBlock.rebuild cons_stmts - ~tail: - [ - ( (match ctxt.inside_definition_of with - | None -> A.SReturn (Mark.remove new_cons) - | Some x -> - A.SLocalDef - { - name = Mark.copy new_cons x; - expr = new_cons; - typ = - Expr.maybe_ty (Mark.get block_expr); - }), - Expr.pos block_expr ); - ]; - return_typ = Expr.maybe_ty (Mark.get block_expr); - }), - Expr.pos block_expr ); - ]) + (* | EAppOp + * { op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] } + * when ctxt.config.keep_special_ops -> + * let exceptions = + * match Mark.remove exceptions with + * | EStruct { fields; _ } -> ( + * let _, exceptions = + * List.find + * (fun (field, _) -> + * String.equal (Mark.remove (StructField.get_info field)) "content") + * (StructField.Map.bindings fields) + * in + * match Mark.remove exceptions with + * | EArray exceptions -> exceptions + * | _ -> failwith "should not happen") + * | _ -> failwith "should not happen" + * in + * let just = unthunk just in + * let cons = unthunk cons in + * let exceptions_stmts, new_exceptions = + * translate_expr_list ctxt exceptions + * in + * let just_stmts, new_just = translate_expr ctxt just in + * let cons_stmts, new_cons = translate_expr ctxt cons in + * RevBlock.rebuild exceptions_stmts + * ~tail: + * (RevBlock.rebuild just_stmts + * ~tail: + * [ + * ( A.SSpecialOp + * (OHandleDefaultOpt + * { + * exceptions = new_exceptions; + * just = new_just; + * cons = + * RevBlock.rebuild cons_stmts + * ~tail: + * [ + * ( (match ctxt.inside_definition_of with + * | None -> A.SReturn (Mark.remove new_cons) + * | Some x -> + * A.SLocalDef + * { + * name = Mark.copy new_cons x; + * expr = new_cons; + * typ = + * Expr.maybe_ty (Mark.get block_expr); + * }), + * Expr.pos block_expr ); + * ]; + * return_typ = Expr.maybe_ty (Mark.get block_expr); + * }), + * Expr.pos block_expr ); + * ]) *) | EApp { f = EAbs { binder; tys }, binder_mark; args; _ } -> (* This defines multiple local variables at the time *) let binder_pos = Expr.mark_pos binder_mark in @@ -483,29 +466,6 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block = }, Expr.pos block_expr ); ] - | ECatchEmpty { body; handler } -> - let s_e_try = translate_statements ctxt body in - let s_e_catch = translate_statements ctxt handler in - [ - ( A.STryWEmpty { try_block = s_e_try; with_block = s_e_catch }, - Expr.pos block_expr ); - ] - | ERaiseEmpty -> - (* Before raising the exception, we still give a dummy definition to the - current variable so that tools like mypy don't complain. *) - (match ctxt.inside_definition_of with - | Some x when ctxt.config.dead_value_assignment -> - [ - ( A.SLocalDef - { - name = x, Expr.pos block_expr; - expr = Ast.EVar Ast.dead_value, Expr.pos block_expr; - typ = Expr.maybe_ty (Mark.get block_expr); - }, - Expr.pos block_expr ); - ] - | _ -> []) - @ [A.SRaiseEmpty, Expr.pos block_expr] | EInj { e = e1; cons; name } when ctxt.config.no_struct_literals -> let e1_stmts, new_e1 = translate_expr ctxt e1 in let tmp_struct_var_name = diff --git a/compiler/scalc/print.ml b/compiler/scalc/print.ml index 9cbf411b..5863678f 100644 --- a/compiler/scalc/print.ml +++ b/compiler/scalc/print.ml @@ -53,7 +53,7 @@ let rec format_expr (StructField.Map.bindings es) Print.punctuation "}" | ETuple es -> - Format.fprintf fmt "@[%a%a%a@]" Print.punctuation "()" + Format.fprintf fmt "@[%a%a%a@]" Print.punctuation "(" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (fun fmt e -> Format.fprintf fmt "%a" format_expr e)) @@ -233,21 +233,11 @@ let format_item decl_ctx ?debug ppf def = Format.pp_print_cut ppf () let format_program ?debug ppf prg = - let decl_ctx = - (* TODO: this is redundant with From_dcalc.add_option_type (which is already - applied in avoid_exceptions mode) *) - { - prg.ctx.decl_ctx with - ctx_enums = - EnumName.Map.add Expr.option_enum Expr.option_enum_config - prg.ctx.decl_ctx.ctx_enums; - } - in Format.pp_open_vbox ppf 0; ModuleName.Map.iter (fun m var -> Format.fprintf ppf "%a %a = %a@," Print.keyword "module" format_var_name var ModuleName.format m) prg.ctx.modules; - Format.pp_print_list (format_item decl_ctx ?debug) ppf prg.code_items; + Format.pp_print_list (format_item prg.ctx.decl_ctx ?debug) ppf prg.code_items; Format.pp_close_box ppf () diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 4869ca14..3205968d 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -313,9 +313,8 @@ 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" + | HandleExceptions -> Format.pp_print_string fmt "catala_handle_exceptions" + | FromClosureEnv | ToClosureEnv | Map2 -> failwith "unimplemented" let _format_string_list (fmt : Format.formatter) (uids : string list) : unit = let sanitize_quotes = Re.compile (Re.char '"') in @@ -368,8 +367,6 @@ 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 = _ } -> - failwith "should not happen because of keep_special_ops" | EApp { f; args } -> Format.fprintf fmt "%a(@[%a)@]" (format_expression ctx) f (Format.pp_print_list diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index c76a26c2..65be82b6 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -88,8 +88,7 @@ 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" + | HandleExceptions -> Format.pp_print_string fmt "handle_exceptions" | FromClosureEnv | ToClosureEnv -> failwith "unimplemented" let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) @@ -347,41 +346,27 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit = args = [arg1]; } -> Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 + | EAppOp { op = (HandleExceptions, _) as op; args = [(EArray el, _)] as args } + -> + Format.fprintf fmt "@[%a(@,[%a],@ %a@;<0 -4>)@]" format_op op + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") + format_position) + (List.map Mark.get el) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") + (format_expression ctx)) + args | EAppOp { op; args = [arg1] } -> Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1 - | EAppOp { op = ((HandleDefault | HandleDefaultOpt), _) as op; args } -> - let pos = Mark.get e in - Format.fprintf fmt - "%a(@[SourcePosition(filename=\"%s\",@ start_line=%d,@ \ - start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]" - format_op op (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 -> - Format.fprintf fmt - "%a(@[SourcePosition(filename=\"%s\",@ start_line=%d,@ \ - start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]" - format_func_name x (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; args } -> - Format.fprintf fmt "%a(@[%a)@]" (format_expression ctx) f + Format.fprintf fmt "%a(@[%a)@]" (format_expression ctx) f (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (format_expression ctx)) args | EAppOp { op; args } -> - Format.fprintf fmt "%a(@[%a)@]" format_op op + Format.fprintf fmt "%a(@[%a)@]" format_op op (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (format_expression ctx)) @@ -402,10 +387,10 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit = match Mark.remove s with | SInnerFuncDef { name; func = { func_params; func_body; _ } } -> - Format.fprintf fmt "@[def %a(%a):@\n%a@]" format_var + Format.fprintf fmt "@[def %a(@[%a@]):@ %a@]" format_var (Mark.remove name) (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (fun fmt (var, typ) -> Format.fprintf fmt "%a:%a" format_var (Mark.remove var) (format_typ ctx) typ)) @@ -414,16 +399,16 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit assert false (* We don't need to declare variables in Python *) | SLocalDef { name = v; expr = e; _ } | SLocalInit { name = v; expr = e; _ } -> - Format.fprintf fmt "@[%a = %a@]" format_var (Mark.remove v) + Format.fprintf fmt "@[%a = %a@]" format_var (Mark.remove v) (format_expression ctx) e | STryWEmpty { try_block = try_b; with_block = catch_b } -> - Format.fprintf fmt "@[try:@,%a@]@\n@[except Empty:@,%a@]" + Format.fprintf fmt "@[try:@ %a@]@,@[except Empty:@ %a@]" (format_block ctx) try_b (format_block ctx) catch_b | SRaiseEmpty -> Format.fprintf fmt "raise Empty" | SFatalError err -> Format.fprintf fmt "@[raise %a@]" format_error (err, Mark.get s) | SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } -> - Format.fprintf fmt "@[if %a:@\n%a@]@\n@[else:@\n%a@]" + Format.fprintf fmt "@[if %a:@ %a@]@,@[else:@ %a@]" (format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2 | SSwitch { @@ -439,11 +424,11 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit when EnumName.equal e_name Expr.option_enum -> (* We translate the option type with an overloading by Python's [None] *) let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in - Format.fprintf fmt "%a = %a@\n" format_var tmp_var (format_expression ctx) - e1; - Format.fprintf fmt "@[if %a is None:@\n%a@]@\n" format_var tmp_var + Format.fprintf fmt "@[%a = %a@]@," format_var tmp_var + (format_expression ctx) e1; + Format.fprintf fmt "@[if %a is None:@ %a@]@," format_var tmp_var (format_block ctx) case_none; - Format.fprintf fmt "@[else:@\n%a = %a@\n%a@]" format_var case_some_var + Format.fprintf fmt "@[else:@ %a = %a@,%a@]" format_var case_some_var format_var tmp_var (format_block ctx) case_some | SSwitch { switch_expr = e1; enum_name = e_name; switch_cases = cases; _ } -> let cons_map = EnumName.Map.find e_name ctx.decl_ctx.ctx_enums in @@ -470,10 +455,10 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit | SAssert e1 -> let pos = Mark.get s in Format.fprintf fmt - "@[if not (%a):@\n\ - raise AssertionFailure(@[SourcePosition(@[filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \ - end_column=%d,@ law_headings=@[%a@])@])@]@]" + "@[if not (%a):@,\ + raise AssertionFailure(@[SourcePosition(@[filename=\"%s\",@ \ + start_line=%d,@ start_column=%d,@ end_line=%d,@ end_column=%d,@ \ + law_headings=@[%a@])@])@]@]" (format_expression ctx) (e1, Mark.get s) (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) @@ -482,12 +467,14 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit | SSpecialOp _ -> failwith "should not happen" and format_block ctx (fmt : Format.formatter) (b : block) : unit = + Format.pp_open_vbox fmt 0; Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,") (format_statement ctx) fmt (List.filter (fun s -> match Mark.remove s with SLocalDecl _ -> false | _ -> true) - b) + b); + Format.pp_close_box fmt () let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) @@ -496,20 +483,20 @@ let format_ctx let format_struct_decl fmt (struct_name, struct_fields) = let fields = StructField.Map.bindings struct_fields in Format.fprintf fmt - "class %a:@\n\ - \ def __init__(self, %a) -> None:@\n\ - %a@\n\ - @\n\ - \ def __eq__(self, other: object) -> bool:@\n\ - \ if isinstance(other, %a):@\n\ - \ return @[(%a)@]@\n\ - \ else:@\n\ - \ return False@\n\ - @\n\ - \ def __ne__(self, other: object) -> bool:@\n\ - \ return not (self == other)@\n\ - @\n\ - \ def __str__(self) -> str:@\n\ + "class %a:@,\ + \ def __init__(self, %a) -> None:@,\ + %a@,\ + @,\ + \ def __eq__(self, other: object) -> bool:@,\ + \ if isinstance(other, %a):@,\ + \ return @[(%a)@]@,\ + \ else:@,\ + \ return False@,\ + @,\ + \ def __ne__(self, other: object) -> bool:@,\ + \ return not (self == other)@,\ + @,\ + \ def __str__(self) -> str:@,\ \ @[return \"%a(%a)\".format(%a)@]" (format_struct_name ctx) struct_name (Format.pp_print_list @@ -521,9 +508,7 @@ let format_ctx (if StructField.Map.is_empty struct_fields then fun fmt _ -> Format.fprintf fmt " pass" else - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun fmt (struct_field, _) -> + Format.pp_print_list (fun fmt (struct_field, _) -> Format.fprintf fmt " self.%a = %a" format_struct_field_name struct_field format_struct_field_name struct_field)) fields (format_struct_name ctx) struct_name @@ -551,32 +536,30 @@ let format_ctx failwith "no constructors in the enum" else Format.fprintf fmt - "@[class %a_Code(Enum):@\n\ - %a@]@\n\ - @\n\ - class %a:@\n\ - \ def __init__(self, code: %a_Code, value: Any) -> None:@\n\ - \ self.code = code@\n\ - \ self.value = value@\n\ - @\n\ - @\n\ - \ def __eq__(self, other: object) -> bool:@\n\ - \ if isinstance(other, %a):@\n\ + "@[class %a_Code(Enum):@,\ + %a@]@,\ + @,\ + class %a:@,\ + \ def __init__(self, code: %a_Code, value: Any) -> None:@,\ + \ self.code = code@,\ + \ self.value = value@,\ + @,\ + @,\ + \ def __eq__(self, other: object) -> bool:@,\ + \ if isinstance(other, %a):@,\ \ return self.code == other.code and self.value == \ - other.value@\n\ - \ else:@\n\ - \ return False@\n\ - @\n\ - @\n\ - \ def __ne__(self, other: object) -> bool:@\n\ - \ return not (self == other)@\n\ - @\n\ - \ def __str__(self) -> str:@\n\ + other.value@,\ + \ else:@,\ + \ return False@,\ + @,\ + @,\ + \ def __ne__(self, other: object) -> bool:@,\ + \ return not (self == other)@,\ + @,\ + \ def __str__(self) -> str:@,\ \ @[return \"{}({})\".format(self.code, self.value)@]" (format_enum_name ctx) enum_name - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun fmt (i, enum_cons, _enum_cons_type) -> + (Format.pp_print_list (fun fmt (i, enum_cons, _enum_cons_type) -> Format.fprintf fmt "%a = %d" format_enum_cons_name enum_cons i)) (List.mapi (fun i (x, y) -> i, x, y) @@ -606,11 +589,11 @@ let format_ctx match struct_or_enum with | Scopelang.Dependency.TVertex.Struct s -> if StructName.path s = [] then - Format.fprintf fmt "%a@\n@\n" format_struct_decl + Format.fprintf fmt "%a@,@," format_struct_decl (s, StructName.Map.find s ctx.decl_ctx.ctx_structs) | Scopelang.Dependency.TVertex.Enum e -> if EnumName.path e = [] then - Format.fprintf fmt "%a@\n@\n" format_enum_decl + Format.fprintf fmt "%a@,@," format_enum_decl (e, EnumName.Map.find e ctx.decl_ctx.ctx_enums)) (type_ordering @ scope_structs) @@ -626,14 +609,15 @@ let reserve_func_name = function let format_code_item ctx fmt = function | SVar { var; expr; typ = _ } -> - Format.fprintf fmt "@[%a = (@,%a@,@])@," format_var var + Format.fprintf fmt "@[%a = (@,%a@;<0 -4>)@]@," format_var var (format_expression ctx) expr | SFunc { var; func } | SScope { scope_body_var = var; scope_body_func = func; _ } -> let { Ast.func_params; Ast.func_body; _ } = func in - Format.fprintf fmt "@[def %a(%a):@\n%a@]@," format_func_name var + Format.fprintf fmt "@[@[def %a(@,%a@;<0 -2>):@]@ %a@]@," + format_func_name var (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (fun fmt (var, typ) -> Format.fprintf fmt "%a:%a" format_var (Mark.remove var) (format_typ ctx) typ)) diff --git a/compiler/scalc/to_r.ml b/compiler/scalc/to_r.ml index eb1e82b9..e9f842f2 100644 --- a/compiler/scalc/to_r.ml +++ b/compiler/scalc/to_r.ml @@ -103,8 +103,7 @@ 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" + | HandleExceptions | FromClosureEnv | ToClosureEnv -> failwith "unimplemented" let format_string_list (fmt : Format.formatter) (uids : string list) : unit = let sanitize_quotes = Re.compile (Re.char '"') in @@ -319,36 +318,20 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : args = [arg1]; } -> Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1 + | EAppOp { op = HandleExceptions, _ as op; args = [EArray el, _] as args } -> + Format.fprintf fmt + "%a(%a, %a)@]" + format_op op + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ") + format_position) + (List.map Mark.get el) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") + (format_expression ctx)) + args | EAppOp { op; args = [arg1] } -> Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1 - | 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 - | EApp { f = EFunc x, pos; args } - when Ast.FuncName.compare x Ast.handle_default = 0 - || Ast.FuncName.compare x Ast.handle_default_opt = 0 -> - 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_func_name x (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; args } -> Format.fprintf fmt "%a(@[%a)@]" (format_expression ctx) f (Format.pp_print_list diff --git a/compiler/shared_ast/boundList.ml b/compiler/shared_ast/boundList.ml index faeba5de..ac08591f 100644 --- a/compiler/shared_ast/boundList.ml +++ b/compiler/shared_ast/boundList.ml @@ -20,6 +20,13 @@ type ('e, 'elt, 'last) t = ('e, 'elt, 'last) bound_list = | Last of 'last | Cons of 'elt * ('e, ('e, 'elt, 'last) t) binder +let rec to_seq = function + | Last () -> Seq.empty + | Cons (item, next_bind) -> + fun () -> + let v, next = Bindlib.unbind next_bind in + Seq.Cons ((v, item), to_seq next) + let rec last = function | Last e -> e | Cons (_, bnd) -> diff --git a/compiler/shared_ast/boundList.mli b/compiler/shared_ast/boundList.mli index 33089802..2bd1c524 100644 --- a/compiler/shared_ast/boundList.mli +++ b/compiler/shared_ast/boundList.mli @@ -30,6 +30,7 @@ type ('e, 'elt, 'last) t = ('e, 'elt, 'last) bound_list = | Last of 'last | Cons of 'elt * ('e, ('e, 'elt, 'last) t) binder +val to_seq : (((_, _) gexpr as 'e), 'elt, unit) t -> ('e Var.t * 'elt) Seq.t val last : (_, _, 'a) t -> 'a val iter : f:('e Var.t -> 'elt -> unit) -> ('e, 'elt, 'last) t -> 'last val find : f:('elt -> 'a option) -> (_, 'elt, _) t -> 'a diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 278b7d5c..83c00386 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -138,7 +138,6 @@ type desugared = ; explicitScopes : yes ; assertions : no ; defaultTerms : yes - ; exceptions : no ; custom : no > (* Technically, desugared before name resolution has [syntacticNames: yes; resolvedNames: no], and after name resolution has the opposite; but the @@ -159,7 +158,6 @@ type scopelang = ; explicitScopes : yes ; assertions : no ; defaultTerms : yes - ; exceptions : no ; custom : no > type dcalc = @@ -173,7 +171,6 @@ type dcalc = ; explicitScopes : no ; assertions : yes ; defaultTerms : yes - ; exceptions : no ; custom : no > type lcalc = @@ -187,7 +184,6 @@ type lcalc = ; explicitScopes : no ; assertions : yes ; defaultTerms : no - ; exceptions : yes ; custom : no > type 'a any = < .. > as 'a @@ -206,12 +202,11 @@ type dcalc_lcalc_features = ; assertions : yes > (** Features that are common to Dcalc and Lcalc *) -type ('a, 'b) dcalc_lcalc = - < dcalc_lcalc_features ; defaultTerms : 'a ; exceptions : 'b ; custom : no > +type 'd dcalc_lcalc = < dcalc_lcalc_features ; defaultTerms : 'd ; custom : no > (** This type regroups Dcalc and Lcalc ASTs. *) -type ('a, 'b, 'c) interpr_kind = - < dcalc_lcalc_features ; defaultTerms : 'a ; exceptions : 'b ; custom : 'c > +type ('d, 'c) interpr_kind = + < dcalc_lcalc_features ; defaultTerms : 'd ; custom : 'c > (** This type corresponds to the types handled by the interpreter: it regroups Dcalc and Lcalc ASTs and may have custom terms *) @@ -372,8 +367,7 @@ module Op = struct (* * polymorphic *) | Reduce : < polymorphic ; .. > t | Fold : < polymorphic ; .. > t - | HandleDefault : < polymorphic ; .. > t - | HandleDefaultOpt : < polymorphic ; .. > t + | HandleExceptions : < polymorphic ; .. > t end type 'a operator = 'a Op.t @@ -563,13 +557,6 @@ and ('a, 'b, 'm) base_gexpr = | EErrorOnEmpty : ('a, 'm) gexpr -> ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr - (* Lambda calculus with exceptions *) - | ERaiseEmpty : ('a, < exceptions : yes ; .. >, 'm) base_gexpr - | ECatchEmpty : { - body : ('a, 'm) gexpr; - handler : ('a, 'm) gexpr; - } - -> ('a, < exceptions : yes ; .. >, 'm) base_gexpr (* Only used during evaluation *) | ECustom : { obj : Obj.t; diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index a23abbf0..9f8a0d3f 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -145,10 +145,6 @@ let eifthenelse cond etrue efalse = let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> EErrorOnEmpty e1 let eempty mark = Mark.add mark (Bindlib.box EEmpty) -let eraiseempty mark = Mark.add mark (Bindlib.box ERaiseEmpty) - -let ecatchempty body handler = - Box.app2 body handler @@ fun body handler -> ECatchEmpty { body; handler } let ecustom obj targs tret mark = Mark.add mark (Bindlib.box (ECustom { obj; targs; tret })) @@ -333,8 +329,6 @@ let map | EPureDefault e1 -> epuredefault (f e1) m | EEmpty -> eempty m | EErrorOnEmpty e1 -> eerroronempty (f e1) m - | ECatchEmpty { body; handler } -> ecatchempty (f body) (f handler) m - | ERaiseEmpty -> eraiseempty m | ELocation loc -> elocation loc m | EStruct { name; fields } -> let fields = StructField.Map.map f fields in @@ -365,9 +359,7 @@ let shallow_fold (acc : 'acc) : 'acc = let lfold x acc = List.fold_left (fun acc x -> f x acc) acc x in match Mark.remove e with - | ELit _ | EVar _ | EFatalError _ | EExternal _ | ERaiseEmpty | ELocation _ - | EEmpty -> - acc + | ELit _ | EVar _ | EFatalError _ | EExternal _ | ELocation _ | EEmpty -> acc | EApp { f = e; args; _ } -> acc |> f e |> lfold args | EAppOp { args; _ } -> acc |> lfold args | EArray args -> acc |> lfold args @@ -382,7 +374,6 @@ let shallow_fold | EDefault { excepts; just; cons } -> acc |> lfold excepts |> f just |> f cons | EPureDefault e -> acc |> f e | EErrorOnEmpty e -> acc |> f e - | ECatchEmpty { body; handler } -> acc |> f body |> f handler | EStruct { fields; _ } -> acc |> StructField.Map.fold (fun _ -> f) fields | EDStructAmend { e; fields; _ } -> acc |> f e |> Ident.Map.fold (fun _ -> f) fields @@ -460,11 +451,6 @@ let map_gather | EErrorOnEmpty e -> let acc, e = f e in acc, eerroronempty e m - | ECatchEmpty { body; handler } -> - let acc1, body = f body in - let acc2, handler = f handler in - join acc1 acc2, ecatchempty body handler m - | ERaiseEmpty -> acc, eraiseempty m | ELocation loc -> acc, elocation loc m | EStruct { name; fields } -> let acc, fields = @@ -532,7 +518,7 @@ let untype e = map_marks ~f:(fun m -> Untyped { pos = mark_pos m }) e let is_value (type a) (e : (a, _) gexpr) = match Mark.remove e with - | ELit _ | EAbs _ | ERaiseEmpty | ECustom _ | EExternal _ -> true + | ELit _ | EAbs _ | ECustom _ | EExternal _ -> true | _ -> false let equal_lit (l1 : lit) (l2 : lit) = @@ -664,10 +650,6 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool = equal if1 if2 && equal then1 then2 && equal else1 else2 | EEmpty, EEmpty -> true | EErrorOnEmpty e1, EErrorOnEmpty e2 -> equal e1 e2 - | ERaiseEmpty, ERaiseEmpty -> true - | ( ECatchEmpty { body = etry1; handler = ewith1 }, - ECatchEmpty { body = etry2; handler = ewith2 } ) -> - equal etry1 etry2 && equal ewith1 ewith2 | ELocation l1, ELocation l2 -> equal_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2) | ( EStruct { name = s1; fields = fields1 }, @@ -700,10 +682,9 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool = Type.equal_list targs1 targs2 && Type.equal tret1 tret2 && obj1 == obj2 | ( ( EVar _ | EExternal _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _ | EAbs _ | EApp _ | EAppOp _ | EAssert _ | EFatalError _ | EDefault _ - | EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ERaiseEmpty - | ECatchEmpty _ | ELocation _ | EStruct _ | EDStructAmend _ - | EDStructAccess _ | EStructAccess _ | EInj _ | EMatch _ | EScopeCall _ - | ECustom _ ), + | EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ELocation _ + | EStruct _ | EDStructAmend _ | EDStructAccess _ | EStructAccess _ + | EInj _ | EMatch _ | EScopeCall _ | ECustom _ ), _ ) -> false @@ -796,11 +777,6 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = | EEmpty, EEmpty -> 0 | EErrorOnEmpty e1, EErrorOnEmpty e2 -> compare e1 e2 - | ERaiseEmpty, ERaiseEmpty -> 0 - | ECatchEmpty {body=etry1; handler=ewith1}, - ECatchEmpty {body=etry2; handler=ewith2} -> - compare etry1 etry2 @@< fun () -> - compare ewith1 ewith2 | ECustom _, _ | _, ECustom _ -> (* fixme: ideally this would be forbidden by typing *) invalid_arg "Custom block comparison" @@ -827,9 +803,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = | EDefault _, _ -> -1 | _, EDefault _ -> 1 | EPureDefault _, _ -> -1 | _, EPureDefault _ -> 1 | EEmpty , _ -> -1 | _, EEmpty -> 1 - | EErrorOnEmpty _, _ -> -1 | _, EErrorOnEmpty _ -> 1 - | ERaiseEmpty, _ -> -1 | _, ERaiseEmpty -> 1 - | ECatchEmpty _, _ -> . | _, ECatchEmpty _ -> . + | EErrorOnEmpty _, _ -> . | _, EErrorOnEmpty _ -> . let rec free_vars : ('a, 't) gexpr -> ('a, 't) gexpr Var.Set.t = function | EVar v, _ -> Var.Set.singleton v @@ -960,8 +934,6 @@ let rec size : type a. (a, 't) gexpr -> int = (fun acc except -> acc + size except) (1 + size just + size cons) excepts - | ERaiseEmpty -> 1 - | ECatchEmpty { body; handler } -> 1 + size body + size handler | ELocation _ -> 1 | EStruct { fields; _ } -> StructField.Map.fold (fun _ e acc -> acc + 1 + size e) fields 0 diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index 292eff31..4ebf78ab 100644 --- a/compiler/shared_ast/expr.mli +++ b/compiler/shared_ast/expr.mli @@ -117,13 +117,6 @@ val eerroronempty : 'm mark -> ((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr -val ecatchempty : - ('a, 'm) boxed_gexpr -> - ('a, 'm) boxed_gexpr -> - 'm mark -> - ((< exceptions : yes ; .. > as 'a), 'm) boxed_gexpr - -val eraiseempty : 'm mark -> (< exceptions : yes ; .. >, 'm) boxed_gexpr val elocation : 'a glocation -> 'm mark -> ((< .. > as 'a), 'm) boxed_gexpr val estruct : diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 171dce2d..88bfeb93 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -422,36 +422,7 @@ 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] -> ( + | HandleExceptions, [(EArray exps, _)] -> ( let valid_exceptions = ListLabels.filter exps ~f:(function | EInj { name; cons; _ }, _ when EnumName.equal name Expr.option_enum -> @@ -459,28 +430,9 @@ let rec evaluate_operator | _ -> err ()) in match valid_exceptions with - | [] -> ( - let e = evaluate_expr (Expr.unthunk_term_nobox justification) in - match Mark.remove e with - | ELit (LBool true) -> - Mark.remove (evaluate_expr (Expr.unthunk_term_nobox conclusion)) - | ELit (LBool false) -> - EInj - { - name = Expr.option_enum; - cons = Expr.none_constr; - e = Mark.copy justification (ELit LUnit); - } - | EInj { name; cons; e } - when EnumName.equal name Expr.option_enum - && EnumConstructor.equal cons Expr.none_constr -> - EInj - { - name = Expr.option_enum; - cons = Expr.none_constr; - e = Mark.copy e (ELit LUnit); - } - | _ -> err ()) + | [] -> + EInj + { name = Expr.option_enum; cons = Expr.none_constr; e = ELit LUnit, m } | [((EInj { cons; name; _ } as e), _)] when EnumName.equal name Expr.option_enum && EnumConstructor.equal cons Expr.some_constr -> @@ -501,23 +453,22 @@ 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 | HandleExceptions ), _ ) -> err () (* /S\ dark magic here. This relies both on internals of [Lcalc.to_ocaml] *and* of the OCaml runtime *) let rec runtime_to_val : - type d e. + type d. (decl_ctx -> - ((d, e, _) interpr_kind, 'm) gexpr -> - ((d, e, _) interpr_kind, 'm) gexpr) -> + ((d, _) interpr_kind, 'm) gexpr -> + ((d, _) interpr_kind, 'm) gexpr) -> decl_ctx -> 'm mark -> typ -> Obj.t -> - (((d, e, yes) interpr_kind as 'a), 'm) gexpr = + (((d, yes) interpr_kind as 'a), 'm) gexpr = fun eval_expr ctx m ty o -> let m = Expr.map_ty (fun _ -> ty) m in match Mark.remove ty with @@ -578,21 +529,26 @@ let rec runtime_to_val : (Array.to_list (Obj.obj o))), m ) | TArrow (targs, tret) -> ECustom { obj = o; targs; tret }, m - | TDefault ty -> runtime_to_val eval_expr ctx m ty o + | TDefault ty -> ( + (* This case is only valid for ASTs including default terms; but the typer + isn't aware so we need some additional dark arts. *) + match (Obj.obj o : 'a Runtime.Eoption.t) with + | Runtime.Eoption.ENone () -> Obj.magic EEmpty, m + | Runtime.Eoption.ESome o -> Obj.magic (runtime_to_val eval_expr ctx m ty o) + ) | TAny -> assert false and val_to_runtime : - type d e. + type d. (decl_ctx -> - ((d, e, _) interpr_kind, 'm) gexpr -> - ((d, e, _) interpr_kind, 'm) gexpr) -> + ((d, _) interpr_kind, 'm) gexpr -> + ((d, _) interpr_kind, 'm) gexpr) -> decl_ctx -> typ -> - ((d, e, _) interpr_kind, 'm) gexpr -> + ((d, _) interpr_kind, 'm) gexpr -> Obj.t = fun eval_expr ctx ty v -> match Mark.remove ty, Mark.remove v with - | _, EEmpty -> raise Runtime.Empty | TLit TBool, ELit (LBool b) -> Obj.repr b | TLit TUnit, ELit LUnit -> Obj.repr () | TLit TInt, ELit (LInt i) -> Obj.repr i @@ -659,7 +615,11 @@ and val_to_runtime : curry (runtime_to_val eval_expr ctx m targ x :: acc) targs) in curry [] targs - | TDefault ty, _ -> val_to_runtime eval_expr ctx ty v + | TDefault ty, _ -> ( + match v with + | EEmpty, _ -> Obj.repr (Runtime.Eoption.ENone ()) + | EPureDefault e, _ | e -> + Obj.repr (Runtime.Eoption.ESome (val_to_runtime eval_expr ctx ty e))) | TClosureEnv, v -> (* By construction, a closure environment can only be consumed from the same scope where it was built (compiled or not) ; for this reason, we can @@ -671,11 +631,11 @@ and val_to_runtime : Expr.format v let rec evaluate_expr : - type d e. + type d. decl_ctx -> Global.backend_lang -> - ((d, e, yes) interpr_kind, 't) gexpr -> - ((d, e, yes) interpr_kind, 't) gexpr = + ((d, yes) interpr_kind, 't) gexpr -> + ((d, yes) interpr_kind, 't) gexpr = fun ctx lang e -> let m = Mark.get e in let pos = Expr.mark_pos m in @@ -875,18 +835,14 @@ let rec evaluate_expr : in raise Runtime.(Error (Conflict, poslist))) | EPureDefault e -> evaluate_expr ctx lang e - | ERaiseEmpty -> raise Runtime.Empty - | ECatchEmpty { body; handler } -> ( - try evaluate_expr ctx lang body - with Runtime.Empty -> evaluate_expr ctx lang handler) | _ -> . and partially_evaluate_expr_for_assertion_failure_message : - type d e. + type d. decl_ctx -> Global.backend_lang -> - ((d, e, yes) interpr_kind, 't) gexpr -> - ((d, e, yes) interpr_kind, 't) gexpr = + ((d, yes) interpr_kind, 't) gexpr -> + ((d, yes) interpr_kind, 't) gexpr = fun ctx lang e -> (* Here we want to print an expression that explains why an assertion has failed. Since assertions have type [bool] and are usually constructed with @@ -921,11 +877,11 @@ and partially_evaluate_expr_for_assertion_failure_message : | _ -> evaluate_expr ctx lang e let evaluate_expr_trace : - type d e. + type d. decl_ctx -> Global.backend_lang -> - ((d, e, yes) interpr_kind, 't) gexpr -> - ((d, e, yes) interpr_kind, 't) gexpr = + ((d, yes) interpr_kind, 't) gexpr -> + ((d, yes) interpr_kind, 't) gexpr = fun ctx lang e -> Fun.protect (fun () -> evaluate_expr ctx lang e) @@ -937,11 +893,11 @@ let evaluate_expr_trace : (Runtime.EventParser.parse_raw_events trace)] fais here, check why *)) let evaluate_expr_safe : - type d e. + type d. decl_ctx -> Global.backend_lang -> - ((d, e, yes) interpr_kind, 't) gexpr -> - ((d, e, yes) interpr_kind, 't) gexpr = + ((d, yes) interpr_kind, 't) gexpr -> + ((d, yes) interpr_kind, 't) gexpr = fun ctx lang e -> try evaluate_expr_trace ctx lang e with Runtime.Error (err, rpos) -> @@ -953,9 +909,9 @@ let evaluate_expr_safe : (* Typing shenanigan to add custom terms to the AST type. *) let addcustom e = let rec f : - type c d e. - ((d, e, c) interpr_kind, 't) gexpr -> - ((d, e, yes) interpr_kind, 't) gexpr boxed = function + type c d. + ((d, c) interpr_kind, 't) gexpr -> ((d, yes) interpr_kind, 't) gexpr boxed + = function | (ECustom _, _) as e -> Expr.map ~f e | EAppOp { op; tys; args }, m -> Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) m @@ -963,8 +919,6 @@ let addcustom e = | (EPureDefault _, _) as e -> Expr.map ~f e | (EEmpty, _) as e -> Expr.map ~f e | (EErrorOnEmpty _, _) as e -> Expr.map ~f e - | (ECatchEmpty _, _) as e -> Expr.map ~f e - | (ERaiseEmpty, _) as e -> Expr.map ~f e | ( ( EAssert _ | EFatalError _ | ELit _ | EApp _ | EArray _ | EVar _ | EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EStruct _ | EStructAccess _ | EMatch _ ), @@ -974,8 +928,8 @@ let addcustom e = in let open struct external id : - (('d, 'e, 'c) interpr_kind, 't) gexpr -> - (('d, 'e, yes) interpr_kind, 't) gexpr = "%identity" + (('d, 'c) interpr_kind, 't) gexpr -> (('d, yes) interpr_kind, 't) gexpr + = "%identity" end in if false then Expr.unbox (f e) (* We keep the implementation as a typing proof, but bypass the AST @@ -985,9 +939,9 @@ let addcustom e = let delcustom e = let rec f : - type c d e. - ((d, e, c) interpr_kind, 't) gexpr -> - ((d, e, no) interpr_kind, 't) gexpr boxed = function + type c d. + ((d, c) interpr_kind, 't) gexpr -> ((d, no) interpr_kind, 't) gexpr boxed + = function | ECustom _, _ -> invalid_arg "Custom term remaining in evaluated term" | EAppOp { op; args; tys }, m -> Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) m @@ -995,8 +949,6 @@ let delcustom e = | (EPureDefault _, _) as e -> Expr.map ~f e | (EEmpty, _) as e -> Expr.map ~f e | (EErrorOnEmpty _, _) as e -> Expr.map ~f e - | (ECatchEmpty _, _) as e -> Expr.map ~f e - | (ERaiseEmpty, _) as e -> Expr.map ~f e | ( ( EAssert _ | EFatalError _ | ELit _ | EApp _ | EArray _ | EVar _ | EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EStruct _ | EStructAccess _ | EMatch _ ), @@ -1027,22 +979,13 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list (fun ty -> match Mark.remove ty with | TArrow (ty_in, (TOption _, _)) -> - (* Context args may return an option if avoid_exceptions is on *) + (* Context args should return an option *) Expr.make_abs (Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in) (Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr ~name:Expr.option_enum mark_e : (_, _) boxed_gexpr) ty_in pos - | TArrow (ty_in, ty_out) -> - (* Or a default term (translated into a plain one if it is off) *) - (* Note: this might catch non-context args, but since the - compilation to lcalc strips the default around [ty_out] we can't - tell with just this info. *) - Expr.make_abs - (Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in) - (Expr.eraiseempty (Expr.with_ty mark_e ty_out)) - ty_in (Expr.mark_pos mark_e) | TTuple ((TArrow (ty_in, (TOption _, _)), _) :: _) -> (* ... or a closure if closure conversion is enabled *) Expr.make_tuple diff --git a/compiler/shared_ast/interpreter.mli b/compiler/shared_ast/interpreter.mli index f89c494e..cff47197 100644 --- a/compiler/shared_ast/interpreter.mli +++ b/compiler/shared_ast/interpreter.mli @@ -21,7 +21,7 @@ open Catala_utils open Definitions val evaluate_operator : - ((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) -> + ((((_, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) -> 'a operator Mark.pos -> 'm mark -> Global.backend_lang -> @@ -35,14 +35,14 @@ val evaluate_operator : val evaluate_expr : decl_ctx -> Global.backend_lang -> - (('a, 'b, _) interpr_kind, 'm) gexpr -> - (('a, 'b, yes) interpr_kind, 'm) gexpr + (('a, _) interpr_kind, 'm) gexpr -> + (('a, yes) interpr_kind, 'm) gexpr (** Evaluates an expression according to the semantics of the default calculus. *) val interpret_program_dcalc : (dcalc, 'm) gexpr program -> ScopeName.t -> - (Uid.MarkedString.info * ((yes, no, yes) interpr_kind, 'm) gexpr) list + (Uid.MarkedString.info * ((yes, yes) interpr_kind, 'm) gexpr) list (** Interprets a program. This function expects an expression typed as a function whose argument are all thunked. The function is executed by providing for each argument a thunked empty default. Returns a list of all @@ -51,14 +51,14 @@ val interpret_program_dcalc : val interpret_program_lcalc : (lcalc, 'm) gexpr program -> ScopeName.t -> - (Uid.MarkedString.info * ((no, yes, yes) interpr_kind, 'm) gexpr) list + (Uid.MarkedString.info * ((no, yes) interpr_kind, 'm) gexpr) list (** Interprets a program. This function expects an expression typed as a function whose argument are all thunked. The function is executed by providing for each argument a thunked empty default. Returns a list of all the computed values for the scope variables of the executed scope. *) val delcustom : - (('a, 'b, 'c) interpr_kind, 'm) gexpr -> (('a, 'b, no) interpr_kind, 'm) gexpr + (('a, 'b) interpr_kind, 'm) gexpr -> (('a, no) interpr_kind, 'm) gexpr (** Runtime check that the term contains no custom terms (raises [Invalid_argument] if that is the case *) diff --git a/compiler/shared_ast/operator.ml b/compiler/shared_ast/operator.ml index 79970768..d7bbb8e4 100644 --- a/compiler/shared_ast/operator.ml +++ b/compiler/shared_ast/operator.ml @@ -108,8 +108,7 @@ 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" + | HandleExceptions -> "handle_exceptions" | ToClosureEnv -> "o_toclosureenv" | FromClosureEnv -> "o_fromclosureenv" @@ -232,8 +231,7 @@ 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 + | HandleExceptions, HandleExceptions | FromClosureEnv, FromClosureEnv | ToClosureEnv, ToClosureEnv -> 0 | Not, _ -> -1 | _, Not -> 1 | Length, _ -> -1 | _, Length -> 1 @@ -318,8 +316,7 @@ 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 + | HandleExceptions, _ -> -1 | _, HandleExceptions -> 1 | FromClosureEnv, _ -> -1 | _, FromClosureEnv -> 1 | ToClosureEnv, _ -> -1 | _, ToClosureEnv -> 1 | Fold, _ | _, Fold -> . @@ -344,7 +341,7 @@ let kind_dispatch : _ ) as op -> monomorphic op | ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold - | HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ), + | HandleExceptions | 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 | HandleExceptions | 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/optimizations.ml b/compiler/shared_ast/optimizations.ml index c77a985c..3ad6f126 100644 --- a/compiler/shared_ast/optimizations.ml +++ b/compiler/shared_ast/optimizations.ml @@ -58,14 +58,14 @@ let all_match_cases_map_to_same_constructor cases n = let binder_vars_used_at_most_once (binder : - ( (('a, 'b) dcalc_lcalc, ('a, 'b) dcalc_lcalc, 'm) base_gexpr, - (('a, 'b) dcalc_lcalc, 'm) gexpr ) + ( ('a dcalc_lcalc, 'a dcalc_lcalc, 'm) base_gexpr, + ('a dcalc_lcalc, 'm) gexpr ) Bindlib.mbinder) : bool = (* fast path: variables not used at all *) (not (Array.exists Fun.id (Bindlib.mbinder_occurs binder))) || let vars, body = Bindlib.unmbind binder in - let rec vars_count (e : (('a, 'b) dcalc_lcalc, 'm) gexpr) : int array = + let rec vars_count (e : ('a dcalc_lcalc, 'm) gexpr) : int array = match e with | EVar v, _ -> Array.map @@ -82,8 +82,8 @@ let binder_vars_used_at_most_once let rec optimize_expr : type a b. (a, b, 'm) optimizations_ctx -> - ((a, b) dcalc_lcalc, 'm) gexpr -> - ((a, b) dcalc_lcalc, 'm) boxed_gexpr = + (a dcalc_lcalc, 'm) gexpr -> + (a dcalc_lcalc, 'm) boxed_gexpr = fun ctx e -> (* We proceed bottom-up, first apply on the subterms *) let e = Expr.map ~f:(optimize_expr ctx) ~op:Fun.id e in @@ -92,7 +92,7 @@ let rec optimize_expr : able to keep the inner position (see the division_by_zero test) *) (* Then reduce the parent node (this is applied through Box.apply, therefore delayed to unbinding time: no need to be concerned about reboxing) *) - let reduce (e : ((a, b) dcalc_lcalc, 'm) gexpr) = + let reduce (e : (a dcalc_lcalc, 'm) gexpr) = (* Todo: improve the handling of eapp(log,elit) cases here, it obfuscates the matches and the log calls are not preserved, which would be a good property *) @@ -365,22 +365,15 @@ let rec optimize_expr : el) -> (* identity tuple reconstruction *) Mark.remove e - | ECatchEmpty { body; handler } -> ( - (* peephole exception catching reductions *) - match Mark.remove body, Mark.remove handler with - | ERaiseEmpty, _ -> Mark.remove handler - | _, ERaiseEmpty -> Mark.remove body - | _ -> ECatchEmpty { body; handler }) | e -> e in Expr.Box.app1 e reduce mark let optimize_expr : 'm. - decl_ctx -> - (('a, 'b) dcalc_lcalc, 'm) gexpr -> - (('a, 'b) dcalc_lcalc, 'm) boxed_gexpr = - fun (decl_ctx : decl_ctx) (e : (('a, 'b) dcalc_lcalc, 'm) gexpr) -> + decl_ctx -> ('a dcalc_lcalc, 'm) gexpr -> ('a dcalc_lcalc, 'm) boxed_gexpr + = + fun (decl_ctx : decl_ctx) (e : ('a dcalc_lcalc, 'm) gexpr) -> optimize_expr { decl_ctx } e let optimize_program (p : 'm program) : 'm program = diff --git a/compiler/shared_ast/optimizations.mli b/compiler/shared_ast/optimizations.mli index ea413388..b8f50357 100644 --- a/compiler/shared_ast/optimizations.mli +++ b/compiler/shared_ast/optimizations.mli @@ -21,13 +21,10 @@ open Definitions val optimize_expr : - decl_ctx -> - (('a, 'b) dcalc_lcalc, 'm) gexpr -> - (('a, 'b) dcalc_lcalc, 'm) boxed_gexpr + decl_ctx -> ('a dcalc_lcalc, 'm) gexpr -> ('a dcalc_lcalc, 'm) boxed_gexpr val optimize_program : - (('a, 'b) dcalc_lcalc, 'm) gexpr program -> - (('a, 'b) dcalc_lcalc, 'm) gexpr program + ('a dcalc_lcalc, 'm) gexpr program -> ('a dcalc_lcalc, 'm) gexpr program (** {1 Tests}*) diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index 3d82ff1c..e894aa7d 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -142,7 +142,7 @@ let rec typ_gen mty)) def punctuation "]") | TOption t -> - Format.fprintf fmt "@[%a@ %a@]" base_type "eoption" (typ ~colors) t + Format.fprintf fmt "@[%a@ %a@]" base_type "option" (typ ~colors) t | TArrow ([t1], t2) -> Format.fprintf fmt "@[%a@ %a@ %a@]" (typ_with_parens ~colors) t1 op_style "→" (typ ~colors) t2 @@ -280,8 +280,7 @@ 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" + | HandleExceptions -> "handle_exceptions" | ToClosureEnv -> "to_closure_env" | FromClosureEnv -> "from_closure_env" @@ -325,8 +324,7 @@ 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" + | HandleExceptions -> "handle_exceptions" | 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 -> + | HandleExceptions | Map | Map2 | Concat | Filter | Reduce | Fold + | ToClosureEnv | FromClosureEnv -> App) | EApp _ -> App | EArray _ -> Contained @@ -426,8 +424,6 @@ module Precedence = struct | EPureDefault _ -> Contained | EEmpty -> Contained | EErrorOnEmpty _ -> App - | ERaiseEmpty -> App - | ECatchEmpty _ -> App | ECustom _ -> Contained let needs_parens ~context ?(rhs = false) e = @@ -671,12 +667,6 @@ module ExprGen (C : EXPR_PARAM) = struct | EFatalError err -> Format.fprintf fmt "@[%a@ @{%s@}@]" keyword "error" (Runtime.error_to_string err) - | ECatchEmpty { body; handler } -> - Format.fprintf fmt - "@[@[%a@ %a@]@ @[%a@ %a ->@ %a@]@]" keyword "try" - expr body keyword "with" op_style "Empty" (rhs exprc) handler - | ERaiseEmpty -> - Format.fprintf fmt "@[%a@ %a@]" keyword "raise" op_style "Empty" | ELocation loc -> location fmt loc | EDStructAccess { e; field; _ } -> Format.fprintf fmt "@[%a%a@,%a%a%a@]" (lhs exprc) e punctuation @@ -712,7 +702,6 @@ module ExprGen (C : EXPR_PARAM) = struct Format.fprintf fmt "@[@[%a@ %a@;<1 -2>%a@]@ %a@]" keyword "match" (lhs exprc) e keyword "with" (EnumConstructor.Map.format_bindings - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt pp_cons_name case_expr -> match case_expr with | EAbs { binder; tys; _ }, _ -> @@ -868,13 +857,12 @@ let enum fmt (pp_name : Format.formatter -> unit) (c : typ EnumConstructor.Map.t) = - Format.fprintf fmt "@[%a %t %a@ %a@]" keyword "type" pp_name punctuation - "=" - (EnumConstructor.Map.format_bindings - ~pp_sep:(fun _ _ -> ()) + Format.fprintf fmt "@[%a %t %a@ %a@]@," keyword "type" pp_name + punctuation "=" + (EnumConstructor.Map.format_bindings ~pp_sep:Format.pp_print_space (fun fmt pp_n ty -> - Format.fprintf fmt "@[ %a %t %a %a@]@;" punctuation "|" pp_n - keyword "of" + Format.fprintf fmt "@[%a %t %a %a@]" punctuation "|" pp_n keyword + "of" (if debug then typ_debug else typ decl_ctx) ty)) c @@ -897,14 +885,10 @@ let struct_ let decl_ctx ?(debug = false) decl_ctx (fmt : Format.formatter) (ctx : decl_ctx) : unit = let { ctx_enums; ctx_structs; _ } = ctx in - Format.fprintf fmt "%a@.%a@.@." - (EnumName.Map.format_bindings - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@.") - (enum ~debug decl_ctx)) + Format.fprintf fmt "@[%a@,%a@,@,@]" + (EnumName.Map.format_bindings (enum ~debug decl_ctx)) ctx_enums - (StructName.Map.format_bindings - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@.") - (struct_ ~debug decl_ctx)) + (StructName.Map.format_bindings (struct_ ~debug decl_ctx)) ctx_structs let scope @@ -936,11 +920,15 @@ let code_item ?(debug = false) ?name decl_ctx fmt c = "=" (expr ~debug ()) e let code_item_list ?(debug = false) decl_ctx fmt c = - BoundList.iter c ~f:(fun x item -> + Format.pp_open_vbox fmt 0; + Format.pp_print_seq + (fun fmt (x, item) -> code_item ~debug ~name:(Format.asprintf "%a" var_debug x) decl_ctx fmt item; - Format.pp_print_newline fmt ()) + Format.pp_print_cut fmt ()) + fmt (BoundList.to_seq c); + Format.pp_close_box fmt () let program ?(debug = false) fmt p = decl_ctx ~debug p.decl_ctx fmt p.decl_ctx; @@ -1136,8 +1124,8 @@ module UserFacing = struct | EExternal _ -> Format.pp_print_string ppf "" | EApp _ | EAppOp _ | EVar _ | EIfThenElse _ | EMatch _ | ETupleAccess _ | EStructAccess _ | EAssert _ | EFatalError _ | EDefault _ | EPureDefault _ - | EErrorOnEmpty _ | ERaiseEmpty | ECatchEmpty _ | ELocation _ | EScopeCall _ - | EDStructAmend _ | EDStructAccess _ | ECustom _ -> + | EErrorOnEmpty _ | ELocation _ | EScopeCall _ | EDStructAmend _ + | EDStructAccess _ | ECustom _ -> fallback ppf e let expr : diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 302974db..ab6bf8d6 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -294,7 +294,6 @@ let polymorphic_op_type (op : Operator.polymorphic A.operator Mark.pos) : let any2 = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in let any3 = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in let bt = lazy (UnionFind.make (TLit TBool, pos)) in - let ut = lazy (UnionFind.make (TLit TUnit, pos)) in let it = lazy (UnionFind.make (TLit TInt, pos)) in let cet = lazy (UnionFind.make (TClosureEnv, pos)) in let array a = lazy (UnionFind.make (TArray (Lazy.force a), pos)) in @@ -314,9 +313,7 @@ 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 + | HandleExceptions -> [array (option any)] @-> option any | ToClosureEnv -> [any] @-> cet | FromClosureEnv -> [cet] @-> any in @@ -348,7 +345,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 + | HandleExceptions, [_] -> any () | ToClosureEnv, _ -> uf TClosureEnv | FromClosureEnv, _ -> any () | _ -> Message.error ~pos "Mismatched operator arguments" @@ -760,11 +757,6 @@ and typecheck_expr_top_down : args in Expr.escopecall ~scope ~args:args' mark - | A.ERaiseEmpty -> Expr.eraiseempty context_mark - | A.ECatchEmpty { body; handler } -> - let body' = typecheck_expr_top_down ctx env tau body in - let handler' = typecheck_expr_top_down ctx env tau handler in - Expr.ecatchempty body' handler' context_mark | A.EVar v -> let tau' = match Env.get env v with @@ -895,15 +887,17 @@ and typecheck_expr_top_down : let args = Operator.kind_dispatch (Mark.set pos_e op) ~polymorphic:(fun op -> - (* Type the operator first, then right-to-left: polymorphic operators - are required to allow the resolution of all type variables this - way *) - if not env.flags.assume_op_types then - unify ctx e (polymorphic_op_type op) t_func - else unify ctx e (polymorphic_op_return_type ctx e op t_args) tau; - List.rev_map2 - (typecheck_expr_top_down ctx env) - (List.rev t_args) (List.rev args)) + if env.flags.assume_op_types then ( + unify ctx e (polymorphic_op_return_type ctx e op t_args) tau; + List.rev_map (typecheck_expr_bottom_up ctx env) (List.rev args)) + else ( + (* Type the operator first, then right-to-left: polymorphic + operators are required to allow the resolution of all type + variables this way *) + unify ctx e (polymorphic_op_type op) t_func; + List.rev_map2 + (typecheck_expr_top_down ctx env) + (List.rev t_args) (List.rev args))) ~overloaded:(fun op -> (* Typing the arguments first is required to resolve the operator *) let args' = List.map2 (typecheck_expr_top_down ctx env) t_args args in diff --git a/runtimes/ocaml/runtime.ml b/runtimes/ocaml/runtime.ml index 6721a850..011d5c04 100644 --- a/runtimes/ocaml/runtime.ml +++ b/runtimes/ocaml/runtime.ml @@ -716,32 +716,9 @@ 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 +let handle_exceptions (pos : source_position array) - (exceptions : 'a Eoption.t array) - (just : unit -> bool) - (cons : unit -> 'a Eoption.t) : 'a Eoption.t = + (exceptions : 'a Eoption.t array) : 'a Eoption.t = let len = Array.length exceptions in let rec filt_except i = if i < len then @@ -751,7 +728,7 @@ let handle_default_opt else [] in match filt_except 0 with - | [] -> if just () then cons () else Eoption.ENone () + | [] -> Eoption.ENone () | [(res, _)] -> res | res -> error Conflict (List.map (fun (_, i) -> pos.(i)) res) diff --git a/runtimes/ocaml/runtime.mli b/runtimes/ocaml/runtime.mli index 2fe2965a..6301db54 100644 --- a/runtimes/ocaml/runtime.mli +++ b/runtimes/ocaml/runtime.mli @@ -335,21 +335,8 @@ 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 -> - (unit -> bool) -> - (unit -> 'a Eoption.t) -> - 'a Eoption.t +val handle_exceptions : + source_position array -> 'a Eoption.t array -> 'a Eoption.t (** @raise Error Conflict *) (**{1 Operators} *) diff --git a/runtimes/python/src/catala/runtime.py b/runtimes/python/src/catala/runtime.py index 20a9a3f5..61d1fabf 100644 --- a/runtimes/python/src/catala/runtime.py +++ b/runtimes/python/src/catala/runtime.py @@ -383,9 +383,9 @@ class NoValue(CatalaError): source_position) class Conflict(CatalaError): - def __init__(self, source_position: SourcePosition) -> None: - super().__init__("two or more concurring valid computations", - source_position) + def __init__(self, pos1: SourcePosition, pos2: SourcePosition) -> None: + super().__init__("two or more concurring valid computations:\nAt {}".format(pos2), + pos1) class DivisionByZero(CatalaError): def __init__(self, source_position: SourcePosition) -> None: @@ -606,56 +606,20 @@ 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: +def handle_exceptions( + pos: List[SourcePosition], + exceptions: List[Optional[Alpha]]) -> Optional[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: + acc_pos: Optional[pos] = None + for exception, pos in zip(exceptions, pos): + if exception 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]], - just: Callable[[Unit], bool], - cons: Callable[[Unit], Optional[Alpha]] -) -> Optional[Alpha]: - acc: Optional[Alpha] = None - for exception in exceptions: - if acc is None: + elif acc is None: acc = exception - elif not (acc is None) and exception is None: - pass # acc stays the same - elif not (acc is None) and not (exception is None): - raise Conflict(pos) - if acc is None: - b = just(Unit()) - if b: - return cons(Unit()) + acc_pos = pos else: - return None - else: - return acc + raise Conflict(acc_pos,pos) + return acc def no_input() -> Callable[[Unit], Alpha]: 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 diff --git a/tests/backends/output/simple.c b/tests/backends/output/simple.c index d68a1113..a90cc655 100644 --- a/tests/backends/output/simple.c +++ b/tests/backends/output/simple.c @@ -86,114 +86,116 @@ typedef struct array_1_struct { int length_field; } array_1_struct; -typedef struct tuple_0_struct { +typedef struct tuple_1_struct { option_1_enum (*elt_0_field)(void * /* closure_env */ arg_0_typ, void* /* unit */ arg_1_typ); void * /* closure_env */ elt_1_field; -} tuple_0_struct; +} tuple_1_struct; typedef struct baz_in_struct { - tuple_0_struct a_in_field; + tuple_1_struct a_in_field; } baz_in_struct; baz_struct baz_func(baz_in_struct baz_in) { - tuple_0_struct a; + tuple_1_struct a; a = baz_in.a_in_field; bar_enum temp_a; option_1_enum temp_a_1; - tuple_0_struct code_and_env; + tuple_1_struct code_and_env; code_and_env = a; option_1_enum (*code)(void * /* closure_env */ arg_0_typ, void* /* unit */ arg_1_typ); void * /* closure_env */ env; code = code_and_env.elt_0_field; env = code_and_env.elt_1_field; - option_1_enum exception_acc = {option_1_enum_none_1_cons, - {none_1_cons: NULL}}; - option_1_enum exception_current; - char exception_conflict = 0; - exception_current = code(env, NULL); - if (exception_current.code == option_1_enum_some_1_cons) { - if (exception_acc.code == option_1_enum_some_1_cons) { - exception_conflict = 1; - } else { - exception_acc = exception_current; - } - } - if (exception_conflict) { - catala_raise_fatal_error(catala_conflict, - "tests/backends/simple.catala_en", 11, 11, 11, 12); - } - if (exception_acc.code == option_1_enum_some_1_cons) { - temp_a_1 = exception_acc; - } else { - if (1 /* TRUE */) { - bar_enum temp_a_2; - option_1_enum temp_a_3; - option_1_enum temp_a_4; + array_1_struct temp_a_2; + temp_a_2.content_field = catala_malloc(sizeof(array_1_struct)); + temp_a_2.content_field[0] = code(env, NULL); + option_1_enum match_arg = catala_handle_exceptions(temp_a_2); + switch (match_arg.code) { + case option_1_enum_none_1_cons: if (1 /* TRUE */) { - bar_enum temp_a_5 = {bar_enum_no_cons, {no_cons: NULL}}; - option_1_enum temp_a_6 = {option_1_enum_some_1_cons, - {some_1_cons: temp_a_5}}; - temp_a_4 = temp_a_6; - } else { - temp_a_4.code = option_1_enum_none_1_cons; - temp_a_4.payload.none_1_cons = NULL; - } - option_1_enum exception_acc_1 = {option_1_enum_none_1_cons, - {none_1_cons: NULL}}; - option_1_enum exception_current_1; - char exception_conflict_1 = 0; - exception_current_1 = temp_a_4; - if (exception_current_1.code == option_1_enum_some_1_cons) { - if (exception_acc_1.code == option_1_enum_some_1_cons) { - exception_conflict_1 = 1; - } else { - exception_acc_1 = exception_current_1; + bar_enum temp_a_3; + option_1_enum temp_a_4; + option_1_enum temp_a_5; + array_1_struct temp_a_6; + temp_a_6.content_field = catala_malloc(sizeof(array_1_struct)); + + option_1_enum match_arg_1 = catala_handle_exceptions(temp_a_6); + switch (match_arg_1.code) { + case option_1_enum_none_1_cons: + if (1 /* TRUE */) { + bar_enum temp_a_7 = {bar_enum_no_cons, {no_cons: NULL}}; + option_1_enum temp_a_5 = {option_1_enum_some_1_cons, + {some_1_cons: temp_a_7}}; + + } else { + option_1_enum temp_a_5 = {option_1_enum_none_1_cons, + {none_1_cons: NULL}}; + + } + break; + case option_1_enum_some_1_cons: + bar_enum x = match_arg_1.payload.some_1_cons; + option_1_enum temp_a_5 = {option_1_enum_some_1_cons, + {some_1_cons: x}}; + break; } - } - if (exception_conflict_1) { - catala_raise_fatal_error(catala_conflict, - "tests/backends/simple.catala_en", 11, 11, 11, 12); - } - if (exception_acc_1.code == option_1_enum_some_1_cons) { - temp_a_3 = exception_acc_1; - } else { - if (0 /* FALSE */) { - option_1_enum temp_a_7 = {option_1_enum_none_1_cons, - {none_1_cons: NULL}}; - temp_a_3 = temp_a_7; - } else { - temp_a_3.code = option_1_enum_none_1_cons; - temp_a_3.payload.none_1_cons = NULL; + array_1_struct temp_a_8; + temp_a_8.content_field = catala_malloc(sizeof(array_1_struct)); + temp_a_8.content_field[0] = temp_a_5; + option_1_enum match_arg_2 = catala_handle_exceptions(temp_a_8); + switch (match_arg_2.code) { + case option_1_enum_none_1_cons: + if (0 /* FALSE */) { + option_1_enum temp_a_4 = {option_1_enum_none_1_cons, + {none_1_cons: NULL}}; + + } else { + option_1_enum temp_a_4 = {option_1_enum_none_1_cons, + {none_1_cons: NULL}}; + + } + break; + case option_1_enum_some_1_cons: + bar_enum x_1 = match_arg_2.payload.some_1_cons; + option_1_enum temp_a_4 = {option_1_enum_some_1_cons, + {some_1_cons: x_1}}; + break; } + option_1_enum match_arg_3 = temp_a_4; + switch (match_arg_3.code) { + case option_1_enum_none_1_cons: + catala_raise_fatal_error (catala_no_value, + "tests/backends/simple.catala_en", 11, 11, 11, 12); + break; + case option_1_enum_some_1_cons: + bar_enum arg = match_arg_3.payload.some_1_cons; + temp_a_3 = arg; + break; + } + option_1_enum temp_a_1 = {option_1_enum_some_1_cons, + {some_1_cons: temp_a_3}}; + + } else { + option_1_enum temp_a_1 = {option_1_enum_none_1_cons, + {none_1_cons: NULL}}; + } - option_1_enum match_arg = temp_a_3; - switch (match_arg.code) { - case option_1_enum_none_1_cons: - catala_raise_fatal_error (catala_no_value, - "tests/backends/simple.catala_en", 11, 11, 11, 12); - break; - case option_1_enum_some_1_cons: - bar_enum arg = match_arg.payload.some_1_cons; - temp_a_2 = arg; - break; - } - option_1_enum temp_a_8 = {option_1_enum_some_1_cons, - {some_1_cons: temp_a_2}}; - temp_a_1 = temp_a_8; - } else { - temp_a_1.code = option_1_enum_none_1_cons; - temp_a_1.payload.none_1_cons = NULL; - } + break; + case option_1_enum_some_1_cons: + bar_enum x_2 = match_arg.payload.some_1_cons; + option_1_enum temp_a_1 = {option_1_enum_some_1_cons, + {some_1_cons: x_2}}; + break; } - option_1_enum match_arg_1 = temp_a_1; - switch (match_arg_1.code) { + option_1_enum match_arg_4 = temp_a_1; + switch (match_arg_4.code) { case option_1_enum_none_1_cons: catala_raise_fatal_error (catala_no_value, "tests/backends/simple.catala_en", 11, 11, 11, 12); break; case option_1_enum_some_1_cons: - bar_enum arg_1 = match_arg_1.payload.some_1_cons; + bar_enum arg_1 = match_arg_4.payload.some_1_cons; temp_a = arg_1; break; } @@ -203,133 +205,143 @@ baz_struct baz_func(baz_in_struct baz_in) { option_2_enum temp_b_1; option_2_enum temp_b_2; option_2_enum temp_b_3; - char /* bool */ temp_b_4; - bar_enum match_arg_2 = a_1; - switch (match_arg_2.code) { - case bar_enum_no_cons: temp_b_4 = 1 /* TRUE */; break; - case bar_enum_yes_cons: - foo_struct dummy_var = match_arg_2.payload.yes_cons; - temp_b_4 = 0 /* FALSE */; + array_2_struct temp_b_4; + temp_b_4.content_field = catala_malloc(sizeof(array_2_struct)); + + option_2_enum match_arg_5 = catala_handle_exceptions(temp_b_4); + switch (match_arg_5.code) { + case option_2_enum_none_2_cons: + char /* bool */ temp_b_5; + bar_enum match_arg_6 = a_1; + switch (match_arg_6.code) { + case bar_enum_no_cons: temp_b_5 = 1 /* TRUE */; break; + case bar_enum_yes_cons: + foo_struct dummy_var = match_arg_6.payload.yes_cons; + temp_b_5 = 0 /* FALSE */; + break; + } + if (temp_b_5) { + option_2_enum temp_b_3 = {option_2_enum_some_2_cons, + {some_2_cons: 42.}}; + + } else { + option_2_enum temp_b_3 = {option_2_enum_none_2_cons, + {none_2_cons: NULL}}; + + } + break; + case option_2_enum_some_2_cons: + double x_3 = match_arg_5.payload.some_2_cons; + option_2_enum temp_b_3 = {option_2_enum_some_2_cons, + {some_2_cons: x_3}}; break; } - if (temp_b_4) { - option_2_enum temp_b_5 = {option_2_enum_some_2_cons, {some_2_cons: 42.}}; - temp_b_3 = temp_b_5; - } else { - temp_b_3.code = option_2_enum_none_2_cons; - temp_b_3.payload.none_2_cons = NULL; + array_2_struct temp_b_6; + temp_b_6.content_field = catala_malloc(sizeof(array_2_struct)); + temp_b_6.content_field[0] = temp_b_3; + option_2_enum match_arg_7 = catala_handle_exceptions(temp_b_6); + switch (match_arg_7.code) { + case option_2_enum_none_2_cons: + if (0 /* FALSE */) { + option_2_enum temp_b_2 = {option_2_enum_none_2_cons, + {none_2_cons: NULL}}; + + } else { + option_2_enum temp_b_2 = {option_2_enum_none_2_cons, + {none_2_cons: NULL}}; + + } + break; + case option_2_enum_some_2_cons: + double x_4 = match_arg_7.payload.some_2_cons; + option_2_enum temp_b_2 = {option_2_enum_some_2_cons, + {some_2_cons: x_4}}; + break; } - option_2_enum exception_acc_2 = {option_2_enum_none_2_cons, - {none_2_cons: NULL}}; - option_2_enum exception_current_2; - char exception_conflict_2 = 0; - exception_current_2 = temp_b_3; - if (exception_current_2.code == option_2_enum_some_2_cons) { - if (exception_acc_2.code == option_2_enum_some_2_cons) { - exception_conflict_2 = 1; - } else { - exception_acc_2 = exception_current_2; - } - } - if (exception_conflict_2) { - catala_raise_fatal_error(catala_conflict, - "tests/backends/simple.catala_en", 12, 10, 12, 11); - } - if (exception_acc_2.code == option_2_enum_some_2_cons) { - temp_b_2 = exception_acc_2; - } else { - if (0 /* FALSE */) { - option_2_enum temp_b_6 = {option_2_enum_none_2_cons, - {none_2_cons: NULL}}; - temp_b_2 = temp_b_6; - } else { - temp_b_2.code = option_2_enum_none_2_cons; - temp_b_2.payload.none_2_cons = NULL; - } - } - option_2_enum exception_acc_3 = {option_2_enum_none_2_cons, - {none_2_cons: NULL}}; - option_2_enum exception_current_3; - char exception_conflict_3 = 0; - exception_current_3 = temp_b_2; - if (exception_current_3.code == option_2_enum_some_2_cons) { - if (exception_acc_3.code == option_2_enum_some_2_cons) { - exception_conflict_3 = 1; - } else { - exception_acc_3 = exception_current_3; - } - } - if (exception_conflict_3) { - catala_raise_fatal_error(catala_conflict, - "tests/backends/simple.catala_en", 12, 10, 12, 11); - } - if (exception_acc_3.code == option_2_enum_some_2_cons) { - temp_b_1 = exception_acc_3; - } else { - if (1 /* TRUE */) { - option_2_enum temp_b_7; - option_2_enum temp_b_8; + array_2_struct temp_b_7; + temp_b_7.content_field = catala_malloc(sizeof(array_2_struct)); + temp_b_7.content_field[0] = temp_b_2; + option_2_enum match_arg_8 = catala_handle_exceptions(temp_b_7); + switch (match_arg_8.code) { + case option_2_enum_none_2_cons: if (1 /* TRUE */) { - double temp_b_9; - bar_enum match_arg_3 = a_1; - switch (match_arg_3.code) { - case bar_enum_no_cons: temp_b_9 = 0.; break; - case bar_enum_yes_cons: - foo_struct foo = match_arg_3.payload.yes_cons; - double temp_b_10; - if (foo.x_field) {temp_b_10 = 1.; } else {temp_b_10 = 0.; } - temp_b_9 = (foo.y_field + temp_b_10); + option_2_enum temp_b_8; + array_2_struct temp_b_9; + temp_b_9.content_field = catala_malloc(sizeof(array_2_struct)); + + option_2_enum match_arg_9 = catala_handle_exceptions(temp_b_9); + switch (match_arg_9.code) { + case option_2_enum_none_2_cons: + if (1 /* TRUE */) { + double temp_b_10; + bar_enum match_arg_10 = a_1; + switch (match_arg_10.code) { + case bar_enum_no_cons: temp_b_10 = 0.; break; + case bar_enum_yes_cons: + foo_struct foo = match_arg_10.payload.yes_cons; + double temp_b_11; + if (foo.x_field) {temp_b_11 = 1.; } else {temp_b_11 = 0.; } + temp_b_10 = (foo.y_field + temp_b_11); + break; + } + option_2_enum temp_b_8 = {option_2_enum_some_2_cons, + {some_2_cons: temp_b_10}}; + + } else { + option_2_enum temp_b_8 = {option_2_enum_none_2_cons, + {none_2_cons: NULL}}; + + } + break; + case option_2_enum_some_2_cons: + double x_5 = match_arg_9.payload.some_2_cons; + option_2_enum temp_b_8 = {option_2_enum_some_2_cons, + {some_2_cons: x_5}}; break; } - option_2_enum temp_b_11 = {option_2_enum_some_2_cons, - {some_2_cons: temp_b_9}}; - temp_b_8 = temp_b_11; - } else { - temp_b_8.code = option_2_enum_none_2_cons; - temp_b_8.payload.none_2_cons = NULL; - } - option_2_enum exception_acc_4 = {option_2_enum_none_2_cons, - {none_2_cons: NULL}}; - option_2_enum exception_current_4; - char exception_conflict_4 = 0; - exception_current_4 = temp_b_8; - if (exception_current_4.code == option_2_enum_some_2_cons) { - if (exception_acc_4.code == option_2_enum_some_2_cons) { - exception_conflict_4 = 1; - } else { - exception_acc_4 = exception_current_4; + array_2_struct temp_b_12; + temp_b_12.content_field = catala_malloc(sizeof(array_2_struct)); + temp_b_12.content_field[0] = temp_b_8; + option_2_enum match_arg_11 = catala_handle_exceptions(temp_b_12); + switch (match_arg_11.code) { + case option_2_enum_none_2_cons: + if (0 /* FALSE */) { + option_2_enum temp_b_1 = {option_2_enum_none_2_cons, + {none_2_cons: NULL}}; + + } else { + option_2_enum temp_b_1 = {option_2_enum_none_2_cons, + {none_2_cons: NULL}}; + + } + break; + case option_2_enum_some_2_cons: + double x_6 = match_arg_11.payload.some_2_cons; + option_2_enum temp_b_1 = {option_2_enum_some_2_cons, + {some_2_cons: x_6}}; + break; } - } - if (exception_conflict_4) { - catala_raise_fatal_error(catala_conflict, - "tests/backends/simple.catala_en", 12, 10, 12, 11); - } - if (exception_acc_4.code == option_2_enum_some_2_cons) { - temp_b_7 = exception_acc_4; + } else { - if (0 /* FALSE */) { - option_2_enum temp_b_12 = {option_2_enum_none_2_cons, - {none_2_cons: NULL}}; - temp_b_7 = temp_b_12; - } else { - temp_b_7.code = option_2_enum_none_2_cons; - temp_b_7.payload.none_2_cons = NULL; - } + option_2_enum temp_b_1 = {option_2_enum_none_2_cons, + {none_2_cons: NULL}}; + } - temp_b_1 = temp_b_7; - } else { - temp_b_1.code = option_2_enum_none_2_cons; - temp_b_1.payload.none_2_cons = NULL; - } + break; + case option_2_enum_some_2_cons: + double x_7 = match_arg_8.payload.some_2_cons; + option_2_enum temp_b_1 = {option_2_enum_some_2_cons, + {some_2_cons: x_7}}; + break; } - option_2_enum match_arg_4 = temp_b_1; - switch (match_arg_4.code) { + option_2_enum match_arg_12 = temp_b_1; + switch (match_arg_12.code) { case option_2_enum_none_2_cons: catala_raise_fatal_error (catala_no_value, "tests/backends/simple.catala_en", 12, 10, 12, 11); break; case option_2_enum_some_2_cons: - double arg_2 = match_arg_4.payload.some_2_cons; + double arg_2 = match_arg_12.payload.some_2_cons; temp_b = arg_2; break; } @@ -338,54 +350,62 @@ baz_struct baz_func(baz_in_struct baz_in) { array_3_struct temp_c; option_3_enum temp_c_1; option_3_enum temp_c_2; - if (1 /* TRUE */) { - array_3_struct temp_c_3; - temp_c_3.content_field = catala_malloc(sizeof(array_3_struct)); - temp_c_3.content_field[0] = b; - temp_c_3.content_field[1] = b; - option_3_enum temp_c_4 = {option_3_enum_some_3_cons, - {some_3_cons: temp_c_3}}; - temp_c_2 = temp_c_4; - } else { - temp_c_2.code = option_3_enum_none_3_cons; - temp_c_2.payload.none_3_cons = NULL; + array_4_struct temp_c_3; + temp_c_3.content_field = catala_malloc(sizeof(array_4_struct)); + + option_3_enum match_arg_13 = catala_handle_exceptions(temp_c_3); + switch (match_arg_13.code) { + case option_3_enum_none_3_cons: + if (1 /* TRUE */) { + array_3_struct temp_c_4; + temp_c_4.content_field = catala_malloc(sizeof(array_3_struct)); + temp_c_4.content_field[0] = b; + temp_c_4.content_field[1] = b; + option_3_enum temp_c_2 = {option_3_enum_some_3_cons, + {some_3_cons: temp_c_4}}; + + } else { + option_3_enum temp_c_2 = {option_3_enum_none_3_cons, + {none_3_cons: NULL}}; + + } + break; + case option_3_enum_some_3_cons: + array_3_struct x_8 = match_arg_13.payload.some_3_cons; + option_3_enum temp_c_2 = {option_3_enum_some_3_cons, + {some_3_cons: x_8}}; + break; } - option_3_enum exception_acc_5 = {option_3_enum_none_3_cons, - {none_3_cons: NULL}}; - option_3_enum exception_current_5; - char exception_conflict_5 = 0; - exception_current_5 = temp_c_2; - if (exception_current_5.code == option_3_enum_some_3_cons) { - if (exception_acc_5.code == option_3_enum_some_3_cons) { - exception_conflict_5 = 1; - } else { - exception_acc_5 = exception_current_5; - } + array_4_struct temp_c_5; + temp_c_5.content_field = catala_malloc(sizeof(array_4_struct)); + temp_c_5.content_field[0] = temp_c_2; + option_3_enum match_arg_14 = catala_handle_exceptions(temp_c_5); + switch (match_arg_14.code) { + case option_3_enum_none_3_cons: + if (0 /* FALSE */) { + option_3_enum temp_c_1 = {option_3_enum_none_3_cons, + {none_3_cons: NULL}}; + + } else { + option_3_enum temp_c_1 = {option_3_enum_none_3_cons, + {none_3_cons: NULL}}; + + } + break; + case option_3_enum_some_3_cons: + array_3_struct x_9 = match_arg_14.payload.some_3_cons; + option_3_enum temp_c_1 = {option_3_enum_some_3_cons, + {some_3_cons: x_9}}; + break; } - if (exception_conflict_5) { - catala_raise_fatal_error(catala_conflict, - "tests/backends/simple.catala_en", 13, 10, 13, 11); - } - if (exception_acc_5.code == option_3_enum_some_3_cons) { - temp_c_1 = exception_acc_5; - } else { - if (0 /* FALSE */) { - option_3_enum temp_c_5 = {option_3_enum_none_3_cons, - {none_3_cons: NULL}}; - temp_c_1 = temp_c_5; - } else { - temp_c_1.code = option_3_enum_none_3_cons; - temp_c_1.payload.none_3_cons = NULL; - } - } - option_3_enum match_arg_5 = temp_c_1; - switch (match_arg_5.code) { + option_3_enum match_arg_15 = temp_c_1; + switch (match_arg_15.code) { case option_3_enum_none_3_cons: catala_raise_fatal_error (catala_no_value, "tests/backends/simple.catala_en", 13, 10, 13, 11); break; case option_3_enum_some_3_cons: - array_3_struct arg_3 = match_arg_5.payload.some_3_cons; + array_3_struct arg_3 = match_arg_15.payload.some_3_cons; temp_c = arg_3; break; } diff --git a/tests/backends/python_name_clash.catala_en b/tests/backends/python_name_clash.catala_en index b1e23529..16311a4c 100644 --- a/tests/backends/python_name_clash.catala_en +++ b/tests/backends/python_name_clash.catala_en @@ -91,60 +91,79 @@ class BIn: def some_name(some_name_in:SomeNameIn): i = some_name_in.i_in - try: - def temp_o(_:Unit): - def temp_o_1(_:Unit): - return True - def temp_o_2(_:Unit): - return (i + integer_of_string("1")) - return handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en", + perhaps_none_arg = handle_exceptions([], []) + if perhaps_none_arg is None: + if True: + temp_o = (i + integer_of_string("1")) + else: + temp_o = None + else: + x = perhaps_none_arg + temp_o = x + perhaps_none_arg_1 = handle_exceptions( + [SourcePosition( + filename="tests/backends/python_name_clash.catala_en", start_line=10, start_column=23, - end_line=10, end_column=28, - law_headings=[]), [], temp_o_1, temp_o_2) - def temp_o_3(_:Unit): - return False - def temp_o_4(_:Unit): - raise Empty - temp_o_5 = handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en", - start_line=7, start_column=10, - end_line=7, end_column=11, - law_headings=[]), [temp_o], temp_o_3, - temp_o_4) - except Empty: + end_line=10, end_column=28, law_headings=[] + )], + [temp_o] + ) + if perhaps_none_arg_1 is None: + if False: + temp_o_1 = None + else: + temp_o_1 = None + else: + x_1 = perhaps_none_arg_1 + temp_o_1 = x_1 + perhaps_none_arg_2 = temp_o_1 + if perhaps_none_arg_2 is None: raise NoValue(SourcePosition( filename="tests/backends/python_name_clash.catala_en", start_line=7, start_column=10, end_line=7, end_column=11, law_headings=[])) - o = temp_o_5 + else: + arg = perhaps_none_arg_2 + temp_o_2 = arg + o = temp_o_2 return SomeName(o = o) def b(b_in:BIn): - try: - def temp_result(_:Unit): - def temp_result_1(_:Unit): - return True - def temp_result_2(_:Unit): - return integer_of_string("1") - return handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en", + perhaps_none_arg_3 = handle_exceptions([], []) + if perhaps_none_arg_3 is None: + if True: + temp_result = integer_of_string("1") + else: + temp_result = None + else: + x_2 = perhaps_none_arg_3 + temp_result = x_2 + perhaps_none_arg_4 = handle_exceptions( + [SourcePosition( + filename="tests/backends/python_name_clash.catala_en", start_line=16, start_column=33, - end_line=16, end_column=34, - law_headings=[]), [], temp_result_1, - temp_result_2) - def temp_result_3(_:Unit): - return False - def temp_result_4(_:Unit): - raise Empty - temp_result_5 = handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en", - start_line=16, start_column=14, - end_line=16, end_column=25, - law_headings=[]), [temp_result], - temp_result_3, temp_result_4) - except Empty: + end_line=16, end_column=34, law_headings=[] + )], + [temp_result] + ) + if perhaps_none_arg_4 is None: + if False: + temp_result_1 = None + else: + temp_result_1 = None + else: + x_3 = perhaps_none_arg_4 + temp_result_1 = x_3 + perhaps_none_arg_5 = temp_result_1 + if perhaps_none_arg_5 is None: raise NoValue(SourcePosition( filename="tests/backends/python_name_clash.catala_en", start_line=16, start_column=14, end_line=16, end_column=25, law_headings=[])) - result = some_name(SomeNameIn(i_in = temp_result_5)) + else: + arg_1 = perhaps_none_arg_5 + temp_result_2 = arg_1 + result = some_name(SomeNameIn(i_in = temp_result_2)) result_1 = SomeName(o = result.o) if True: temp_some_name = result_1 diff --git a/tests/func/good/closure_conversion.catala_en b/tests/func/good/closure_conversion.catala_en index e869a0de..7912a943 100644 --- a/tests/func/good/closure_conversion.catala_en +++ b/tests/func/good/closure_conversion.catala_en @@ -24,14 +24,16 @@ $ catala Typecheck --check-invariants ``` ```catala-test-inline -$ catala Lcalc --avoid-exceptions -O --closure-conversion -type Eoption = | ENone of unit | ESome of any +$ catala Lcalc -O --closure-conversion +type Eoption = | ENone of unit | ESome of any + type S_in = { x_in: bool; } type S = { z: integer; } let topval closure_f1 : (closure_env, integer) → integer = λ (env: closure_env) (y: integer) → if (from_closure_env env).0 then y else - y + let scope S (S_in: S_in {x_in: bool}): S {z: integer} = let get x : bool = S_in.x_in in let set f : ((closure_env, integer) → integer, closure_env) = @@ -65,7 +67,7 @@ scope S2Use: ``` ```catala-test-inline -$ catala Lcalc --avoid-exceptions -O --closure-conversion -s S2Use +$ catala Lcalc -O --closure-conversion -s S2Use let scope S2Use (S2Use_in: S2Use_in) : S2Use { diff --git a/tests/func/good/closure_conversion_reduce.catala_en b/tests/func/good/closure_conversion_reduce.catala_en index a799b424..395eaa1d 100644 --- a/tests/func/good/closure_conversion_reduce.catala_en +++ b/tests/func/good/closure_conversion_reduce.catala_en @@ -24,7 +24,7 @@ $ catala Typecheck --check-invariants ``` ```catala-test-inline -$ catala Lcalc -s S --avoid-exceptions -O --closure-conversion +$ catala Lcalc -s S -O --closure-conversion let scope S (S_in: S_in {x_in: list of integer}): S {y: integer} = let get x : list of integer = S_in.x_in in let set y : integer = @@ -38,12 +38,12 @@ let scope S (S_in: S_in {x_in: list of integer}): S {y: integer} = ``` The next test of closure conversion should give the same results, it checks that -`--avoid-exceptions` and `-O` are correctly implied by `--closure-conversion` +`-O` is correctly implied by `--closure-conversion` The detection of closures that should not be converted because they are arguments to reduce or other special operators relies on pattern matching the special operator and its EAbs argument. However without exceptions on, because the ---avoid-exceptions pass is not optimized and produces more options than needed, -the closures that are arguments to special operators are let-binded with an +lcalc translation pass is not optimized and produces more options than needed, +the closures that are arguments to special operators are let-bound with an option. This let-binding is reduced by partial evaluation, which is why the test with optimizations on passes. @@ -53,31 +53,34 @@ let scope S (S_in: S_in {x_in: list of integer}): S {y: integer} = let get x : list of integer = S_in.x_in in let set y : integer = match - (handle_default_opt - [ - handle_default_opt - [] - (λ () → true) - (λ () → - ESome - (let weights : list of (integer, integer) = - map (λ (potential_max: integer) → - (potential_max, - let potential_max1 : integer = potential_max in - potential_max1)) - x - in - reduce - (λ (x1: (integer, integer)) (x2: (integer, integer)) → - if x1.1 < x2.1 then x1 else x2) - let potential_max : integer = -1 in - (potential_max, - let potential_max1 : integer = potential_max in - potential_max1) - weights).0) - ] - (λ () → false) - (λ () → ENone ())) + (match + (handle_exceptions + [ + match (handle_exceptions []) with + | ENone → + if true then + ESome + (let weights : list of (integer, integer) = + map (λ (potential_max: integer) → + (potential_max, + let potential_max1 : integer = potential_max in + potential_max1)) + x + in + reduce + (λ (x1: (integer, integer)) (x2: (integer, integer)) → + if x1.1 < x2.1 then x1 else x2) + let potential_max : integer = -1 in + (potential_max, + let potential_max1 : integer = potential_max in + potential_max1) + weights).0 + else ENone () + | ESome x → ESome x + ]) + with + | ENone → if false then ENone () else ENone () + | ESome x → ESome x) with | ENone → error NoValue | ESome arg → arg diff --git a/tests/func/good/closure_return.catala_en b/tests/func/good/closure_return.catala_en index e3cfd85e..ec705043 100644 --- a/tests/func/good/closure_return.catala_en +++ b/tests/func/good/closure_return.catala_en @@ -22,14 +22,16 @@ $ catala Typecheck --check-invariants ``` ```catala-test-inline -$ catala Lcalc --avoid-exceptions -O --closure-conversion -type Eoption = | ENone of unit | ESome of any +$ catala Lcalc -O --closure-conversion +type Eoption = | ENone of unit | ESome of any + type S_in = { x_in: bool; } type S = { f: ((closure_env, integer) → integer, closure_env); } let topval closure_f1 : (closure_env, integer) → integer = λ (env: closure_env) (y: integer) → if (from_closure_env env).0 then y else - y + let scope S (S_in: S_in {x_in: bool}) : S {f: ((closure_env, integer) → integer, closure_env)} diff --git a/tests/func/good/closure_through_scope.catala_en b/tests/func/good/closure_through_scope.catala_en index c0a2036a..ccd4680a 100644 --- a/tests/func/good/closure_through_scope.catala_en +++ b/tests/func/good/closure_through_scope.catala_en @@ -30,7 +30,7 @@ $ catala Typecheck --check-invariants ``` ```catala-test-inline -$ catala Lcalc -s T --avoid-exceptions -O --closure-conversion +$ catala Lcalc -s T -O --closure-conversion let scope T (T_in: T_in): T {y: integer} = let set s : S {f: ((closure_env, integer) → integer, closure_env)} = { S f = (closure_s1, to_closure_env ()); } @@ -45,7 +45,7 @@ let scope T (T_in: T_in): T {y: integer} = ``` ```catala-test-inline -$ catala Interpret --lcalc -s T --avoid-exceptions -O --closure-conversion +$ catala Interpret --lcalc -s T -O --closure-conversion ┌─[RESULT]─ │ y = -2 └─ diff --git a/tests/func/good/scope_call_func_struct_closure.catala_en b/tests/func/good/scope_call_func_struct_closure.catala_en index def85b5f..640c66df 100644 --- a/tests/func/good/scope_call_func_struct_closure.catala_en +++ b/tests/func/good/scope_call_func_struct_closure.catala_en @@ -53,8 +53,9 @@ $ catala Typecheck --check-invariants ``` ```catala-test-inline -$ catala Lcalc --avoid-exceptions -O --closure-conversion -type Eoption = | ENone of unit | ESome of any +$ catala Lcalc -O --closure-conversion +type Eoption = | ENone of unit | ESome of any + type Result = { r: ((closure_env, integer) → integer, closure_env); q: integer; @@ -69,12 +70,13 @@ type SubFoo2 = { x1: integer; y: ((closure_env, integer) → integer, closure_env); } -type Foo_in = { b_in: ((closure_env, unit) → eoption bool, closure_env); } +type Foo_in = { b_in: ((closure_env, unit) → option bool, closure_env); } type Foo = { z: integer; } let topval closure_y1 : (closure_env, integer) → integer = λ (env: closure_env) (z: integer) → (from_closure_env env).0 + z + let scope SubFoo1 (SubFoo1_in: SubFoo1_in {x_in: integer}) : SubFoo1 { @@ -87,10 +89,12 @@ let scope SubFoo1 (closure_y1, to_closure_env (x)) in return { SubFoo1 x = x; y = y; } + let topval closure_y1 : (closure_env, integer) → integer = λ (env: closure_env) (z: integer) → let env1 : (integer, integer) = from_closure_env env in ((env1.1 + env1.0 + z)) + let scope SubFoo2 (SubFoo2_in: SubFoo2_in {x1_in: integer; x2_in: integer}) : SubFoo2 { @@ -104,29 +108,33 @@ let scope SubFoo2 (closure_y1, to_closure_env (x2, x1)) in return { SubFoo2 x1 = x1; y = y; } + let topval closure_r2 : (closure_env, integer) → integer = λ (env: closure_env) (param0: integer) → let code_and_env : ((closure_env, integer) → integer, closure_env) = (from_closure_env env).0.y in code_and_env.0 code_and_env.1 param0 + let topval closure_r1 : (closure_env, integer) → integer = λ (env: closure_env) (param0: integer) → let code_and_env : ((closure_env, integer) → integer, closure_env) = (from_closure_env env).0.y in code_and_env.0 code_and_env.1 param0 + let scope Foo - (Foo_in: - Foo_in {b_in: ((closure_env, unit) → eoption bool, closure_env)}) + (Foo_in: Foo_in {b_in: ((closure_env, unit) → option bool, closure_env)}) : Foo {z: integer} = - let get b : ((closure_env, unit) → eoption bool, closure_env) = + let get b : ((closure_env, unit) → option bool, closure_env) = Foo_in.b_in in let set b : bool = match - (handle_default_opt [b.0 b.1 ()] (λ () → true) (λ () → ESome true)) + (match (handle_exceptions [b.0 b.1 ()]) with + | ENone → ESome true + | ESome x → ESome x) with | ENone → error NoValue | ESome arg → arg @@ -165,7 +173,7 @@ let scope Foo ``` ```catala-test-inline -$ catala Interpret --lcalc -s Foo --avoid-exceptions -O --closure-conversion +$ catala Interpret --lcalc -s Foo -O --closure-conversion ┌─[RESULT]─ │ z = 11 └─ diff --git a/tests/modules/good/output/mod_def.ml b/tests/modules/good/output/mod_def.ml index d3ac9384..443b777d 100644 --- a/tests/modules/good/output/mod_def.ml +++ b/tests/modules/good/output/mod_def.ml @@ -27,39 +27,66 @@ end 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=29; start_column=24; end_line=29; end_column=30; - law_headings=["Test modules + inclusions 1"]}|] - ([|(fun (_: unit) -> - 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"]}]))) - in + match + (match + (handle_exceptions + [|{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"]}|] + ([|(match + (handle_exceptions + [|{filename="tests/modules/good/mod_def.catala_en"; + start_line=29; start_column=24; + end_line=29; end_column=30; + law_headings=["Test modules + inclusions 1"]}|] + ([||])) + with + | Eoption.ENone _ -> + ( if true then + (Eoption.ESome (money_of_cents_string "100000")) else + (Eoption.ENone ())) + | Eoption.ESome x_ -> (Eoption.ESome x_))|])) + with + | Eoption.ENone _ -> + ( if false then (Eoption.ENone ()) else (Eoption.ENone ())) + | Eoption.ESome x_ -> (Eoption.ESome x_)) + with + | Eoption.ENone _ -> (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"]}]))) + | Eoption.ESome arg_ -> arg_ in let e1_: Enum1.t = - try - (handle_default - [|{filename="tests/modules/good/mod_def.catala_en"; - start_line=30; start_column=24; end_line=30; end_column=29; - law_headings=["Test modules + inclusions 1"]}|] - ([|(fun (_: unit) -> - 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"]}]))) - in + match + (match + (handle_exceptions + [|{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"]}|] + ([|(match + (handle_exceptions + [|{filename="tests/modules/good/mod_def.catala_en"; + start_line=30; start_column=24; + end_line=30; end_column=29; + law_headings=["Test modules + inclusions 1"]}|] + ([||])) + with + | Eoption.ENone _ -> + ( if true then (Eoption.ESome (Enum1.Maybe ())) else + (Eoption.ENone ())) + | Eoption.ESome x_ -> (Eoption.ESome x_))|])) + with + | Eoption.ENone _ -> + ( if false then (Eoption.ENone ()) else (Eoption.ENone ())) + | Eoption.ESome x_ -> (Eoption.ESome x_)) + with + | Eoption.ENone _ -> (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"]}]))) + | Eoption.ESome arg_ -> arg_ in {S.sr = sr_; S.e1 = e1_} let half_ : integer -> decimal = diff --git a/tests/monomorphisation/context_var.catala_en b/tests/monomorphisation/context_var.catala_en new file mode 100644 index 00000000..02ea2fe9 --- /dev/null +++ b/tests/monomorphisation/context_var.catala_en @@ -0,0 +1,111 @@ +## Testing monomorphisation on context variables + +```catala +declaration scope TestXor: + context output t content boolean + +scope TestXor: + definition t equals true +``` + +```catala-test-inline +$ catala lcalc --monomorphize-types +type option_1 = | None_1 of unit | Some_1 of bool + +type TestXor_in = { t_in: unit → option_1[None_1: unit | Some_1: bool]; } +type TestXor = { t: bool; } +type array_1 = { + content: list of option_1[None_1: unit | Some_1: bool]; + length: integer; +} + +let scope TestXor + (TestXor_in: + TestXor_in {t_in: unit → option_1[None_1: unit | Some_1: bool]}) + : TestXor {t: bool} + = + let get t : unit → option_1[None_1: unit | Some_1: bool] = + TestXor_in.t_in + in + let set t : bool = + match + (match + (handle_exceptions { array_1 content = [t ()]; length = 1; }) + with + | None_1 → + if true then + Some_1 + (match + (match + (handle_exceptions + { array_1 + content = + [ + match + (handle_exceptions + { array_1 content = []; length = 0; }) + with + | None_1 → + if true then Some_1 true else None_1 () + | Some_1 x → Some_1 x + ]; + length = 1; + }) + with + | None_1 → if false then None_1 () else None_1 () + | Some_1 x → Some_1 x) + with + | None_1 → error NoValue + | Some_1 arg → arg) + else None_1 () + | Some_1 x → Some_1 x) + with + | None_1 → error NoValue + | Some_1 arg → arg + in + return { TestXor t = t; } + +``` + +```catala +declaration scope TestXor2: + t scope TestXor + output o content boolean + +scope TestXor2: + definition o equals t.t +``` + +```catala-test-inline +$ catala lcalc --monomorphize-types -s TestXor2 +let scope TestXor2 (TestXor2_in: TestXor2_in): TestXor2 {o: bool} = + let set t : TestXor {t: bool} = + let result : TestXor = TestXor { TestXor_in t_in = λ () → None_1 (); } in + let result1 : TestXor = { TestXor t = result.t; } in + if true then result1 else result1 + in + let set o : bool = + match + (match + (handle_exceptions + { array_1 + content = + [ + match + (handle_exceptions { array_1 content = []; length = 0; }) + with + | None_1 → if true then Some_1 t.t else None_1 () + | Some_1 x → Some_1 x + ]; + length = 1; + }) + with + | None_1 → if false then None_1 () else None_1 () + | Some_1 x → Some_1 x) + with + | None_1 → error NoValue + | Some_1 arg → arg + in + return { TestXor2 o = o; } +``` + diff --git a/tests/name_resolution/good/let_in2.catala_en b/tests/name_resolution/good/let_in2.catala_en index 826234bd..09eca7af 100644 --- a/tests/name_resolution/good/let_in2.catala_en +++ b/tests/name_resolution/good/let_in2.catala_en @@ -47,44 +47,66 @@ module S = struct end module S_in = struct - type t = {a_in: unit -> bool} + type t = {a_in: unit -> (bool) Eoption.t} end let s (s_in: S_in.t) : S.t = - let a_: unit -> bool = s_in.S_in.a_in in + let a_: unit -> (bool) Eoption.t = s_in.S_in.a_in in 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_ ())|]) - (fun (_: unit) -> true) - (fun (_: unit) -> - try - (handle_default - [|{filename="tests/name_resolution/good/let_in2.catala_en"; - start_line=11; start_column=5; end_line=13; end_column=6; - law_headings=["Article"]}|] - ([|(fun (_: unit) -> - 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 + match + (match + (handle_exceptions + [|{filename="tests/name_resolution/good/let_in2.catala_en"; + start_line=7; start_column=18; end_line=7; end_column=19; + law_headings=["Article"]}|] ([|(a_ ())|])) + with + | Eoption.ENone _ -> + ( if true then + (Eoption.ESome + (match + (match + (handle_exceptions + [|{filename="tests/name_resolution/good/let_in2.catala_en"; + start_line=7; start_column=18; + end_line=7; end_column=19; + law_headings=["Article"]}|] + ([|(match + (handle_exceptions + [|{filename="tests/name_resolution/good/let_in2.catala_en"; + start_line=11; start_column=5; + end_line=13; end_column=6; + law_headings=["Article"]}|] ([||])) + with + | Eoption.ENone _ -> + ( if true then + (Eoption.ESome (let a_ : bool = false + in + (let a_ : bool = (o_or a_ true) + in + a_))) else (Eoption.ENone ())) + | Eoption.ESome x_ -> (Eoption.ESome x_))|])) + with + | Eoption.ENone _ -> + ( if false then (Eoption.ENone ()) else + (Eoption.ENone ())) + | Eoption.ESome x_ -> (Eoption.ESome x_)) + with + | Eoption.ENone _ -> (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"]}]))) + | Eoption.ESome arg_ -> arg_)) else (Eoption.ENone ())) + | Eoption.ESome x_ -> (Eoption.ESome x_)) + with + | Eoption.ENone _ -> (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"]}]))) + | Eoption.ESome arg_ -> arg_ in {S.a = a_} let () = diff --git a/tests/name_resolution/good/toplevel_defs.catala_en b/tests/name_resolution/good/toplevel_defs.catala_en index 022b4421..c32d6301 100644 --- a/tests/name_resolution/good/toplevel_defs.catala_en +++ b/tests/name_resolution/good/toplevel_defs.catala_en @@ -107,144 +107,164 @@ $ catala test-scope S4 ```catala-test-inline $ catala scalc -let glob1_2 = 44.12 +let glob1_1 = 44.12 -let glob3_3 (x_3: money) = return to_rat x_3 + 10. +let glob3_1 (x_2: money) = return to_rat x_2 + 10. -let glob4_4 (x_4: money) (y_5: decimal) = return to_rat x_4 * y_5 + 10. +let glob4_2 (x_3: money) (y_4: decimal) = return to_rat x_3 * y_4 + 10. -let glob5_aux_5 = - decl x_7 : decimal; - x_7 = to_rat 2 * 3.; - decl y_8 : decimal; - y_8 = 1000.; - return x_7 * y_8 +let glob5_aux_3 = + decl x_6 : decimal; + x_6 = to_rat 2 * 3.; + decl y_7 : decimal; + y_7 = 1000.; + return x_6 * y_7 -let glob5_6 = glob5_aux_5 () +let glob5_5 = glob5_aux_3 () -let glob2_9 = A {"y": glob1_2 >= 30., "z": 123. * 17.} +let glob2_8 = A {"y": glob1_1 >= 30., "z": 123. * 17.} -let S2_6 (S2_in_10: S2_in) = - decl temp_a_12 : decimal; - try: - decl temp_a_13 : unit → decimal; - let func temp_a_13 (__14 : unit) = - decl temp_a_15 : unit → bool; - let func temp_a_15 (__16 : unit) = - return true; - decl temp_a_17 : unit → decimal; - let func temp_a_17 (__18 : unit) = - return glob3_3 ¤44.00 + 100.; - return handle_default [] temp_a_15 temp_a_17; - decl temp_a_19 : unit → bool; - let func temp_a_19 (__20 : unit) = - return false; - decl temp_a_21 : unit → decimal; - let func temp_a_21 (__22 : unit) = - raise Empty; - temp_a_12 = handle_default [temp_a_13] temp_a_19 temp_a_21 - with Empty: - fatal NoValue; - decl a_11 : decimal; - a_11 = temp_a_12; - return S2 {"a": a_11} +let S2_4 (S2_in_9: S2_in) = + decl temp_a_11 : decimal; + decl temp_a_12 : option decimal; + decl temp_a_13 : option decimal; + switch handle_exceptions []: + | ENone __14 → + if true: + temp_a_13 = ESome glob3_1 ¤44.00 + 100. + else: + temp_a_13 = ENone () + | ESome x_15 → + temp_a_13 = ESome x_15; + switch handle_exceptions [temp_a_13]: + | ENone __16 → + if false: + temp_a_12 = ENone () + else: + temp_a_12 = ENone () + | ESome x_17 → + temp_a_12 = ESome x_17; + switch temp_a_12: + | ENone __18 → + fatal NoValue + | ESome arg_19 → + temp_a_11 = arg_19; + decl a_10 : decimal; + a_10 = temp_a_11; + return S2 {"a": a_10} -let S3_7 (S3_in_23: S3_in) = - decl temp_a_25 : decimal; - try: - decl temp_a_26 : unit → decimal; - let func temp_a_26 (__27 : unit) = - decl temp_a_28 : unit → bool; - let func temp_a_28 (__29 : unit) = - return true; - decl temp_a_30 : unit → decimal; - let func temp_a_30 (__31 : unit) = - return 50. + glob4_4 ¤44.00 55.; - return handle_default [] temp_a_28 temp_a_30; - decl temp_a_32 : unit → bool; - let func temp_a_32 (__33 : unit) = - return false; - decl temp_a_34 : unit → decimal; - let func temp_a_34 (__35 : unit) = - raise Empty; - temp_a_25 = handle_default [temp_a_26] temp_a_32 temp_a_34 - with Empty: - fatal NoValue; - decl a_24 : decimal; - a_24 = temp_a_25; - return S3 {"a": a_24} +let S3_5 (S3_in_20: S3_in) = + decl temp_a_22 : decimal; + decl temp_a_23 : option decimal; + decl temp_a_24 : option decimal; + switch handle_exceptions []: + | ENone __25 → + if true: + temp_a_24 = ESome 50. + glob4_2 ¤44.00 55. + else: + temp_a_24 = ENone () + | ESome x_26 → + temp_a_24 = ESome x_26; + switch handle_exceptions [temp_a_24]: + | ENone __27 → + if false: + temp_a_23 = ENone () + else: + temp_a_23 = ENone () + | ESome x_28 → + temp_a_23 = ESome x_28; + switch temp_a_23: + | ENone __29 → + fatal NoValue + | ESome arg_30 → + temp_a_22 = arg_30; + decl a_21 : decimal; + a_21 = temp_a_22; + return S3 {"a": a_21} -let S4_8 (S4_in_36: S4_in) = - decl temp_a_38 : decimal; - try: - decl temp_a_39 : unit → decimal; - let func temp_a_39 (__40 : unit) = - decl temp_a_41 : unit → bool; - let func temp_a_41 (__42 : unit) = - return true; - decl temp_a_43 : unit → decimal; - let func temp_a_43 (__44 : unit) = - return glob5_6 + 1.; - return handle_default [] temp_a_41 temp_a_43; - decl temp_a_45 : unit → bool; - let func temp_a_45 (__46 : unit) = - return false; - decl temp_a_47 : unit → decimal; - let func temp_a_47 (__48 : unit) = - raise Empty; - temp_a_38 = handle_default [temp_a_39] temp_a_45 temp_a_47 - with Empty: - fatal NoValue; - decl a_37 : decimal; - a_37 = temp_a_38; - return S4 {"a": a_37} +let S4_6 (S4_in_31: S4_in) = + decl temp_a_33 : decimal; + decl temp_a_34 : option decimal; + decl temp_a_35 : option decimal; + switch handle_exceptions []: + | ENone __36 → + if true: + temp_a_35 = ESome glob5_5 + 1. + else: + temp_a_35 = ENone () + | ESome x_37 → + temp_a_35 = ESome x_37; + switch handle_exceptions [temp_a_35]: + | ENone __38 → + if false: + temp_a_34 = ENone () + else: + temp_a_34 = ENone () + | ESome x_39 → + temp_a_34 = ESome x_39; + switch temp_a_34: + | ENone __40 → + fatal NoValue + | ESome arg_41 → + temp_a_33 = arg_41; + decl a_32 : decimal; + a_32 = temp_a_33; + return S4 {"a": a_32} -let S_9 (S_in_49: S_in) = - decl temp_a_63 : decimal; - try: - decl temp_a_64 : unit → decimal; - let func temp_a_64 (__65 : unit) = - decl temp_a_66 : unit → bool; - let func temp_a_66 (__67 : unit) = - return true; - decl temp_a_68 : unit → decimal; - let func temp_a_68 (__69 : unit) = - return glob1_2 * glob1_2; - return handle_default [] temp_a_66 temp_a_68; - decl temp_a_70 : unit → bool; - let func temp_a_70 (__71 : unit) = - return false; - decl temp_a_72 : unit → decimal; - let func temp_a_72 (__73 : unit) = - raise Empty; - temp_a_63 = handle_default [temp_a_64] temp_a_70 temp_a_72 - with Empty: - fatal NoValue; - decl a_50 : decimal; - a_50 = temp_a_63; - decl temp_b_52 : A {y: bool; z: decimal}; - try: - decl temp_b_53 : unit → A {y: bool; z: decimal}; - let func temp_b_53 (__54 : unit) = - decl temp_b_55 : unit → bool; - let func temp_b_55 (__56 : unit) = - return true; - decl temp_b_57 : unit → A {y: bool; z: decimal}; - let func temp_b_57 (__58 : unit) = - return glob2_9; - return handle_default [] temp_b_55 temp_b_57; - decl temp_b_59 : unit → bool; - let func temp_b_59 (__60 : unit) = - return false; - decl temp_b_61 : unit → A {y: bool; z: decimal}; - let func temp_b_61 (__62 : unit) = - raise Empty; - temp_b_52 = handle_default [temp_b_53] temp_b_59 temp_b_61 - with Empty: - fatal NoValue; - decl b_51 : A {y: bool; z: decimal}; - b_51 = temp_b_52; - return S {"a": a_50, "b": b_51} +let S_7 (S_in_42: S_in) = + decl temp_a_54 : decimal; + decl temp_a_55 : option decimal; + decl temp_a_56 : option decimal; + switch handle_exceptions []: + | ENone __57 → + if true: + temp_a_56 = ESome glob1_1 * glob1_1 + else: + temp_a_56 = ENone () + | ESome x_58 → + temp_a_56 = ESome x_58; + switch handle_exceptions [temp_a_56]: + | ENone __59 → + if false: + temp_a_55 = ENone () + else: + temp_a_55 = ENone () + | ESome x_60 → + temp_a_55 = ESome x_60; + switch temp_a_55: + | ENone __61 → + fatal NoValue + | ESome arg_62 → + temp_a_54 = arg_62; + decl a_43 : decimal; + a_43 = temp_a_54; + decl temp_b_45 : A {y: bool; z: decimal}; + decl temp_b_46 : option A {y: bool; z: decimal}; + decl temp_b_47 : option A {y: bool; z: decimal}; + switch handle_exceptions []: + | ENone __48 → + if true: + temp_b_47 = ESome glob2_8 + else: + temp_b_47 = ENone () + | ESome x_49 → + temp_b_47 = ESome x_49; + switch handle_exceptions [temp_b_47]: + | ENone __50 → + if false: + temp_b_46 = ENone () + else: + temp_b_46 = ENone () + | ESome x_51 → + temp_b_46 = ESome x_51; + switch temp_b_46: + | ENone __52 → + fatal NoValue + | ESome arg_53 → + temp_b_45 = arg_53; + decl b_44 : A {y: bool; z: decimal}; + b_44 = temp_b_45; + return S {"a": a_43, "b": b_44} ``` ```catala-test-inline @@ -423,155 +443,205 @@ glob2 = ( decimal_of_string("30.")), z = (decimal_of_string("123.") * decimal_of_string("17."))) - ) +) def s2(s2_in:S2In): - try: - def temp_a(_:Unit): - def temp_a_1(_:Unit): - return True - def temp_a_2(_:Unit): - return (glob3(money_of_cents_string("4400")) + - decimal_of_string("100.")) - return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", + perhaps_none_arg = handle_exceptions([], []) + if perhaps_none_arg is None: + if True: + temp_a = (glob3(money_of_cents_string("4400")) + + decimal_of_string("100.")) + else: + temp_a = None + else: + x_3 = perhaps_none_arg + temp_a = x_3 + perhaps_none_arg_1 = handle_exceptions( + [SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=53, start_column=24, end_line=53, end_column=43, - law_headings=["Test toplevel function defs"]), [], - temp_a_1, temp_a_2) - def temp_a_3(_:Unit): - return False - def temp_a_4(_:Unit): - raise Empty - temp_a_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=50, start_column=10, - end_line=50, end_column=11, - law_headings=["Test toplevel function defs"]), [temp_a], - temp_a_3, temp_a_4) - except Empty: + law_headings=["Test toplevel function defs"] + )], + [temp_a] + ) + if perhaps_none_arg_1 is None: + if False: + temp_a_1 = None + else: + temp_a_1 = None + else: + x_4 = perhaps_none_arg_1 + temp_a_1 = x_4 + perhaps_none_arg_2 = temp_a_1 + if perhaps_none_arg_2 is None: raise NoValue(SourcePosition( filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=50, start_column=10, end_line=50, end_column=11, law_headings=["Test toplevel function defs"])) - a = temp_a_5 + else: + arg = perhaps_none_arg_2 + temp_a_2 = arg + a = temp_a_2 return S2(a = a) def s3(s3_in:S3In): - try: - def temp_a_6(_:Unit): - def temp_a_7(_:Unit): - return True - def temp_a_8(_:Unit): - return (decimal_of_string("50.") + - glob4(money_of_cents_string("4400"), - decimal_of_string("55."))) - return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", + perhaps_none_arg_3 = handle_exceptions([], []) + if perhaps_none_arg_3 is None: + if True: + temp_a_3 = (decimal_of_string("50.") + + glob4(money_of_cents_string("4400"), + decimal_of_string("55."))) + else: + temp_a_3 = None + else: + x_5 = perhaps_none_arg_3 + temp_a_3 = x_5 + perhaps_none_arg_4 = handle_exceptions( + [SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=74, start_column=24, end_line=74, end_column=47, - law_headings=["Test function def with two args"]), [], - temp_a_7, temp_a_8) - def temp_a_9(_:Unit): - return False - def temp_a_10(_:Unit): - raise Empty - temp_a_11 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=71, start_column=10, - end_line=71, end_column=11, - law_headings=["Test function def with two args"]), [temp_a_6], - temp_a_9, temp_a_10) - except Empty: + law_headings=["Test function def with two args"] + )], + [temp_a_3] + ) + if perhaps_none_arg_4 is None: + if False: + temp_a_4 = None + else: + temp_a_4 = None + else: + x_6 = perhaps_none_arg_4 + temp_a_4 = x_6 + perhaps_none_arg_5 = temp_a_4 + if perhaps_none_arg_5 is None: raise NoValue(SourcePosition( filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=71, start_column=10, end_line=71, end_column=11, law_headings=["Test function def with two args"])) - a_1 = temp_a_11 + else: + arg_1 = perhaps_none_arg_5 + temp_a_5 = arg_1 + a_1 = temp_a_5 return S3(a = a_1) def s4(s4_in:S4In): - try: - def temp_a_12(_:Unit): - def temp_a_13(_:Unit): - return True - def temp_a_14(_:Unit): - return (glob5 + decimal_of_string("1.")) - return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", + perhaps_none_arg_6 = handle_exceptions([], []) + if perhaps_none_arg_6 is None: + if True: + temp_a_6 = (glob5 + decimal_of_string("1.")) + else: + temp_a_6 = None + else: + x_7 = perhaps_none_arg_6 + temp_a_6 = x_7 + perhaps_none_arg_7 = handle_exceptions( + [SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=98, start_column=24, end_line=98, end_column=34, - law_headings=["Test inline defs in toplevel defs"]), [], - temp_a_13, temp_a_14) - def temp_a_15(_:Unit): - return False - def temp_a_16(_:Unit): - raise Empty - temp_a_17 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=95, start_column=10, - end_line=95, end_column=11, - law_headings=["Test inline defs in toplevel defs"]), [temp_a_12], - temp_a_15, temp_a_16) - except Empty: + law_headings=["Test inline defs in toplevel defs"] + )], + [temp_a_6] + ) + if perhaps_none_arg_7 is None: + if False: + temp_a_7 = None + else: + temp_a_7 = None + else: + x_8 = perhaps_none_arg_7 + temp_a_7 = x_8 + perhaps_none_arg_8 = temp_a_7 + if perhaps_none_arg_8 is None: raise NoValue(SourcePosition( filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=95, start_column=10, end_line=95, end_column=11, law_headings=["Test inline defs in toplevel defs"])) - a_2 = temp_a_17 + else: + arg_2 = perhaps_none_arg_8 + temp_a_8 = arg_2 + a_2 = temp_a_8 return S4(a = a_2) def s(s_in:SIn): - try: - def temp_a_18(_:Unit): - def temp_a_19(_:Unit): - return True - def temp_a_20(_:Unit): - return (glob1 * glob1) - return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=18, start_column=24, - end_line=18, end_column=37, - law_headings=["Test basic toplevel values defs"]), [], - temp_a_19, temp_a_20) - def temp_a_21(_:Unit): - return False - def temp_a_22(_:Unit): - raise Empty - temp_a_23 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=7, start_column=10, - end_line=7, end_column=11, - law_headings=["Test basic toplevel values defs"]), [temp_a_18], - temp_a_21, temp_a_22) - except Empty: + perhaps_none_arg_9 = handle_exceptions([], []) + if perhaps_none_arg_9 is None: + if True: + temp_a_9 = (glob1 * glob1) + else: + temp_a_9 = None + else: + x_9 = perhaps_none_arg_9 + temp_a_9 = x_9 + perhaps_none_arg_10 = handle_exceptions( + [SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", + start_line=18, start_column=24, + end_line=18, end_column=37, + law_headings=["Test basic toplevel values defs"] + )], + [temp_a_9] + ) + if perhaps_none_arg_10 is None: + if False: + temp_a_10 = None + else: + temp_a_10 = None + else: + x_10 = perhaps_none_arg_10 + temp_a_10 = x_10 + perhaps_none_arg_11 = temp_a_10 + if perhaps_none_arg_11 is None: raise NoValue(SourcePosition( filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=7, start_column=10, end_line=7, end_column=11, law_headings=["Test basic toplevel values defs"])) - a_3 = temp_a_23 - try: - def temp_b(_:Unit): - def temp_b_1(_:Unit): - return True - def temp_b_2(_:Unit): - return glob2 - return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=19, start_column=24, - end_line=19, end_column=29, - law_headings=["Test basic toplevel values defs"]), [], - temp_b_1, temp_b_2) - def temp_b_3(_:Unit): - return False - def temp_b_4(_:Unit): - raise Empty - temp_b_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=8, start_column=10, - end_line=8, end_column=11, - law_headings=["Test basic toplevel values defs"]), [temp_b], - temp_b_3, temp_b_4) - except Empty: + else: + arg_3 = perhaps_none_arg_11 + temp_a_11 = arg_3 + a_3 = temp_a_11 + perhaps_none_arg_12 = handle_exceptions([], []) + if perhaps_none_arg_12 is None: + if True: + temp_b = glob2 + else: + temp_b = None + else: + x_11 = perhaps_none_arg_12 + temp_b = x_11 + perhaps_none_arg_13 = handle_exceptions( + [SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", + start_line=19, start_column=24, + end_line=19, end_column=29, + law_headings=["Test basic toplevel values defs"] + )], + [temp_b] + ) + if perhaps_none_arg_13 is None: + if False: + temp_b_1 = None + else: + temp_b_1 = None + else: + x_12 = perhaps_none_arg_13 + temp_b_1 = x_12 + perhaps_none_arg_14 = temp_b_1 + if perhaps_none_arg_14 is None: raise NoValue(SourcePosition( filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=8, start_column=10, end_line=8, end_column=11, law_headings=["Test basic toplevel values defs"])) - b = temp_b_5 + else: + arg_4 = perhaps_none_arg_14 + temp_b_2 = arg_4 + b = temp_b_2 return S(a = a_3, b = b) ``` diff --git a/tests/scope/good/nothing.catala_en b/tests/scope/good/nothing.catala_en index 21a0916d..88548eaa 100644 --- a/tests/scope/good/nothing.catala_en +++ b/tests/scope/good/nothing.catala_en @@ -39,11 +39,11 @@ $ catala Scalc -s Foo2 -O -t │ 5 │ output bar content integer │ │ ‾‾‾ └─ Test -let Foo2_3 (Foo2_in_2: Foo2_in) = - decl temp_bar_4 : integer; +let Foo2_1 (Foo2_in_1: Foo2_in) = + decl temp_bar_3 : integer; fatal NoValue; - decl bar_3 : integer; - bar_3 = temp_bar_4; - return Foo2 {"bar": bar_3} + decl bar_2 : integer; + bar_2 = temp_bar_3; + return Foo2 {"bar": bar_2} ``` diff --git a/tests/scope/good/scope_call4.catala_en b/tests/scope/good/scope_call4.catala_en index e9fb67f0..96af8776 100644 --- a/tests/scope/good/scope_call4.catala_en +++ b/tests/scope/good/scope_call4.catala_en @@ -68,7 +68,7 @@ $ catala interpret -s RentComputation --debug ``` ```catala-test-inline -$ catala Interpret --lcalc -s RentComputation --avoid-exceptions --optimize --debug +$ catala Interpret --lcalc -s RentComputation --optimize --debug [DEBUG] = INIT = [DEBUG] = SURFACE = [DEBUG] Parsing "tests/scope/good/scope_call4.catala_en" diff --git a/tests/scope/good/simple.catala_en b/tests/scope/good/simple.catala_en index 4c841d21..e501c028 100644 --- a/tests/scope/good/simple.catala_en +++ b/tests/scope/good/simple.catala_en @@ -24,12 +24,20 @@ $ catala Typecheck --check-invariants $ catala Lcalc -s Foo let scope Foo (Foo_in: Foo_in): Foo {bar: integer} = let set bar : integer = - try - handle_default - [λ () → handle_default [] (λ () → true) (λ () → 0)] - (λ () → false) - (λ () → raise Empty) - with Empty -> error NoValue + match + (match + (handle_exceptions + [ + match (handle_exceptions []) with + | ENone → if true then ESome 0 else ENone () + | ESome x → ESome x + ]) + with + | ENone → if false then ENone () else ENone () + | ESome x → ESome x) + with + | ENone → error NoValue + | ESome arg → arg in return { Foo bar = bar; } ```