CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-16 14:57:13 +03:00
Code Issues Projects Releases Wiki Activity

Renaming: more customisation

Browse Source 
in particular, this avoids regression with reused struct fields getting renamed
with indices, which would have required changes in e.g.
`french_law/ocaml/bench.ml`
This commit is contained in:
Louis Gesbert 2024-08-06 16:41:52 +02:00
parent acc13867bf
commit 8b06511915
11 changed files with 94 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/lcalc/to_ocaml.ml
View File

@ -735,7 +735,7 @@ let format_program
~reserved:ocaml_keywords
(* TODO: add catala runtime built-ins as reserved as well ? *)
~reset_context_for_closed_terms:true ~skip_constant_binders:true
~constant_binder_name:(Some "_")
~constant_binder_name:(Some "_") ~namespaced_fields_constrs:true
in
let type_ordering =
let open Scopelang.Dependency.TVertex in

2
compiler/lcalc/to_ocaml.mli
View File

@ -17,6 +17,8 @@
open Catala_utils
open Shared_ast
val ocaml_keywords : string list
(** Formats a lambda calculus program into a valid OCaml program *)
val typ_needs_parens : typ -> bool

19
compiler/plugins/api_web.ml
View File

@ -37,16 +37,18 @@ module To_jsoo = struct
other modules: here everything is flattened in the current namespace *)
let format_struct_name ppf name =
StructName.to_string name
|> String.to_ascii
|> String.uncapitalize_ascii
|> String.map (function '.' -> '_' | c -> c)
|> String.to_snake_case
|> Format.pp_print_string ppf
(* Supersedes [To_ocaml.format_enum_name], which can refer to enums from other
modules: here everything is flattened in the current namespace *)
let format_enum_name ppf name =
EnumName.to_string name
|> String.to_ascii
|> String.uncapitalize_ascii
|> String.map (function '.' -> '_' | c -> c)
|> String.to_snake_case
|> Format.pp_print_string ppf
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
@ -477,6 +479,19 @@ let run
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
~closure_conversion ~typed:Expr.typed ~monomorphize_types
in
let prg, ren_ctx =
Program.rename_ids prg ~reserved:To_ocaml.ocaml_keywords
~reset_context_for_closed_terms:true ~skip_constant_binders:true
~constant_binder_name:None ~namespaced_fields_constrs:true
in
let type_ordering =
let open Scopelang.Dependency.TVertex in
List.map
(function
| Struct s -> Struct (Expr.Renaming.struct_name ren_ctx s)
| Enum e -> Enum (Expr.Renaming.enum_name ren_ctx e))
type_ordering
in
let jsoo_output_file, with_formatter =
Driver.Commands.get_output_format options ~ext:"_api_web.ml" output
in

1
compiler/plugins/explain.ml
View File

