Add a duration / duration overload

Interstingly enough, it was already implemented in the Python backend. Required to implement *pro rata temporis*, which the US tax section 121 does make use of. Only allowed for durations expressed in days (as returned by `<date> - <date>`), of course.
2024-11-08 07:51:43 +03:00 · 2023-03-06 10:54:51 +01:00 · 2023-03-06 10:54:51 +01:00 · 42b8adb968
commit 42b8adb968
parent 56ac72f57e
6 changed files with 35 additions and 15 deletions
--- a/compiler/dcalc/interpreter.ml
+++ b/compiler/dcalc/interpreter.ml
@ -260,6 +260,8 @@ and evaluate_operator :
            LRat (protect o_div_mon_mon x y)
          | Div_mon_rat, [LMoney x; LRat y] ->
            LMoney (protect o_div_mon_rat x y)
+          | Div_dur_dur, [LDuration x; LDuration y] ->
+            LRat (protect o_div_dur_dur x y)
          | Lt_int_int, [LInt x; LInt y] -> LBool (o_lt_int_int x y)
          | Lt_rat_rat, [LRat x; LRat y] -> LBool (o_lt_rat_rat x y)
          | Lt_mon_mon, [LMoney x; LMoney y] -> LBool (o_lt_mon_mon x y)
@ -296,13 +298,13 @@ and evaluate_operator :
              | 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 | 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
-                ),
+              | 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 ),
              _ ) ->
            err ()
        in
--- a/compiler/shared_ast/definitions.ml
+++ b/compiler/shared_ast/definitions.ml
@ -181,6 +181,7 @@ module Op = struct
    | Div_rat_rat : ([< scopelang | dcalc | lcalc ], resolved) t
    | Div_mon_rat : ([< scopelang | dcalc | lcalc ], resolved) t
    | Div_mon_mon : ([< scopelang | dcalc | lcalc ], resolved) t
+    | Div_dur_dur : ([< scopelang | dcalc | lcalc ], resolved) t
    | Lt : (desugared, overloaded) t
    | Lt_int_int : ([< scopelang | dcalc | lcalc ], resolved) t
    | Lt_rat_rat : ([< scopelang | dcalc | lcalc ], resolved) t
--- a/compiler/shared_ast/operator.ml
+++ b/compiler/shared_ast/operator.ml
@ -71,6 +71,7 @@ let name : type a k. (a, k) t -> string = function
  | Div_rat_rat -> "o_div_rat_rat"
  | Div_mon_mon -> "o_div_mon_mon"
  | Div_mon_rat -> "o_div_mon_mon"
+  | Div_dur_dur -> "o_div_dur_dur"
  | Lt -> "o_lt"
  | Lt_int_int -> "o_lt_int_int"
  | Lt_rat_rat -> "o_lt_rat_rat"
@ -175,6 +176,7 @@ let compare (type a k a2 k2) (t1 : (a, k) t) (t2 : (a2, k2) t) =
  | Div_rat_rat, Div_rat_rat
  | Div_mon_mon, Div_mon_mon
  | Div_mon_rat, Div_mon_rat
+  | Div_dur_dur, Div_dur_dur
  | Lt, Lt
  | Lt_int_int, Lt_int_int
  | Lt_rat_rat, Lt_rat_rat
@ -257,6 +259,7 @@ let compare (type a k a2 k2) (t1 : (a, k) t) (t2 : (a2, k2) t) =
  | Div_rat_rat, _ -> -1 | _, Div_rat_rat -> 1
  | Div_mon_mon, _ -> -1 | _, Div_mon_mon -> 1
  | Div_mon_rat, _ -> -1 | _, Div_mon_rat -> 1
+  | Div_dur_dur, _ -> -1 | _, Div_dur_dur -> 1
  | Lt, _ -> -1 | _, Lt -> 1
  | Lt_int_int, _ -> -1 | _, Lt_int_int -> 1
  | Lt_rat_rat, _ -> -1 | _, Lt_rat_rat -> 1
@ -316,12 +319,12 @@ let kind_dispatch :
    | 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 | 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 ) as op ->
