Performing nearest rounding for money multiplication

src/catala/catala_surface/desugaring.ml

@@ -68,13 +68,26 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t)
   | Literal l ->
       let untyped_term =
         match l with
-        | Number ((Int i, _), _) -> Scopelang.Ast.ELit (Dcalc.Ast.LInt i)
-        | Number ((Dec (i, f), _), _) ->
+        | Number ((Int i, _), None) -> Scopelang.Ast.ELit (Dcalc.Ast.LInt i)
+        | Number ((Int i, _), Some (Percent, _)) ->
+            Scopelang.Ast.ELit (Dcalc.Ast.LRat (Q.div (Q.of_bigint i) (Q.of_int 100)))
+        | Number ((Dec (i, f), _), None) ->
             let digits_f = int_of_float (ceil (float_of_int (Z.log2up f) *. log 2.0 /. log 10.0)) in
             Scopelang.Ast.ELit
               (Dcalc.Ast.LRat
                  Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f))))
+        | Number ((Dec (i, f), _), Some (Percent, _)) ->
+            let digits_f =
+              int_of_float (ceil (float_of_int (Z.log2up f) *. log 2.0 /. log 10.0)) + 2
+              (* because of % *)
+            in
+            Scopelang.Ast.ELit
+              (Dcalc.Ast.LRat
+                 Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f))))
         | Bool b -> Scopelang.Ast.ELit (Dcalc.Ast.LBool b)
+        | MoneyAmount i ->
+            Scopelang.Ast.ELit
+              (Dcalc.Ast.LMoney Z.((i.money_amount_units * of_int 100) + i.money_amount_cents))
         | _ -> Name_resolution.raise_unsupported_feature "literal" pos
       in
       Bindlib.box (untyped_term, pos)

src/catala/default_calculus/interpreter.ml

@@ -48,6 +48,26 @@ let evaluate_operator (op : A.operator Pos.marked) (args : A.expr Pos.marked lis
               (Some "The division operator:", Pos.get_position op);
               (Some "The null denominator:", Pos.get_position (List.nth args 2));
             ]
+    | A.Binop (A.Add KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] ->
+        A.ELit (LMoney (Z.add i1 i2))
+    | A.Binop (A.Sub KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] ->
+        A.ELit (LMoney (Z.sub i1 i2))
+    | A.Binop (A.Mult KMoney), [ ELit (LMoney i1); ELit (LRat i2) ] ->
+        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 !*)
+        let out =
+          if Z.(of_int 2 * remainder >= Q.den rat_result) then Z.add res (Z.of_int 1) else res
+        in
+        A.ELit (LMoney out)
+    | A.Binop (A.Div KMoney), [ ELit (LMoney i1); ELit (LMoney i2) ] ->
+        if i2 <> Z.zero then A.ELit (LRat (Q.div (Q.of_bigint i1) (Q.of_bigint i2)))
+        else
+          Errors.raise_multispanned_error "division by zero at runtime"
+            [
+              (Some "The division operator:", Pos.get_position op);
+              (Some "The null denominator:", Pos.get_position (List.nth args 2));
+            ]
     | A.Binop (A.Lt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 < i2))
     | A.Binop (A.Lte KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 <= i2))
     | A.Binop (A.Gt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 > i2))

src/catala/default_calculus/print.ml

@@ -83,21 +83,23 @@ let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
         else "" )
   | LMoney e -> Format.fprintf fmt "$%.2f" Q.(to_float (of_bigint e / of_int 100))
 
+let format_op_kind (fmt : Format.formatter) (k : op_kind) =
+  Format.fprintf fmt "%s" (match k with KInt -> "" | KRat -> "." | KMoney -> "$")
+
 let format_binop (fmt : Format.formatter) (op : binop Pos.marked) : unit =