@ -624,6 +624,7 @@ let program_to_graph
(Expr.Renaming.get_ctx
{
Expr.Renaming.reserved = [];
sanitize_varname = String.to_snake_case;
reset_context_for_closed_terms = false;
skip_constant_binders = false;
constant_binder_name = None;

5
compiler/shared_ast/expr.ml
View File

@ -879,6 +879,7 @@ module Renaming = struct
type config = {
reserved : string list;
sanitize_varname : string -> string;
reset_context_for_closed_terms : bool;
skip_constant_binders : bool;
constant_binder_name : string option;
@ -887,6 +888,7 @@ module Renaming = struct
type context = {
bindCtx : (module BindlibCtxt);
bcontext : DefaultBindlibCtxRename.ctxt;
vars : string -> string;
scopes : ScopeName.t -> ScopeName.t;
topdefs : TopdefName.t -> TopdefName.t;
structs : StructName.t -> StructName.t;
@ -956,6 +958,7 @@ module Renaming = struct
List.fold_left
(fun ctx name -> DefaultBindlibCtxRename.reserve_name name ctx)
BindCtx.empty_ctxt cfg.reserved;
vars = cfg.sanitize_varname;
scopes = Fun.id;
topdefs = Fun.id;
structs = Fun.id;
@ -976,7 +979,7 @@ module Renaming = struct
| EExternal { name = External_value d, pos }, m ->
eexternal ~name:(External_value (ctx.topdefs d), pos) m
| EAbs { binder; tys }, m ->
let vars, body, ctx = unmbind_in ctx ~fname:String.to_snake_case binder in
let vars, body, ctx = unmbind_in ctx ~fname:ctx.vars binder in
let body = expr ctx body in
let binder = bind vars body in
eabs binder (List.map (typ ctx) tys) m

1
compiler/shared_ast/expr.mli
View File

@ -398,6 +398,7 @@ val remove_logging_calls :
module Renaming : sig
type config = {
reserved : string list; (** Use for keywords and built-ins *)
sanitize_varname : string -> string; (** Typically String.to_snake_case *)
reset_context_for_closed_terms : bool; (** See [Bindlib.Rename] *)
skip_constant_binders : bool; (** See [Bindlib.Rename] *)
constant_binder_name : string option; (** See [Bindlib.Rename] *)

44
compiler/shared_ast/program.ml
View File

@ -97,19 +97,28 @@ let modules_to_list (mt : module_tree) =
in
List.rev (aux [] mt)
(* Todo? - add handling for specific naming constraints (automatically convert
to camel/snake-case, etc.) - register module names as reserved names *)
let cap s = String.to_ascii s |> String.capitalize_ascii
let uncap s = String.to_ascii s |> String.uncapitalize_ascii
(* Todo? - handle separate namespaces ? (e.g. allow a field and var to have the
same name for backends that support it) - register module names as reserved
names *)
let rename_ids
~reserved
~reset_context_for_closed_terms
~skip_constant_binders
~constant_binder_name
~namespaced_fields_constrs
?(f_var = String.to_snake_case)
?(f_struct = cap)
?(f_field = uncap)
?(f_enum = cap)
?(f_constr = cap)
p =
let cap s = String.to_camel_case s in
let uncap s = String.to_snake_case s in
let cfg =
{
Expr.Renaming.reserved;
sanitize_varname = f_var;
reset_context_for_closed_terms;
skip_constant_binders;
constant_binder_name;
@ -119,6 +128,7 @@ let rename_ids
(* Each module needs its separate ctx since resolution is qualified ; and name
resolution in a given module must be processed consistently independently
on the current context. *)
let ctx0 = ctx in
let module PathMap = Map.Make (Uid.Path) in
let pctxmap = PathMap.singleton [] ctx in
let pctxmap, structs_map, fields_map, ctx_structs =
@ -134,20 +144,23 @@ let rename_ids
try pctxmap, PathMap.find path pctxmap
with PathMap.Not_found _ -> PathMap.add path ctx pctxmap, ctx
in
let id, ctx = Expr.Renaming.new_id ctx (cap str) in
let id, ctx = Expr.Renaming.new_id ctx (f_struct str) in
let new_name = StructName.fresh path (id, pos) in
let ctx, fields_map, ctx_fields =
let ctx1, fields_map, ctx_fields =
StructField.Map.fold
(fun name ty (ctx, fields_map, ctx_fields) ->
let str, pos = StructField.get_info name in
let id, ctx = Expr.Renaming.new_id ctx (uncap str) in
let id, ctx = Expr.Renaming.new_id ctx (f_field str) in
let new_name = StructField.fresh (id, pos) in
( ctx,
StructField.Map.add name new_name fields_map,
StructField.Map.add new_name ty ctx_fields ))
fields
(ctx, fields_map, StructField.Map.empty)
( (if namespaced_fields_constrs then ctx0 else ctx),
fields_map,
StructField.Map.empty )
in
let ctx = if namespaced_fields_constrs then ctx else ctx1 in
( PathMap.add path ctx pctxmap,
StructName.Map.add name new_name structs_map,
fields_map,
@ -167,20 +180,23 @@ let rename_ids
try pctxmap, PathMap.find path pctxmap
with Not_found -> PathMap.add path ctx pctxmap, ctx
in
let id, ctx = Expr.Renaming.new_id ctx (cap str) in
let id, ctx = Expr.Renaming.new_id ctx (f_enum str) in
let new_name = EnumName.fresh path (id, pos) in
let ctx, constrs_map, ctx_constrs =
let ctx1, constrs_map, ctx_constrs =
EnumConstructor.Map.fold
(fun name ty (ctx, constrs_map, ctx_constrs) ->
let str, pos = EnumConstructor.get_info name in
let id, ctx = Expr.Renaming.new_id ctx (cap str) in
let id, ctx = Expr.Renaming.new_id ctx (f_constr str) in
let new_name = EnumConstructor.fresh (id, pos) in
( ctx,
EnumConstructor.Map.add name new_name constrs_map,
EnumConstructor.Map.add new_name ty ctx_constrs ))
constrs
(ctx, constrs_map, EnumConstructor.Map.empty)
( (if namespaced_fields_constrs then ctx0 else ctx),
constrs_map,
EnumConstructor.Map.empty )
in
let ctx = if namespaced_fields_constrs then ctx else ctx1 in
( PathMap.add path ctx pctxmap,
EnumName.Map.add name new_name enums_map,
constrs_map,
@ -218,7 +234,7 @@ let rename_ids
try pctxmap, PathMap.find path pctxmap
with Not_found -> PathMap.add path ctx pctxmap, ctx
in
let id, ctx = Expr.Renaming.new_id ctx (uncap str) in
let id, ctx = Expr.Renaming.new_id ctx (f_var str) in
let new_name = ScopeName.fresh path (id, pos) in
( PathMap.add path ctx pctxmap,
ScopeName.Map.add name new_name scopes_map,
@ -243,7 +259,7 @@ let rename_ids
try pctxmap, PathMap.find path pctxmap
with Not_found -> PathMap.add path ctx pctxmap, ctx
in
let id, ctx = Expr.Renaming.new_id ctx (uncap str) in
let id, ctx = Expr.Renaming.new_id ctx (f_var str) in
let new_name = TopdefName.fresh path (id, pos) in
( PathMap.add path ctx pctxmap,
TopdefName.Map.add name new_name topdefs_map,

16
compiler/shared_ast/program.mli
View File

@ -62,12 +62,26 @@ val rename_ids :
reset_context_for_closed_terms:bool ->
skip_constant_binders:bool ->
constant_binder_name:string option ->
namespaced_fields_constrs:bool ->
?f_var:(string -> string) ->
?f_struct:(string -> string) ->
?f_field:(string -> string) ->
?f_enum:(string -> string) ->
?f_constr:(string -> string) ->
('a, 't) gexpr program ->
('a, 't) gexpr program * Expr.Renaming.context
(** Renames all idents (variables, types, struct and enum names, fields and
constructors) to dispel ambiguities in the target language. Names in
[reserved], typically keywords and built-ins, will be avoided ; the meaning
of the flags is described in [Bindlib.Renaming].
of the following three flags is described in [Bindlib.Renaming].
if [namespaced_fields_constrs] is true, then struct fields and enum
constructors can reuse names from other fields/constructors or other idents.
The [f_*] optional arguments sanitize the different kinds of ids. The
default is what is used for OCaml: project to ASCII, capitalise structs,
enums (both modules in the backend) and constructors, lowercase fields, and
rewrite variables to snake case.
In the returned program, it is safe to directly use `Bindlib.name_of` on
variables for printing. The same is true for `StructName.get_info` etc. *)

10
tests/modules/good/output/mod_def.ml
View File

@ -19,13 +19,13 @@ module Str1 = struct
type t = {fld1: Enum1.t; fld2: integer}
end
module SIn = struct
module S_in = struct
type t = unit
end
let s (s_in: SIn.t) : S.t =
let sr1: money =
let s (s_in: S_in.t) : S.t =
let sr: money =
match
(match
(handle_exceptions
@ -56,7 +56,7 @@ let s (s_in: SIn.t) : S.t =
end_line=16; end_column=12;
law_headings=["Test modules + inclusions 1"]}])))
| Eoption.ESome arg -> arg in
let e2: Enum1.t =
let e1: Enum1.t =
match
(match
(handle_exceptions
@ -86,7 +86,7 @@ let s (s_in: SIn.t) : S.t =
end_line=17; end_column=12;
law_headings=["Test modules + inclusions 1"]}])))
| Eoption.ESome arg -> arg in
{S.sr = sr1; S.e1 = e2}
{S.sr = sr; S.e1 = e1}
let half : integer -> decimal =
fun (x: integer) ->

18
tests/name_resolution/good/let_in2.catala_en
View File

@ -45,20 +45,20 @@ module S = struct
type t = {a: bool}
end
module SIn = struct
module S_in = struct
type t = {a_in: unit -> (bool) Eoption.t}
end
let s (s_in: SIn.t) : S.t =
let a1: unit -> (bool) Eoption.t = s_in.SIn.a_in in
let a2: bool =
let s (s_in: S_in.t) : S.t =
let a: unit -> (bool) Eoption.t = s_in.S_in.a_in in
let a1: bool =
match
(match
(handle_exceptions
[|{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18; end_line=7; end_column=19;
law_headings=["Article"]}|] ([|(a1 ())|]))
law_headings=["Article"]}|] ([|(a ())|]))
with
| Eoption.ENone _ ->
( if true then
@ -79,11 +79,11 @@ let s (s_in: SIn.t) : S.t =
with
| Eoption.ENone _1 ->
( if true then
(Eoption.ESome (let a2 : bool = false
(Eoption.ESome (let a1 : bool = false
in
(let a3 : bool = (o_or a2 true)
(let a2 : bool = (o_or a1 true)
in
a3))) else (Eoption.ENone ()))
a2))) else (Eoption.ENone ()))
| Eoption.ESome x -> (Eoption.ESome x))|]))
with
| Eoption.ENone _1 ->
@ -106,7 +106,7 @@ let s (s_in: SIn.t) : S.t =
end_line=7; end_column=19;
law_headings=["Article"]}])))
| Eoption.ESome arg -> arg in
{S.a = a2}
{S.a = a1}
let () =
Runtime_ocaml.Runtime.register_module "Let_in2"

18
tests/scope/good/191_fix_record_name_confusion.catala_en
View File

@ -41,26 +41,26 @@ module ScopeA = struct
end
module ScopeB = struct
type t = {a1: bool}
type t = {a: bool}
end
module ScopeAIn = struct
module ScopeA_in = struct
type t = unit
end
module ScopeBIn = struct
module ScopeB_in = struct
type t = unit
end
let scope_a (scope_a_in: ScopeAIn.t) : ScopeA.t =
let a2: bool = true in
{ScopeA.a = a2}
let scope_a (scope_a_in: ScopeA_in.t) : ScopeA.t =
let a: bool = true in
{ScopeA.a = a}
let scope_b (scope_b_in: ScopeBIn.t) : ScopeB.t =
let scope_b (scope_b_in: ScopeB_in.t) : ScopeB.t =
let scope_a1: ScopeA.t = {ScopeA.a = ((scope_a (())).ScopeA.a)} in
let a2: bool = scope_a1.ScopeA.a in
{ScopeB.a1 = a2}
let a: bool = scope_a1.ScopeA.a in
{ScopeB.a = a}
let entry_scopes = [