diff --git a/compiler/plugins/jsoo.ml b/compiler/plugins/jsoo.ml index 9eaa1523..41d39d53 100644 --- a/compiler/plugins/jsoo.ml +++ b/compiler/plugins/jsoo.ml @@ -1,6 +1,7 @@ (* This file is part of the Catala compiler, a specification language for tax - and social benefits computation rules. Copyright (C) 2020 Inria, contributor: - Louis Gesbert . + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Emile Rolley , Louis Gesbert + . 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 @@ -35,7 +36,7 @@ module To_jsoo = struct | TUnit -> "'a Js.opt" | TInt -> "int" | TRat -> "float" - | TMoney -> "int" + | TMoney -> "float" | TDuration -> "string" | TBool -> "bool Js.t" | TDate -> "Js.date Js.t") @@ -74,8 +75,7 @@ module To_jsoo = struct | Dcalc.Ast.TLit TBool -> Format.fprintf fmt "Js.bool" | Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_to_int" | Dcalc.Ast.TLit TRat -> Format.fprintf fmt "decimal_to_float" - | Dcalc.Ast.TLit TMoney -> - Format.fprintf fmt "integer_to_int %@%@ money_to_cents" + | Dcalc.Ast.TLit TMoney -> Format.fprintf fmt "money_to_float" | Dcalc.Ast.TLit TDuration -> Format.fprintf fmt "duration_to_jsoo" | Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_to_jsoo" | Dcalc.Ast.TEnum (_, ename) -> @@ -93,7 +93,8 @@ module To_jsoo = struct | Dcalc.Ast.TLit TBool -> Format.fprintf fmt "Js.to_bool" | Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_of_int" | Dcalc.Ast.TLit TRat -> Format.fprintf fmt "decimal_of_float" - | Dcalc.Ast.TLit TMoney -> Format.fprintf fmt "money_of_units_int" + | Dcalc.Ast.TLit TMoney -> + Format.fprintf fmt "money_of_decimal %@%@ decimal_of_float" | Dcalc.Ast.TLit TDuration -> Format.fprintf fmt "duration_of_jsoo" | Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_of_jsoo" | Dcalc.Ast.TEnum (_, ename) -> @@ -174,8 +175,8 @@ module To_jsoo = struct match Marked.unmark struct_field_type with | Dcalc.Ast.TArrow _ -> Format.fprintf fmt - "%a = failwith \"the function %a translation isn't \ - supported yet..\"" + "%a = failwith \"The function '%a' translation isn't yet \ + supported...\"" format_struct_field_name (None, struct_field) format_struct_field_name (None, struct_field) | _ -> @@ -209,19 +210,11 @@ module To_jsoo = struct fmt_struct_name () (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun _fmt (struct_field, struct_field_type) -> - match Marked.unmark struct_field_type with - (* | Dcalc.Ast.TArrow _ -> *) - (* Format.fprintf fmt *) - (* "(* NOTE: the %a method is ignored for now.*)" *) - (* format_struct_field_name_camel_case struct_field *) - | _ -> - Format.fprintf fmt "method %a:@ %a %a" - format_struct_field_name_camel_case struct_field format_typ - struct_field_type format_prop_or_meth struct_field_type)) + (fun fmt (struct_field, struct_field_type) -> + Format.fprintf fmt "method %a:@ %a %a" + format_struct_field_name_camel_case struct_field format_typ + struct_field_type format_prop_or_meth struct_field_type)) struct_fields fmt_conv_funs () - (* if !Cli.trace_flag then *) - (* format_struct_embedding fmt (struct_name, struct_fields) *) in let format_enum_decl fmt @@ -231,28 +224,24 @@ module To_jsoo = struct let fmt_module_enum_name fmt _ = To_ocaml.format_to_module_name fmt (`Ename enum_name) in - let _fmt_enum_args fmt ts = - Format.fprintf fmt "(%s)" - (List.init (List.length ts) (fun i -> "arg" ^ string_of_int i) - |> String.concat ",") - in - let fmt_to_jsoo fmt _ = Format.fprintf fmt "%a" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt (cname, typ) -> match Marked.unmark typ with - | Dcalc.Ast.TLit _ -> + | Dcalc.Ast.TTuple (_, None) -> + Cli.error_print + "Tuples aren't supported yet in the conversion to JS" + | _ -> Format.fprintf fmt "| %a arg -> object%%js@[@\n\ val kind = Js.string \"%a\"@\n\ - val args = Js.Unsafe.coerce (Js.Unsafe.inject (0, %a arg \ - ))@]@\n\ + val payload = Js.Unsafe.coerce (Js.Unsafe.inject (%a \ + arg))@]@\n\ end" format_enum_cons_name cname format_enum_cons_name cname - format_typ_to_jsoo typ - | _ -> failwith "TODO: support constructor arguments")) + format_typ_to_jsoo typ)) enum_cons in let fmt_of_jsoo fmt _ = @@ -266,14 +255,19 @@ module To_jsoo = struct ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt (cname, typ) -> match Marked.unmark typ with - | Dcalc.Ast.TLit _ -> + | Dcalc.Ast.TTuple (_, None) -> + Cli.error_print + "Tuples aren't yet supported in the conversion to JS..." + | Dcalc.Ast.TLit TUnit -> + Format.fprintf fmt "| \"%a\" ->@\n%a.%a ()" + format_enum_cons_name cname fmt_module_enum_name () + format_enum_cons_name cname + | _ -> Format.fprintf fmt - "| \"%a\" ->@\n\ - \ let arg = Js.Unsafe.get %a##.args 2 in@\n\ - %a.%a (%a arg)" format_enum_cons_name cname fmt_enum_name () - fmt_module_enum_name () format_enum_cons_name cname - format_typ_to_jsoo typ - | _ -> failwith "TODO: support constructor arguments")) + "| \"%a\" ->@\n%a.%a (%a (Js.Unsafe.get %a##.payload 0))" + format_enum_cons_name cname fmt_module_enum_name () + format_enum_cons_name cname format_typ_to_jsoo typ + fmt_enum_name ())) enum_cons fmt_module_enum_name () in @@ -293,18 +287,16 @@ module To_jsoo = struct @[(** Expects one of:@\n\ %a *)@\n\ @\n\ - @]method args : Js.Unsafe.any_js_array Js.t Js.readonly_prop@\n\ + @]method payload : Js.Unsafe.any Js.t Js.readonly_prop@\n\ @]@\n\ end@]@\n\ %a@\n" format_enum_name enum_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun _fmt (enum_cons, _) -> + (fun fmt (enum_cons, _) -> Format.fprintf fmt "- \"%a\"" format_enum_cons_name enum_cons)) enum_cons fmt_conv_funs () - (* if !Cli.trace_flag then format_enum_embedding fmt (enum_name, - enum_cons) *) in let is_in_type_ordering s = List.exists @@ -331,55 +323,61 @@ module To_jsoo = struct Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx)) (type_ordering @ scope_structs) - let rec format_scopes + let fmt_input_struct_name fmt (scope_def : ('a expr, 'm) D.scope_def) = + format_struct_name fmt scope_def.scope_body.scope_body_input_struct + + let fmt_output_struct_name fmt (scope_def : ('a expr, 'm) D.scope_def) = + format_struct_name fmt scope_def.scope_body.scope_body_output_struct + + let rec format_scopes_to_fun (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) - (scopes : ('expr, 'm) Dcalc.Ast.scopes) : unit = - let _format_fun_call_res fmt struct_name = - let struct_fields = find_struct struct_name ctx in - Format.fprintf fmt "(@[ object%%js@\n%a@\nend@])" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - (fun _ (struct_field, struct_field_type) -> - Format.fprintf fmt "val %a =@ %a result.%a" - format_struct_field_name_camel_case struct_field - format_typ_to_jsoo struct_field_type format_struct_field_name - (Some struct_name, struct_field))) - struct_fields - in + (scopes : ('expr, 'm) Dcalc.Ast.scopes) = match scopes with | Dcalc.Ast.Nil -> () | Dcalc.Ast.ScopeDef scope_def -> - let scope_input_var, _scope_body_expr = - Bindlib.unbind scope_def.scope_body.scope_body_expr - in let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in - let fmt_input_struct_name fmt _ = - format_struct_name fmt scope_def.scope_body.scope_body_input_struct - in - let fmt_output_struct_name fmt _ = - format_struct_name fmt scope_def.scope_body.scope_body_output_struct - in - let fmt_meth_name fmt _ = - Format.fprintf fmt "method %a : (%a -> %a) Js.callback" - format_var_camel_case scope_var fmt_input_struct_name () - fmt_output_struct_name () - in let fmt_fun_call fmt _ = Format.fprintf fmt "%a |> %a_of_jsoo |> %a |> %a_to_jsoo" - fmt_input_struct_name () fmt_input_struct_name () format_var scope_var - fmt_output_struct_name () + fmt_input_struct_name scope_def fmt_input_struct_name scope_def + format_var scope_var fmt_output_struct_name scope_def in - Format.fprintf fmt - "@\n@\n@[ %a =@\n Js.wrap_callback@ (fun %a -> %a)@]%a" - fmt_meth_name () format_var scope_input_var fmt_fun_call () - (format_scopes ctx) scope_next + Format.fprintf fmt "@\n@\nlet %a (%a : %a Js.t) : %a Js.t =@\n%a@\n%a" + format_var scope_var fmt_input_struct_name scope_def + fmt_input_struct_name scope_def fmt_output_struct_name scope_def + fmt_fun_call () (format_scopes_to_fun ctx) scope_next + + let rec format_scopes_to_callbacks + (ctx : Dcalc.Ast.decl_ctx) + (fmt : Format.formatter) + (scopes : ('expr, 'm) Dcalc.Ast.scopes) : unit = + match scopes with + | Dcalc.Ast.Nil -> () + | Dcalc.Ast.ScopeDef scope_def -> + let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in + let fmt_meth_name fmt _ = + Format.fprintf fmt "method %a : (%a Js.t -> %a Js.t) Js.callback" + format_var_camel_case scope_var fmt_input_struct_name scope_def + fmt_output_struct_name scope_def + in + Format.fprintf fmt "@\n@\n@[ %a =@\n Js.wrap_callback@ %a@]%a" + fmt_meth_name () format_var scope_var + (format_scopes_to_callbacks ctx) + scope_next let format_program (fmt : Format.formatter) (module_name : string) (prgm : 'm Lcalc.Ast.program) (type_ordering : Scopelang.Dependency.TVertex.t list) = + let fmt_lib_name fmt _ = + Format.fprintf fmt "%sLib" + (List.nth (String.split_on_char ' ' module_name) 1 + |> String.split_on_char '_' + |> List.map String.capitalize_ascii + |> String.concat "") + in + Cli.call_unstyled (fun _ -> Format.fprintf fmt "(** This file has been generated by the Catala compiler, do not \ @@ -394,13 +392,16 @@ module To_jsoo = struct @\n\ (* Generated API *)\n\n\ %a@\n\ + %a@\n\ @\n\n\ - \ let _ =@ @[ Js.export_all@\n\ + \ let _ =@ @[ Js.export \"%a\"@\n\ (object%%js@ @[\n\ - \ val eventsManager = Runtime_jsoo.Runtime.event_manager@\n\n\ - %a@]end)@]@?" + %a@]@\n\ + end)@]@?" module_name (format_ctx type_ordering) prgm.decl_ctx - (format_scopes prgm.decl_ctx) + (format_scopes_to_fun prgm.decl_ctx) + prgm.scopes fmt_lib_name () + (format_scopes_to_callbacks prgm.decl_ctx) prgm.scopes) end diff --git a/compiler/utils/file.ml b/compiler/utils/file.ml index c62d9b48..a0a606a2 100644 --- a/compiler/utils/file.ml +++ b/compiler/utils/file.ml @@ -50,5 +50,5 @@ let ocamlformat_file_opt = function | Some f -> Cli.debug_print "Formatting %s..." f; if Sys.command (Printf.sprintf "ocamlformat %s -i" f) <> 0 then - failwith ("Internal error: ocamlformat failed on " ^ f) + Cli.error_print "Internal error: ocamlformat failed on %s" f | None -> () diff --git a/french_law/ocaml/api_web.ml b/french_law/ocaml/api_web.ml index e4cee469..808cabb4 100644 --- a/french_law/ocaml/api_web.ml +++ b/french_law/ocaml/api_web.ml @@ -156,78 +156,8 @@ let _ = : (allocations_familiales_input Js.t -> float) Js.callback = Js.wrap_callback (fun input -> let result = - AF.interface_allocations_familiales - { - AF.InterfaceAllocationsFamilialesIn - .i_personne_charge_effective_permanente_est_parent_in = - Js.to_bool - input##.personneQuiAssumeLaChargeEffectivePermanenteEstParent; - AF.InterfaceAllocationsFamilialesIn - .i_personne_charge_effective_permanente_remplit_titre_I_in = - Js.to_bool - input##.personneQuiAssumeLaChargeEffectivePermanenteRemplitConditionsTitreISecuriteSociale; - AF.InterfaceAllocationsFamilialesIn.i_date_courante_in = - date_of_numbers - input##.currentDate##getUTCFullYear - input##.currentDate##getUTCMonth - input##.currentDate##getUTCDate; - AF.InterfaceAllocationsFamilialesIn.i_enfants_in = - Array.map - (fun (child : enfant_entree Js.t) -> - { - AF.EnfantEntree - .d_a_deja_ouvert_droit_aux_allocations_familiales = - Js.to_bool - child##.aDejaOuvertDroitAuxAllocationsFamiliales; - AF.EnfantEntree.d_identifiant = - integer_of_int child##.id; - AF.EnfantEntree.d_date_de_naissance = - date_of_numbers - child##.dateNaissance##getUTCFullYear - child##.dateNaissance##getUTCMonth - child##.dateNaissance##getUTCDate; - AF.EnfantEntree.d_prise_en_charge = - (match Js.to_string child##.priseEnCharge with - | "Effective et permanente" -> - EffectiveEtPermanente () - | "Garde alternée, allocataire unique" -> - GardeAlterneeAllocataireUnique () - | "Garde alternée, partage des allocations" -> - GardeAlterneePartageAllocations () - | "Confié aux service sociaux, allocation versée \ - à la famille" -> - ServicesSociauxAllocationVerseeALaFamille () - | "Confié aux service sociaux, allocation versée \ - aux services sociaux" -> - ServicesSociauxAllocationVerseeAuxServicesSociaux - () - | _ -> failwith "Unknown prise en charge"); - AF.EnfantEntree.d_remuneration_mensuelle = - money_of_units_int child##.remunerationMensuelle; - AF.EnfantEntree - .d_beneficie_titre_personnel_aide_personnelle_logement = - Js.to_bool - child##.beneficieTitrePersonnelAidePersonnelleAuLogement; - }) - (Js.to_array input##.children); - AF.InterfaceAllocationsFamilialesIn.i_ressources_menage_in = - money_of_units_int input##.income; - AF.InterfaceAllocationsFamilialesIn.i_residence_in = - (match Js.to_string input##.residence with - | "Métropole" -> AF.Metropole () - | "Guyane" -> AF.Guyane () - | "Guadeloupe" -> AF.Guadeloupe () - | "Martinique" -> AF.Martinique () - | "La Réunion" -> AF.LaReunion () - | "Saint Barthélemy" -> AF.SaintBarthelemy () - | "Saint Pierre et Miquelon" -> AF.SaintPierreEtMiquelon () - | "Saint Martin" -> AF.SaintMartin () - | "Mayotte" -> AF.Mayotte () - | _ -> failwith "unknown collectivite!"); - AF.InterfaceAllocationsFamilialesIn - .i_avait_enfant_a_charge_avant_1er_janvier_2012_in = - Js.to_bool input##.avaitEnfantAChargeAvant1erJanvier2012; - } + AF_web.#interfaceAllocationsFamiliales + input in money_to_float result.AF.InterfaceAllocationsFamilialesOut.i_montant_verse_out) diff --git a/runtimes/ocaml/runtime.ml b/runtimes/ocaml/runtime.ml index 63f03b5a..a6b6a312 100644 --- a/runtimes/ocaml/runtime.ml +++ b/runtimes/ocaml/runtime.ml @@ -44,6 +44,9 @@ let money_of_units_int (units : int) : money = Z.(of_int units * of_int 100) let money_of_cents_integer (cents : integer) : money = cents let money_to_float (m : money) : float = Z.to_float m /. 100. +let money_of_decimal (d : decimal) : money = + Q.to_bigint (Q.mul d (Q.of_int 100)) + let money_to_string (m : money) : string = Format.asprintf "%.2f" Q.(to_float (of_bigint m / of_int 100)) diff --git a/runtimes/ocaml/runtime.mli b/runtimes/ocaml/runtime.mli index e6957483..f6a155d6 100644 --- a/runtimes/ocaml/runtime.mli +++ b/runtimes/ocaml/runtime.mli @@ -209,6 +209,10 @@ val pp_events : ?is_first_call:bool -> Format.formatter -> event list -> unit val money_of_cents_string : string -> money val money_of_units_int : int -> money + +val money_of_decimal : decimal -> money +(** Warning: rounds to nearest cent. *) + val money_of_cents_integer : integer -> money val money_to_float : money -> float val money_to_string : money -> string