From 081e07378a0de36b58500528f1c3ee930bcfd4f7 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 7 Aug 2024 18:03:10 +0200 Subject: [PATCH] Renaming: move to its own module --- compiler/driver.ml | 15 +- compiler/driver.mli | 8 +- compiler/lcalc/to_ocaml.ml | 2 +- compiler/lcalc/to_ocaml.mli | 2 +- compiler/plugins/explain.ml | 6 +- compiler/scalc/from_lcalc.ml | 10 +- compiler/scalc/from_lcalc.mli | 2 +- compiler/scalc/to_c.ml | 2 +- compiler/scalc/to_c.mli | 2 +- compiler/scalc/to_python.ml | 2 +- compiler/scalc/to_python.mli | 2 +- compiler/shared_ast/expr.ml | 192 ------------ compiler/shared_ast/expr.mli | 54 +--- compiler/shared_ast/program.ml | 218 -------------- compiler/shared_ast/program.mli | 33 -- compiler/shared_ast/renaming.ml | 482 ++++++++++++++++++++++++++++++ compiler/shared_ast/renaming.mli | 105 +++++++ compiler/shared_ast/scope.ml | 58 ---- compiler/shared_ast/scope.mli | 5 - compiler/shared_ast/shared_ast.ml | 1 + 20 files changed, 615 insertions(+), 586 deletions(-) create mode 100644 compiler/shared_ast/renaming.ml create mode 100644 compiler/shared_ast/renaming.mli diff --git a/compiler/driver.ml b/compiler/driver.ml index 852707b1..0a0469d8 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -232,7 +232,7 @@ module Passes = struct ~renaming : typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list - * Expr.Renaming.context option = + * Renaming.context option = let prg, type_ordering = dcalc options ~includes ~optimize ~check_invariants ~typed in @@ -281,13 +281,13 @@ module Passes = struct match renaming with | None -> prg, type_ordering, None | Some renaming -> - let prg, ren_ctx = Program.apply renaming prg in + let prg, ren_ctx = Renaming.apply renaming prg 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)) + | Struct s -> Struct (Renaming.struct_name ren_ctx s) + | Enum e -> Enum (Renaming.enum_name ren_ctx e)) type_ordering in prg, type_ordering, Some ren_ctx @@ -303,9 +303,8 @@ module Passes = struct ~no_struct_literals ~monomorphize_types ~renaming : - Scalc.Ast.program - * Scopelang.Dependency.TVertex.t list - * Expr.Renaming.context = + Scalc.Ast.program * Scopelang.Dependency.TVertex.t list * Renaming.context + = let prg, type_ordering, renaming_context = lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed ~closure_conversion ~monomorphize_types ~renaming @@ -313,7 +312,7 @@ module Passes = struct let renaming_context = match renaming_context with | None -> - Expr.Renaming.get_ctx + Renaming.get_ctx { reserved = []; sanitize_varname = Fun.id; diff --git a/compiler/driver.mli b/compiler/driver.mli index 372b19e1..29a40832 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -53,10 +53,10 @@ module Passes : sig typed:'m Shared_ast.mark -> closure_conversion:bool -> monomorphize_types:bool -> - renaming:Shared_ast.Program.renaming option -> + renaming:Shared_ast.Renaming.t option -> Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list - * Shared_ast.Expr.Renaming.context option + * Shared_ast.Renaming.context option val scalc : Global.options -> @@ -68,10 +68,10 @@ module Passes : sig dead_value_assignment:bool -> no_struct_literals:bool -> monomorphize_types:bool -> - renaming:Shared_ast.Program.renaming option -> + renaming:Shared_ast.Renaming.t option -> Scalc.Ast.program * Scopelang.Dependency.TVertex.t list - * Shared_ast.Expr.Renaming.context + * Shared_ast.Renaming.context end module Commands : sig diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index d1a783ba..02f238b7 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -131,7 +131,7 @@ let ocaml_keywords = ] let renaming = - Program.renaming () + Renaming.program () ~reserved:ocaml_keywords (* TODO: add catala runtime built-ins as reserved as well ? *) ~reset_context_for_closed_terms:true ~skip_constant_binders:true diff --git a/compiler/lcalc/to_ocaml.mli b/compiler/lcalc/to_ocaml.mli index 489343d7..9611ad32 100644 --- a/compiler/lcalc/to_ocaml.mli +++ b/compiler/lcalc/to_ocaml.mli @@ -17,7 +17,7 @@ open Catala_utils open Shared_ast -val renaming : Program.renaming +val renaming : Renaming.t (** Formats a lambda calculus program into a valid OCaml program *) diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index 068ced80..1ed7cc20 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -620,10 +620,10 @@ let program_to_graph let e = customize (Expr.unbox e) in let e = Expr.remove_logging_calls (Expr.unbox e) in let e = - Expr.Renaming.expr - (Expr.Renaming.get_ctx + Renaming.expr + (Renaming.get_ctx { - Expr.Renaming.reserved = []; + Renaming.reserved = []; sanitize_varname = String.to_snake_case; reset_context_for_closed_terms = false; skip_constant_binders = false; diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index cbf65fe6..997e8321 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -24,7 +24,7 @@ type translation_config = { keep_special_ops : bool; dead_value_assignment : bool; no_struct_literals : bool; - renaming_context : Expr.Renaming.context; + renaming_context : Renaming.context; } type 'm ctxt = { @@ -34,7 +34,7 @@ type 'm ctxt = { context_name : string; config : translation_config; program_ctx : A.ctx; - ren_ctx : Expr.Renaming.context; + ren_ctx : Renaming.context; } (* Expressions can spill out side effect, hence this function also returns a @@ -68,15 +68,15 @@ end let ( ++ ) = RevBlock.seq let unbind ctxt bnd = - let v, body, ren_ctx = Expr.Renaming.unbind_in ctxt.ren_ctx bnd in + let v, body, ren_ctx = Renaming.unbind_in ctxt.ren_ctx bnd in v, body, { ctxt with ren_ctx } let unmbind ctxt bnd = - let vs, body, ren_ctx = Expr.Renaming.unmbind_in ctxt.ren_ctx bnd in + let vs, body, ren_ctx = Renaming.unmbind_in ctxt.ren_ctx bnd in vs, body, { ctxt with ren_ctx } let get_name ctxt s = - let name, ren_ctx = Expr.Renaming.new_id ctxt.ren_ctx s in + let name, ren_ctx = Renaming.new_id ctxt.ren_ctx s in name, { ctxt with ren_ctx } let fresh_var ~pos ctxt name = diff --git a/compiler/scalc/from_lcalc.mli b/compiler/scalc/from_lcalc.mli index 7ab7f417..c7871441 100644 --- a/compiler/scalc/from_lcalc.mli +++ b/compiler/scalc/from_lcalc.mli @@ -32,7 +32,7 @@ type translation_config = { (** When [no_struct_literals] is true, the translation inserts a temporary variable to hold the initialization of struct literals. This matches what C89 expects. *) - renaming_context : Expr.Renaming.context; + renaming_context : Renaming.context; } val translate_program : diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 77841ed7..784b0b97 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -60,7 +60,7 @@ let c_keywords = ] let renaming = - Program.renaming () + Renaming.program () ~reserved:c_keywords (* TODO: add catala runtime built-ins as reserved as well ? *) ~reset_context_for_closed_terms:true ~skip_constant_binders:true diff --git a/compiler/scalc/to_c.mli b/compiler/scalc/to_c.mli index 2b7c6853..efab8798 100644 --- a/compiler/scalc/to_c.mli +++ b/compiler/scalc/to_c.mli @@ -18,7 +18,7 @@ open Shared_ast -val renaming : Program.renaming +val renaming : Renaming.t val format_program : Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index 2391a4f1..81e980f6 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -154,7 +154,7 @@ let python_keywords = exposed by the runtime. *) let renaming = - Program.renaming () + Renaming.program () ~reserved:python_keywords (* TODO: add catala runtime built-ins as reserved as well ? *) ~reset_context_for_closed_terms:false ~skip_constant_binders:false diff --git a/compiler/scalc/to_python.mli b/compiler/scalc/to_python.mli index d055d0ab..84988908 100644 --- a/compiler/scalc/to_python.mli +++ b/compiler/scalc/to_python.mli @@ -18,7 +18,7 @@ open Shared_ast -val renaming : Program.renaming +val renaming : Renaming.t val format_program : Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index 5441d144..32d7a5e7 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -819,198 +819,6 @@ let remove_logging_calls e = in f e -module Renaming = struct - module DefaultBindlibCtxRename : Bindlib.Renaming = struct - (* This code is a copy-paste from Bindlib, they forgot to expose the default - implementation ! *) - type ctxt = int String.Map.t - - let empty_ctxt = String.Map.empty - - let split_name : string -> string * int = - fun name -> - let len = String.length name in - (* [i] is the index of the first first character of the suffix. *) - let i = - let is_digit c = '0' <= c && c <= '9' in - let first_digit = ref len in - let first_non_0 = ref len in - while !first_digit > 0 && is_digit name.[!first_digit - 1] do - decr first_digit; - if name.[!first_digit] <> '0' then first_non_0 := !first_digit - done; - !first_non_0 - in - if i = len then name, 0 - else String.sub name 0 i, int_of_string (String.sub name i (len - i)) - - let get_suffix : string -> int -> ctxt -> int * ctxt = - fun name suffix ctxt -> - let n = - try String.Map.find name ctxt with String.Map.Not_found _ -> -1 - in - let suffix = if suffix > n then suffix else n + 1 in - suffix, String.Map.add name suffix ctxt - - let merge_name : string -> int -> string = - fun prefix suffix -> - if suffix > 0 then prefix ^ string_of_int suffix else prefix - - let new_name : string -> ctxt -> string * ctxt = - fun name ctxt -> - let prefix, suffix = split_name name in - let suffix, ctxt = get_suffix prefix suffix ctxt in - merge_name prefix suffix, ctxt - - let reserve_name : string -> ctxt -> ctxt = - fun name ctxt -> - let prefix, suffix = split_name name in - try - let n = String.Map.find prefix ctxt in - if suffix <= n then ctxt else String.Map.add prefix suffix ctxt - with String.Map.Not_found _ -> String.Map.add prefix suffix ctxt - - let reset_context_for_closed_terms = false - let skip_constant_binders = false - let constant_binder_name = None - end - - module type BindlibCtxt = module type of Bindlib.Ctxt (DefaultBindlibCtxRename) - - type config = { - reserved : string list; - sanitize_varname : string -> string; - reset_context_for_closed_terms : bool; - skip_constant_binders : bool; - constant_binder_name : string option; - } - - 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; - fields : StructField.t -> StructField.t; - enums : EnumName.t -> EnumName.t; - constrs : EnumConstructor.t -> EnumConstructor.t; - } - - let unbind_in ctx ?fname b = - let module BindCtx = (val ctx.bindCtx) in - match fname with - | Some fn -> - let name = fn (Bindlib.binder_name b) in - let v, bcontext = - BindCtx.new_var_in ctx.bcontext (fun v -> EVar v) name - in - let e = Bindlib.subst b (EVar v) in - v, e, { ctx with bcontext } - | None -> - let v, e, bcontext = BindCtx.unbind_in ctx.bcontext b in - v, e, { ctx with bcontext } - - let unmbind_in ctx ?fname b = - let module BindCtx = (val ctx.bindCtx) in - match fname with - | Some fn -> - let names = Array.map fn (Bindlib.mbinder_names b) in - let rvs, bcontext = - Array.fold_left - (fun (rvs, bcontext) n -> - let v, bcontext = BindCtx.new_var_in bcontext (fun v -> EVar v) n in - v :: rvs, bcontext) - ([], ctx.bcontext) names - in - let vs = Array.of_list (List.rev rvs) in - let e = Bindlib.msubst b (Array.map (fun v -> EVar v) vs) in - vs, e, { ctx with bcontext } - | None -> - let vs, e, bcontext = BindCtx.unmbind_in ctx.bcontext b in - vs, e, { ctx with bcontext } - - let set_rewriters ?scopes ?topdefs ?structs ?fields ?enums ?constrs ctx = - (fun ?(scopes = ctx.scopes) ?(topdefs = ctx.topdefs) - ?(structs = ctx.structs) ?(fields = ctx.fields) ?(enums = ctx.enums) - ?(constrs = ctx.constrs) () -> - { ctx with scopes; topdefs; structs; fields; enums; constrs }) - ?scopes ?topdefs ?structs ?fields ?enums ?constrs () - - let new_id ctx name = - let module BindCtx = (val ctx.bindCtx) in - let var, bcontext = - BindCtx.new_var_in ctx.bcontext (fun _ -> assert false) name - in - Bindlib.name_of var, { ctx with bcontext } - - let get_ctx cfg = - let module BindCtx = Bindlib.Ctxt (struct - include DefaultBindlibCtxRename - - let reset_context_for_closed_terms = cfg.reset_context_for_closed_terms - let skip_constant_binders = cfg.skip_constant_binders - let constant_binder_name = cfg.constant_binder_name - end) in - { - bindCtx = (module BindCtx); - bcontext = - 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; - fields = Fun.id; - enums = Fun.id; - constrs = Fun.id; - } - - let rec typ ctx = function - | TStruct n, m -> TStruct (ctx.structs n), m - | TEnum n, m -> TEnum (ctx.enums n), m - | ty -> Type.map (typ ctx) ty - - let rec expr : type k. context -> (k, 'm) gexpr -> (k, 'm) gexpr boxed = - fun ctx -> function - | EExternal { name = External_scope s, pos }, m -> - eexternal ~name:(External_scope (ctx.scopes s), pos) m - | 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:ctx.vars binder in - let body = expr ctx body in - let binder = bind vars body in - eabs binder (List.map (typ ctx) tys) m - | EStruct { name; fields }, m -> - estruct ~name:(ctx.structs name) - ~fields: - (StructField.Map.fold - (fun fld e -> StructField.Map.add (ctx.fields fld) (expr ctx e)) - fields StructField.Map.empty) - m - | EStructAccess { name; field; e }, m -> - estructaccess ~name:(ctx.structs name) ~field:(ctx.fields field) - ~e:(expr ctx e) m - | EInj { name; e; cons }, m -> - einj ~name:(ctx.enums name) ~cons:(ctx.constrs cons) ~e:(expr ctx e) m - | EMatch { name; e; cases }, m -> - ematch ~name:(ctx.enums name) - ~cases: - (EnumConstructor.Map.fold - (fun cons e -> - EnumConstructor.Map.add (ctx.constrs cons) (expr ctx e)) - cases EnumConstructor.Map.empty) - ~e:(expr ctx e) m - | e -> map ~typ:(typ ctx) ~f:(expr ctx) ~op:Fun.id e - - let scope_name ctx s = ctx.scopes s - let topdef_name ctx s = ctx.topdefs s - let struct_name ctx s = ctx.structs s - let enum_name ctx e = ctx.enums e -end - let format ppf e = Print.expr ~debug:false () ppf e let rec size : type a. (a, 't) gexpr -> int = diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index 28207ae6..6b73ab97 100644 --- a/compiler/shared_ast/expr.mli +++ b/compiler/shared_ast/expr.mli @@ -393,59 +393,7 @@ val remove_logging_calls : (** Removes all calls to [Log] unary operators in the AST, replacing them by their argument. *) -(** {2 Renamings and formatting} *) - -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.Renaming] *) - skip_constant_binders : bool; (** See [Bindlib.Renaming] *) - constant_binder_name : string option; (** See [Bindlib.Renaming] *) - } - - type context - - val get_ctx : config -> context - - val unbind_in : - context -> - ?fname:(string -> string) -> - ('e, 'b) Bindlib.binder -> - ('e, _) Mark.ed Var.t * 'b * context - (* [fname] applies a transformation on the variable name (typically something - like [String.to_snake_case]). The result is advisory and a numerical suffix - may be appended or modified *) - - val unmbind_in : - context -> - ?fname:(string -> string) -> - ('e, 'b) Bindlib.mbinder -> - ('e, _) Mark.ed Var.t Array.t * 'b * context - - val new_id : context -> string -> string * context - - val set_rewriters : - ?scopes:(ScopeName.t -> ScopeName.t) -> - ?topdefs:(TopdefName.t -> TopdefName.t) -> - ?structs:(StructName.t -> StructName.t) -> - ?fields:(StructField.t -> StructField.t) -> - ?enums:(EnumName.t -> EnumName.t) -> - ?constrs:(EnumConstructor.t -> EnumConstructor.t) -> - context -> - context - - val typ : context -> typ -> typ - - val expr : context -> ('a any, 'm) gexpr -> ('a, 'm) boxed_gexpr - (** Disambiguates all variable names in [e], and renames structs, fields, - enums and constrs according to the given context configuration *) - - val scope_name : context -> ScopeName.t -> ScopeName.t - val topdef_name : context -> TopdefName.t -> TopdefName.t - val struct_name : context -> StructName.t -> StructName.t - val enum_name : context -> EnumName.t -> EnumName.t -end +(** {2 Formatting} *) val format : Format.formatter -> ('a, 'm) gexpr -> unit (** Simple printing without debug, use [Print.expr ()] instead to follow the diff --git a/compiler/shared_ast/program.ml b/compiler/shared_ast/program.ml index b76d1e84..7d92f909 100644 --- a/compiler/shared_ast/program.ml +++ b/compiler/shared_ast/program.ml @@ -96,221 +96,3 @@ let modules_to_list (mt : module_tree) = mtree acc in List.rev (aux [] mt) - -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 cfg = - { - Expr.Renaming.reserved; - sanitize_varname = f_var; - reset_context_for_closed_terms; - skip_constant_binders; - constant_binder_name; - } - in - let ctx = Expr.Renaming.get_ctx cfg in - (* 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 = - (* Warning: the folding order matters here, if a module contains e.g. two - fields with the same name. This fold relies on UIDs, and is thus - dependent on the definition order. Another possibility would be to fold - lexicographically, but the result would be "less intuitive" *) - StructName.Map.fold - (fun name fields (pctxmap, structs_map, fields_map, ctx_structs) -> - let path = StructName.path name in - let str, pos = StructName.get_info name in - let pctxmap, ctx = - 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 (f_struct str) in - let new_name = StructName.fresh path (id, pos) in - 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 (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 - ( (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, - StructName.Map.add new_name ctx_fields ctx_structs )) - p.decl_ctx.ctx_structs - ( pctxmap, - StructName.Map.empty, - StructField.Map.empty, - StructName.Map.empty ) - in - let pctxmap, enums_map, constrs_map, ctx_enums = - EnumName.Map.fold - (fun name constrs (pctxmap, enums_map, constrs_map, ctx_enums) -> - let path = EnumName.path name in - let str, pos = EnumName.get_info name in - let pctxmap, ctx = - try pctxmap, PathMap.find path pctxmap - with Not_found -> PathMap.add path ctx pctxmap, ctx - in - let id, ctx = Expr.Renaming.new_id ctx (f_enum str) in - let new_name = EnumName.fresh path (id, pos) in - 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 (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 - ( (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, - EnumName.Map.add new_name ctx_constrs ctx_enums )) - p.decl_ctx.ctx_enums - ( pctxmap, - EnumName.Map.empty, - EnumConstructor.Map.empty, - EnumName.Map.empty ) - in - let pctxmap, scopes_map, ctx_scopes = - ScopeName.Map.fold - (fun name info (pctxmap, scopes_map, ctx_scopes) -> - let info = - { - in_struct_name = StructName.Map.find info.in_struct_name structs_map; - out_struct_name = - StructName.Map.find info.out_struct_name structs_map; - out_struct_fields = - ScopeVar.Map.map - (fun fld -> StructField.Map.find fld fields_map) - info.out_struct_fields; - } - in - let path = ScopeName.path name in - if path = [] then - (* Scopes / topdefs in the root module will be renamed through the - variables binding them in the code_items *) - ( pctxmap, - ScopeName.Map.add name name scopes_map, - ScopeName.Map.add name info ctx_scopes ) - else - let str, pos = ScopeName.get_info name in - let pctxmap, ctx = - try pctxmap, PathMap.find path pctxmap - with Not_found -> PathMap.add path ctx pctxmap, ctx - 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, - ScopeName.Map.add new_name info ctx_scopes )) - p.decl_ctx.ctx_scopes - (pctxmap, ScopeName.Map.empty, ScopeName.Map.empty) - in - let pctxmap, topdefs_map, ctx_topdefs = - TopdefName.Map.fold - (fun name typ (pctxmap, topdefs_map, ctx_topdefs) -> - let path = TopdefName.path name in - if path = [] then - (* Topdefs / topdefs in the root module will be renamed through the - variables binding them in the code_items *) - ( pctxmap, - TopdefName.Map.add name name topdefs_map, - TopdefName.Map.add name typ ctx_topdefs ) - (* [typ] is rewritten later on *) - else - let str, pos = TopdefName.get_info name in - let pctxmap, ctx = - try pctxmap, PathMap.find path pctxmap - with Not_found -> PathMap.add path ctx pctxmap, ctx - 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, - TopdefName.Map.add new_name typ ctx_topdefs )) - p.decl_ctx.ctx_topdefs - (pctxmap, TopdefName.Map.empty, TopdefName.Map.empty) - in - let ctx = PathMap.find [] pctxmap in - let ctx = - Expr.Renaming.set_rewriters ctx - ~scopes:(fun n -> ScopeName.Map.find n scopes_map) - ~topdefs:(fun n -> TopdefName.Map.find n topdefs_map) - ~structs:(fun n -> StructName.Map.find n structs_map) - ~fields:(fun n -> StructField.Map.find n fields_map) - ~enums:(fun n -> EnumName.Map.find n enums_map) - ~constrs:(fun n -> EnumConstructor.Map.find n constrs_map) - in - let decl_ctx = - { p.decl_ctx with ctx_enums; ctx_structs; ctx_scopes; ctx_topdefs } - in - let decl_ctx = map_decl_ctx ~f:(Expr.Renaming.typ ctx) decl_ctx in - let code_items = Scope.rename_ids ctx p.code_items in - { p with decl_ctx; code_items }, ctx - -(* This first-class module wrapping is here to allow a polymorphic renaming - function to be passed around *) - -module type Renaming = sig - val apply : 'e program -> 'e program * Expr.Renaming.context -end - -type renaming = (module Renaming) - -let apply (module R : Renaming) = R.apply - -let renaming - ~reserved - ~reset_context_for_closed_terms - ~skip_constant_binders - ~constant_binder_name - ~namespaced_fields_constrs - ?f_var - ?f_struct - ?f_field - ?f_enum - ?f_constr - () = - let module M = struct - let apply p = - rename_ids ~reserved ~reset_context_for_closed_terms - ~skip_constant_binders ~constant_binder_name ~namespaced_fields_constrs - ?f_var ?f_struct ?f_field ?f_enum ?f_constr p - end in - (module M : Renaming) diff --git a/compiler/shared_ast/program.mli b/compiler/shared_ast/program.mli index 41880a03..071b7873 100644 --- a/compiler/shared_ast/program.mli +++ b/compiler/shared_ast/program.mli @@ -56,36 +56,3 @@ val find_scope : ScopeName.t -> 'e code_item_list -> 'e scope_body val modules_to_list : module_tree -> (ModuleName.t * module_intf_id) list (** Returns a list of used modules, in topological order ; the boolean indicates if the module is external *) - -type renaming - -val apply : renaming -> 'e program -> 'e program * Expr.Renaming.context - -val renaming : - reserved:string list -> - 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) -> - unit -> - renaming -(** 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 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/compiler/shared_ast/renaming.ml b/compiler/shared_ast/renaming.ml new file mode 100644 index 00000000..a310fabc --- /dev/null +++ b/compiler/shared_ast/renaming.ml @@ -0,0 +1,482 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2024 Inria, contributor: + Louis Gesbert + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +open Catala_utils +open Definitions + +module DefaultBindlibCtxRename : Bindlib.Renaming = struct + (* This code is a copy-paste from Bindlib, they forgot to expose the default + implementation ! *) + type ctxt = int String.Map.t + + let empty_ctxt = String.Map.empty + + let split_name : string -> string * int = + fun name -> + let len = String.length name in + (* [i] is the index of the first first character of the suffix. *) + let i = + let is_digit c = '0' <= c && c <= '9' in + let first_digit = ref len in + let first_non_0 = ref len in + while !first_digit > 0 && is_digit name.[!first_digit - 1] do + decr first_digit; + if name.[!first_digit] <> '0' then first_non_0 := !first_digit + done; + !first_non_0 + in + if i = len then name, 0 + else String.sub name 0 i, int_of_string (String.sub name i (len - i)) + + let get_suffix : string -> int -> ctxt -> int * ctxt = + fun name suffix ctxt -> + let n = try String.Map.find name ctxt with String.Map.Not_found _ -> -1 in + let suffix = if suffix > n then suffix else n + 1 in + suffix, String.Map.add name suffix ctxt + + let merge_name : string -> int -> string = + fun prefix suffix -> + if suffix > 0 then prefix ^ string_of_int suffix else prefix + + let new_name : string -> ctxt -> string * ctxt = + fun name ctxt -> + let prefix, suffix = split_name name in + let suffix, ctxt = get_suffix prefix suffix ctxt in + merge_name prefix suffix, ctxt + + let reserve_name : string -> ctxt -> ctxt = + fun name ctxt -> + let prefix, suffix = split_name name in + try + let n = String.Map.find prefix ctxt in + if suffix <= n then ctxt else String.Map.add prefix suffix ctxt + with String.Map.Not_found _ -> String.Map.add prefix suffix ctxt + + let reset_context_for_closed_terms = false + let skip_constant_binders = false + let constant_binder_name = None +end + +module type BindlibCtxt = module type of Bindlib.Ctxt (DefaultBindlibCtxRename) + +type config = { + reserved : string list; + sanitize_varname : string -> string; + reset_context_for_closed_terms : bool; + skip_constant_binders : bool; + constant_binder_name : string option; +} + +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; + fields : StructField.t -> StructField.t; + enums : EnumName.t -> EnumName.t; + constrs : EnumConstructor.t -> EnumConstructor.t; +} + +let unbind_in ctx ?fname b = + let module BindCtx = (val ctx.bindCtx) in + match fname with + | Some fn -> + let name = fn (Bindlib.binder_name b) in + let v, bcontext = BindCtx.new_var_in ctx.bcontext (fun v -> EVar v) name in + let e = Bindlib.subst b (EVar v) in + v, e, { ctx with bcontext } + | None -> + let v, e, bcontext = BindCtx.unbind_in ctx.bcontext b in + v, e, { ctx with bcontext } + +let unmbind_in ctx ?fname b = + let module BindCtx = (val ctx.bindCtx) in + match fname with + | Some fn -> + let names = Array.map fn (Bindlib.mbinder_names b) in + let rvs, bcontext = + Array.fold_left + (fun (rvs, bcontext) n -> + let v, bcontext = BindCtx.new_var_in bcontext (fun v -> EVar v) n in + v :: rvs, bcontext) + ([], ctx.bcontext) names + in + let vs = Array.of_list (List.rev rvs) in + let e = Bindlib.msubst b (Array.map (fun v -> EVar v) vs) in + vs, e, { ctx with bcontext } + | None -> + let vs, e, bcontext = BindCtx.unmbind_in ctx.bcontext b in + vs, e, { ctx with bcontext } + +let set_rewriters ?scopes ?topdefs ?structs ?fields ?enums ?constrs ctx = + (fun ?(scopes = ctx.scopes) ?(topdefs = ctx.topdefs) ?(structs = ctx.structs) + ?(fields = ctx.fields) ?(enums = ctx.enums) ?(constrs = ctx.constrs) () -> + { ctx with scopes; topdefs; structs; fields; enums; constrs }) + ?scopes ?topdefs ?structs ?fields ?enums ?constrs () + +let new_id ctx name = + let module BindCtx = (val ctx.bindCtx) in + let var, bcontext = + BindCtx.new_var_in ctx.bcontext (fun _ -> assert false) name + in + Bindlib.name_of var, { ctx with bcontext } + +let get_ctx cfg = + let module BindCtx = Bindlib.Ctxt (struct + include DefaultBindlibCtxRename + + let reset_context_for_closed_terms = cfg.reset_context_for_closed_terms + let skip_constant_binders = cfg.skip_constant_binders + let constant_binder_name = cfg.constant_binder_name + end) in + { + bindCtx = (module BindCtx); + bcontext = + 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; + fields = Fun.id; + enums = Fun.id; + constrs = Fun.id; + } + +let rec typ ctx = function + | TStruct n, m -> TStruct (ctx.structs n), m + | TEnum n, m -> TEnum (ctx.enums n), m + | ty -> Type.map (typ ctx) ty + +(* {2 Handling expressions} *) + +let rec expr : type k. context -> (k, 'm) gexpr -> (k, 'm) gexpr boxed = + fun ctx -> function + | EExternal { name = External_scope s, pos }, m -> + Expr.eexternal ~name:(External_scope (ctx.scopes s), pos) m + | EExternal { name = External_value d, pos }, m -> + Expr.eexternal ~name:(External_value (ctx.topdefs d), pos) m + | EAbs { binder; tys }, m -> + let vars, body, ctx = unmbind_in ctx ~fname:ctx.vars binder in + let body = expr ctx body in + let binder = Expr.bind vars body in + Expr.eabs binder (List.map (typ ctx) tys) m + | EStruct { name; fields }, m -> + Expr.estruct ~name:(ctx.structs name) + ~fields: + (StructField.Map.fold + (fun fld e -> StructField.Map.add (ctx.fields fld) (expr ctx e)) + fields StructField.Map.empty) + m + | EStructAccess { name; field; e }, m -> + Expr.estructaccess ~name:(ctx.structs name) ~field:(ctx.fields field) + ~e:(expr ctx e) m + | EInj { name; e; cons }, m -> + Expr.einj ~name:(ctx.enums name) ~cons:(ctx.constrs cons) ~e:(expr ctx e) m + | EMatch { name; e; cases }, m -> + Expr.ematch ~name:(ctx.enums name) + ~cases: + (EnumConstructor.Map.fold + (fun cons e -> + EnumConstructor.Map.add (ctx.constrs cons) (expr ctx e)) + cases EnumConstructor.Map.empty) + ~e:(expr ctx e) m + | e -> Expr.map ~typ:(typ ctx) ~f:(expr ctx) ~op:Fun.id e + +let scope_name ctx s = ctx.scopes s +let topdef_name ctx s = ctx.topdefs s +let struct_name ctx s = ctx.structs s +let enum_name ctx e = ctx.enums e + +(* {2 Handling scopes} *) + +(** Maps carrying around a naming context, enriched at each [unbind] *) +let rec boundlist_map_ctx ~f ~fname ~last ~ctx = function + | Last l -> Bindlib.box_apply (fun l -> Last l) (last ctx l) + | Cons (item, next_bind) -> + let item = f ctx item in + let var, next, ctx = unbind_in ctx ~fname next_bind in + let next = boundlist_map_ctx ~f ~fname ~last ~ctx next in + let next_bind = Bindlib.bind_var var next in + Bindlib.box_apply2 + (fun item next_bind -> Cons (item, next_bind)) + item next_bind + +let rename_vars_in_lets ctx scope_body_expr = + boundlist_map_ctx scope_body_expr ~ctx ~fname:String.to_snake_case + ~last:(fun ctx e -> Expr.Box.lift (expr ctx e)) + ~f:(fun ctx scope_let -> + Bindlib.box_apply + (fun scope_let_expr -> + { + scope_let with + scope_let_expr; + scope_let_typ = typ ctx scope_let.scope_let_typ; + }) + (Expr.Box.lift (expr ctx scope_let.scope_let_expr))) + +let code_items ctx (scopes : 'e code_item_list) = + let f ctx = function + | ScopeDef (name, body) -> + let name = scope_name ctx name in + let scope_input_var, scope_lets, ctx = + unbind_in ctx ~fname:String.to_snake_case body.scope_body_expr + in + let scope_lets = rename_vars_in_lets ctx scope_lets in + let scope_body_expr = Bindlib.bind_var scope_input_var scope_lets in + Bindlib.box_apply + (fun scope_body_expr -> + let body = + { + scope_body_input_struct = + struct_name ctx body.scope_body_input_struct; + scope_body_output_struct = + struct_name ctx body.scope_body_output_struct; + scope_body_expr; + } + in + ScopeDef (name, body)) + scope_body_expr + | Topdef (name, ty, e) -> + Bindlib.box_apply + (fun e -> Topdef (name, typ ctx ty, e)) + (Expr.Box.lift (expr ctx e)) + in + Bindlib.unbox + @@ boundlist_map_ctx ~ctx ~f ~fname:String.to_snake_case + ~last:(fun _ctx -> Bindlib.box) + scopes + +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 program + ~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 cfg = + { + reserved; + sanitize_varname = f_var; + reset_context_for_closed_terms; + skip_constant_binders; + constant_binder_name; + } + in + let ctx = get_ctx cfg in + (* 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 = + (* Warning: the folding order matters here, if a module contains e.g. two + fields with the same name. This fold relies on UIDs, and is thus + dependent on the definition order. Another possibility would be to fold + lexicographically, but the result would be "less intuitive" *) + StructName.Map.fold + (fun name fields (pctxmap, structs_map, fields_map, ctx_structs) -> + let path = StructName.path name in + let str, pos = StructName.get_info name in + let pctxmap, ctx = + try pctxmap, PathMap.find path pctxmap + with PathMap.Not_found _ -> PathMap.add path ctx pctxmap, ctx + in + let id, ctx = new_id ctx (f_struct str) in + let new_name = StructName.fresh path (id, pos) in + 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 = 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 + ( (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, + StructName.Map.add new_name ctx_fields ctx_structs )) + p.decl_ctx.ctx_structs + ( pctxmap, + StructName.Map.empty, + StructField.Map.empty, + StructName.Map.empty ) + in + let pctxmap, enums_map, constrs_map, ctx_enums = + EnumName.Map.fold + (fun name constrs (pctxmap, enums_map, constrs_map, ctx_enums) -> + let path = EnumName.path name in + let str, pos = EnumName.get_info name in + let pctxmap, ctx = + try pctxmap, PathMap.find path pctxmap + with Not_found -> PathMap.add path ctx pctxmap, ctx + in + let id, ctx = new_id ctx (f_enum str) in + let new_name = EnumName.fresh path (id, pos) in + 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 = 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 + ( (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, + EnumName.Map.add new_name ctx_constrs ctx_enums )) + p.decl_ctx.ctx_enums + ( pctxmap, + EnumName.Map.empty, + EnumConstructor.Map.empty, + EnumName.Map.empty ) + in + let pctxmap, scopes_map, ctx_scopes = + ScopeName.Map.fold + (fun name info (pctxmap, scopes_map, ctx_scopes) -> + let info = + { + in_struct_name = StructName.Map.find info.in_struct_name structs_map; + out_struct_name = + StructName.Map.find info.out_struct_name structs_map; + out_struct_fields = + ScopeVar.Map.map + (fun fld -> StructField.Map.find fld fields_map) + info.out_struct_fields; + } + in + let path = ScopeName.path name in + if path = [] then + (* Scopes / topdefs in the root module will be renamed through the + variables binding them in the code_items *) + ( pctxmap, + ScopeName.Map.add name name scopes_map, + ScopeName.Map.add name info ctx_scopes ) + else + let str, pos = ScopeName.get_info name in + let pctxmap, ctx = + try pctxmap, PathMap.find path pctxmap + with Not_found -> PathMap.add path ctx pctxmap, ctx + in + let id, ctx = 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, + ScopeName.Map.add new_name info ctx_scopes )) + p.decl_ctx.ctx_scopes + (pctxmap, ScopeName.Map.empty, ScopeName.Map.empty) + in + let pctxmap, topdefs_map, ctx_topdefs = + TopdefName.Map.fold + (fun name typ (pctxmap, topdefs_map, ctx_topdefs) -> + let path = TopdefName.path name in + if path = [] then + (* Topdefs / topdefs in the root module will be renamed through the + variables binding them in the code_items *) + ( pctxmap, + TopdefName.Map.add name name topdefs_map, + TopdefName.Map.add name typ ctx_topdefs ) + (* [typ] is rewritten later on *) + else + let str, pos = TopdefName.get_info name in + let pctxmap, ctx = + try pctxmap, PathMap.find path pctxmap + with Not_found -> PathMap.add path ctx pctxmap, ctx + in + let id, ctx = 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, + TopdefName.Map.add new_name typ ctx_topdefs )) + p.decl_ctx.ctx_topdefs + (pctxmap, TopdefName.Map.empty, TopdefName.Map.empty) + in + let ctx = PathMap.find [] pctxmap in + let ctx = + set_rewriters ctx + ~scopes:(fun n -> ScopeName.Map.find n scopes_map) + ~topdefs:(fun n -> TopdefName.Map.find n topdefs_map) + ~structs:(fun n -> StructName.Map.find n structs_map) + ~fields:(fun n -> StructField.Map.find n fields_map) + ~enums:(fun n -> EnumName.Map.find n enums_map) + ~constrs:(fun n -> EnumConstructor.Map.find n constrs_map) + in + let decl_ctx = + { p.decl_ctx with ctx_enums; ctx_structs; ctx_scopes; ctx_topdefs } + in + let decl_ctx = Program.map_decl_ctx ~f:(typ ctx) decl_ctx in + let code_items = code_items ctx p.code_items in + { p with decl_ctx; code_items }, ctx + +(* This first-class module wrapping is here to allow a polymorphic renaming + function to be passed around *) + +module type Renaming = sig + val apply : 'e program -> 'e program * context +end + +type t = (module Renaming) + +let apply (module R : Renaming) = R.apply + +let program + ~reserved + ~reset_context_for_closed_terms + ~skip_constant_binders + ~constant_binder_name + ~namespaced_fields_constrs + ?f_var + ?f_struct + ?f_field + ?f_enum + ?f_constr + () = + let module M = struct + let apply p = + program ~reserved ~reset_context_for_closed_terms ~skip_constant_binders + ~constant_binder_name ~namespaced_fields_constrs ?f_var ?f_struct + ?f_field ?f_enum ?f_constr p + end in + (module M : Renaming) diff --git a/compiler/shared_ast/renaming.mli b/compiler/shared_ast/renaming.mli new file mode 100644 index 00000000..966be016 --- /dev/null +++ b/compiler/shared_ast/renaming.mli @@ -0,0 +1,105 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2024 Inria, contributor: + Louis Gesbert + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +open Catala_utils +open Definitions + +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.Renaming] *) + skip_constant_binders : bool; (** See [Bindlib.Renaming] *) + constant_binder_name : string option; (** See [Bindlib.Renaming] *) +} + +type context + +val get_ctx : config -> context + +val unbind_in : + context -> + ?fname:(string -> string) -> + ('e, 'b) Bindlib.binder -> + ('e, _) Mark.ed Var.t * 'b * context +(* [fname] applies a transformation on the variable name (typically something + like [String.to_snake_case]). The result is advisory and a numerical suffix + may be appended or modified *) + +val unmbind_in : + context -> + ?fname:(string -> string) -> + ('e, 'b) Bindlib.mbinder -> + ('e, _) Mark.ed Var.t Array.t * 'b * context + +val new_id : context -> string -> string * context + +val set_rewriters : + ?scopes:(ScopeName.t -> ScopeName.t) -> + ?topdefs:(TopdefName.t -> TopdefName.t) -> + ?structs:(StructName.t -> StructName.t) -> + ?fields:(StructField.t -> StructField.t) -> + ?enums:(EnumName.t -> EnumName.t) -> + ?constrs:(EnumConstructor.t -> EnumConstructor.t) -> + context -> + context + +val typ : context -> typ -> typ + +val expr : context -> ('a any, 'm) gexpr -> ('a, 'm) boxed_gexpr +(** Disambiguates all variable names in [e], and renames structs, fields, enums + and constrs according to the given context configuration *) + +val scope_name : context -> ScopeName.t -> ScopeName.t +val topdef_name : context -> TopdefName.t -> TopdefName.t +val struct_name : context -> StructName.t -> StructName.t +val enum_name : context -> EnumName.t -> EnumName.t + +val code_items : + context -> ((_ any, 'm) gexpr as 'e) code_item_list -> 'e code_item_list + +type t +(** Enclosing of a polymorphic renaming function, to be used by [apply] *) + +val apply : t -> 'e program -> 'e program * context + +val program : + reserved:string list -> + 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) -> + unit -> + t +(** 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 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/compiler/shared_ast/scope.ml b/compiler/shared_ast/scope.ml index bf43c64d..d7514bc3 100644 --- a/compiler/shared_ast/scope.ml +++ b/compiler/shared_ast/scope.ml @@ -146,61 +146,3 @@ let free_vars scopes = ~init:(fun _vlist -> Var.Set.empty) ~f:(fun item v acc -> Var.Set.union (Var.Set.remove v acc) (free_vars_item item)) - -(** Maps carrying around a naming context, enriched at each [unbind] *) -let rec boundlist_map_ctx ~f ~fname ~last ~ctx = function - | Last l -> Bindlib.box_apply (fun l -> Last l) (last ctx l) - | Cons (item, next_bind) -> - let item = f ctx item in - let var, next, ctx = Expr.Renaming.unbind_in ctx ~fname next_bind in - let next = boundlist_map_ctx ~f ~fname ~last ~ctx next in - let next_bind = Bindlib.bind_var var next in - Bindlib.box_apply2 - (fun item next_bind -> Cons (item, next_bind)) - item next_bind - -let rename_vars_in_lets ctx scope_body_expr = - boundlist_map_ctx scope_body_expr ~ctx ~fname:String.to_snake_case - ~last:(fun ctx e -> Expr.Box.lift (Expr.Renaming.expr ctx e)) - ~f:(fun ctx scope_let -> - Bindlib.box_apply - (fun scope_let_expr -> - { - scope_let with - scope_let_expr; - scope_let_typ = Expr.Renaming.typ ctx scope_let.scope_let_typ; - }) - (Expr.Box.lift (Expr.Renaming.expr ctx scope_let.scope_let_expr))) - -let rename_ids ctx (scopes : 'e code_item_list) = - let f ctx = function - | ScopeDef (name, body) -> - let name = Expr.Renaming.scope_name ctx name in - let scope_input_var, scope_lets, ctx = - Expr.Renaming.unbind_in ctx ~fname:String.to_snake_case - body.scope_body_expr - in - let scope_lets = rename_vars_in_lets ctx scope_lets in - let scope_body_expr = Bindlib.bind_var scope_input_var scope_lets in - Bindlib.box_apply - (fun scope_body_expr -> - let body = - { - scope_body_input_struct = - Expr.Renaming.struct_name ctx body.scope_body_input_struct; - scope_body_output_struct = - Expr.Renaming.struct_name ctx body.scope_body_output_struct; - scope_body_expr; - } - in - ScopeDef (name, body)) - scope_body_expr - | Topdef (name, ty, expr) -> - Bindlib.box_apply - (fun e -> Topdef (name, Expr.Renaming.typ ctx ty, e)) - (Expr.Box.lift (Expr.Renaming.expr ctx expr)) - in - Bindlib.unbox - @@ boundlist_map_ctx ~ctx ~f ~fname:String.to_snake_case - ~last:(fun _ctx -> Bindlib.box) - scopes diff --git a/compiler/shared_ast/scope.mli b/compiler/shared_ast/scope.mli index d63b06d1..30d14699 100644 --- a/compiler/shared_ast/scope.mli +++ b/compiler/shared_ast/scope.mli @@ -77,11 +77,6 @@ val input_type : typ -> Runtime.io_input Mark.pos -> typ this doesn't take thunking into account (thunking is added during the scopelang->dcalc translation) *) -val rename_ids : - Expr.Renaming.context -> - ((_ any, 'm) gexpr as 'e) code_item_list -> - 'e code_item_list - (** {2 Analysis and tests} *) val free_vars_body_expr : 'e scope_body_expr -> 'e Var.Set.t diff --git a/compiler/shared_ast/shared_ast.ml b/compiler/shared_ast/shared_ast.ml index 739066cc..c854c71d 100644 --- a/compiler/shared_ast/shared_ast.ml +++ b/compiler/shared_ast/shared_ast.ml @@ -23,6 +23,7 @@ module Expr = Expr module BoundList = BoundList module Scope = Scope module Program = Program +module Renaming = Renaming module Print = Print module Typing = Typing module Interpreter = Interpreter