Benchmarked the result on allocations familiales, it is fast enough

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

dune-project

@@ -35,6 +35,7 @@
    (ocamlgraph (>= 1.8.8))
    (calendar (>= 2.04))
    (visitors (>= 20200210))
+   (benchmark (>= 1.6))
  )
 )
 

examples/Makefile.common.mk

@@ -35,7 +35,6 @@ endif
 	@$(CATALA) Makefile $<
 	@$(CATALA) \
 		OCaml \
-		-s $(SCOPE) \
 		$<
 
 

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 

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€
 */

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"

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
+          match (ex_scope, backend) with
-          | None -> Errors.raise_error "No scope was provided for execution."
+          | None, Cli.Run -> Errors.raise_error "No scope was provided for execution."
-          | Some name -> (
+          | 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

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))

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)
+  | LDate d ->
-  | LDuration d -> Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LDuration d) l)
+      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"
+  | Map -> Format.fprintf fmt "Array.map"
-  | Filter -> Format.fprintf fmt "List.filter"
+  | 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
-    ( match Pos.unmark op with
+  | Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
-    | Minus _ -> "-"
+  | Not -> Format.fprintf fmt "%s" "not"
-    | Not -> "not"
+  | ErrorOnEmpty -> Format.fprintf fmt "%s" "error_empty"
-    | ErrorOnEmpty -> "error_empty"
+  | Log (entry, infos) ->
-    | Log (entry, infos) ->
+      Format.fprintf fmt "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry
-        Format.asprintf "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry
+        (Format.pp_print_list
-          (Format.pp_print_list
+           ~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
-             ~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
+           (fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
-             (fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
+        infos
-          infos
+  | Length -> Format.fprintf fmt "%s" "array_length"
-    | Length -> "length"
+  | IntToRat -> Format.fprintf fmt "%s" "int_to_rat"
-    | IntToRat -> "int_to_rat"
+  | GetDay -> Format.fprintf fmt "%s" "get_day"
-    | GetDay -> "get_day"
+  | GetMonth -> Format.fprintf fmt "%s" "get_month"
-    | GetMonth -> "get_month"
+  | GetYear -> Format.fprintf fmt "%s" "get_year"
-    | GetYear -> "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 "@[<hov 2>[%a]@]"
+      Format.fprintf fmt "@[<hov 2>[|%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 "@[<hov 2>%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 "@[<hov 2>%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 "@[<hov 2>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 =
+let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Format.formatter)
-  Format.fprintf fmt "%a\n\n%a"
+    (ctx : D.decl_ctx) : unit =
-    (Format.pp_print_list
+  let format_struct_decl fmt (struct_name, struct_fields) =
-       ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
+    Format.fprintf fmt "type %a = {@\n@[<hov 2>  %a@]@\n}" format_struct_name struct_name
-       (fun fmt (struct_name, struct_fields) ->
+      (Format.pp_print_list
-         Format.fprintf fmt "type %a = {@\n@[<hov 2>  %a@]@\n}" format_struct_name struct_name
+         ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
-           (Format.pp_print_list
+         (fun _fmt (struct_field, struct_field_type) ->
-              ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
+           Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ
-              (fun _fmt (struct_field, struct_field_type) ->
+             struct_field_type))
-                Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ
+      struct_fields
-                  struct_field_type))
+  in
-           struct_fields))
+  let format_enum_decl fmt (enum_name, enum_cons) =
-    (Dcalc.Ast.StructMap.bindings ctx.Dcalc.Ast.ctx_structs)
+    Format.fprintf fmt "type %a =@\n@[<hov 2>  %a@]@\n" format_enum_name enum_name
-    (Format.pp_print_list
+      (Format.pp_print_list
-       ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
+         ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
-       (fun _fmt (enum_name, enum_cons) ->
+         (fun _fmt (enum_cons, enum_cons_type) ->
-         Format.fprintf fmt "type %a =@\n@[<hov 2>  %a@]@\n" format_enum_name enum_name
+           Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ
-           (Format.pp_print_list
+             enum_cons_type))
-              ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
+      enum_cons
-              (fun _fmt (enum_cons, enum_cons_type) ->
+  in
-                Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ
+  List.iter
-                  enum_cons_type))
+    (fun struct_or_enum ->
-           enum_cons))
+      match struct_or_enum with
-    (List.filter
+      | Scopelang.Dependency.TVertex.Struct s ->
-       (* option is a polymorphic type which we don't handle well... *)
+          Format.fprintf fmt "%a@\n@\n" format_struct_decl
-         (fun (e, _) -> e <> Compile_with_exceptions.option_enum)
+            (s, Dcalc.Ast.StructMap.find s ctx.Dcalc.Ast.ctx_structs)
-       (Dcalc.Ast.EnumMap.bindings ctx.Dcalc.Ast.ctx_enums))
+      | 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 =
+let format_program (fmt : Format.formatter) (p : Ast.program)
-  Format.fprintf fmt "open Runtime@\n@\n[@@@@@@ocaml.warning \"-26\"]@\n@\n%a@\n@\n%a" format_ctx
+    (type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
-    p.decl_ctx
+  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) ->

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 [])

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)

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
+  ()

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))

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 =
+let duration_of_numbers (year : int) (month : int) (day : int) : duration =
- fun msg arg ->
+  CalendarLib.Date.Period.make year month day
-  Printf.printf "%s\n" msg;
+
-  arg
+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 ( <! ) (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)