diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index a98bbf19..c09efc97 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -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 diff --git a/compiler/lcalc/to_ocaml.mli b/compiler/lcalc/to_ocaml.mli index abee6f03..ff853298 100644 --- a/compiler/lcalc/to_ocaml.mli +++ b/compiler/lcalc/to_ocaml.mli @@ -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 diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index 784af796..e892ba3f 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -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 diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index fa194ac5..068ced80 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -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; diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index ef29b9bb..5441d144 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -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 diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index 1d534a7b..ddf85038 100644 --- a/compiler/shared_ast/expr.mli +++ b/compiler/shared_ast/expr.mli @@ -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] *) diff --git a/compiler/shared_ast/program.ml b/compiler/shared_ast/program.ml index dc807647..c5ec07aa 100644 --- a/compiler/shared_ast/program.ml +++ b/compiler/shared_ast/program.ml @@ -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, diff --git a/compiler/shared_ast/program.mli b/compiler/shared_ast/program.mli index 98e669e3..6d15cd46 100644 --- a/compiler/shared_ast/program.mli +++ b/compiler/shared_ast/program.mli @@ -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. *) diff --git a/tests/modules/good/output/mod_def.ml b/tests/modules/good/output/mod_def.ml index 1e95d261..db2345e5 100644 --- a/tests/modules/good/output/mod_def.ml +++ b/tests/modules/good/output/mod_def.ml @@ -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) -> diff --git a/tests/name_resolution/good/let_in2.catala_en b/tests/name_resolution/good/let_in2.catala_en index 2d20264d..68657124 100644 --- a/tests/name_resolution/good/let_in2.catala_en +++ b/tests/name_resolution/good/let_in2.catala_en @@ -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" diff --git a/tests/scope/good/191_fix_record_name_confusion.catala_en b/tests/scope/good/191_fix_record_name_confusion.catala_en index f0ce665c..bc755771 100644 --- a/tests/scope/good/191_fix_record_name_confusion.catala_en +++ b/tests/scope/good/191_fix_record_name_confusion.catala_en @@ -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 = [