mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Remove the R backend (#643)
This commit is contained in:
Denis Merigoux
GitHub
commit
6e5e99a60a
@ -928,31 +928,6 @@ module Commands = struct
|
||||
$ Cli.Flags.check_invariants
|
||||
$ Cli.Flags.closure_conversion)
|
||||
|
||||
let r options includes output optimize check_invariants closure_conversion =
|
||||
let prg, type_ordering =
|
||||
Passes.scalc options ~includes ~optimize ~check_invariants
|
||||
~closure_conversion ~keep_special_ops:false ~dead_value_assignment:false
|
||||
~no_struct_literals:false ~monomorphize_types:false
|
||||
in
|
||||
|
||||
let output_file, with_output = get_output_format options ~ext:".r" output in
|
||||
Message.debug "Compiling program into R...";
|
||||
Message.debug "Writing to %s..."
|
||||
(Option.value ~default:"stdout" output_file);
|
||||
with_output @@ fun fmt -> Scalc.To_r.format_program fmt prg type_ordering
|
||||
|
||||
let r_cmd =
|
||||
Cmd.v
|
||||
(Cmd.info "r" ~doc:"Generates an R translation of the Catala program.")
|
||||
Term.(
|
||||
const r
|
||||
$ Cli.Flags.Global.options
|
||||
$ Cli.Flags.include_dirs
|
||||
$ Cli.Flags.output
|
||||
$ Cli.Flags.optimize
|
||||
$ Cli.Flags.check_invariants
|
||||
$ Cli.Flags.closure_conversion)
|
||||
|
||||
let c options includes output optimize check_invariants =
|
||||
let prg, type_ordering =
|
||||
Passes.scalc options ~includes ~optimize ~check_invariants
|
||||
@ -1071,7 +1046,6 @@ module Commands = struct
|
||||
proof_cmd;
|
||||
ocaml_cmd;
|
||||
python_cmd;
|
||||
r_cmd;
|
||||
c_cmd;
|
||||
latex_cmd;
|
||||
html_cmd;
|
||||
|
||||
@ -1,567 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
open Catala_utils
|
||||
open Shared_ast
|
||||
open Ast
|
||||
module Runtime = Runtime_ocaml.Runtime
|
||||
module D = Dcalc.Ast
|
||||
module L = Lcalc.Ast
|
||||
|
||||
let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
|
||||
match Mark.remove l with
|
||||
| LBool true -> Format.pp_print_string fmt "TRUE"
|
||||
| LBool false -> Format.pp_print_string fmt "FALSE"
|
||||
| LInt i ->
|
||||
if Z.fits_nativeint i then
|
||||
Format.fprintf fmt "catala_integer_from_numeric(%s)"
|
||||
(Runtime.integer_to_string i)
|
||||
else
|
||||
Format.fprintf fmt "catala_integer_from_string(\"%s\")"
|
||||
(Runtime.integer_to_string i)
|
||||
| LUnit -> Format.pp_print_string fmt "new(\"catala_unit\",v=0)"
|
||||
| LRat i ->
|
||||
Format.fprintf fmt "catala_decimal_from_fraction(%s,%s)"
|
||||
(if Z.fits_nativeint (Q.num i) then Z.to_string (Q.num i)
|
||||
else "\"" ^ Z.to_string (Q.num i) ^ "\"")
|
||||
(if Z.fits_nativeint (Q.den i) then Z.to_string (Q.den i)
|
||||
else "\"" ^ Z.to_string (Q.den i) ^ "\"")
|
||||
| LMoney e ->
|
||||
if Z.fits_nativeint e then
|
||||
Format.fprintf fmt "catala_money_from_cents(%s)"
|
||||
(Runtime.integer_to_string (Runtime.money_to_cents e))
|
||||
else
|
||||
Format.fprintf fmt "catala_money_from_cents(\"%s\")"
|
||||
(Runtime.integer_to_string (Runtime.money_to_cents e))
|
||||
| LDate d ->
|
||||
Format.fprintf fmt "catala_date_from_ymd(%d,%d,%d)"
|
||||
(Runtime.integer_to_int (Runtime.year_of_date d))
|
||||
(Runtime.integer_to_int (Runtime.month_number_of_date d))
|
||||
(Runtime.integer_to_int (Runtime.day_of_month_of_date d))
|
||||
| LDuration d ->
|
||||
let years, months, days = Runtime.duration_to_years_months_days d in
|
||||
Format.fprintf fmt "catala_duration_from_ymd(%d,%d,%d)" years months days
|
||||
|
||||
let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
|
||||
match Mark.remove op with
|
||||
| Log (_entry, _infos) -> assert false
|
||||
| Minus_int | Minus_rat | Minus_mon | Minus_dur ->
|
||||
Format.pp_print_string fmt "-"
|
||||
(* Todo: use the names from [Operator.name] *)
|
||||
| Not -> Format.pp_print_string fmt "!"
|
||||
| Length -> Format.pp_print_string fmt "catala_list_length"
|
||||
| ToRat_int -> Format.pp_print_string fmt "catala_decimal_from_integer"
|
||||
| ToRat_mon -> Format.pp_print_string fmt "catala_decimal_from_money"
|
||||
| ToMoney_rat -> Format.pp_print_string fmt "catala_money_from_decimal"
|
||||
| GetDay -> Format.pp_print_string fmt "catala_day_of_month_of_date"
|
||||
| GetMonth -> Format.pp_print_string fmt "catala_month_number_of_date"
|
||||
| GetYear -> Format.pp_print_string fmt "catala_year_of_date"
|
||||
| FirstDayOfMonth ->
|
||||
Format.pp_print_string fmt "catala_date_first_day_of_month"
|
||||
| LastDayOfMonth -> Format.pp_print_string fmt "catala_date_last_day_of_month"
|
||||
| Round_mon -> Format.pp_print_string fmt "catala_money_round"
|
||||
| Round_rat -> Format.pp_print_string fmt "catala_decimal_round"
|
||||
| Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _ | Add_dur_dur
|
||||
| Concat ->
|
||||
Format.pp_print_string fmt "+"
|
||||
| Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur
|
||||
| Sub_dur_dur ->
|
||||
Format.pp_print_string fmt "-"
|
||||
| Mult_int_int | Mult_rat_rat | Mult_mon_rat | Mult_dur_int ->
|
||||
Format.pp_print_string fmt "*"
|
||||
| Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur ->
|
||||
Format.pp_print_string fmt "/"
|
||||
| And -> Format.pp_print_string fmt "&&"
|
||||
| Or -> Format.pp_print_string fmt "||"
|
||||
| Eq -> Format.pp_print_string fmt "=="
|
||||
| Xor -> Format.pp_print_string fmt "!="
|
||||
| Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur ->
|
||||
Format.pp_print_string fmt "<"
|
||||
| Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur ->
|
||||
Format.pp_print_string fmt "<="
|
||||
| Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur ->
|
||||
Format.pp_print_string fmt ">"
|
||||
| Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur ->
|
||||
Format.pp_print_string fmt ">="
|
||||
| Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur ->
|
||||
Format.pp_print_string fmt "=="
|
||||
| Map -> Format.pp_print_string fmt "catala_list_map"
|
||||
| Map2 -> Format.pp_print_string fmt "catala_list_map2"
|
||||
| Reduce -> Format.pp_print_string fmt "catala_list_reduce"
|
||||
| Filter -> Format.pp_print_string fmt "catala_list_filter"
|
||||
| Fold -> Format.pp_print_string fmt "catala_list_fold_left"
|
||||
| HandleExceptions | FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
|
||||
|
||||
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
||||
let sanitize_quotes = Re.compile (Re.char '"') in
|
||||
Format.fprintf fmt "c(%a)"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(fun fmt info ->
|
||||
Format.fprintf fmt "\"%s\""
|
||||
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
|
||||
uids
|
||||
|
||||
let avoid_keywords (s : string) : string =
|
||||
if
|
||||
match s with
|
||||
(* list taken from
|
||||
https://cran.r-project.org/doc/manuals/r-release/R-lang.html#Reserved-words *)
|
||||
| "if" | "else" | "repeat" | "while" | "function" | "for" | "in" | "next"
|
||||
| "break" | "TRUE" | "FALSE" | "NULL" | "Inf" | "NaN" | "NA" | "NA_integer_"
|
||||
| "NA_real_" | "NA_complex_" | "NA_character_"
|
||||
(* additions of things that are not keywords but that we should not
|
||||
overwrite*)
|
||||
| "list" | "c" | "character" | "logical" | "complex" | "setClass" | "new" ->
|
||||
true
|
||||
| _ -> false
|
||||
then s ^ "_"
|
||||
else s
|
||||
|
||||
let format_struct_name (fmt : Format.formatter) (v : StructName.t) : unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords
|
||||
(String.to_camel_case
|
||||
(String.to_ascii (Format.asprintf "%a" StructName.format v))))
|
||||
|
||||
let format_struct_field_name (fmt : Format.formatter) (v : StructField.t) : unit
|
||||
=
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords
|
||||
(String.to_ascii (Format.asprintf "%a" StructField.format v)))
|
||||
|
||||
let format_enum_name (fmt : Format.formatter) (v : EnumName.t) : unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords
|
||||
(String.to_camel_case
|
||||
(String.to_ascii (Format.asprintf "%a" EnumName.format v))))
|
||||
|
||||
let format_enum_cons_name (fmt : Format.formatter) (v : EnumConstructor.t) :
|
||||
unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords
|
||||
(String.to_ascii (Format.asprintf "%a" EnumConstructor.format v)))
|
||||
|
||||
let rec format_typ ~inside_comment (fmt : Format.formatter) (typ : typ) : unit =
|
||||
let format_typ = format_typ in
|
||||
match Mark.remove typ with
|
||||
| TLit TUnit -> Format.fprintf fmt "\"catala_unit\""
|
||||
| TLit TMoney -> Format.fprintf fmt "\"catala_money\""
|
||||
| TLit TInt -> Format.fprintf fmt "\"catala_integer\""
|
||||
| TLit TRat -> Format.fprintf fmt "\"catala_decimal\""
|
||||
| TLit TDate -> Format.fprintf fmt "\"catala_date\""
|
||||
| TLit TDuration -> Format.fprintf fmt "\"catala_duration\""
|
||||
| TLit TBool -> Format.fprintf fmt "\"logical\""
|
||||
| TTuple ts ->
|
||||
Format.fprintf fmt "\"list\"@ # tuple(%a)%t"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@;")
|
||||
(format_typ ~inside_comment:true))
|
||||
ts
|
||||
(fun fmt -> if inside_comment then () else Format.pp_force_newline fmt ())
|
||||
| TStruct s -> Format.fprintf fmt "\"catala_struct_%a\"" format_struct_name s
|
||||
| TOption some_typ | TDefault some_typ ->
|
||||
(* We loose track of optional value as they're crammed into NULL *)
|
||||
format_typ ~inside_comment:false fmt some_typ
|
||||
| TEnum e -> Format.fprintf fmt "\"catala_enum_%a\"" format_enum_name e
|
||||
| TArrow (t1, t2) ->
|
||||
Format.fprintf fmt "\"function\" # %a -> %a%t"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
|
||||
(format_typ ~inside_comment:true))
|
||||
t1
|
||||
(format_typ ~inside_comment:true)
|
||||
t2
|
||||
(fun fmt -> if inside_comment then () else Format.pp_force_newline fmt ())
|
||||
| TArray t1 ->
|
||||
Format.fprintf fmt "\"list\" # array(%a)%t"
|
||||
(format_typ ~inside_comment:true) t1 (fun fmt ->
|
||||
if inside_comment then () else Format.pp_force_newline fmt ())
|
||||
| TAny -> Format.fprintf fmt "\"ANY\""
|
||||
| TClosureEnv -> failwith "unimplemented!"
|
||||
|
||||
let format_name_cleaned (fmt : Format.formatter) (s : string) : unit =
|
||||
s
|
||||
|> String.to_ascii
|
||||
|> String.to_snake_case
|
||||
|> Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_")
|
||||
|> String.to_ascii
|
||||
|> avoid_keywords
|
||||
|> Format.fprintf fmt "%s"
|
||||
|
||||
module StringMap = String.Map
|
||||
|
||||
module IntMap = Map.Make (struct
|
||||
include Int
|
||||
|
||||
let format ppf i = Format.pp_print_int ppf i
|
||||
end)
|
||||
|
||||
(** For each `VarName.t` defined by its string and then by its hash, we keep
|
||||
track of which local integer id we've given it. This is used to keep
|
||||
variable naming with low indices rather than one global counter for all
|
||||
variables. TODO: should be removed when
|
||||
https://github.com/CatalaLang/catala/issues/240 is fixed. *)
|
||||
let string_counter_map : int IntMap.t StringMap.t ref = ref StringMap.empty
|
||||
|
||||
let format_var (fmt : Format.formatter) (v : VarName.t) : unit =
|
||||
let v_str = Mark.remove (VarName.get_info v) in
|
||||
let id = VarName.id v in
|
||||
let local_id =
|
||||
match StringMap.find_opt v_str !string_counter_map with
|
||||
| Some ids -> (
|
||||
match IntMap.find_opt id ids with
|
||||
| None ->
|
||||
let max_id =
|
||||
snd
|
||||
(List.hd
|
||||
(List.fast_sort
|
||||
(fun (_, x) (_, y) -> Int.compare y x)
|
||||
(IntMap.bindings ids)))
|
||||
in
|
||||
string_counter_map :=
|
||||
StringMap.add v_str
|
||||
(IntMap.add id (max_id + 1) ids)
|
||||
!string_counter_map;
|
||||
max_id + 1
|
||||
| Some local_id -> local_id)
|
||||
| None ->
|
||||
string_counter_map :=
|
||||
StringMap.add v_str (IntMap.singleton id 0) !string_counter_map;
|
||||
0
|
||||
in
|
||||
if v_str = "_" then Format.fprintf fmt "dummy_var"
|
||||
(* special case for the unit pattern TODO escape dummy_var *)
|
||||
else if local_id = 0 then format_name_cleaned fmt v_str
|
||||
else Format.fprintf fmt "%a_%d" format_name_cleaned v_str local_id
|
||||
|
||||
let format_func_name (fmt : Format.formatter) (v : FuncName.t) : unit =
|
||||
let v_str = Mark.remove (FuncName.get_info v) in
|
||||
format_name_cleaned fmt v_str
|
||||
|
||||
let format_position ppf pos =
|
||||
Format.fprintf ppf
|
||||
"@[<hov 2>catala_position(@,\
|
||||
filename=\"%s\",@ start_line=%d, start_column=%d,@ end_line=%d, \
|
||||
end_column=%d,@ law_headings=%a@;\
|
||||
<0 -2>)@]" (Pos.get_file pos) (Pos.get_start_line pos)
|
||||
(Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos)
|
||||
format_string_list (Pos.get_law_info pos)
|
||||
|
||||
let format_error (ppf : Format.formatter) (err : Runtime.error Mark.pos) : unit
|
||||
=
|
||||
let pos = Mark.get err in
|
||||
let tag = String.to_snake_case (Runtime.error_to_string (Mark.remove err)) in
|
||||
Format.fprintf ppf "%s(%a)" tag format_position pos
|
||||
|
||||
let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
|
||||
unit =
|
||||
match Mark.remove e with
|
||||
| EVar v -> format_var fmt v
|
||||
| EFunc f -> format_func_name fmt f
|
||||
| EStruct { fields = es; name = s } ->
|
||||
Format.fprintf fmt "new(\"catala_struct_%a\",@ %a)" format_struct_name s
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(fun fmt (struct_field, e) ->
|
||||
Format.fprintf fmt "%a = %a" format_struct_field_name struct_field
|
||||
(format_expression ctx) e))
|
||||
(StructField.Map.bindings es)
|
||||
| EStructFieldAccess { e1; field; _ } ->
|
||||
Format.fprintf fmt "%a@%a" (format_expression ctx) e1
|
||||
format_struct_field_name field
|
||||
| EInj { cons; name = e_name; _ }
|
||||
when EnumName.equal e_name Expr.option_enum
|
||||
&& EnumConstructor.equal cons Expr.none_constr ->
|
||||
(* We translate the option type with an overloading by R's [NULL] *)
|
||||
Format.fprintf fmt "NULL"
|
||||
| EInj { e1 = e; cons; name = e_name; _ }
|
||||
when EnumName.equal e_name Expr.option_enum
|
||||
&& EnumConstructor.equal cons Expr.some_constr ->
|
||||
(* We translate the option type with an overloading by R's [NULL] *)
|
||||
format_expression ctx fmt e
|
||||
| EInj { e1 = e; cons; name = enum_name; _ } ->
|
||||
Format.fprintf fmt "new(\"catala_enum_%a\", code = \"%a\",@ value = %a)"
|
||||
format_enum_name enum_name format_enum_cons_name cons
|
||||
(format_expression ctx) e
|
||||
| EArray es ->
|
||||
Format.fprintf fmt "list(%a)"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
|
||||
es
|
||||
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
|
||||
| EAppOp { op = ((Map | Filter), _) as op; args = [arg1; arg2] } ->
|
||||
Format.fprintf fmt "%a(%a,@ %a)" format_op op (format_expression ctx) arg1
|
||||
(format_expression ctx) arg2
|
||||
| EAppOp { op; args = [arg1; arg2] } ->
|
||||
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op op
|
||||
(format_expression ctx) arg2
|
||||
| EAppOp { op = (Not, _) as op; args = [arg1] } ->
|
||||
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
|
||||
| EAppOp
|
||||
{
|
||||
op = ((Minus_int | Minus_rat | Minus_mon | Minus_dur), _) as op;
|
||||
args = [arg1];
|
||||
} ->
|
||||
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
|
||||
| EAppOp { op = HandleExceptions, _ as op; args = [EArray el, _] as args } ->
|
||||
Format.fprintf fmt
|
||||
"%a(%a, %a)@]"
|
||||
format_op op
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
|
||||
format_position)
|
||||
(List.map Mark.get el)
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(format_expression ctx))
|
||||
args
|
||||
| EAppOp { op; args = [arg1] } ->
|
||||
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
|
||||
| EApp { f; args } ->
|
||||
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(format_expression ctx))
|
||||
args
|
||||
| EAppOp { op; args } ->
|
||||
Format.fprintf fmt "%a(@[<hov 0>%a)@]" format_op op
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(format_expression ctx))
|
||||
args
|
||||
| ETuple args ->
|
||||
Format.fprintf fmt "list(@[<hov 0>%a)@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(format_expression ctx))
|
||||
args
|
||||
| ETupleAccess { e1; index } ->
|
||||
Format.fprintf fmt "(%a)[%d]" (format_expression ctx) e1 index
|
||||
| EExternal _ -> failwith "TODO"
|
||||
|
||||
let rec format_statement
|
||||
(ctx : decl_ctx)
|
||||
(fmt : Format.formatter)
|
||||
(s : stmt Mark.pos) : unit =
|
||||
match Mark.remove s with
|
||||
| SInnerFuncDef { name; func = { func_params; func_body; _ } } ->
|
||||
Format.fprintf fmt "@[<hov 2>%a <- function(@\n%a) {@\n%a@]@\n}" format_var
|
||||
(Mark.remove name)
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n,@;")
|
||||
(fun fmt (var, typ) ->
|
||||
Format.fprintf fmt "%a# (%a)@\n" format_var (Mark.remove var)
|
||||
(format_typ ~inside_comment:true)
|
||||
typ))
|
||||
func_params (format_block ctx) func_body
|
||||
| SLocalDecl _ ->
|
||||
assert false (* We don't need to declare variables in Python *)
|
||||
| SLocalDef { name = v; expr = e; _ } | SLocalInit { name = v; expr = e; _ }
|
||||
->
|
||||
Format.fprintf fmt "@[<hov 2>%a <- %a@]" format_var (Mark.remove v)
|
||||
(format_expression ctx) e
|
||||
| STryWEmpty { try_block = try_b; with_block = catch_b } ->
|
||||
Format.fprintf fmt
|
||||
(* TODO escape dummy__arg*)
|
||||
"@[<hov 2>tryCatch(@[<hov 2>{@;\
|
||||
%a@;\
|
||||
}@],@;\
|
||||
catala_empty_error() = function(dummy__arg) @[<hov 2>{@;\
|
||||
%a@;\
|
||||
}@])@]"
|
||||
(format_block ctx) try_b (format_block ctx) catch_b
|
||||
| SRaiseEmpty -> Format.pp_print_string fmt "stop(catala_empty_error())"
|
||||
| SFatalError err ->
|
||||
Format.fprintf fmt "@[<hov 2>stop(%a)@]" format_error (err, Mark.get s)
|
||||
| SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } ->
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>if (%a) {@\n%a@]@\n@[<hov 2>} else {@\n%a@]@\n}"
|
||||
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
|
||||
| SSwitch
|
||||
{
|
||||
switch_expr = e1;
|
||||
enum_name = e_name;
|
||||
switch_cases =
|
||||
[
|
||||
{ case_block = case_none; _ };
|
||||
{ case_block = case_some; payload_var_name = case_some_var; _ };
|
||||
];
|
||||
_;
|
||||
}
|
||||
when EnumName.equal e_name Expr.option_enum ->
|
||||
(* We translate the option type with an overloading by Python's [None] *)
|
||||
let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in
|
||||
Format.fprintf fmt
|
||||
"%a <- %a@\n\
|
||||
@[<hov 2>if (is.null(%a)) {@\n\
|
||||
%a@]@\n\
|
||||
@[<hov 2>} else {@\n\
|
||||
%a = %a@\n\
|
||||
%a@]@\n\
|
||||
}"
|
||||
format_var tmp_var (format_expression ctx) e1 format_var tmp_var
|
||||
(format_block ctx) case_none format_var case_some_var format_var tmp_var
|
||||
(format_block ctx) case_some
|
||||
| SSwitch { switch_expr = e1; enum_name = e_name; switch_cases = cases; _ } ->
|
||||
let cases =
|
||||
List.map2
|
||||
(fun x (cons, _) -> x, cons)
|
||||
cases
|
||||
(EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums))
|
||||
in
|
||||
let tmp_var = VarName.fresh ("match_arg", Pos.no_pos) in
|
||||
Format.fprintf fmt "@[<hov 2>%a <- %a@]@\n@[<hov 2>if %a@]@\n}" format_var
|
||||
tmp_var (format_expression ctx) e1
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@]@\n@[<hov 2>} else if ")
|
||||
(fun fmt ({ case_block; payload_var_name; _ }, cons_name) ->
|
||||
Format.fprintf fmt "(%a@code == \"%a\") {@\n%a <- %a@value@\n%a"
|
||||
format_var tmp_var format_enum_cons_name cons_name format_var
|
||||
payload_var_name format_var tmp_var (format_block ctx) case_block))
|
||||
cases
|
||||
| SReturn e1 ->
|
||||
Format.fprintf fmt "@[<hov 2>return(%a)@]" (format_expression ctx)
|
||||
(e1, Mark.get s)
|
||||
| SAssert e1 ->
|
||||
let pos = Mark.get s in
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>if (!(%a)) {@\n\
|
||||
stop(catala_assertion_failure(@[<hov 0>catala_position(@[<hov \
|
||||
0>filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \
|
||||
end_column=%d,@ law_headings=@[<hv>%a@])@])@])@]@\n\
|
||||
}"
|
||||
(format_expression ctx)
|
||||
(e1, Mark.get s)
|
||||
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
|
||||
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
|
||||
(Pos.get_law_info pos)
|
||||
| SSpecialOp _ -> failwith "should not happen"
|
||||
|
||||
and format_block (ctx : decl_ctx) (fmt : Format.formatter) (b : block) : unit =
|
||||
Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(format_statement ctx) fmt
|
||||
(List.filter
|
||||
(fun s -> match Mark.remove s with SLocalDecl _ -> false | _ -> true)
|
||||
b)
|
||||
|
||||
let format_ctx
|
||||
(type_ordering : Scopelang.Dependency.TVertex.t list)
|
||||
(fmt : Format.formatter)
|
||||
(ctx : decl_ctx) : unit =
|
||||
let format_struct_decl fmt (struct_name, struct_fields) =
|
||||
let fields = StructField.Map.bindings struct_fields in
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>setClass(@,\
|
||||
\"catala_struct_%a\",@;\
|
||||
representation@[<hov 2>(%a)@]@\n\
|
||||
)@]"
|
||||
format_struct_name struct_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@;")
|
||||
(fun fmt (struct_field, typ) ->
|
||||
Format.fprintf fmt "%a = %a" format_struct_field_name struct_field
|
||||
(format_typ ~inside_comment:false)
|
||||
typ))
|
||||
fields
|
||||
in
|
||||
let format_enum_decl fmt (enum_name, enum_cons) =
|
||||
if EnumConstructor.Map.is_empty enum_cons then
|
||||
failwith "no constructors in the enum"
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"# Enum cases: %a@\n\
|
||||
@[<hov 2>setClass(@,\
|
||||
\"catala_enum_%a\",@;\
|
||||
representation@[<hov 2>(code =@;\
|
||||
\"character\",@;\
|
||||
value =@;\
|
||||
\"ANY\")@])@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
|
||||
(fun fmt (enum_cons, enum_cons_type) ->
|
||||
Format.fprintf fmt "\"%a\" (%a)" format_enum_cons_name enum_cons
|
||||
(format_typ ~inside_comment:false)
|
||||
enum_cons_type))
|
||||
(EnumConstructor.Map.bindings enum_cons)
|
||||
format_enum_name enum_name
|
||||
in
|
||||
|
||||
let is_in_type_ordering s =
|
||||
List.exists
|
||||
(fun struct_or_enum ->
|
||||
match struct_or_enum with
|
||||
| Scopelang.Dependency.TVertex.Enum _ -> false
|
||||
| Scopelang.Dependency.TVertex.Struct s' -> s = s')
|
||||
type_ordering
|
||||
in
|
||||
let scope_structs =
|
||||
List.map
|
||||
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
|
||||
(StructName.Map.bindings
|
||||
(StructName.Map.filter
|
||||
(fun s _ -> not (is_in_type_ordering s))
|
||||
ctx.ctx_structs))
|
||||
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, StructName.Map.find s ctx.ctx_structs)
|
||||
| Scopelang.Dependency.TVertex.Enum e ->
|
||||
Format.fprintf fmt "%a@\n@\n" format_enum_decl
|
||||
(e, EnumName.Map.find e ctx.ctx_enums))
|
||||
(type_ordering @ scope_structs)
|
||||
|
||||
let format_program
|
||||
(fmt : Format.formatter)
|
||||
(p : Ast.program)
|
||||
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
|
||||
(* We disable the style flag in order to enjoy formatting from the
|
||||
pretty-printers of Dcalc and Lcalc but without the color terminal
|
||||
markers. *)
|
||||
Format.fprintf fmt
|
||||
"@[<v># This file has been generated by the Catala compiler, do not edit!@,\
|
||||
@,\
|
||||
library(catalaRuntime)@,\
|
||||
@,\
|
||||
@[<v>%a@]@,\
|
||||
@,\
|
||||
%a@]@?"
|
||||
(format_ctx type_ordering) p.ctx.decl_ctx
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun fmt -> function
|
||||
| SVar { var; expr; typ = _ } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a <- (@,%a@,@])@," format_var var
|
||||
(format_expression p.ctx.decl_ctx)
|
||||
expr
|
||||
| SFunc { var; func }
|
||||
| SScope { scope_body_var = var; scope_body_func = func; _ } ->
|
||||
let { Ast.func_params; Ast.func_body; _ } = func in
|
||||
Format.fprintf fmt "@[<hv 2>%a <- function(@\n%a) {@\n%a@]@\n}@,"
|
||||
format_func_name var
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n,@;")
|
||||
(fun fmt (var, typ) ->
|
||||
Format.fprintf fmt "%a# (%a)@\n" format_var (Mark.remove var)
|
||||
(format_typ ~inside_comment:true)
|
||||
typ))
|
||||
func_params
|
||||
(format_block p.ctx.decl_ctx)
|
||||
func_body))
|
||||
p.code_items
|
||||
@ -1,21 +0,0 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2021 Inria, contributor:
|
||||
Denis Merigoux <denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
(** Formats a lambda calculus program into a valid R program *)
|
||||
|
||||
val format_program :
|
||||
Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit
|
||||
(** Usage [format_program fmt p type_dependencies_ordering] *)
|
||||
@ -1 +0,0 @@
|
||||
^LICENSE\.md$
|
||||
@ -1,16 +0,0 @@
|
||||
Package: catalaRuntime
|
||||
Title: R runtime for programs compiled from Catala
|
||||
Version: 0.0.0.9000
|
||||
Authors@R:
|
||||
person("Denis", "Merigoux", , "denis.merigoux@inria.fr", role = c("aut", "cre"),
|
||||
comment = c(ORCID = "0000-0003-2247-0938"))
|
||||
Description: This package provides all S4 classes and functions necessary to run
|
||||
programs generated by the Catala compiler.
|
||||
License: Apache License (>= 2)
|
||||
Encoding: UTF-8
|
||||
Roxygen: list(markdown = TRUE)
|
||||
RoxygenNote: 7.2.3
|
||||
Imports:
|
||||
methods,
|
||||
gmp,
|
||||
lubridate
|
||||
@ -1,194 +0,0 @@
|
||||
Apache License
|
||||
==============
|
||||
|
||||
_Version 2.0, January 2004_
|
||||
_<<http://www.apache.org/licenses/>>_
|
||||
|
||||
### Terms and Conditions for use, reproduction, and distribution
|
||||
|
||||
#### 1. Definitions
|
||||
|
||||
“License” shall mean the terms and conditions for use, reproduction, and
|
||||
distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
“Licensor” shall mean the copyright owner or entity authorized by the copyright
|
||||
owner that is granting the License.
|
||||
|
||||
“Legal Entity” shall mean the union of the acting entity and all other entities
|
||||
that control, are controlled by, or are under common control with that entity.
|
||||
For the purposes of this definition, “control” means **(i)** the power, direct or
|
||||
indirect, to cause the direction or management of such entity, whether by
|
||||
contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or **(iii)** beneficial ownership of such entity.
|
||||
|
||||
“You” (or “Your”) shall mean an individual or Legal Entity exercising
|
||||
permissions granted by this License.
|
||||
|
||||
“Source” form shall mean the preferred form for making modifications, including
|
||||
but not limited to software source code, documentation source, and configuration
|
||||
files.
|
||||
|
||||
“Object” form shall mean any form resulting from mechanical transformation or
|
||||
translation of a Source form, including but not limited to compiled object code,
|
||||
generated documentation, and conversions to other media types.
|
||||
|
||||
“Work” shall mean the work of authorship, whether in Source or Object form, made
|
||||
available under the License, as indicated by a copyright notice that is included
|
||||
in or attached to the work (an example is provided in the Appendix below).
|
||||
|
||||
“Derivative Works” shall mean any work, whether in Source or Object form, that
|
||||
is based on (or derived from) the Work and for which the editorial revisions,
|
||||
annotations, elaborations, or other modifications represent, as a whole, an
|
||||
original work of authorship. For the purposes of this License, Derivative Works
|
||||
shall not include works that remain separable from, or merely link (or bind by
|
||||
name) to the interfaces of, the Work and Derivative Works thereof.
|
||||
|
||||
“Contribution” shall mean any work of authorship, including the original version
|
||||
of the Work and any modifications or additions to that Work or Derivative Works
|
||||
thereof, that is intentionally submitted to Licensor for inclusion in the Work
|
||||
by the copyright owner or by an individual or Legal Entity authorized to submit
|
||||
on behalf of the copyright owner. For the purposes of this definition,
|
||||
“submitted” means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems, and
|
||||
issue tracking systems that are managed by, or on behalf of, the Licensor for
|
||||
the purpose of discussing and improving the Work, but excluding communication
|
||||
that is conspicuously marked or otherwise designated in writing by the copyright
|
||||
owner as “Not a Contribution.”
|
||||
|
||||
“Contributor” shall mean Licensor and any individual or Legal Entity on behalf
|
||||
of whom a Contribution has been received by Licensor and subsequently
|
||||
incorporated within the Work.
|
||||
|
||||
#### 2. Grant of Copyright License
|
||||
|
||||
Subject to the terms and conditions of this License, each Contributor hereby
|
||||
grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free,
|
||||
irrevocable copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the Work and such
|
||||
Derivative Works in Source or Object form.
|
||||
|
||||
#### 3. Grant of Patent License
|
||||
|
||||
Subject to the terms and conditions of this License, each Contributor hereby
|
||||
grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free,
|
||||
irrevocable (except as stated in this section) patent license to make, have
|
||||
made, use, offer to sell, sell, import, and otherwise transfer the Work, where
|
||||
such license applies only to those patent claims licensable by such Contributor
|
||||
that are necessarily infringed by their Contribution(s) alone or by combination
|
||||
of their Contribution(s) with the Work to which such Contribution(s) was
|
||||
submitted. If You institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work or a
|
||||
Contribution incorporated within the Work constitutes direct or contributory
|
||||
patent infringement, then any patent licenses granted to You under this License
|
||||
for that Work shall terminate as of the date such litigation is filed.
|
||||
|
||||
#### 4. Redistribution
|
||||
|
||||
You may reproduce and distribute copies of the Work or Derivative Works thereof
|
||||
in any medium, with or without modifications, and in Source or Object form,
|
||||
provided that You meet the following conditions:
|
||||
|
||||
* **(a)** You must give any other recipients of the Work or Derivative Works a copy of
|
||||
this License; and
|
||||
* **(b)** You must cause any modified files to carry prominent notices stating that You
|
||||
changed the files; and
|
||||
* **(c)** You must retain, in the Source form of any Derivative Works that You distribute,
|
||||
all copyright, patent, trademark, and attribution notices from the Source form
|
||||
of the Work, excluding those notices that do not pertain to any part of the
|
||||
Derivative Works; and
|
||||
* **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any
|
||||
Derivative Works that You distribute must include a readable copy of the
|
||||
attribution notices contained within such NOTICE file, excluding those notices
|
||||
that do not pertain to any part of the Derivative Works, in at least one of the
|
||||
following places: within a NOTICE text file distributed as part of the
|
||||
Derivative Works; within the Source form or documentation, if provided along
|
||||
with the Derivative Works; or, within a display generated by the Derivative
|
||||
Works, if and wherever such third-party notices normally appear. The contents of
|
||||
the NOTICE file are for informational purposes only and do not modify the
|
||||
License. You may add Your own attribution notices within Derivative Works that
|
||||
You distribute, alongside or as an addendum to the NOTICE text from the Work,
|
||||
provided that such additional attribution notices cannot be construed as
|
||||
modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and may provide
|
||||
additional or different license terms and conditions for use, reproduction, or
|
||||
distribution of Your modifications, or for any such Derivative Works as a whole,
|
||||
provided Your use, reproduction, and distribution of the Work otherwise complies
|
||||
with the conditions stated in this License.
|
||||
|
||||
#### 5. Submission of Contributions
|
||||
|
||||
Unless You explicitly state otherwise, any Contribution intentionally submitted
|
||||
for inclusion in the Work by You to the Licensor shall be under the terms and
|
||||
conditions of this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify the terms of
|
||||
any separate license agreement you may have executed with Licensor regarding
|
||||
such Contributions.
|
||||
|
||||
#### 6. Trademarks
|
||||
|
||||
This License does not grant permission to use the trade names, trademarks,
|
||||
service marks, or product names of the Licensor, except as required for
|
||||
reasonable and customary use in describing the origin of the Work and
|
||||
reproducing the content of the NOTICE file.
|
||||
|
||||
#### 7. Disclaimer of Warranty
|
||||
|
||||
Unless required by applicable law or agreed to in writing, Licensor provides the
|
||||
Work (and each Contributor provides its Contributions) on an “AS IS” BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied,
|
||||
including, without limitation, any warranties or conditions of TITLE,
|
||||
NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are
|
||||
solely responsible for determining the appropriateness of using or
|
||||
redistributing the Work and assume any risks associated with Your exercise of
|
||||
permissions under this License.
|
||||
|
||||
#### 8. Limitation of Liability
|
||||
|
||||
In no event and under no legal theory, whether in tort (including negligence),
|
||||
contract, or otherwise, unless required by applicable law (such as deliberate
|
||||
and grossly negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special, incidental,
|
||||
or consequential damages of any character arising as a result of this License or
|
||||
out of the use or inability to use the Work (including but not limited to
|
||||
damages for loss of goodwill, work stoppage, computer failure or malfunction, or
|
||||
any and all other commercial damages or losses), even if such Contributor has
|
||||
been advised of the possibility of such damages.
|
||||
|
||||
#### 9. Accepting Warranty or Additional Liability
|
||||
|
||||
While redistributing the Work or Derivative Works thereof, You may choose to
|
||||
offer, and charge a fee for, acceptance of support, warranty, indemnity, or
|
||||
other liability obligations and/or rights consistent with this License. However,
|
||||
in accepting such obligations, You may act only on Your own behalf and on Your
|
||||
sole responsibility, not on behalf of any other Contributor, and only if You
|
||||
agree to indemnify, defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason of your
|
||||
accepting any such warranty or additional liability.
|
||||
|
||||
_END OF TERMS AND CONDITIONS_
|
||||
|
||||
### APPENDIX: How to apply the Apache License to your work
|
||||
|
||||
To apply the Apache License to your work, attach the following boilerplate
|
||||
notice, with the fields enclosed by brackets `[]` replaced with your own
|
||||
identifying information. (Don't include the brackets!) The text should be
|
||||
enclosed in the appropriate comment syntax for the file format. We also
|
||||
recommend that a file or class name and description of purpose be included on
|
||||
the same “printed page” as the copyright notice for easier identification within
|
||||
third-party archives.
|
||||
|
||||
Copyright [yyyy] [name of copyright owner]
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
||||
@ -1,53 +0,0 @@
|
||||
# Generated by roxygen2: do not edit by hand
|
||||
|
||||
export(catala_assertion_failure)
|
||||
export(catala_conflict_error)
|
||||
export(catala_date_first_day_of_month)
|
||||
export(catala_date_from_ymd)
|
||||
export(catala_date_last_day_of_month)
|
||||
export(catala_date_to_string)
|
||||
export(catala_day_of_month_of_date)
|
||||
export(catala_decimal_from_fraction)
|
||||
export(catala_decimal_from_integer)
|
||||
export(catala_decimal_from_money)
|
||||
export(catala_decimal_from_numeric)
|
||||
export(catala_decimal_round)
|
||||
export(catala_decimal_to_numeric)
|
||||
export(catala_duration_from_ymd)
|
||||
export(catala_duration_to_ymd)
|
||||
export(catala_empty_error)
|
||||
export(catala_integer_from_numeric)
|
||||
export(catala_integer_from_string)
|
||||
export(catala_integer_to_numeric)
|
||||
export(catala_list_filter)
|
||||
export(catala_list_fold_left)
|
||||
export(catala_list_length)
|
||||
export(catala_list_map)
|
||||
export(catala_list_reduce)
|
||||
export(catala_money_from_cents)
|
||||
export(catala_money_from_decimal)
|
||||
export(catala_money_from_units)
|
||||
export(catala_money_round)
|
||||
export(catala_money_to_numeric)
|
||||
export(catala_money_to_string)
|
||||
export(catala_month_number_of_date)
|
||||
export(catala_no_value_provided_error)
|
||||
export(catala_position_to_string)
|
||||
export(catala_year_of_date)
|
||||
export(dead_value)
|
||||
exportClasses(catala_date)
|
||||
exportClasses(catala_decimal)
|
||||
exportClasses(catala_duration)
|
||||
exportClasses(catala_integer)
|
||||
exportClasses(catala_money)
|
||||
exportClasses(catala_position)
|
||||
exportClasses(catala_unit)
|
||||
exportMethods("*")
|
||||
exportMethods("+")
|
||||
exportMethods("-")
|
||||
exportMethods("/")
|
||||
exportMethods(Arith)
|
||||
exportMethods(Compare)
|
||||
import(gmp)
|
||||
import(lubridate)
|
||||
import(methods)
|
||||
@ -1,4 +0,0 @@
|
||||
(install
|
||||
(section lib)
|
||||
(files
|
||||
(runtime.R as runtime_r/runtime.R)))
|
||||
@ -1,372 +0,0 @@
|
||||
#' @import methods
|
||||
#' @import gmp
|
||||
#' @import lubridate
|
||||
|
||||
################ Integers #################
|
||||
|
||||
#' @export
|
||||
setClass(
|
||||
"catala_integer",
|
||||
representation(v = "bigz")
|
||||
)
|
||||
#' @export
|
||||
setMethod("Arith", "catala_integer", function(e1, e2) {
|
||||
v <- callGeneric(e1@v, e2@v)
|
||||
new("catala_integer", v = v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("-", c("catala_integer", "missing"), function(e1) {
|
||||
new("catala_integer", v = -e1@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("Compare", "catala_integer", function(e1, e2) {
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
################ Decimals #################
|
||||
|
||||
#' @export
|
||||
setClass(
|
||||
"catala_decimal",
|
||||
representation(v = "bigq")
|
||||
)
|
||||
#' @export
|
||||
setMethod("Arith", "catala_decimal", function(e1, e2) {
|
||||
v <- callGeneric(e1@v, e2@v)
|
||||
new("catala_decimal", v = v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("-", c("catala_decimal", "missing"), function(e1) {
|
||||
new("catala_decimal", v = -e1@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("Compare", "catala_decimal", function(e1, e2) {
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
################ Money #################
|
||||
|
||||
#' @export
|
||||
setClass(
|
||||
"catala_money",
|
||||
representation(v = "bigz")
|
||||
)
|
||||
#' @export
|
||||
setMethod("+", c("catala_money", "catala_money"), function(e1, e2) {
|
||||
new("catala_money", v = e1@v + e2@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("-", c("catala_money", "catala_money"), function(e1, e2) {
|
||||
new("catala_money", v = e1@v - e2@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("-", c("catala_money", "missing"), function(e1) {
|
||||
new("catala_money", v = -e1@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("*", c("catala_money", "catala_decimal"), function(e1, e2) {
|
||||
new("catala_money", v = as.bigz(as.bigq(e1@v) * e2@v))
|
||||
})
|
||||
#' @export
|
||||
setMethod("/", c("catala_money", "catala_money"), function(e1, e2) {
|
||||
new("catala_decimal", v = as.bigq(e1@v / e2@v))
|
||||
})
|
||||
#' @export
|
||||
setMethod("Compare", "catala_money", function(e1, e2) {
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
################ Duration #################
|
||||
|
||||
#' @export
|
||||
setClass(
|
||||
"catala_duration",
|
||||
representation(v = "Period")
|
||||
)
|
||||
#' @export
|
||||
setMethod("+", c("catala_duration", "catala_duration"), function(e1, e2) {
|
||||
new("catala_duration", v = e1@v + e2@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("-", c("catala_duration", "catala_duration"), function(e1, e2) {
|
||||
new("catala_duration", v = e1@v - e2@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("-", c("catala_duration", "missing"), function(e1) {
|
||||
new("catala_duration", v = -e1@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("/", c("catala_duration", "catala_duration"), function(e1, e2) {
|
||||
new("catala_duration", v = e1@v / e2@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("Compare", "catala_duration", function(e1, e2) {
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
|
||||
# TODO: port the dates_calc library to R to make date computations
|
||||
# more robust.
|
||||
|
||||
################ Dates #################
|
||||
|
||||
#' @export
|
||||
setClass(
|
||||
"catala_date",
|
||||
representation(v = "Date")
|
||||
)
|
||||
#' @export
|
||||
setMethod("+", c("catala_date", "catala_duration"), function(e1, e2) {
|
||||
new("catala_date", v = e1@v + e2@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("-", c("catala_date", "catala_date"), function(e1, e2) {
|
||||
new("catala_date", v = e1@v - e2@v)
|
||||
})
|
||||
#' @export
|
||||
setMethod("Compare", "catala_date", function(e1, e2) {
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
################ Unit #################
|
||||
|
||||
#' @export
|
||||
setClass("catala_unit", representation(v = "numeric"))
|
||||
|
||||
################ Constructors and conversions #################
|
||||
|
||||
# Money
|
||||
|
||||
#' @export
|
||||
catala_money_from_units <- function(x) {
|
||||
new("catala_money", v = as.bigz(x) * as.bigz(100))
|
||||
}
|
||||
#' @export
|
||||
catala_money_from_cents <- function(x) {
|
||||
new("catala_money", v = as.bigz(x))
|
||||
}
|
||||
#' @export
|
||||
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)) {
|
||||
new("catala_money", v = as.bigz(sign(d@v)) * unit_part_num_cents_z)
|
||||
} else {
|
||||
new("catala_money", v = as.bigz(sign(d@v)) * (unit_part_num_cents_z + as.bigz(1)))
|
||||
}
|
||||
}
|
||||
#' @export
|
||||
catala_money_to_numeric <- function(m) {
|
||||
as.numeric(as.bigq(m@v) / as.bigq(100))
|
||||
}
|
||||
#' @export
|
||||
catala_money_to_string <- function(m) {
|
||||
paste0("$", catala_money_to_numeric(m))
|
||||
}
|
||||
#' @export
|
||||
catala_money_round <- function(m) {
|
||||
q <- abs(m@v) %/% as.bigz(100)
|
||||
r <- abs(m@v) %% as.bigz(100)
|
||||
if (abs(r) < 50) {
|
||||
new("catala_money", v = sign(m@v) * q * as.bigz(100))
|
||||
} else {
|
||||
new("catala_money", v = sign(m@v) * (q + 1) * as.bigz(100))
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Decimals
|
||||
|
||||
#' @export
|
||||
catala_decimal_from_numeric <- function(x) {
|
||||
new("catala_decimal", v = as.bigq(x))
|
||||
}
|
||||
#' @export
|
||||
catala_decimal_from_fraction <- function(x, y) {
|
||||
new("catala_decimal", v = as.bigq(n = x, d = y))
|
||||
}
|
||||
#' @export
|
||||
catala_decimal_from_integer <- function(x) {
|
||||
new("catala_decimal", v = as.bigq(x@v))
|
||||
}
|
||||
#' @export
|
||||
catala_decimal_to_numeric <- function(x) {
|
||||
as.numeric(x@v)
|
||||
}
|
||||
#' @export
|
||||
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)) {
|
||||
new("catala_decimal", v = sign(d@v) * q)
|
||||
} else {
|
||||
new("catala_decimal", v = sign(d@v) * (q + as.bigq(1)))
|
||||
}
|
||||
}
|
||||
#' @export
|
||||
catala_decimal_from_money <- function(m) {
|
||||
new("catala_decimal", v = as.bigq(as.bigq(m@v) / as.bigq(100)))
|
||||
}
|
||||
|
||||
# Integers
|
||||
|
||||
#' @export
|
||||
catala_integer_from_numeric <- function(x) {
|
||||
new("catala_integer", v = as.bigz(x))
|
||||
}
|
||||
#' @export
|
||||
catala_integer_from_string <- function(x) {
|
||||
new("catala_integer", v = as.bigz(x))
|
||||
}
|
||||
#' @export
|
||||
catala_integer_to_numeric <- function(x) {
|
||||
as.numeric(x@v)
|
||||
}
|
||||
|
||||
# Dates
|
||||
|
||||
#' @export
|
||||
catala_date_from_ymd <- function(y, m, d) {
|
||||
new("catala_date", v = make_date(year = y, month = m, day = d))
|
||||
}
|
||||
#' @export
|
||||
catala_day_of_month_of_date <- function(d) {
|
||||
mday(d@v)
|
||||
}
|
||||
#' @export
|
||||
catala_month_number_of_date <- function(d) {
|
||||
month(d@v)
|
||||
}
|
||||
#' @export
|
||||
catala_year_of_date <- function(d) {
|
||||
year(d@v)
|
||||
}
|
||||
#' @export
|
||||
catala_date_to_string <- function(d) {
|
||||
paste0(d@v)
|
||||
}
|
||||
#' @export
|
||||
catala_date_first_day_of_month <- function(d) {
|
||||
new("catala_date", v = make_date(year = year(d@v), month = month(d@v), day = 1))
|
||||
}
|
||||
#' @export
|
||||
catala_date_last_day_of_month <- function(d) {
|
||||
new("catala_date", v = make_date(
|
||||
year = year(d@v),
|
||||
month = month(d@v),
|
||||
day = days_in_month(d@v)
|
||||
))
|
||||
}
|
||||
|
||||
# Durations
|
||||
|
||||
#' @export
|
||||
catala_duration_from_ymd <- function(y, m, d) {
|
||||
new("catala_duration", v = years(y) + months(m) + days(d))
|
||||
}
|
||||
#' @export
|
||||
catala_duration_to_ymd <- function(d) {
|
||||
c(d@v@year, d@v@month, d@v@day)
|
||||
}
|
||||
|
||||
# List
|
||||
|
||||
#' @export
|
||||
catala_list_fold_left <- function(f, init, l) {
|
||||
Reduce(f, l, init)
|
||||
}
|
||||
#' @export
|
||||
catala_list_filter <- function(f, l) {
|
||||
Filter(f, l)
|
||||
}
|
||||
#' @export
|
||||
catala_list_map <- function(f, l) {
|
||||
Map(f, l)
|
||||
}
|
||||
#' @export
|
||||
catala_list_map2 <- function(f, l1, l2) {
|
||||
Map(f, l1, l2)
|
||||
}
|
||||
#' @export
|
||||
catala_list_reduce <- function(f, default, l) {
|
||||
if (length(l) == 0) {
|
||||
default
|
||||
} else {
|
||||
Reduce(f, l[-(1:1)], l[[1]])
|
||||
}
|
||||
}
|
||||
#' @export
|
||||
catala_list_length <- function(l) {
|
||||
catala_integer_from_numeric(length(l))
|
||||
}
|
||||
|
||||
################ Exceptions #################
|
||||
|
||||
#' @export
|
||||
setClass(
|
||||
"catala_position",
|
||||
representation(
|
||||
filename = "character",
|
||||
start_line = "numeric",
|
||||
end_line = "numeric",
|
||||
start_column = "numeric",
|
||||
end_column = "numeric",
|
||||
law_headings = "character"
|
||||
)
|
||||
)
|
||||
|
||||
#' @export
|
||||
catala_position_to_string <- function(pos) {
|
||||
headings <- paste(pos@law_headings, collapse = ", ")
|
||||
paste0(
|
||||
pos@filename, ":",
|
||||
pos@start_line, ".",
|
||||
pos@start_column, "-",
|
||||
pos@end_line, ".",
|
||||
pos@end_column, " (",
|
||||
headings, ")"
|
||||
)
|
||||
}
|
||||
|
||||
# Source: http://adv-r.had.co.nz/beyond-exception-handling.html
|
||||
# We redefine conditions to add our own conditions
|
||||
|
||||
#' @export
|
||||
catala_empty_error <- function() {
|
||||
structure(
|
||||
class = c("catala_empty_error", "error", "condition"),
|
||||
list(message = "EmptyError", call = sys.call(-1))
|
||||
)
|
||||
}
|
||||
#' @export
|
||||
catala_conflict_error <- function(pos) {
|
||||
structure(
|
||||
class = c("catala_conflict_error", "error", "condition"),
|
||||
list(message = catala_position_to_string(pos), call = sys.call(-1))
|
||||
)
|
||||
}
|
||||
#' @export
|
||||
catala_no_value_provided_error <- function(pos) {
|
||||
structure(
|
||||
class = c("catala_no_value_provided_error", "error", "condition"),
|
||||
list(message = catala_position_to_string(pos), call = sys.call(-1))
|
||||
)
|
||||
}
|
||||
#' @export
|
||||
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 #################
|
||||
|
||||
# This value is used for the R code generation to trump R and forcing
|
||||
# it to accept dead code. Indeed, when raising an exception during a variable
|
||||
# definition, R could complains that the later dead code will not know what
|
||||
# this variable was. So we give this variable a dead value.
|
||||
|
||||
#' @export
|
||||
dead_value <- 0
|
||||
@ -1,5 +0,0 @@
|
||||
#! /bin/bash
|
||||
|
||||
temp=$(mktemp)
|
||||
(Rscript -e "options(styler.colored_print.vertical=FALSE); con <- file('stdin'); out <- styler::style_text(readLines(con)); close(con); out" < $1) > $temp
|
||||
cat $temp > $1
|
||||
Loading…
Reference in New Issue
Block a user