Merge branch 'master' into aides_logement

build_system/clerk_driver.ml

@@ -226,7 +226,6 @@ let add_reset_rules_aux
       [
         Var "catala_cmd";
         Var "tested_file";
-        Var "extra_flags";
         Lit "--unstyled";
         Lit "--output=-";
         Lit redirect;
@@ -265,7 +264,6 @@ let add_test_rules_aux
             :: [
                  Var "catala_cmd";
                  Var "tested_file";
-                 Var "extra_flags";
                  Lit "--unstyled";
                  Lit "--output=/dev/stdout";
                  Lit "2>&1 | colordiff -u -b";
@@ -363,8 +361,10 @@ let collect_all_ninja_build
                   ninja.builds;
             }
           in
-          ( ninja_add_new_build expected_output_file rule_to_call vars ninja,
-            test_names ^ " $\n  " ^ expected_output_file ))
+          ( ninja_add_new_build
+              (expected_output_file ^ ".PHONY")
+              rule_to_call vars ninja,
+            test_names ^ " $\n  " ^ expected_output_file ^ ".PHONY" ))
         (ninja, "") expected_outputs
     in
     let test_name =

compiler/lcalc/to_ocaml.ml

@@ -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)))
 
@@ -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
@@ -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|]@]"
@@ -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))
@@ -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
@@ -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)
@@ -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
@@ -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

french_law/ocaml/api.ml

@@ -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)
@@ -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

french_law/ocaml/api.mli

@@ -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 ->

french_law/ocaml/api_web.ml

@@ -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 ()
@@ -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 ()
@@ -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)

french_law/ocaml/bench.ml

@@ -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
@@ -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;

french_law/ocaml/law_source/allocations_familiales.mli

@@ -49,37 +49,45 @@ type element_prestations_familiales =
   | AllocationRentreeScolaire of unit
   | AllocationJournalierePresenceParentale of unit
 
-type enfant_entree = {
-  d_identifiant : integer;
-  d_remuneration_mensuelle : money;
-  d_date_de_naissance : date;
-  d_prise_en_charge : prise_en_charge;
-  d_a_deja_ouvert_droit_aux_allocations_familiales : bool;
-  d_beneficie_titre_personnel_aide_personnelle_logement : bool;
-}
+module EnfantEntree : sig
+  type t = {
+    d_identifiant : integer;
+    d_remuneration_mensuelle : money;
+    d_date_de_naissance : date;
+    d_prise_en_charge : prise_en_charge;
+    d_a_deja_ouvert_droit_aux_allocations_familiales : bool;
+    d_beneficie_titre_personnel_aide_personnelle_logement : bool;
+  }
+end
 
-type enfant = {
-  identifiant : integer;
-  obligation_scolaire : situation_obligation_scolaire;
-  remuneration_mensuelle : money;
-  date_de_naissance : date;
-  age : integer;
-  prise_en_charge : prise_en_charge;
-  a_deja_ouvert_droit_aux_allocations_familiales : bool;
-  beneficie_titre_personnel_aide_personnelle_logement : bool;
-}
+module Enfant : sig
+  type t = {
+    identifiant : integer;
+    obligation_scolaire : situation_obligation_scolaire;
+    remuneration_mensuelle : money;
+    date_de_naissance : date;
+    age : integer;
+    prise_en_charge : prise_en_charge;
+    a_deja_ouvert_droit_aux_allocations_familiales : bool;
+    beneficie_titre_personnel_aide_personnelle_logement : bool;
+  }
+end
 
-type interface_allocations_familiales_out = { i_montant_verse_out : money }
+module InterfaceAllocationsFamilialesOut : sig
+  type t = { i_montant_verse_out : money }
+end
 
