Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

feat(backend): disambiguate OCaml record names derived from Catala structs #288

Merged
merged 2 commits into from
Jul 13, 2022
Merged

feat(backend): disambiguate OCaml record names derived from Catala structs #288

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
4991350
feat(backend/ocaml): disambiguate OCaml record names derived from Cat…
EmileRolley Jul 12, 2022
a5c80b3
Not silent commands
denismerigoux Jul 13, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
73 changes: 49 additions & 24 deletions compiler/lcalc/to_ocaml.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -143,16 +143,33 @@ let avoid_keywords (s : string) : string =
else s

let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) :
unit =
Format.asprintf "%a" Dcalc.Ast.StructName.format_t v
|> to_ascii
|> to_lowercase
|> avoid_keywords
|> Format.fprintf fmt "%s"
[@@ocamlformat "disable"]

let format_to_struct_type (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) :
unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_lowercase
(to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v))))
Format.asprintf "%a" Dcalc.Ast.StructName.format_t v
|> to_ascii
|> to_lowercase
|> avoid_keywords
|> String.split_on_char '_'
|> List.map String.capitalize_ascii
|> String.concat ""
|> Format.fprintf fmt "%s"
[@@ocamlformat "disable"]

let format_struct_field_name
(fmt : Format.formatter)
(v : Dcalc.Ast.StructFieldName.t) : unit =
Format.fprintf fmt "%s"
((sname_opt, v) :
Dcalc.Ast.StructName.t option * Dcalc.Ast.StructFieldName.t) : unit =
(match sname_opt with
| Some sname -> Format.fprintf fmt "%a.%s" format_to_struct_type sname
| None -> Format.fprintf fmt "%s")
(avoid_keywords
(to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v)))

Expand Down Expand Up @@ -206,7 +223,7 @@ let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) :
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
format_typ_with_parens)
ts
| TTuple (_, Some s) -> Format.fprintf fmt "%a" format_struct_name s
| TTuple (_, Some s) -> Format.fprintf fmt "%a.t" format_to_struct_type s
| TEnum ([t], e) when D.EnumName.compare e Ast.option_enum = 0 ->
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
format_enum_name e
Expand Down Expand Up @@ -283,7 +300,7 @@ let rec format_expr
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt (e, struct_field) ->
Format.fprintf fmt "@[<hov 2>%a =@ %a@]" format_struct_field_name
struct_field format_with_parens e))
(Some s, struct_field) format_with_parens e))
(List.combine es (List.map fst (find_struct s ctx)))
| EArray es ->
Format.fprintf fmt "@[<hov 2>[|%a|]@]"
Expand All @@ -302,7 +319,7 @@ let rec format_expr
format_with_parens e1
| Some s ->
Format.fprintf fmt "%a.%a" format_with_parens e1 format_struct_field_name
(fst (List.nth (find_struct s ctx) n)))
(Some s, fst (List.nth (find_struct s ctx) n)))
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_enum_cons_name
(fst (List.nth (find_enum en ctx) n))
Expand Down Expand Up @@ -410,21 +427,22 @@ let format_struct_embedding
((struct_name, struct_fields) :
D.StructName.t * (D.StructFieldName.t * D.typ Pos.marked) list) =
if List.length struct_fields = 0 then
Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n"
format_struct_name struct_name format_struct_name struct_name
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_struct_name struct_name format_to_struct_type struct_name
else
Format.fprintf fmt
"@[<hov 2>let embed_%a (x: %a) : runtime_value =@ Struct([\"%a\"],@ \
"@[<hov 2>let embed_%a (x: %a.t) : runtime_value =@ Struct([\"%a\"],@ \
@[<hov 2>[%a]@])@]@\n\
@\n"
format_struct_name struct_name format_struct_name struct_name
format_struct_name struct_name format_to_struct_type struct_name
D.StructName.format_t struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" D.StructFieldName.format_t
struct_field typ_embedding_name struct_field_type
format_struct_field_name struct_field))
format_struct_field_name
(Some struct_name, struct_field)))
struct_fields

