diff --git a/runtimes/r/runtime.R b/runtimes/r/runtime.R index 54c79176..8fff4997 100644 --- a/runtimes/r/runtime.R +++ b/runtimes/r/runtime.R @@ -12,10 +12,6 @@ setMethod("Ops", "catala_integer", function(e1, e2) { new("catala_integer", v = v) }) -as.catala_integer <- function(x) { - catala_integer(v = as.bigz(x)) -} - ################ Decimals ################# catala_decimal <- setClass( @@ -26,12 +22,6 @@ setMethod("Ops", "catala_decimal", function(e1, e2) { v <- callGeneric(e1@v, e2@v) new("catala_decimal", v = v) }) -as.catala_decimal <- function(x) { - catala_decimal(v = as.bigq(x)) -} - - - ################ Money ################# catala_money <- setClass( @@ -54,12 +44,6 @@ setMethod("Compare", "catala_money", function(e1, e2) { v <- callGeneric(e1@v, e2@v) new("catala_money", v = v) }) -as.catala_money_units <- function(x) { - catala_money(v = as.bigz(x) * as.bigz(100)) -} -as.catala_money_cents <- function(x) { - catala_money(v = as.bigz(x)) -} ################ Duration ################# catala_duration <- suppressWarnings(setClass( @@ -79,9 +63,10 @@ setMethod("Compare", "catala_duration", function(e1, e2) { v <- callGeneric(e1@v, e2@v) new("catala_duration", v = v) }) -as.catala_duration_ymd <- function(y, m, d) { - catala_duration(v = years(y) + months(m) + days(d)) -} + + +# TODO: port the dates_calc library to R to make date computations +# more robust. ################ Dates ################# catala_date <- setClass( @@ -98,11 +83,136 @@ setMethod("Compare", "catala_date", function(e1, e2) { v <- callGeneric(e1@v, e2@v) new("catala_date", v = v) }) -as.catala_date_ymd <- function(y, m, d) { + +################ Unit ################# + +catala_unit <- setClass("catala_unit") + +################ Constructors and conversions ################# + +# Money + +catala_money_from_units <- function(x) { + catala_money(v = as.bigz(x) * as.bigz(100)) +} +catala_money_from_cents <- function(x) { + catala_money(v = as.bigz(x)) +} +catala_money_from_decimal <- function(d) { + num_cents_q <- abs(d@v * as.bigq(100)) + unit_part_num_cents_z <- as.bigz(num_cents_q) + remainder_q <- num_cents_q - as.bigq(unit_part_num_cents_z) + if (remainder_q < as.bigq(0.5)) { + catala_money(v = as.bigz(sign(d@v)) * unit_part_num_cents_z) + } else { + catala_money(v = as.bigz(sign(d@v)) * (unit_part_num_cents_z + as.bigz(1))) + } +} +catala_money_to_numeric <- function(m) { + as.numeric(as.bigq(m@v) / as.bigq(100)) +} +catala_money_to_string <- function(m) { + paste0("$", catala_money_to_numeric(m)) +} +catala_money_round <- function(m) { + q <- abs(m@v) %/% as.bigz(100) + r <- abs(m@v) %% as.bigz(100) + if (abs(r) < 50) { + catala_money(v = sign(m@v) * q * as.bigz(100)) + } else { + catala_money(v = sign(m@v) * (q + 1) * as.bigz(100)) + } +} + + +# Decimals + +catala_decimal_from_numeric <- function(x) { + catala_decimal(v = as.bigq(x)) +} + +catala_decimal_from_string <- function(x) { + catala_decimal(v = as.bigq(x)) +} + +catala_decimal_from_integer <- function(x) { + catala_decimal(v = as.bigq(x@v)) +} + +catala_decimal_to_numeric <- function(x) { + as.numeric(x@v) +} +catala_decimal_round <- function(d) { + q <- abs(as.bigq(as.bigz(d@v))) + r <- abs(d@v) - as.bigq(q) + if (r < as.bigq(0.5)) { + catala_decimal(v = sign(d@v) * q) + } else { + catala_decimal(v = sign(d@v) * (q + as.bigq(1))) + } +} +catala_decimal_from_money <- function(m) { + catala_decimal(v = as.bigq(as.bigq(m@v) / as.bigq(100))) +} + +# Integers + +catala_integer_from_numeric <- function(x) { + catala_integer(v = as.bigz(x)) +} +catala_integer_from_string <- function(x) { + catala_integer(v = as.bigz(x)) +} +catala_integer_to_numeric <- function(x) { + as.numeric(x@v) +} + +# Dates + +catala_date_from_ymd <- function(y, m, d) { catala_date(v = make_date(year = y, month = m, day = d)) } -################ Lists ################# +catala_day_of_month_of_date <- function(d) { + mday(d@v) +} + +catala_month_number_of_date <- function(d) { + month(d@v) +} + +catala_year_of_date <- function(d) { + year(d@v) +} + +catala_date_to_string <- function(d) { + paste0(d@v) +} + +catala_date_first_day_of_month <- function(d) { + catala_date(v = make_date(year = year(d@v), month = month(d@v), day = 1)) +} + +catala_date_last_day_of_month <- function(d) { + catala_date(v = make_date( + year = year(d@v), + month = month(d@v), + day = days_in_month(d@v) + )) +} + + +# Durations + +catala_duration_from_ymd <- function(y, m, d) { + catala_duration(v = years(y) + months(m) + days(d)) +} + +catala_duration_to_ymd <- function(d) { + c(d@v@year, d@v@month, d@v@day) +} + +# List catala_list_fold_left <- function(f, init, l) { Reduce(f, l, init) @@ -124,7 +234,11 @@ catala_list_reduce <- function(f, default, l) { } } -################ Defaults ################# +catala_list_length <- function(l) { + catala_integer_from_numeric(length(l)) +} + +################ Exceptions ################# catala_position <- setClass( "catala_position", @@ -171,7 +285,14 @@ catala_no_value_provided_error <- function(pos) { ) } -catala_unit <- setClass("catala_unit") +catala_assertion_failure <- function(pos) { + structure( + class = c("catala_assertion_failure", "error", "condition"), + list(message = catala_position_to_string(pos), call = sys.call(-1)) + ) +} + +################ Defaults ################# catala_handle_default <- function(pos, exceptions, just, cons) { acc <- Reduce(function(acc, exception) {