-  Format.fprintf fmt "%s"
-    ( match Pos.unmark op with
-    | Add _ -> "+"
-    | Sub _ -> "-"
-    | Mult _ -> "*"
-    | Div _ -> "/"
-    | And -> "&&"
-    | Or -> "||"
-    | Eq -> "=="
-    | Neq -> "!="
-    | Lt _ -> "<"
-    | Lte _ -> "<="
-    | Gt _ -> ">"
-    | Gte _ -> ">=" )
+  match Pos.unmark op with
+  | Add k -> Format.fprintf fmt "+%a" format_op_kind k
+  | Sub k -> Format.fprintf fmt "-%a" format_op_kind k
+  | Mult k -> Format.fprintf fmt "*%a" format_op_kind k
+  | Div k -> Format.fprintf fmt "/%a" format_op_kind k
+  | And -> Format.fprintf fmt "%s" "&&"
+  | Or -> Format.fprintf fmt "%s" "||"
+  | Eq -> Format.fprintf fmt "%s" "=="
+  | Neq -> Format.fprintf fmt "%s" "!="
+  | Lt _ -> Format.fprintf fmt "%s" "<"
+  | Lte _ -> Format.fprintf fmt "%s" "<="
+  | Gt _ -> Format.fprintf fmt "%s" ">"
+  | Gte _ -> Format.fprintf fmt "%s" ">="
 
 let format_unop (fmt : Format.formatter) (op : unop Pos.marked) : unit =
   Format.fprintf fmt "%s"

src/catala/default_calculus/typing.ml

@@ -84,7 +84,9 @@ let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem =
   | A.Binop (A.And | A.Or) -> arr bt (arr bt bt)
   | A.Binop (A.Add KInt | A.Sub KInt | A.Mult KInt | A.Div KInt) -> arr it (arr it it)
   | A.Binop (A.Add KRat | A.Sub KRat | A.Mult KRat | A.Div KRat) -> arr rt (arr rt rt)
-  | A.Binop (A.Add KMoney | A.Sub KMoney | A.Mult KMoney | A.Div KMoney) -> arr mt (arr mt mt)
+  | A.Binop (A.Add KMoney | A.Sub KMoney) -> arr mt (arr mt mt)
+  | A.Binop (A.Div KMoney) -> arr mt (arr mt rt)
+  | A.Binop (A.Mult KMoney) -> arr mt (arr rt mt)
   | A.Binop (A.Lt KInt | A.Lte KInt | A.Gt KInt | A.Gte KInt) -> arr it (arr it bt)
   | A.Binop (A.Lt KRat | A.Lte KRat | A.Gt KRat | A.Gte KRat) -> arr rt (arr rt bt)
   | A.Binop (A.Lt KMoney | A.Lte KMoney | A.Gt KMoney | A.Gte KMoney) -> arr mt (arr mt bt)
@@ -184,7 +186,8 @@ let rec typecheck_expr_bottom_up (env : env) (e : A.expr Pos.marked) : typ Pos.m
         let xstaus = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
         let env =
           List.fold_left
-            (fun env (x, tau) -> A.VarMap.add x (ast_to_typ (Pos.unmark tau), pos_binder) env)
+            (fun env (x, tau) ->
+              A.VarMap.add x (ast_to_typ (Pos.unmark tau), Pos.get_position tau) env)
             env xstaus
         in
         List.fold_right

tests/README.md

@@ -6,6 +6,8 @@ It uses `make` to launch tests and compare the test terminal output with an expe
 
 When you create a new test, please register it in the `Makefile` following the other examples. Expected outputs are stored using the convention `<name_of_test>.catala.<name_of_scope>.out` in the corresponding test folder.
 
+For both workflows: use `CATALA_OPTS="..." make ...` to pass in Catala compiler
+options when debugging.
 
 ## Workflow for adding new tests
 

tests/test_money/simple.catala

@@ -0,0 +1,13 @@
+@Article@
+
+/*
+new scope A:
+  param x content amount
+  param y content amount 
+  param z content amount
+
+scope A:
+  def x := $123.54
+  def y := $8548,650.96
+  def z := $250,000,000 *$ ((x /$ y) *. 0.2 %)
+*/

tests/test_money/simple.catala.A.out

@@ -0,0 +1,3 @@
+[RESULT] x -> $123.54
+[RESULT] y -> $8548650.96
+[RESULT] z -> $7.23