let format_enum_embedding
Expand Down Expand Up @@ -455,15 +473,22 @@ let format_ctx
(ctx : D.decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
if List.length struct_fields = 0 then
Format.fprintf fmt "type %a = unit@\n@\n" format_struct_name struct_name
Format.fprintf fmt
"module %a = struct@\n@[<hov 2>@ type t = unit\nend@] @\n"
format_to_struct_type struct_name
else
Format.fprintf fmt "type %a = {@\n@[<hov 2> %a@]@\n}@\n@\n"
format_struct_name struct_name
Format.fprintf fmt
"module %a = struct@\n\
@[<hov 2>@ type t = {@\n\
@[<hov 2> %a@]@\n\
}\n\
end@]@\n"
format_to_struct_type struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field
format_typ struct_field_type))
Format.fprintf fmt "%a:@ %a;" format_struct_field_name
(None, struct_field) format_typ struct_field_type))
struct_fields;
if !Cli.trace_flag then
format_struct_embedding fmt (struct_name, struct_fields)
Expand Down Expand Up @@ -502,9 +527,9 @@ let format_ctx
(fun struct_or_enum ->
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
Format.fprintf fmt "%a@\n@\n" format_struct_decl (s, find_struct s ctx)
Format.fprintf fmt "%a@\n" format_struct_decl (s, find_struct s ctx)
| Scopelang.Dependency.TVertex.Enum e ->
Format.fprintf fmt "%a@\n@\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)

let rec format_scope_body_expr
Expand Down Expand Up @@ -534,9 +559,9 @@ let rec format_scopes
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
Format.fprintf fmt "@\n@\n@[<hov 2>let %a (%a: %a) : %a =@\n%a@]%a"
format_var scope_var format_var scope_input_var format_struct_name
scope_def.scope_body.scope_body_input_struct format_struct_name
Format.fprintf fmt "@\n@\n@[<hov 2>let %a (%a: %a.t) : %a.t =@\n%a@]%a"
format_var scope_var format_var scope_input_var format_to_struct_type
scope_def.scope_body.scope_body_input_struct format_to_struct_type
scope_def.scope_body.scope_body_output_struct
(format_scope_body_expr ctx)
scope_body_expr (format_scopes ctx) scope_next
Expand Down
5,606 changes: 2,719 additions & 2,887 deletions french_law/js/french_law.js
View file
Open in desktop

Large diffs are not rendered by default.

22 changes: 13 additions & 9 deletions french_law/ocaml/api.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ open Runtime

let compute_allocations_familiales
~(current_date : Runtime.date)
~(children : AF.enfant_entree array)
~(children : AF.EnfantEntree.t array)
~(income : int)
~(residence : AF.collectivite)
~(is_parent : bool)
Expand All @@ -29,15 +29,19 @@ let compute_allocations_familiales
let result =
AF.interface_allocations_familiales
{
AF.i_date_courante_in = current_date;
AF.i_enfants_in = children;
AF.i_ressources_menage_in = money_of_units_int income;
AF.i_residence_in = residence;
AF.i_personne_charge_effective_permanente_est_parent_in = is_parent;
AF.i_personne_charge_effective_permanente_remplit_titre_I_in =
AF.InterfaceAllocationsFamilialesIn.i_date_courante_in = current_date;
AF.InterfaceAllocationsFamilialesIn.i_enfants_in = children;
AF.InterfaceAllocationsFamilialesIn.i_ressources_menage_in =
money_of_units_int income;
AF.InterfaceAllocationsFamilialesIn.i_residence_in = residence;
AF.InterfaceAllocationsFamilialesIn
.i_personne_charge_effective_permanente_est_parent_in = is_parent;
AF.InterfaceAllocationsFamilialesIn
.i_personne_charge_effective_permanente_remplit_titre_I_in =
fills_title_I;
AF.i_avait_enfant_a_charge_avant_1er_janvier_2012_in =
AF.InterfaceAllocationsFamilialesIn
.i_avait_enfant_a_charge_avant_1er_janvier_2012_in =
had_rights_open_before_2012;
}
in
money_to_float result.AF.i_montant_verse_out
money_to_float result.AF.InterfaceAllocationsFamilialesOut.i_montant_verse_out
2 changes: 1 addition & 1 deletion french_law/ocaml/api.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@ module Allocations_familiales = Law_source.Allocations_familiales

val compute_allocations_familiales :
current_date:Runtime.date ->
children:Allocations_familiales.enfant_entree array ->
children:Allocations_familiales.EnfantEntree.t array ->
income:int ->
residence:Allocations_familiales.collectivite ->
is_parent:bool ->
Expand Down
35 changes: 21 additions & 14 deletions french_law/ocaml/api_web.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -158,31 +158,35 @@ let _ =
let result =
AF.interface_allocations_familiales
{
AF.i_personne_charge_effective_permanente_est_parent_in =
AF.InterfaceAllocationsFamilialesIn
.i_personne_charge_effective_permanente_est_parent_in =
Js.to_bool
input##.personneQuiAssumeLaChargeEffectivePermanenteEstParent;
AF.i_personne_charge_effective_permanente_remplit_titre_I_in =
AF.InterfaceAllocationsFamilialesIn
.i_personne_charge_effective_permanente_remplit_titre_I_in =
Js.to_bool
input##.personneQuiAssumeLaChargeEffectivePermanenteRemplitConditionsTitreISecuriteSociale;
AF.i_date_courante_in =
AF.InterfaceAllocationsFamilialesIn.i_date_courante_in =
date_of_numbers
input##.currentDate##getUTCFullYear
input##.currentDate##getUTCMonth
input##.currentDate##getUTCDate;
AF.i_enfants_in =
AF.InterfaceAllocationsFamilialesIn.i_enfants_in =
Array.map
(fun (child : enfant_entree Js.t) ->
{
AF.d_a_deja_ouvert_droit_aux_allocations_familiales =
AF.EnfantEntree
.d_a_deja_ouvert_droit_aux_allocations_familiales =
Js.to_bool
child##.aDejaOuvertDroitAuxAllocationsFamiliales;
AF.d_identifiant = integer_of_int child##.id;
AF.d_date_de_naissance =
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.d_prise_en_charge =
AF.EnfantEntree.d_prise_en_charge =
(match Js.to_string child##.priseEnCharge with
| "Effective et permanente" ->
EffectiveEtPermanente ()
Expand All @@ -198,16 +202,17 @@ let _ =
ServicesSociauxAllocationVerseeAuxServicesSociaux
()
| _ -> failwith "Unknown prise en charge");
AF.d_remuneration_mensuelle =
AF.EnfantEntree.d_remuneration_mensuelle =
money_of_units_int child##.remunerationMensuelle;
AF
AF.EnfantEntree
.d_beneficie_titre_personnel_aide_personnelle_logement =
Js.to_bool
child##.beneficieTitrePersonnelAidePersonnelleAuLogement;
})
(Js.to_array input##.children);
AF.i_ressources_menage_in = money_of_units_int input##.income;
AF.i_residence_in =
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 ()
Expand All @@ -219,9 +224,11 @@ let _ =
| "Saint Martin" -> AF.SaintMartin ()
| "Mayotte" -> AF.Mayotte ()
| _ -> failwith "unknown collectivite!");
AF.i_avait_enfant_a_charge_avant_1er_janvier_2012_in =
AF.InterfaceAllocationsFamilialesIn
.i_avait_enfant_a_charge_avant_1er_janvier_2012_in =
Js.to_bool input##.avaitEnfantAChargeAvant1erJanvier2012;
}
in
money_to_float result.AF.i_montant_verse_out)
money_to_float
result.AF.InterfaceAllocationsFamilialesOut.i_montant_verse_out)
end)
10 changes: 5 additions & 5 deletions french_law/ocaml/bench.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@ open Runtime

let random_children (id : int) =
{
AF.d_identifiant = integer_of_int id;
AF.EnfantEntree.d_identifiant = integer_of_int id;
d_remuneration_mensuelle = money_of_units_int (Random.int 2000);
d_date_de_naissance =
date_of_numbers
Expand Down Expand Up @@ -100,10 +100,10 @@ let run_test () =
\ income: %.2f\n\
\ birth date: %s\n\
\ prise en charge: %a"
(integer_to_int child.AF.d_identifiant)
(money_to_float child.AF.d_remuneration_mensuelle)
(Runtime.date_to_string child.AF.d_date_de_naissance)
format_prise_en_charge child.AF.d_prise_en_charge))
(integer_to_int child.AF.EnfantEntree.d_identifiant)
(money_to_float child.AF.EnfantEntree.d_remuneration_mensuelle)
(Runtime.date_to_string child.AF.EnfantEntree.d_date_de_naissance)
format_prise_en_charge child.AF.EnfantEntree.d_prise_en_charge))
(Array.to_list children) income
(Runtime.date_to_string current_date)
format_residence residence;
Expand Down
Loading