Skip to content

Commit

Permalink
feat(backend/ocaml): disambiguate OCaml record names derived from Cat…
Browse files Browse the repository at this point in the history 
…ala struct
  • Loading branch information
@EmileRolley
EmileRolley committed Jul 12, 2022
1 parent 43eb4de commit 4991350
Show file tree
Hide file tree
Showing 11 changed files with 3,355 additions and 3,249 deletions.
4 changes: 2 additions & 2 deletions Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -272,10 +272,10 @@ CLERK=$(CLERK_BIN) --exe $(CATALA_BIN) \
.FORCE:

test_suite: .FORCE
$(CLERK) test tests
@$(CLERK) test tests

test_examples: .FORCE
$(CLERK) test examples
@$(CLERK) test examples

#> tests : Run interpreter tests
tests: test_suite test_examples
Expand Down
73 changes: 49 additions & 24 deletions compiler/lcalc/to_ocaml.ml
View file
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

Large diffs are not rendered by default.

22 changes: 13 additions & 9 deletions french_law/ocaml/api.ml
View file
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
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
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
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

0 comments on commit 4991350

Please sign in to comment.