mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-20 00:41:05 +03:00
feat(jsoo): v1 jsoo plugin
This commit is contained in:
parent
ad0efd3447
commit
231f327efb
@ -1,6 +1,7 @@
|
|||||||
(* This file is part of the Catala compiler, a specification language for tax
|
(* This file is part of the Catala compiler, a specification language for tax
|
||||||
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
|
and social benefits computation rules. Copyright (C) 2020 Inria,
|
||||||
Louis Gesbert <louis.gesbert@inria.fr>.
|
contributors: Emile Rolley <emile.rolley@tuta.io>, Louis Gesbert
|
||||||
|
<louis.gesbert@inria.fr>.
|
||||||
|
|
||||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
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
|
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"
|
| TUnit -> "'a Js.opt"
|
||||||
| TInt -> "int"
|
| TInt -> "int"
|
||||||
| TRat -> "float"
|
| TRat -> "float"
|
||||||
| TMoney -> "int"
|
| TMoney -> "float"
|
||||||
| TDuration -> "string"
|
| TDuration -> "string"
|
||||||
| TBool -> "bool Js.t"
|
| TBool -> "bool Js.t"
|
||||||
| TDate -> "Js.date 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 TBool -> Format.fprintf fmt "Js.bool"
|
||||||
| Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_to_int"
|
| Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_to_int"
|
||||||
| Dcalc.Ast.TLit TRat -> Format.fprintf fmt "decimal_to_float"
|
| Dcalc.Ast.TLit TRat -> Format.fprintf fmt "decimal_to_float"
|
||||||
| Dcalc.Ast.TLit TMoney ->
|
| Dcalc.Ast.TLit TMoney -> Format.fprintf fmt "money_to_float"
|
||||||
Format.fprintf fmt "integer_to_int %@%@ money_to_cents"
|
|
||||||
| Dcalc.Ast.TLit TDuration -> Format.fprintf fmt "duration_to_jsoo"
|
| Dcalc.Ast.TLit TDuration -> Format.fprintf fmt "duration_to_jsoo"
|
||||||
| Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_to_jsoo"
|
| Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_to_jsoo"
|
||||||
| Dcalc.Ast.TEnum (_, ename) ->
|
| 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 TBool -> Format.fprintf fmt "Js.to_bool"
|
||||||
| Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_of_int"
|
| Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_of_int"
|
||||||
| Dcalc.Ast.TLit TRat -> Format.fprintf fmt "decimal_of_float"
|
| 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 TDuration -> Format.fprintf fmt "duration_of_jsoo"
|
||||||
| Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_of_jsoo"
|
| Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_of_jsoo"
|
||||||
| Dcalc.Ast.TEnum (_, ename) ->
|
| Dcalc.Ast.TEnum (_, ename) ->
|
||||||
@ -174,8 +175,8 @@ module To_jsoo = struct
|
|||||||
match Marked.unmark struct_field_type with
|
match Marked.unmark struct_field_type with
|
||||||
| Dcalc.Ast.TArrow _ ->
|
| Dcalc.Ast.TArrow _ ->
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"%a = failwith \"the function %a translation isn't \
|
"%a = failwith \"The function '%a' translation isn't yet \
|
||||||
supported yet..\""
|
supported...\""
|
||||||
format_struct_field_name (None, struct_field)
|
format_struct_field_name (None, struct_field)
|
||||||
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 ()
|
fmt_struct_name ()
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||||
(fun _fmt (struct_field, struct_field_type) ->
|
(fun fmt (struct_field, struct_field_type) ->
|
||||||
match Marked.unmark struct_field_type with
|
Format.fprintf fmt "method %a:@ %a %a"
|
||||||
(* | Dcalc.Ast.TArrow _ -> *)
|
format_struct_field_name_camel_case struct_field format_typ
|
||||||
(* Format.fprintf fmt *)
|
struct_field_type format_prop_or_meth struct_field_type))
|
||||||
(* "(* 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))
|
|
||||||
struct_fields fmt_conv_funs ()
|
struct_fields fmt_conv_funs ()
|
||||||
(* if !Cli.trace_flag then *)
|
|
||||||
(* format_struct_embedding fmt (struct_name, struct_fields) *)
|
|
||||||
in
|
in
|
||||||
let format_enum_decl
|
let format_enum_decl
|
||||||
fmt
|
fmt
|
||||||
@ -231,28 +224,24 @@ module To_jsoo = struct
|
|||||||
let fmt_module_enum_name fmt _ =
|
let fmt_module_enum_name fmt _ =
|
||||||
To_ocaml.format_to_module_name fmt (`Ename enum_name)
|
To_ocaml.format_to_module_name fmt (`Ename enum_name)
|
||||||
in
|
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 _ =
|
let fmt_to_jsoo fmt _ =
|
||||||
Format.fprintf fmt "%a"
|
Format.fprintf fmt "%a"
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||||
(fun fmt (cname, typ) ->
|
(fun fmt (cname, typ) ->
|
||||||
match Marked.unmark typ with
|
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
|
Format.fprintf fmt
|
||||||
"| %a arg -> object%%js@[<hov 2>@\n\
|
"| %a arg -> object%%js@[<hov 2>@\n\
|
||||||
val kind = Js.string \"%a\"@\n\
|
val kind = Js.string \"%a\"@\n\
|
||||||
val args = Js.Unsafe.coerce (Js.Unsafe.inject (0, %a arg \
|
val payload = Js.Unsafe.coerce (Js.Unsafe.inject (%a \
|
||||||
))@]@\n\
|
arg))@]@\n\
|
||||||
end"
|
end"
|
||||||
format_enum_cons_name cname format_enum_cons_name cname
|
format_enum_cons_name cname format_enum_cons_name cname
|
||||||
format_typ_to_jsoo typ
|
format_typ_to_jsoo typ))
|
||||||
| _ -> failwith "TODO: support constructor arguments"))
|
|
||||||
enum_cons
|
enum_cons
|
||||||
in
|
in
|
||||||
let fmt_of_jsoo fmt _ =
|
let fmt_of_jsoo fmt _ =
|
||||||
@ -266,14 +255,19 @@ module To_jsoo = struct
|
|||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||||
(fun fmt (cname, typ) ->
|
(fun fmt (cname, typ) ->
|
||||||
match Marked.unmark typ with
|
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
|
Format.fprintf fmt
|
||||||
"| \"%a\" ->@\n\
|
"| \"%a\" ->@\n%a.%a (%a (Js.Unsafe.get %a##.payload 0))"
|
||||||
\ let arg = Js.Unsafe.get %a##.args 2 in@\n\
|
format_enum_cons_name cname fmt_module_enum_name ()
|
||||||
%a.%a (%a arg)" format_enum_cons_name cname fmt_enum_name ()
|
format_enum_cons_name cname format_typ_to_jsoo typ
|
||||||
fmt_module_enum_name () format_enum_cons_name cname
|
fmt_enum_name ()))
|
||||||
format_typ_to_jsoo typ
|
|
||||||
| _ -> failwith "TODO: support constructor arguments"))
|
|
||||||
enum_cons fmt_module_enum_name ()
|
enum_cons fmt_module_enum_name ()
|
||||||
in
|
in
|
||||||
|
|
||||||
@ -293,18 +287,16 @@ module To_jsoo = struct
|
|||||||
@[<v 2>(** Expects one of:@\n\
|
@[<v 2>(** Expects one of:@\n\
|
||||||
%a *)@\n\
|
%a *)@\n\
|
||||||
@\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\
|
@]@\n\
|
||||||
end@]@\n\
|
end@]@\n\
|
||||||
%a@\n"
|
%a@\n"
|
||||||
format_enum_name enum_name
|
format_enum_name enum_name
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
~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))
|
Format.fprintf fmt "- \"%a\"" format_enum_cons_name enum_cons))
|
||||||
enum_cons fmt_conv_funs ()
|
enum_cons fmt_conv_funs ()
|
||||||
(* if !Cli.trace_flag then format_enum_embedding fmt (enum_name,
|
|
||||||
enum_cons) *)
|
|
||||||
in
|
in
|
||||||
let is_in_type_ordering s =
|
let is_in_type_ordering s =
|
||||||
List.exists
|
List.exists
|
||||||
@ -331,55 +323,61 @@ module To_jsoo = struct
|
|||||||
Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx))
|
Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx))
|
||||||
(type_ordering @ scope_structs)
|
(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)
|
(ctx : Dcalc.Ast.decl_ctx)
|
||||||
(fmt : Format.formatter)
|
(fmt : Format.formatter)
|
||||||
(scopes : ('expr, 'm) Dcalc.Ast.scopes) : unit =
|
(scopes : ('expr, 'm) Dcalc.Ast.scopes) =
|
||||||
let _format_fun_call_res fmt struct_name =
|
|
||||||
let struct_fields = find_struct struct_name ctx in
|
|
||||||
Format.fprintf fmt "(@[<hov 2> 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
|
|
||||||
match scopes with
|
match scopes with
|
||||||
| Dcalc.Ast.Nil -> ()
|
| Dcalc.Ast.Nil -> ()
|
||||||
| Dcalc.Ast.ScopeDef scope_def ->
|
| 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 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 _ =
|
let fmt_fun_call fmt _ =
|
||||||
Format.fprintf fmt "%a |> %a_of_jsoo |> %a |> %a_to_jsoo"
|
Format.fprintf fmt "%a |> %a_of_jsoo |> %a |> %a_to_jsoo"
|
||||||
fmt_input_struct_name () fmt_input_struct_name () format_var scope_var
|
fmt_input_struct_name scope_def fmt_input_struct_name scope_def
|
||||||
fmt_output_struct_name ()
|
format_var scope_var fmt_output_struct_name scope_def
|
||||||
in
|
in
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt "@\n@\nlet %a (%a : %a Js.t) : %a Js.t =@\n%a@\n%a"
|
||||||
"@\n@\n@[<hov 2> %a =@\n Js.wrap_callback@ (fun %a -> %a)@]%a"
|
format_var scope_var fmt_input_struct_name scope_def
|
||||||
fmt_meth_name () format_var scope_input_var fmt_fun_call ()
|
fmt_input_struct_name scope_def fmt_output_struct_name scope_def
|
||||||
(format_scopes ctx) scope_next
|
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@[<hov 2> %a =@\n Js.wrap_callback@ %a@]%a"
|
||||||
|
fmt_meth_name () format_var scope_var
|
||||||
|
(format_scopes_to_callbacks ctx)
|
||||||
|
scope_next
|
||||||
|
|
||||||
let format_program
|
let format_program
|
||||||
(fmt : Format.formatter)
|
(fmt : Format.formatter)
|
||||||
(module_name : string)
|
(module_name : string)
|
||||||
(prgm : 'm Lcalc.Ast.program)
|
(prgm : 'm Lcalc.Ast.program)
|
||||||
(type_ordering : Scopelang.Dependency.TVertex.t list) =
|
(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 _ ->
|
Cli.call_unstyled (fun _ ->
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"(** This file has been generated by the Catala compiler, do not \
|
"(** This file has been generated by the Catala compiler, do not \
|
||||||
@ -394,13 +392,16 @@ module To_jsoo = struct
|
|||||||
@\n\
|
@\n\
|
||||||
(* Generated API *)\n\n\
|
(* Generated API *)\n\n\
|
||||||
%a@\n\
|
%a@\n\
|
||||||
|
%a@\n\
|
||||||
@\n\n\
|
@\n\n\
|
||||||
\ let _ =@ @[<hov 2> Js.export_all@\n\
|
\ let _ =@ @[<hov 2> Js.export \"%a\"@\n\
|
||||||
(object%%js@ @[\n\
|
(object%%js@ @[\n\
|
||||||
\ val eventsManager = Runtime_jsoo.Runtime.event_manager@\n\n\
|
%a@]@\n\
|
||||||
%a@]end)@]@?"
|
end)@]@?"
|
||||||
module_name (format_ctx type_ordering) prgm.decl_ctx
|
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)
|
prgm.scopes)
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -50,5 +50,5 @@ let ocamlformat_file_opt = function
|
|||||||
| Some f ->
|
| Some f ->
|
||||||
Cli.debug_print "Formatting %s..." f;
|
Cli.debug_print "Formatting %s..." f;
|
||||||
if Sys.command (Printf.sprintf "ocamlformat %s -i" f) <> 0 then
|
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 -> ()
|
| None -> ()
|
||||||
|
@ -156,78 +156,8 @@ let _ =
|
|||||||
: (allocations_familiales_input Js.t -> float) Js.callback =
|
: (allocations_familiales_input Js.t -> float) Js.callback =
|
||||||
Js.wrap_callback (fun input ->
|
Js.wrap_callback (fun input ->
|
||||||
let result =
|
let result =
|
||||||
AF.interface_allocations_familiales
|
AF_web.#interfaceAllocationsFamiliales
|
||||||
{
|
input
|
||||||
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;
|
|
||||||
}
|
|
||||||
in
|
in
|
||||||
money_to_float
|
money_to_float
|
||||||
result.AF.InterfaceAllocationsFamilialesOut.i_montant_verse_out)
|
result.AF.InterfaceAllocationsFamilialesOut.i_montant_verse_out)
|
||||||
|
@ -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_of_cents_integer (cents : integer) : money = cents
|
||||||
let money_to_float (m : money) : float = Z.to_float m /. 100.
|
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 =
|
let money_to_string (m : money) : string =
|
||||||
Format.asprintf "%.2f" Q.(to_float (of_bigint m / of_int 100))
|
Format.asprintf "%.2f" Q.(to_float (of_bigint m / of_int 100))
|
||||||
|
|
||||||
|
@ -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_cents_string : string -> money
|
||||||
val money_of_units_int : int -> 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_of_cents_integer : integer -> money
|
||||||
val money_to_float : money -> float
|
val money_to_float : money -> float
|
||||||
val money_to_string : money -> string
|
val money_to_string : money -> string
|
||||||
|
Loading…
Reference in New Issue
Block a user