diff --git a/Makefile b/Makefile index 74d85834..20324097 100644 --- a/Makefile +++ b/Makefile @@ -14,7 +14,7 @@ dependencies-ocaml: ocamlformat ANSITerminal sedlex menhir menhirLib dune cmdliner obelisk \ re obelisk unionfind bindlib zarith zarith_stubs_js ocamlgraph \ js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx calendar camomile \ - visitors + visitors benchmark init-submodules: git submodule update --init @@ -147,7 +147,7 @@ tests: test_suite test_examples ########################################## allocations_familiales_ml: - SCOPE=InterfaceAllocationsFamiliales $(MAKE) -C examples/allocations_familiales allocations_familiales.ml -B + $(MAKE) -C examples/allocations_familiales allocations_familiales.ml -B cp -f examples/allocations_familiales/allocations_familiales.ml src/catala_examples $(MAKE) -C ./ format dune exec src/catala_examples/driver.exe diff --git a/dune-project b/dune-project index c6f3cecf..51098359 100644 --- a/dune-project +++ b/dune-project @@ -35,6 +35,7 @@ (ocamlgraph (>= 1.8.8)) (calendar (>= 2.04)) (visitors (>= 20200210)) + (benchmark (>= 1.6)) ) ) diff --git a/examples/Makefile.common.mk b/examples/Makefile.common.mk index 49fd8188..19c818cd 100644 --- a/examples/Makefile.common.mk +++ b/examples/Makefile.common.mk @@ -35,7 +35,6 @@ endif @$(CATALA) Makefile $< @$(CATALA) \ OCaml \ - -s $(SCOPE) \ $< diff --git a/examples/allocations_familiales/securite_sociale_R.catala_fr b/examples/allocations_familiales/securite_sociale_R.catala_fr index 5c2015e1..b6d877fd 100644 --- a/examples/allocations_familiales/securite_sociale_R.catala_fr +++ b/examples/allocations_familiales/securite_sociale_R.catala_fr @@ -109,7 +109,8 @@ champ d'application AllocationsFamiliales : montant_initial_base *€ rapport_enfants_total_moyen définition rapport_enfants_total_moyen égal à - nombre_moyen_enfants /. nombre_total_enfants + si nombre_total_enfants = 0,0 alors 0,0 sinon + (nombre_moyen_enfants /. nombre_total_enfants) */ Le nombre moyen d'enfants, pour chaque foyer, est obtenu en faisant la somme diff --git a/examples/allocations_familiales/tests/tests_allocations_familiales.catala_fr b/examples/allocations_familiales/tests/tests_allocations_familiales.catala_fr index f0d8c2ee..e2c423bb 100644 --- a/examples/allocations_familiales/tests/tests_allocations_familiales.catala_fr +++ b/examples/allocations_familiales/tests/tests_allocations_familiales.catala_fr @@ -95,4 +95,15 @@ champ d'application Test4: définition f.date_courante égal à |01/05/2020| définition f.résidence égal à Métropole assertion f.montant_versé = 99,37€ + +déclaration champ d'application Test5: + contexte f champ d'application InterfaceAllocationsFamiliales + contexte données champ d'application Données + +champ d'application Test5: + définition f.enfants égal à [données.enfant1] + définition f.ressources_ménage égal à 30 000 € + définition f.date_courante égal à |01/05/2020| + définition f.résidence égal à Métropole + assertion f.montant_versé = 0,00€ */ diff --git a/src/catala/default_calculus/print.ml b/src/catala/default_calculus/print.ml index 2d8603af..666a365f 100644 --- a/src/catala/default_calculus/print.ml +++ b/src/catala/default_calculus/print.ml @@ -42,7 +42,7 @@ let format_uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit = match l with | TUnit -> Format.fprintf fmt "unit" - | TBool -> Format.fprintf fmt "boolean" + | TBool -> Format.fprintf fmt "bool" | TInt -> Format.fprintf fmt "integer" | TRat -> Format.fprintf fmt "decimal" | TMoney -> Format.fprintf fmt "money" diff --git a/src/catala/driver.ml b/src/catala/driver.ml index c7323b94..4cd05bc1 100644 --- a/src/catala/driver.ml +++ b/src/catala/driver.ml @@ -126,9 +126,10 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) Cli.debug_print "Name resolution..."; let ctxt = Surface.Name_resolution.form_context program in let scope_uid = - match ex_scope with - | None -> Errors.raise_error "No scope was provided for execution." - | Some name -> ( + match (ex_scope, backend) with + | None, Cli.Run -> Errors.raise_error "No scope was provided for execution." + | None, _ -> snd (Desugared.Ast.IdentMap.choose ctxt.scope_idmap) + | Some name, _ -> ( match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with | None -> Errors.raise_error @@ -140,7 +141,9 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) Cli.debug_print "Collecting rules..."; let prgm = Desugared.Desugared_to_scope.translate_program prgm in Cli.debug_print "Translating to default calculus..."; - let prgm, prgm_expr = Scopelang.Scope_to_dcalc.translate_program prgm scope_uid in + let prgm, prgm_expr, type_ordering = + Scopelang.Scope_to_dcalc.translate_program prgm scope_uid + in (* Cli.debug_print (Format.asprintf "Output program:@\n%a" (Dcalc.Print.format_expr ctx) prgm); *) Cli.debug_print "Typechecking..."; @@ -184,7 +187,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) Cli.debug_print (Printf.sprintf "Writing to %s..." output_file); let oc = open_out output_file in let fmt = Format.formatter_of_out_channel oc in - Lcalc.To_ocaml.format_program fmt prgm; + Lcalc.To_ocaml.format_program fmt prgm type_ordering; close_out oc; 0 | _ -> assert false diff --git a/src/catala/lambda_calculus/dune b/src/catala/lambda_calculus/dune index 9e21ca30..5cd4b762 100644 --- a/src/catala/lambda_calculus/dune +++ b/src/catala/lambda_calculus/dune @@ -1,7 +1,7 @@ (library (name lcalc) (public_name catala.lcalc) - (libraries bindlib dcalc)) + (libraries bindlib dcalc scopelang)) (documentation (package catala)) diff --git a/src/catala/lambda_calculus/to_ocaml.ml b/src/catala/lambda_calculus/to_ocaml.ml index e023e8ae..b53f5f2d 100644 --- a/src/catala/lambda_calculus/to_ocaml.ml +++ b/src/catala/lambda_calculus/to_ocaml.ml @@ -24,8 +24,13 @@ let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit = Format.fprintf fmt "decimal_of_string \"%a\"" Dcalc.Print.format_lit (Pos.same_pos_as (Dcalc.Ast.LRat i) l) | LMoney e -> Format.fprintf fmt "money_of_cent_string@ \"%s\"" (Z.to_string e) - | LDate d -> Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LDate d) l) - | LDuration d -> Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LDuration d) l) + | LDate d -> + Format.fprintf fmt "date_of_numbers (%d) (%d) (%d)" (CalendarLib.Date.year d) + (CalendarLib.Date.int_of_month (CalendarLib.Date.month d)) + (CalendarLib.Date.day_of_month d) + | LDuration d -> + let years, months, days = CalendarLib.Date.Period.ymd d in + Format.fprintf fmt "duration_of_numbers (%d) (%d) (%d)" years months days let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) = Format.fprintf fmt "%s" @@ -52,29 +57,28 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : un | Lte k -> Format.fprintf fmt "%s%a" "<=" format_op_kind k | Gt k -> Format.fprintf fmt "%s%a" ">" format_op_kind k | Gte k -> Format.fprintf fmt "%s%a" ">=" format_op_kind k - | Map -> Format.fprintf fmt "List.map" - | Filter -> Format.fprintf fmt "List.filter" + | Map -> Format.fprintf fmt "Array.map" + | Filter -> Format.fprintf fmt "array_filter" let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : unit = - match Pos.unmark op with Fold -> Format.fprintf fmt "List.fold_left" + match Pos.unmark op with Fold -> Format.fprintf fmt "Array.fold_left" let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit = - Format.fprintf fmt "%s" - ( match Pos.unmark op with - | Minus _ -> "-" - | Not -> "not" - | ErrorOnEmpty -> "error_empty" - | Log (entry, infos) -> - Format.asprintf "@[log_entry@ \"%a|%a\"@]" format_log_entry entry - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ".") - (fun fmt info -> Utils.Uid.MarkedString.format_info fmt info)) - infos - | Length -> "length" - | IntToRat -> "int_to_rat" - | GetDay -> "get_day" - | GetMonth -> "get_month" - | GetYear -> "get_year" ) + match Pos.unmark op with + | Minus k -> Format.fprintf fmt "~-%a" format_op_kind k + | Not -> Format.fprintf fmt "%s" "not" + | ErrorOnEmpty -> Format.fprintf fmt "%s" "error_empty" + | Log (entry, infos) -> + Format.fprintf fmt "@[log_entry@ \"%a|%a\"@]" format_log_entry entry + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ".") + (fun fmt info -> Utils.Uid.MarkedString.format_info fmt info)) + infos + | Length -> Format.fprintf fmt "%s" "array_length" + | IntToRat -> Format.fprintf fmt "%s" "int_to_rat" + | GetDay -> Format.fprintf fmt "%s" "get_day" + | GetMonth -> Format.fprintf fmt "%s" "get_month" + | GetYear -> Format.fprintf fmt "%s" "get_year" let to_ascii (s : string) : string = let out = ref "" in @@ -166,7 +170,7 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp Format.fprintf fmt "%a=@ %a" format_struct_field_name struct_field format_expr e)) (List.combine es (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs))) | EArray es -> - Format.fprintf fmt "@[[%a]@]" + Format.fprintf fmt "@[[|%a|]@]" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") (fun fmt e -> Format.fprintf fmt "%a" format_expr e)) @@ -233,6 +237,7 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp | EApp ((EOp (Binop op), _), [ arg1; arg2 ]) -> Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 format_binop (op, Pos.no_pos) format_with_parens arg2 + | EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_expr arg1 | EApp ((EOp (Unop op), _), [ arg1 ]) -> Format.fprintf fmt "@[%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1 | EApp (f, args) -> @@ -251,37 +256,41 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp Format.fprintf fmt "@[try@ %a@ with@ %a@ ->@ %a@]" format_expr e1 format_exception exc format_expr e2 -let format_ctx (fmt : Format.formatter) (ctx : D.decl_ctx) : unit = - Format.fprintf fmt "%a\n\n%a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n") - (fun fmt (struct_name, struct_fields) -> - Format.fprintf fmt "type %a = {@\n@[ %a@]@\n}" format_struct_name struct_name - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun _fmt (struct_field, struct_field_type) -> - Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ - struct_field_type)) - struct_fields)) - (Dcalc.Ast.StructMap.bindings ctx.Dcalc.Ast.ctx_structs) - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun _fmt (enum_name, enum_cons) -> - Format.fprintf fmt "type %a =@\n@[ %a@]@\n" format_enum_name enum_name - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun _fmt (enum_cons, enum_cons_type) -> - Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ - enum_cons_type)) - enum_cons)) - (List.filter - (* option is a polymorphic type which we don't handle well... *) - (fun (e, _) -> e <> Compile_with_exceptions.option_enum) - (Dcalc.Ast.EnumMap.bindings ctx.Dcalc.Ast.ctx_enums)) +let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Format.formatter) + (ctx : D.decl_ctx) : unit = + let format_struct_decl fmt (struct_name, struct_fields) = + Format.fprintf fmt "type %a = {@\n@[ %a@]@\n}" format_struct_name struct_name + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") + (fun _fmt (struct_field, struct_field_type) -> + Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ + struct_field_type)) + struct_fields + in + let format_enum_decl fmt (enum_name, enum_cons) = + Format.fprintf fmt "type %a =@\n@[ %a@]@\n" format_enum_name enum_name + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") + (fun _fmt (enum_cons, enum_cons_type) -> + Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ + enum_cons_type)) + enum_cons + in + List.iter + (fun struct_or_enum -> + match struct_or_enum with + | Scopelang.Dependency.TVertex.Struct s -> + Format.fprintf fmt "%a@\n@\n" format_struct_decl + (s, Dcalc.Ast.StructMap.find s ctx.Dcalc.Ast.ctx_structs) + | Scopelang.Dependency.TVertex.Enum e -> + Format.fprintf fmt "%a@\n@\n" format_enum_decl + (e, Dcalc.Ast.EnumMap.find e ctx.Dcalc.Ast.ctx_enums)) + type_ordering -let format_program (fmt : Format.formatter) (p : Ast.program) : unit = - Format.fprintf fmt "open Runtime@\n@\n[@@@@@@ocaml.warning \"-26\"]@\n@\n%a@\n@\n%a" format_ctx - p.decl_ctx +let format_program (fmt : Format.formatter) (p : Ast.program) + (type_ordering : Scopelang.Dependency.TVertex.t list) : unit = + Format.fprintf fmt "open Runtime@\n@\n[@@@@@@ocaml.warning \"-26\"]@\n@\n%a@\n@\n%a" + (format_ctx type_ordering) p.decl_ctx (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") (fun fmt (name, e) -> diff --git a/src/catala/scope_language/dependency.ml b/src/catala/scope_language/dependency.ml index 9e4b92e6..b2b55e09 100644 --- a/src/catala/scope_language/dependency.ml +++ b/src/catala/scope_language/dependency.ml @@ -203,11 +203,11 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TDepend in g -let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : unit = +let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TVertex.t list = let g = build_type_graph structs enums in (* if there is a cycle, there will be an strongly connected component of cardinality > 1 *) let sccs = TSCC.scc_list g in - if List.length sccs < TDependencies.nb_vertex g then + ( if List.length sccs < TDependencies.nb_vertex g then let scc = List.find (fun scc -> List.length scc > 1) sccs in Errors.raise_multispanned_error "Cyclic dependency detected between types!" (List.flatten @@ -224,4 +224,5 @@ let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : unit = ( Some ("Used here in the definition of another cycle type " ^ succ_str ^ ":"), edge_pos ); ]) - scc)) + scc)) ); + List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g []) diff --git a/src/catala/scope_language/scope_to_dcalc.ml b/src/catala/scope_language/scope_to_dcalc.ml index 66482a17..e974c584 100644 --- a/src/catala/scope_language/scope_to_dcalc.ml +++ b/src/catala/scope_language/scope_to_dcalc.ml @@ -518,10 +518,10 @@ let build_scope_typ_from_sig (scope_sig : (Ast.ScopeVar.t * Dcalc.Ast.typ) list) scope_sig result_typ let translate_program (prgm : Ast.program) (top_level_scope_name : Ast.ScopeName.t) : - Dcalc.Ast.program * Dcalc.Ast.expr Pos.marked = + Dcalc.Ast.program * Dcalc.Ast.expr Pos.marked * Dependency.TVertex.t list = let scope_dependencies = Dependency.build_program_dep_graph prgm in Dependency.check_for_cycle_in_scope scope_dependencies; - Dependency.check_type_cycles prgm.program_structs prgm.program_enums; + let types_ordering = Dependency.check_type_cycles prgm.program_structs prgm.program_enums in let scope_ordering = Dependency.get_scope_ordering scope_dependencies in let struct_ctx = prgm.program_structs in let enum_ctx = prgm.program_enums in @@ -570,4 +570,4 @@ let translate_program (prgm : Ast.program) (top_level_scope_name : Ast.ScopeName (dvar, Bindlib.unbox scope_expr) :: scopes )) scope_ordering (acc, []) in - ({ scopes; decl_ctx }, Bindlib.unbox whole_program_expr) + ({ scopes; decl_ctx }, Bindlib.unbox whole_program_expr, types_ordering) diff --git a/src/catala_examples/driver.ml b/src/catala_examples/driver.ml index 539047b5..0a7ce4f0 100644 --- a/src/catala_examples/driver.ml +++ b/src/catala_examples/driver.ml @@ -1,3 +1,48 @@ module M = Allocations_familiales +open Runtime -let _ = Allocations_familiales.test1 (fun () -> assert false) +let run_test (id : int) = + let _, _, _, _, _, amount = + M.interfaceallocationsfamiliales + (fun _ -> date_of_numbers 2020 05 01) + (fun _ -> + [| + { + d_identifiant = Z.of_int 1; + d_r_muneration_mensuelle = Z.of_int 0; + d_date_de_naissance = date_of_numbers 2007 01 01; + d_garde_altern_e = M.NonGardeUnique (); + d_pris_en_charge_par_services_sociaux = M.NonPriseEnChargeFamille (); + }; + { + d_identifiant = Z.of_int 2; + d_r_muneration_mensuelle = Z.of_int 0; + d_date_de_naissance = date_of_numbers 2009 01 01; + d_garde_altern_e = M.NonGardeUnique (); + d_pris_en_charge_par_services_sociaux = M.NonPriseEnChargeFamille (); + }; + { + d_identifiant = Z.of_int 3; + d_r_muneration_mensuelle = Z.of_int 40000; + d_date_de_naissance = date_of_numbers 2003 01 01; + d_garde_altern_e = M.OuiPartageAllocations (); + d_pris_en_charge_par_services_sociaux = M.NonPriseEnChargeFamille (); + }; + { + d_identifiant = Z.of_int id; + d_r_muneration_mensuelle = Z.of_int 110000; + d_date_de_naissance = date_of_numbers 2001 01 01; + d_garde_altern_e = M.NonGardeUnique (); + d_pris_en_charge_par_services_sociaux = M.NonPriseEnChargeFamille (); + }; + |]) + (fun _ -> raise EmptyError) + (fun _ -> money_of_cent_string "3000000") + (fun _ -> M.M_tropole ()) + (fun _ -> raise EmptyError) + in + assert (Z.to_int amount = 35126) + +let _ = + let _ = Benchmark.latency1 ~style:Auto (Int64.of_int 100000) run_test 4 in + () diff --git a/src/catala_examples/dune b/src/catala_examples/dune index ebdbcda7..c36515d6 100644 --- a/src/catala_examples/dune +++ b/src/catala_examples/dune @@ -2,5 +2,13 @@ (name driver) (modes native) (package catala) + (modules + (:standard \ runtime)) (public_name catala_examples) - (libraries catala.utils zarith calendar)) + (libraries runtime)) + +(library + (name runtime) + (public_name catala.runtime) + (libraries catala.utils zarith calendar benchmark) + (modules runtime)) diff --git a/src/catala_examples/runtime.ml b/src/catala_examples/runtime.ml index 805035b5..91ea040c 100644 --- a/src/catala_examples/runtime.ml +++ b/src/catala_examples/runtime.ml @@ -34,12 +34,13 @@ let decimal_of_string (d : string) : decimal = Q.of_string d let integer_of_string (i : string) : integer = Z.of_string i -(**{1 Logging} *) +let date_of_numbers (year : int) (month : int) (day : int) : date = + CalendarLib.Date.make year month day -let log_entry : 'a. string -> 'a -> 'a = - fun msg arg -> - Printf.printf "%s\n" msg; - arg +let duration_of_numbers (year : int) (month : int) (day : int) : duration = + CalendarLib.Date.Period.make year month day + +let int_to_rat (i : integer) : decimal = Q.of_bigint i (**{1 Exceptions and defaults} *) @@ -48,10 +49,10 @@ exception EmptyError let error_empty : 'a. 'a -> 'a = fun x -> try x with EmptyError -> Errors.raise_error "empty value found!" -let handle_default : 'a. (unit -> 'a) list -> (unit -> bool) -> (unit -> 'a) -> 'a = +let handle_default : 'a. (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> 'a = fun exceptions just cons -> let except = - List.fold_left + Array.fold_left (fun acc except -> let new_val = try Some (except ()) with EmptyError -> None in match (acc, new_val) with @@ -64,12 +65,100 @@ let handle_default : 'a. (unit -> 'a) list -> (unit -> bool) -> (unit -> 'a) -> (**{1 Operators} *) -let ( *$ ) (_m : money) (_d : decimal) : money = assert false +let ( *$ ) (i1 : money) (i2 : decimal) : money = + let rat_result = Q.mul (Q.of_bigint i1) i2 in + let res, remainder = Z.div_rem (Q.num rat_result) (Q.den rat_result) in + (* we perform nearest rounding when multiplying an amount of money by a decimal !*) + if Z.(of_int 2 * remainder >= Q.den rat_result) then Z.add res (Z.of_int 1) else res -let ( +$ ) (_m1 : money) (_m2 : money) : money = assert false +let ( /$ ) (i1 : money) (i2 : money) : decimal = + if i2 <> Z.zero then Q.div (Q.of_bigint i1) (Q.of_bigint i2) + else Errors.raise_error "division by zero at runtime" -let ( -$ ) (_m1 : money) (_m2 : money) : money = assert false +let ( +$ ) (i1 : money) (i2 : money) : money = Z.add i1 i2 -let ( <=$ ) (_m1 : money) (_m2 : money) : bool = assert false +let ( -$ ) (i1 : money) (i2 : money) : money = Z.sub i1 i2 -let ( >=! ) (_m1 : integer) (_m2 : integer) : bool = assert false +let ( ~-$ ) (i1 : money) : money = Z.sub Z.zero i1 + +let ( +! ) (i1 : integer) (i2 : integer) : integer = Z.add i1 i2 + +let ( -! ) (i1 : integer) (i2 : integer) : integer = Z.sub i1 i2 + +let ( ~-! ) (i1 : integer) : integer = Z.sub Z.zero i1 + +let ( *! ) (i1 : integer) (i2 : integer) : integer = Z.mul i1 i2 + +let ( /! ) (i1 : integer) (i2 : integer) : integer = + if i2 <> Z.zero then Z.div i1 i2 else Errors.raise_error "division by zero at runtime" + +let ( +. ) (i1 : decimal) (i2 : decimal) : decimal = Q.add i1 i2 + +let ( -. ) (i1 : decimal) (i2 : decimal) : decimal = Q.sub i1 i2 + +let ( ~-. ) (i1 : decimal) : decimal = Q.sub Q.zero i1 + +let ( *. ) (i1 : decimal) (i2 : decimal) : decimal = Q.mul i1 i2 + +let ( /. ) (i1 : decimal) (i2 : decimal) : decimal = + if i2 <> Q.zero then Q.div i1 i2 else Errors.raise_error "division by zero at runtime" + +let ( +@ ) (d1 : date) (d2 : duration) : date = CalendarLib.Date.add d1 d2 + +let ( -@ ) (d1 : date) (d2 : date) : duration = CalendarLib.Date.sub d1 d2 + +let ( +^ ) (d1 : duration) (d2 : duration) : duration = CalendarLib.Date.Period.add d1 d2 + +let ( -^ ) (d1 : duration) (d2 : duration) : duration = CalendarLib.Date.Period.sub d1 d2 + +let ( <=$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 <= 0 + +let ( >=$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 >= 0 + +let ( <$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 < 0 + +let ( >$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 > 0 + +let ( >=! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 >= 0 + +let ( <=! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 <= 0 + +let ( >! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 > 0 + +let ( =@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 >= 0 + +let ( <=@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 <= 0 + +let ( >@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 > 0 + +let ( <@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 < 0 + +let compare_periods (p1 : CalendarLib.Date.Period.t) (p2 : CalendarLib.Date.Period.t) : int = + try + let p1_days = CalendarLib.Date.Period.nb_days p1 in + let p2_days = CalendarLib.Date.Period.nb_days p2 in + compare p1_days p2_days + with CalendarLib.Date.Period.Not_computable -> + Errors.raise_error + "Cannot compare together durations that cannot be converted to a precise number of days" + +let ( >=^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 >= 0 + +let ( <=^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 <= 0 + +let ( >^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 > 0 + +let ( <^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 < 0 + +let array_filter (f : 'a -> bool) (a : 'a array) : 'a array = + Array.of_list (List.filter f (Array.to_list a)) + +let array_length (a : 'a array) : integer = Z.of_int (Array.length a) + +let get_year (d : date) : integer = Z.of_int (CalendarLib.Date.year d) + +let get_month (d : date) = Z.of_int (CalendarLib.Date.int_of_month (CalendarLib.Date.month d)) + +let get_day (d : date) = Z.of_int (CalendarLib.Date.day_of_month d)