-type interface_allocations_familiales_in = {
-  i_date_courante_in : date;
-  i_enfants_in : enfant_entree array;
-  i_ressources_menage_in : money;
-  i_residence_in : collectivite;
-  i_personne_charge_effective_permanente_est_parent_in : bool;
-  i_personne_charge_effective_permanente_remplit_titre_I_in : bool;
-  i_avait_enfant_a_charge_avant_1er_janvier_2012_in : bool;
-}
+module InterfaceAllocationsFamilialesIn : sig
+  type t = {
+    i_date_courante_in : date;
+    i_enfants_in : EnfantEntree.t array;
+    i_ressources_menage_in : money;
+    i_residence_in : collectivite;
+    i_personne_charge_effective_permanente_est_parent_in : bool;
+    i_personne_charge_effective_permanente_remplit_titre_I_in : bool;
+    i_avait_enfant_a_charge_avant_1er_janvier_2012_in : bool;
+  }
+end
 
 val interface_allocations_familiales :
-  interface_allocations_familiales_in -> interface_allocations_familiales_out
+  InterfaceAllocationsFamilialesIn.t -> InterfaceAllocationsFamilialesOut.t

tests/test_scope/good/191_fix_record_name_confusion.catala_en

@@ -0,0 +1,20 @@
+## Article
+
+```catala
+declaration scope ScopeA:
+  context output a content boolean
+
+declaration scope ScopeB:
+  context a content boolean
+  scopeA scope ScopeA
+
+scope ScopeA:
+  definition a equals true
+
+scope ScopeB:
+  definition a equals scopeA.a
+```
+
+```catala-test {id="OCaml"}
+catala OCaml 
+```

tests/test_scope/good/output/191_fix_record_name_confusion.catala_en.OCaml

@@ -0,0 +1,68 @@
+(** This file has been generated by the Catala compiler, do not edit! *)
+
+open Runtime
+
+[@@@ocaml.warning "-4-26-27-32-41-42"]
+
+module ScopeAOut = struct
+  type t = {
+    a_out: bool;
+  }
+end
+
+module ScopeAIn = struct
+  type t = {
+    a_in: unit -> bool;
+  }
+end
+
+module ScopeBOut = struct
+  type t = unit
+end 
+
+module ScopeBIn = struct
+  type t = {
+    a_in: unit -> bool;
+  }
+end
+
+
+
+let scope_a (scope_a_in: ScopeAIn.t) : ScopeAOut.t =
+  let a_: unit -> bool = scope_a_in.ScopeAIn.a_in in
+  let a_: bool = (try
+                    (handle_default ([|(fun (_: _) -> a_ ())|])
+                       (fun (_: _) -> true)
+                       (fun (_: _) ->
+                          handle_default
+                            ([|(fun (_: _) ->
+                                  handle_default ([||]) (fun (_: _) -> true)
+                                    (fun (_: _) -> true))|])
+                            (fun (_: _) -> false)
+                            (fun (_: _) -> raise EmptyError))) with
+                    EmptyError -> (raise (NoValueProvided
+                    {filename = "tests/test_scope/good/191_fix_record_name_confusion.catala_en";
+                      start_line=5; start_column=18;
+                      end_line=5; end_column=19; law_headings=["Article"]}))) in
+  {ScopeAOut.a_out = a_}
+
+let scope_b (scope_b_in: ScopeBIn.t) : ScopeBOut.t =
+  let a_: unit -> bool = scope_b_in.ScopeBIn.a_in in
+  let scope_a_dot_a_: unit -> bool = fun (_: unit) -> (raise EmptyError) in
+  let result_: ScopeAOut.t = ((scope_a) {ScopeAIn.a_in = scope_a_dot_a_}) in
+  let scope_a_dot_a_: bool = result_.ScopeAOut.a_out in
+  let a_: bool = (try
+                    (handle_default ([|(fun (_: _) -> a_ ())|])
+                       (fun (_: _) -> true)
+                       (fun (_: _) ->
+                          handle_default
+                            ([|(fun (_: _) ->
+                                  handle_default ([||]) (fun (_: _) -> true)
+                                    (fun (_: _) -> scope_a_dot_a_))|])
+                            (fun (_: _) -> false)
+                            (fun (_: _) -> raise EmptyError))) with
+                    EmptyError -> (raise (NoValueProvided
+                    {filename = "tests/test_scope/good/191_fix_record_name_confusion.catala_en";
+                      start_line=8; start_column=11;
+                      end_line=8; end_column=12; law_headings=["Article"]}))) in
+  ()