mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Backend seems to work, needs more debugging
This commit is contained in:
Denis Merigoux
parent
62ea40a40d
commit
e2f8e56e7d
@ -20,7 +20,6 @@
|
||||
type backend_lang = En | Fr | Pl
|
||||
type when_enum = Auto | Always | Never
|
||||
type message_format_enum = Human | GNU
|
||||
type compilation_method = Expression | Statement
|
||||
type input_file = FileName of string | Contents of string
|
||||
|
||||
(** Associates a {!type: Cli.backend_lang} with its string represtation. *)
|
||||
@ -31,7 +30,6 @@ let language_code =
|
||||
fun l -> List.assoc l rl
|
||||
|
||||
let message_format_opt = ["human", Human; "gnu", GNU]
|
||||
let compilation_method_opt = ["expression", Expression; "statement", Statement]
|
||||
|
||||
type options = {
|
||||
mutable input_file : input_file;
|
||||
@ -319,15 +317,6 @@ module Flags = struct
|
||||
"Disables the search for counterexamples. Useful when you want a \
|
||||
deterministic output from the Catala compiler, since provers can \
|
||||
have some randomness in them."
|
||||
|
||||
let scalc_try_with_compilation =
|
||||
value
|
||||
& opt (enum compilation_method_opt) Statement
|
||||
& info
|
||||
["scalc_try_with_compilation"]
|
||||
~doc:
|
||||
"How should try ... with ... constructs be compiled from Lcalc to \
|
||||
Scalc ? Choice is between $(i,expression) or $(i,statement)."
|
||||
end
|
||||
|
||||
let version = "0.8.0"
|
||||
|
||||
@ -24,11 +24,6 @@ type message_format_enum =
|
||||
| Human
|
||||
| GNU (** Format of error and warning messages output by the compiler. *)
|
||||
|
||||
type compilation_method =
|
||||
| Expression
|
||||
| Statement
|
||||
(** Whether to compile something as an expression or a statement *)
|
||||
|
||||
type input_file = FileName of string | Contents of string
|
||||
|
||||
val languages : (string * backend_lang) list
|
||||
@ -104,7 +99,6 @@ module Flags : sig
|
||||
val closure_conversion : bool Term.t
|
||||
val link_modules : string list Term.t
|
||||
val disable_counterexamples : bool Term.t
|
||||
val scalc_try_with_compilation : compilation_method Term.t
|
||||
end
|
||||
|
||||
(** {2 Command-line application} *)
|
||||
|
||||
@ -190,8 +190,7 @@ module Passes = struct
|
||||
~optimize
|
||||
~check_invariants
|
||||
~avoid_exceptions
|
||||
~closure_conversion
|
||||
~scalc_try_with_compilation :
|
||||
~closure_conversion :
|
||||
Scalc.Ast.program
|
||||
* Desugared.Name_resolution.context
|
||||
* Scopelang.Dependency.TVertex.t list =
|
||||
@ -200,15 +199,7 @@ module Passes = struct
|
||||
~closure_conversion
|
||||
in
|
||||
Message.emit_debug "Compiling program into statement calculus...";
|
||||
( Scalc.From_lcalc.translate_program prg
|
||||
{
|
||||
try_catch_type =
|
||||
(match scalc_try_with_compilation with
|
||||
| Cli.Expression -> Scalc.From_lcalc.Expression
|
||||
| Cli.Statement -> Scalc.From_lcalc.Statement);
|
||||
},
|
||||
ctx,
|
||||
type_ordering )
|
||||
Scalc.From_lcalc.translate_program prg, ctx, type_ordering
|
||||
end
|
||||
|
||||
module Commands = struct
|
||||
@ -716,11 +707,10 @@ module Commands = struct
|
||||
check_invariants
|
||||
avoid_exceptions
|
||||
closure_conversion
|
||||
ex_scope_opt
|
||||
scalc_try_with_compilation =
|
||||
ex_scope_opt =
|
||||
let prg, ctx, _ =
|
||||
Passes.scalc options ~link_modules ~optimize ~check_invariants
|
||||
~avoid_exceptions ~closure_conversion ~scalc_try_with_compilation
|
||||
~avoid_exceptions ~closure_conversion
|
||||
in
|
||||
let _output_file, with_output = get_output_format options output in
|
||||
with_output
|
||||
@ -754,8 +744,7 @@ module Commands = struct
|
||||
$ Cli.Flags.check_invariants
|
||||
$ Cli.Flags.avoid_exceptions
|
||||
$ Cli.Flags.closure_conversion
|
||||
$ Cli.Flags.ex_scope_opt
|
||||
$ Cli.Flags.scalc_try_with_compilation)
|
||||
$ Cli.Flags.ex_scope_opt)
|
||||
|
||||
let python
|
||||
options
|
||||
@ -768,8 +757,8 @@ module Commands = struct
|
||||
let prg, _, type_ordering =
|
||||
Passes.scalc options ~link_modules ~optimize ~check_invariants
|
||||
~avoid_exceptions ~closure_conversion
|
||||
~scalc_try_with_compilation:Statement
|
||||
in
|
||||
|
||||
let output_file, with_output =
|
||||
get_output_format options ~ext:".py" output
|
||||
in
|
||||
@ -798,8 +787,8 @@ module Commands = struct
|
||||
let prg, _, type_ordering =
|
||||
Passes.scalc options ~link_modules ~optimize ~check_invariants
|
||||
~avoid_exceptions:false ~closure_conversion
|
||||
~scalc_try_with_compilation:Expression
|
||||
in
|
||||
|
||||
let output_file, with_output = get_output_format options ~ext:".r" output in
|
||||
Message.emit_debug "Compiling program into R...";
|
||||
Message.emit_debug "Writing to %s..."
|
||||
|
||||
@ -66,7 +66,6 @@ module Passes : sig
|
||||
check_invariants:bool ->
|
||||
avoid_exceptions:bool ->
|
||||
closure_conversion:bool ->
|
||||
scalc_try_with_compilation:Cli.compilation_method ->
|
||||
Scalc.Ast.program
|
||||
* Desugared.Name_resolution.context
|
||||
* Scopelang.Dependency.TVertex.t list
|
||||
|
||||
@ -34,8 +34,8 @@ let run
|
||||
let prg, _, type_ordering =
|
||||
Driver.Passes.scalc options ~link_modules ~optimize ~check_invariants
|
||||
~avoid_exceptions ~closure_conversion
|
||||
~scalc_try_with_compilation:Statement
|
||||
in
|
||||
|
||||
let output_file, with_output = get_output_format options ~ext:".py" output in
|
||||
Message.emit_debug "Compiling program into Python...";
|
||||
Message.emit_debug "Writing to %s..."
|
||||
|
||||
@ -20,11 +20,7 @@ module A = Ast
|
||||
module L = Lcalc.Ast
|
||||
module D = Dcalc.Ast
|
||||
|
||||
type compilation_type = Expression | Statement
|
||||
type compilation_options = { try_catch_type : compilation_type }
|
||||
|
||||
type 'm ctxt = {
|
||||
compilation_options : compilation_options;
|
||||
func_dict : ('m L.expr, A.FuncName.t) Var.Map.t;
|
||||
decl_ctx : decl_ctx;
|
||||
var_dict : ('m L.expr, A.VarName.t) Var.Map.t;
|
||||
@ -273,7 +269,6 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
|
||||
])
|
||||
|
||||
let rec translate_scope_body_expr
|
||||
(options : compilation_options)
|
||||
(scope_name : ScopeName.t)
|
||||
(decl_ctx : decl_ctx)
|
||||
(var_dict : ('m L.expr, A.VarName.t) Var.Map.t)
|
||||
@ -284,7 +279,6 @@ let rec translate_scope_body_expr
|
||||
let block, new_e =
|
||||
translate_expr
|
||||
{
|
||||
compilation_options = options;
|
||||
decl_ctx;
|
||||
func_dict;
|
||||
var_dict;
|
||||
@ -304,7 +298,6 @@ let rec translate_scope_body_expr
|
||||
| Assertion ->
|
||||
translate_statements
|
||||
{
|
||||
compilation_options = options;
|
||||
decl_ctx;
|
||||
func_dict;
|
||||
var_dict;
|
||||
@ -316,7 +309,6 @@ let rec translate_scope_body_expr
|
||||
let let_expr_stmts, new_let_expr =
|
||||
translate_expr
|
||||
{
|
||||
compilation_options = options;
|
||||
decl_ctx;
|
||||
func_dict;
|
||||
var_dict;
|
||||
@ -333,11 +325,10 @@ let rec translate_scope_body_expr
|
||||
( A.SLocalDef ((let_var_id, scope_let.scope_let_pos), new_let_expr),
|
||||
scope_let.scope_let_pos );
|
||||
])
|
||||
@ translate_scope_body_expr options scope_name decl_ctx new_var_dict
|
||||
func_dict scope_let_next
|
||||
@ translate_scope_body_expr scope_name decl_ctx new_var_dict func_dict
|
||||
scope_let_next
|
||||
|
||||
let translate_program (p : 'm L.program) (options : compilation_options) :
|
||||
A.program =
|
||||
let translate_program (p : 'm L.program) : A.program =
|
||||
let _, _, rev_items =
|
||||
Scope.fold_left
|
||||
~f:(fun (func_dict, var_dict, rev_items) code_item var ->
|
||||
@ -354,8 +345,8 @@ let translate_program (p : 'm L.program) (options : compilation_options) :
|
||||
Var.Map.add scope_input_var scope_input_var_id var_dict
|
||||
in
|
||||
let new_scope_body =
|
||||
translate_scope_body_expr options name p.decl_ctx var_dict_local
|
||||
func_dict scope_body_expr
|
||||
translate_scope_body_expr name p.decl_ctx var_dict_local func_dict
|
||||
scope_body_expr
|
||||
in
|
||||
let func_id = A.FuncName.fresh (Bindlib.name_of var, Pos.no_pos) in
|
||||
( Var.Map.add var func_id func_dict,
|
||||
@ -390,7 +381,6 @@ let translate_program (p : 'm L.program) (options : compilation_options) :
|
||||
let block, expr =
|
||||
let ctxt =
|
||||
{
|
||||
compilation_options = options;
|
||||
func_dict;
|
||||
decl_ctx = p.decl_ctx;
|
||||
var_dict =
|
||||
@ -420,7 +410,6 @@ let translate_program (p : 'm L.program) (options : compilation_options) :
|
||||
let block, expr =
|
||||
let ctxt =
|
||||
{
|
||||
compilation_options = options;
|
||||
func_dict;
|
||||
decl_ctx = p.decl_ctx;
|
||||
var_dict;
|
||||
|
||||
@ -16,8 +16,4 @@
|
||||
|
||||
open Shared_ast
|
||||
|
||||
type compilation_type = Expression | Statement
|
||||
type compilation_options = { try_catch_type : compilation_type }
|
||||
|
||||
val translate_program :
|
||||
untyped Lcalc.Ast.program -> compilation_options -> Ast.program
|
||||
val translate_program : untyped Lcalc.Ast.program -> Ast.program
|
||||
|
||||
@ -26,9 +26,13 @@ let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
|
||||
| LBool true -> Format.pp_print_string fmt "TRUE"
|
||||
| LBool false -> Format.pp_print_string fmt "FALSE"
|
||||
| LInt i ->
|
||||
Format.fprintf fmt "catala_integer_from_string(\"%s\")"
|
||||
(Runtime.integer_to_string i)
|
||||
| LUnit -> Format.pp_print_string fmt "catala_unit()"
|
||||
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 "catala_unit(v=0)"
|
||||
| LRat i ->
|
||||
Format.fprintf fmt "catala_decimal_from_string(\"%a\")" Print.lit (LRat i)
|
||||
| LMoney e ->
|
||||
@ -93,15 +97,6 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
|
||||
| HandleDefaultOpt -> Format.pp_print_string fmt "handle_default_opt"
|
||||
| FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
|
||||
|
||||
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
|
||||
: unit =
|
||||
Format.fprintf fmt "[%a]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(fun fmt info ->
|
||||
Format.fprintf fmt "\"%a\"" Uid.MarkedString.format info))
|
||||
uids
|
||||
|
||||
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
||||
let sanitize_quotes = Re.compile (Re.char '"') in
|
||||
Format.fprintf fmt "c(%a)"
|
||||
@ -167,18 +162,19 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@;")
|
||||
format_typ)
|
||||
ts
|
||||
| TStruct s -> Format.fprintf fmt "\"catala_class_%a\"" format_struct_name s
|
||||
| TStruct s -> Format.fprintf fmt "\"catala_struct_%a\"" format_struct_name s
|
||||
| TOption some_typ ->
|
||||
(* We loose track of optional value as they're crammed into NULL *)
|
||||
format_typ fmt some_typ
|
||||
| TEnum e -> Format.fprintf fmt "\"catala_enum_%a\"" format_enum_name e
|
||||
| TArrow (_t1, _t2) ->
|
||||
Message.raise_internal_error "This type should not be printed out in R: %a"
|
||||
Print.typ_debug typ
|
||||
| TArrow (t1, t2) ->
|
||||
Format.fprintf fmt "\"function\" # %a -> %a@\n"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
|
||||
format_typ)
|
||||
t1 format_typ t2
|
||||
| TArray t1 -> Format.fprintf fmt "\"list\" # array(%a)@\n" format_typ t1
|
||||
| TAny ->
|
||||
Message.raise_internal_error "This type should not be printed out in R: %a"
|
||||
Print.typ_debug typ
|
||||
| TAny -> Format.fprintf fmt "\"ANY\""
|
||||
| TClosureEnv -> failwith "unimplemented!"
|
||||
|
||||
let format_name_cleaned (fmt : Format.formatter) (s : string) : unit =
|
||||
@ -275,7 +271,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
|
||||
| EVar v -> format_var fmt v
|
||||
| EFunc f -> format_func_name fmt f
|
||||
| EStruct (es, s) ->
|
||||
Format.fprintf fmt "%a(%a)" format_struct_name s
|
||||
Format.fprintf fmt "catala_struct_%a(%a)" format_struct_name s
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(fun fmt (e, (struct_field, _)) ->
|
||||
@ -289,15 +285,15 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
|
||||
| EInj (_, cons, 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 Python's [None] *)
|
||||
(* We translate the option type with an overloading by R's [NULL] *)
|
||||
Format.fprintf fmt "NULL"
|
||||
| EInj (e, cons, 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 Python's [None] *)
|
||||
(* We translate the option type with an overloading by R's [NULL] *)
|
||||
format_expression ctx fmt e
|
||||
| EInj (e, cons, enum_name) ->
|
||||
Format.fprintf fmt "%a(%a_Code.%a,@ %a)" format_enum_name enum_name
|
||||
Format.fprintf fmt "catala_enum_%a(code = \"%a\",@ value = %a)"
|
||||
format_enum_name enum_name format_enum_cons_name cons
|
||||
(format_expression ctx) e
|
||||
| EArray es ->
|
||||
@ -313,33 +309,6 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
|
||||
| EApp ((EOp op, _), [arg1; arg2]) ->
|
||||
Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_op
|
||||
(op, Pos.no_pos) (format_expression ctx) arg2
|
||||
| EApp ((EApp ((EOp (Log (BeginCall, info)), _), [f]), _), [arg])
|
||||
when Cli.globals.trace ->
|
||||
Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info
|
||||
(format_expression ctx) f (format_expression ctx) arg
|
||||
| EApp ((EOp (Log (VarDef var_def_info, info)), _), [arg1])
|
||||
when Cli.globals.trace ->
|
||||
Format.fprintf fmt
|
||||
"log_variable_definition(%a,@ LogIO(io_input=%s,@ io_output=%b),@ %a)"
|
||||
format_uid_list info
|
||||
(match var_def_info.log_io_input with
|
||||
| Runtime.NoInput -> "NoInput"
|
||||
| Runtime.OnlyInput -> "OnlyInput"
|
||||
| Runtime.Reentrant -> "Reentrant")
|
||||
var_def_info.log_io_output (format_expression ctx) arg1
|
||||
| EApp ((EOp (Log (PosRecordIfTrueBool, _)), pos), [arg1])
|
||||
when Cli.globals.trace ->
|
||||
Format.fprintf fmt
|
||||
"log_decision_taken(catala_position(filename=\"%s\",@ start_line=%d,@ \
|
||||
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)"
|
||||
(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) (format_expression ctx) arg1
|
||||
| EApp ((EOp (Log (EndCall, info)), _), [arg1]) when Cli.globals.trace ->
|
||||
Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info
|
||||
(format_expression ctx) arg1
|
||||
| EApp ((EOp (Log _), _), [arg1]) ->
|
||||
Format.fprintf fmt "%a" (format_expression ctx) arg1
|
||||
| EApp ((EOp Not, _), [arg1]) ->
|
||||
Format.fprintf fmt "%a %a" format_op (Not, Pos.no_pos)
|
||||
(format_expression ctx) arg1
|
||||
@ -427,12 +396,13 @@ let rec format_statement
|
||||
(* 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 %a is None:@\n\
|
||||
"%a <- %a@\n\
|
||||
@[<hov 2>if (is.null(%a)) {@\n\
|
||||
%a@]@\n\
|
||||
@[<hov 2>else:@\n\
|
||||
@[<hov 2>} else {@\n\
|
||||
%a = %a@\n\
|
||||
%a@]"
|
||||
%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
|
||||
@ -444,15 +414,14 @@ let rec format_statement
|
||||
(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 "%a = %a@\n@[<hov 2>if %a@]" format_var tmp_var
|
||||
Format.fprintf fmt "%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>elif ")
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@]@\n@[<hov 2>} else if ")
|
||||
(fun fmt (case_block, payload_var, cons_name) ->
|
||||
Format.fprintf fmt "%a.code == %a_Code.%a:@\n%a = %a.value@\n%a"
|
||||
format_var tmp_var format_enum_name e_name format_enum_cons_name
|
||||
cons_name format_var payload_var format_var tmp_var
|
||||
(format_block ctx) case_block))
|
||||
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 format_var tmp_var (format_block ctx) case_block))
|
||||
cases
|
||||
| SReturn e1 ->
|
||||
Format.fprintf fmt "@[<hov 2>return(%a)@]" (format_expression ctx)
|
||||
@ -460,10 +429,11 @@ let rec format_statement
|
||||
| SAssert e1 ->
|
||||
let pos = Mark.get s in
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>if not (%a):@\n\
|
||||
raise AssertionFailure(@[<hov 0>catala_position(@[<hov \
|
||||
"@[<hov 2>if (not (%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@])@])@]@]"
|
||||
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)
|
||||
@ -484,21 +454,10 @@ let format_ctx
|
||||
(ctx : decl_ctx) : unit =
|
||||
let format_struct_decl fmt (struct_name, struct_fields) =
|
||||
let fields = StructField.Map.bindings struct_fields in
|
||||
let non_func_fields =
|
||||
List.filter
|
||||
(fun (_, t) -> match Mark.remove t with TArrow _ -> false | _ -> true)
|
||||
fields
|
||||
in
|
||||
let func_fields =
|
||||
List.filter
|
||||
(fun (_, t) -> match Mark.remove t with TArrow _ -> true | _ -> false)
|
||||
fields
|
||||
in
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>catala_struct_%a <- setRefClass(@,\
|
||||
\"catala_struct_%a\",@;\
|
||||
fields = list@[<hov 2>(%a)@],@,\
|
||||
methods = list@[<hov 2>(%a)@]@,\
|
||||
fields = list@[<hov 2>(%a)@]@\n\
|
||||
)@]"
|
||||
format_struct_name struct_name format_struct_name struct_name
|
||||
(Format.pp_print_list
|
||||
@ -506,14 +465,7 @@ let format_ctx
|
||||
(fun fmt (struct_field, typ) ->
|
||||
Format.fprintf fmt "%a = %a" format_struct_field_name struct_field
|
||||
format_typ typ))
|
||||
non_func_fields
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@;")
|
||||
(fun fmt (struct_field, typ) ->
|
||||
Format.fprintf fmt
|
||||
"%a = # %a@\nfunction () @[<hov 2>{@;stop(\"uninitialized\")@;}@]"
|
||||
format_struct_field_name struct_field Print.typ_debug typ))
|
||||
func_fields
|
||||
fields
|
||||
in
|
||||
let format_enum_decl fmt (enum_name, enum_cons) =
|
||||
if EnumConstructor.Map.is_empty enum_cons then
|
||||
|
||||
5
runner.r
5
runner.r
@ -1,3 +1,4 @@
|
||||
source("test.r")
|
||||
|
||||
foo(catala_struct_FooIn(x_in = catala_integer_from_numeric(1)))
|
||||
v <- Map(function(x) {
|
||||
foo(catala_struct_FooIn(x_in = catala_integer_from_numeric(x)))
|
||||
}, c(1:10000))
|
||||
|
||||
@ -7,10 +7,16 @@ catala_integer <- setClass(
|
||||
"catala_integer",
|
||||
representation(v = "bigz"),
|
||||
)
|
||||
setMethod("Ops", "catala_integer", function(e1, e2) {
|
||||
setMethod("Arith", "catala_integer", function(e1, e2) {
|
||||
v <- callGeneric(e1@v, e2@v)
|
||||
new("catala_integer", v = v)
|
||||
})
|
||||
setMethod("-", c("catala_integer", "missing"), function(e1) {
|
||||
catala_integer(v = -e1@v)
|
||||
})
|
||||
setMethod("Compare", "catala_integer", function(e1, e2) {
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
################ Decimals #################
|
||||
|
||||
@ -18,10 +24,16 @@ catala_decimal <- setClass(
|
||||
"catala_decimal",
|
||||
representation(v = "bigq"),
|
||||
)
|
||||
setMethod("Ops", "catala_decimal", function(e1, e2) {
|
||||
setMethod("Arith", "catala_decimal", function(e1, e2) {
|
||||
v <- callGeneric(e1@v, e2@v)
|
||||
new("catala_decimal", v = v)
|
||||
})
|
||||
setMethod("-", c("catala_decimal", "missing"), function(e1) {
|
||||
catala_decimal(v = -e1@v)
|
||||
})
|
||||
setMethod("Compare", "catala_decimal", function(e1, e2) {
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
################ Money #################
|
||||
catala_money <- setClass(
|
||||
@ -34,6 +46,9 @@ setMethod("+", c("catala_money", "catala_money"), function(e1, e2) {
|
||||
setMethod("-", c("catala_money", "catala_money"), function(e1, e2) {
|
||||
catala_money(v = e1@v - e2@v)
|
||||
})
|
||||
setMethod("-", c("catala_money", "missing"), function(e1) {
|
||||
catala_money(v = -e1@v)
|
||||
})
|
||||
setMethod("*", c("catala_money", "catala_decimal"), function(e1, e2) {
|
||||
catala_money(v = as.bigz(as.bigq(e1@v) * e2@v))
|
||||
})
|
||||
@ -41,8 +56,7 @@ setMethod("/", c("catala_money", "catala_money"), function(e1, e2) {
|
||||
catala_decimal(v = as.bigq(e1@v / e2@v))
|
||||
})
|
||||
setMethod("Compare", "catala_money", function(e1, e2) {
|
||||
v <- callGeneric(e1@v, e2@v)
|
||||
new("catala_money", v = v)
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
################ Duration #################
|
||||
@ -56,12 +70,14 @@ setMethod("+", c("catala_duration", "catala_duration"), function(e1, e2) {
|
||||
setMethod("-", c("catala_duration", "catala_duration"), function(e1, e2) {
|
||||
catala_duration(v = e1@v - e2@v)
|
||||
})
|
||||
setMethod("-", c("catala_duration", "missing"), function(e1) {
|
||||
catala_duration(v = -e1@v)
|
||||
})
|
||||
setMethod("/", c("catala_duration", "catala_duration"), function(e1, e2) {
|
||||
catala_duration(v = e1@v / e2@v)
|
||||
})
|
||||
setMethod("Compare", "catala_duration", function(e1, e2) {
|
||||
v <- callGeneric(e1@v, e2@v)
|
||||
new("catala_duration", v = v)
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
|
||||
@ -80,13 +96,12 @@ setMethod("-", c("catala_date", "catala_date"), function(e1, e2) {
|
||||
catala_date(v = e1@v - e2@v)
|
||||
})
|
||||
setMethod("Compare", "catala_date", function(e1, e2) {
|
||||
v <- callGeneric(e1@v, e2@v)
|
||||
new("catala_date", v = v)
|
||||
callGeneric(e1@v, e2@v)
|
||||
})
|
||||
|
||||
################ Unit #################
|
||||
|
||||
catala_unit <- setClass("catala_unit")
|
||||
catala_unit <- setClass("catala_unit", representation(v = "numeric"))
|
||||
|
||||
################ Constructors and conversions #################
|
||||
|
||||
@ -300,7 +315,7 @@ catala_assertion_failure <- function(pos) {
|
||||
handle_default <- function(pos, exceptions, just, cons) {
|
||||
acc <- Reduce(function(acc, exception) {
|
||||
new_val <- tryCatch(
|
||||
exception(catala_unit()),
|
||||
exception(catala_unit(v = 0)),
|
||||
catala_empty_error = function(e) {
|
||||
NULL
|
||||
}
|
||||
@ -316,8 +331,8 @@ handle_default <- function(pos, exceptions, just, cons) {
|
||||
}
|
||||
}, exceptions, NULL)
|
||||
if (is.null(acc)) {
|
||||
if (just(catala_unit())) {
|
||||
cons(catala_unit())
|
||||
if (just(catala_unit(v = 0))) {
|
||||
cons(catala_unit(v = 0))
|
||||
} else {
|
||||
stop(catala_empty_error())
|
||||
}
|
||||
|
||||
@ -7,7 +7,6 @@ declaration structure S:
|
||||
data a content integer
|
||||
data b content boolean
|
||||
data c content collection decimal
|
||||
data d content integer depends on x content boolean
|
||||
|
||||
declaration enumeration E:
|
||||
-- Case1 content S
|
||||
@ -15,5 +14,16 @@ declaration enumeration E:
|
||||
|
||||
declaration scope Foo:
|
||||
input x content integer
|
||||
output y content integer
|
||||
internal y content E
|
||||
output z content boolean
|
||||
|
||||
scope Foo:
|
||||
definition y equals Case2
|
||||
|
||||
exception definition y under condition x = 1 consequence equals
|
||||
Case1 content S { --a: 1 --b: true --c: [0.2;0.3]}
|
||||
|
||||
definition z equals match y with pattern
|
||||
-- Case1: true
|
||||
-- Case2: false
|
||||
```
|
||||
107
test.r
107
test.r
@ -6,56 +6,127 @@ catala_struct_S <- setRefClass("catala_struct_S",
|
||||
fields = list(
|
||||
a = "catala_integer", b = "logical",
|
||||
c = "list" # array("catala_decimal")
|
||||
),
|
||||
methods = list(
|
||||
d = # bool → integer
|
||||
function() {
|
||||
stop("uninitialized")
|
||||
}
|
||||
)
|
||||
)
|
||||
|
||||
catala_struct_Foo <- setRefClass("catala_struct_Foo",
|
||||
fields = list(y = "catala_integer"), methods = list()
|
||||
fields = list(z = "logical")
|
||||
)
|
||||
|
||||
# Enum cases: "Case1" ("catala_class_S"), "Case2" ("catala_unit")
|
||||
# Enum cases: "Case1" ("catala_struct_S"), "Case2" ("catala_unit")
|
||||
catala_enum_E <- setRefClass("catala_enum_E",
|
||||
fields = list(code = "character", value = "ANY")
|
||||
)
|
||||
|
||||
catala_struct_FooIn <- setRefClass("catala_struct_FooIn",
|
||||
fields = list(x_in = "catala_integer"), methods = list()
|
||||
fields = list(x_in = "catala_integer")
|
||||
)
|
||||
|
||||
|
||||
|
||||
foo <- function(
|
||||
foo_in # ("catala_class_FooIn")
|
||||
foo_in # ("catala_struct_FooIn")
|
||||
) {
|
||||
x <- foo_in$x_in
|
||||
tryCatch(
|
||||
{
|
||||
temp_y <- function(dummy_var # ("catala_unit")
|
||||
) {
|
||||
stop(catala_empty_error())
|
||||
return(catala_enum_E(
|
||||
code = "Case2",
|
||||
value = catala_unit(v = 0)
|
||||
))
|
||||
}
|
||||
temp_y_1 <- function(dummy_var # ("catala_unit")
|
||||
) {
|
||||
return(FALSE)
|
||||
return(TRUE)
|
||||
}
|
||||
temp_y_2 <- handle_default(
|
||||
temp_y_2 <- function(dummy_var # ("catala_unit")
|
||||
) {
|
||||
temp_y_3 <- function(dummy_var # ("catala_unit")
|
||||
) {
|
||||
return(catala_enum_E(
|
||||
code = "Case1",
|
||||
value = catala_struct_S(
|
||||
a = catala_integer_from_numeric(1),
|
||||
b = TRUE, c = list(
|
||||
catala_decimal_from_string("0.2"),
|
||||
catala_decimal_from_string("0.3")
|
||||
)
|
||||
)
|
||||
))
|
||||
}
|
||||
temp_y_4 <- function(dummy_var # ("catala_unit")
|
||||
) {
|
||||
return((x == catala_integer_from_numeric(1)))
|
||||
}
|
||||
return(handle_default(
|
||||
catala_position(
|
||||
filename = "",
|
||||
start_line = 0, start_column = 1,
|
||||
end_line = 0, end_column = 1,
|
||||
law_headings = c()
|
||||
), list(), temp_y_4,
|
||||
temp_y_3
|
||||
))
|
||||
}
|
||||
temp_y_5 <- handle_default(
|
||||
catala_position(
|
||||
filename = "",
|
||||
start_line = 0, start_column = 1,
|
||||
end_line = 0, end_column = 1,
|
||||
law_headings = c()
|
||||
), list(), temp_y_1,
|
||||
temp_y
|
||||
), list(temp_y_2),
|
||||
temp_y_1, temp_y
|
||||
)
|
||||
},
|
||||
catala_empty_error = function(dummy__arg) {
|
||||
temp_y_2 <- dead_value
|
||||
temp_y_5 <- dead_value
|
||||
stop(catala_no_value_provided_error(
|
||||
catala_position(
|
||||
filename = "test.catala_en",
|
||||
start_line = 17,
|
||||
start_column = 12,
|
||||
end_line = 17,
|
||||
end_column = 13,
|
||||
law_headings = c(
|
||||
"Coucou",
|
||||
"Salut"
|
||||
)
|
||||
)
|
||||
))
|
||||
}
|
||||
)
|
||||
y <- temp_y_5
|
||||
tryCatch(
|
||||
{
|
||||
temp_z <- function(dummy_var # ("catala_unit")
|
||||
) {
|
||||
match_arg <- y
|
||||
if (match_arg$code == "Case1") {
|
||||
dummy_var <- match_arg$value
|
||||
return(TRUE)
|
||||
} else if (match_arg$code == "Case2") {
|
||||
dummy_var <- match_arg$value
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
temp_z_1 <- function(dummy_var # ("catala_unit")
|
||||
) {
|
||||
return(TRUE)
|
||||
}
|
||||
temp_z_2 <- handle_default(
|
||||
catala_position(
|
||||
filename = "",
|
||||
start_line = 0, start_column = 1,
|
||||
end_line = 0, end_column = 1,
|
||||
law_headings = c()
|
||||
), list(), temp_z_1,
|
||||
temp_z
|
||||
)
|
||||
},
|
||||
catala_empty_error = function(dummy__arg) {
|
||||
temp_z_2 <- dead_value
|
||||
stop(catala_no_value_provided_error(
|
||||
catala_position(
|
||||
filename = "test.catala_en",
|
||||
@ -71,6 +142,6 @@ foo <- function(
|
||||
))
|
||||
}
|
||||
)
|
||||
y <- temp_y_2
|
||||
return(Foo(y = y))
|
||||
z <- temp_z_2
|
||||
return(catala_struct_Foo(z = z))
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user