CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Renaming: move to its own module

Browse Source
This commit is contained in:
Louis Gesbert 2024-08-07 18:03:10 +02:00
parent 1b6da0b572
commit 081e07378a
20 changed files with 615 additions and 586 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
compiler/driver.ml
View File

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

8
compiler/driver.mli
View File

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

2
compiler/lcalc/to_ocaml.ml
View File

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

2
compiler/lcalc/to_ocaml.mli
View File

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

6
compiler/plugins/explain.ml
View File

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

10
compiler/scalc/from_lcalc.ml
View File

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

2
compiler/scalc/from_lcalc.mli
View File

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

2
compiler/scalc/to_c.ml
View File

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

2
compiler/scalc/to_c.mli
View File

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

2
compiler/scalc/to_python.ml
View File

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

2
compiler/scalc/to_python.mli
View File

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

192
compiler/shared_ast/expr.ml
View File

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

54
compiler/shared_ast/expr.mli
View File

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

218
compiler/shared_ast/program.ml
View File

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

33
compiler/shared_ast/program.mli
View File

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

482
compiler/shared_ast/renaming.ml Normal file
View File

@ -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 <louis.gesbert@inria.fr>
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)

105
compiler/shared_ast/renaming.mli Normal file
View File

@ -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 <louis.gesbert@inria.fr>
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. *)

58
compiler/shared_ast/scope.ml
View File

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

5
compiler/shared_ast/scope.mli
View File

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

1
compiler/shared_ast/shared_ast.ml
View File

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