+    | 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 ) as op ->
    resolved op

 (* Glorified identity... allowed operators are the same in scopelang, dcalc,
@ -377,6 +380,7 @@ let translate :
  | Div_rat_rat -> Div_rat_rat
  | Div_mon_mon -> Div_mon_mon
  | Div_mon_rat -> Div_mon_rat
+  | Div_dur_dur -> Div_dur_dur
  | Lt_int_int -> Lt_int_int
  | Lt_rat_rat -> Lt_rat_rat
  | Lt_mon_mon -> Lt_mon_mon
@ -462,6 +466,7 @@ let resolved_type (op, pos) =
    | Div_rat_rat -> [TRat; TRat], TRat
    | Div_mon_mon -> [TMoney; TMoney], TRat
    | Div_mon_rat -> [TMoney; TRat], TMoney
+    | Div_dur_dur -> [TDuration; TDuration], TRat
    | Lt_int_int -> [TInt; TInt], TBool
    | Lt_rat_rat -> [TRat; TRat], TBool
    | Lt_mon_mon -> [TMoney; TMoney], TBool
@ -524,6 +529,7 @@ let resolve_overload_aux (op : ('a, overloaded) t) (operands : typ_lit list) :
  | Div, [TRat; TRat] -> Div_rat_rat, `Straight
  | Div, [TMoney; TMoney] -> Div_mon_mon, `Straight
  | Div, [TMoney; TRat] -> Div_mon_rat, `Straight
+  | Div, [TDuration; TDuration] -> Div_dur_dur, `Straight
  | Lt, [TInt; TInt] -> Lt_int_int, `Straight
  | Lt, [TRat; TRat] -> Lt_rat_rat, `Straight
  | Lt, [TMoney; TMoney] -> Lt_mon_mon, `Straight
--- a/compiler/shared_ast/print.ml
+++ b/compiler/shared_ast/print.ml
@ -207,6 +207,7 @@ let operator_to_string : type a k. (a, k) Op.t -> string = function
  | Div_rat_rat -> "/."
  | Div_mon_mon -> "/$"
  | Div_mon_rat -> "/$."
+  | Div_dur_dur -> "/^"
  | Lt -> "<"
  | Lt_int_int -> "<!"
  | Lt_rat_rat -> "<."
--- a/runtimes/ocaml/runtime.ml
+++ b/runtimes/ocaml/runtime.ml
@ -36,7 +36,7 @@ exception EmptyError
 exception AssertionFailed of source_position
 exception ConflictError of source_position
 exception UncomparableDurations
-exception IndivisableDurations
+exception IndivisibleDurations
 exception ImpossibleDate
 exception NoValueProvided of source_position

@ -677,6 +677,15 @@ module Oper = struct
  let o_div_mon_rat m1 r1 =
    if Q.zero = r1 then raise Division_by_zero else o_mult_mon_rat m1 (Q.inv r1)

+  let o_div_dur_dur d1 d2 =
+    let i1, i2 =
+      try
+        ( integer_of_int (Dates_calc.Dates.period_to_days d1),
+          integer_of_int (Dates_calc.Dates.period_to_days d2) )
+      with Dates_calc.Dates.AmbiguousComputation -> raise IndivisibleDurations
+    in
+    o_div_int_int i1 i2
+
  let o_lt_int_int i1 i2 = Z.compare i1 i2 < 0
  let o_lt_rat_rat i1 i2 = Q.compare i1 i2 < 0
  let o_lt_mon_mon m1 m2 = Z.compare m1 m2 < 0
--- a/runtimes/ocaml/runtime.mli
+++ b/runtimes/ocaml/runtime.mli
@ -43,7 +43,7 @@ exception EmptyError
 exception AssertionFailed of source_position
 exception ConflictError of source_position
 exception UncomparableDurations
-exception IndivisableDurations
+exception IndivisibleDurations
 exception ImpossibleDate
 exception NoValueProvided of source_position

@ -330,6 +330,7 @@ module Oper : sig
  val o_div_rat_rat : decimal -> decimal -> decimal
  val o_div_mon_mon : money -> money -> decimal
  val o_div_mon_rat : money -> decimal -> money
+  val o_div_dur_dur : duration -> duration -> decimal
  val o_lt_int_int : integer -> integer -> bool
  val o_lt_rat_rat : decimal -> decimal -> bool
  val o_lt_mon_mon : money -> money -> bool