CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-07 10:35:56 +03:00
Code Issues Projects Releases Wiki Activity

Remove the R backend

Browse Source 
There are no users at the moment, so we won't be actively maintaining it.

If and when the need arises again, we can revert this commit and resurrect it.
This commit is contained in:
Louis Gesbert 2024-07-08 14:50:03 +02:00
parent 0b19130c1d
commit 98a460e1b3
10 changed files with 0 additions and 1259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
compiler/driver.ml
View File

@ -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;

567
compiler/scalc/to_r.ml
View File

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

21
compiler/scalc/to_r.mli
View File

@ -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
runtimes/r/.Rbuildignore
View File

@ -1 +0,0 @@
^LICENSE\.md$

16
runtimes/r/DESCRIPTION
View File

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

194
runtimes/r/LICENSE.md
View File

@ -1,194 +0,0 @@
Apache License
==============
_Version 2.0, January 2004_
_&lt;<http://www.apache.org/licenses/>&gt;_
### 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.

53
runtimes/r/NAMESPACE
View File

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

4
runtimes/r/R/dune
View File

@ -1,4 +0,0 @@
(install
(section lib)
(files
(runtime.R as runtime_r/runtime.R)))

372
runtimes/r/R/runtime.R
View File

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

5
runtimes/r/format_r_file.sh
View File

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