diff --git a/engine/backends/fstar/fstar_backend.ml b/engine/backends/fstar/fstar_backend.ml index 4297dcc3a..9bf62ac18 100644 --- a/engine/backends/fstar/fstar_backend.ml +++ b/engine/backends/fstar/fstar_backend.ml @@ -1737,10 +1737,9 @@ let translate_as_fstar m (bo : BackendOptions.t) ~(bundles : AST.item list list) (items : AST.item list) : Types.file list = U.group_items_by_namespace items |> Map.to_alist - |> List.filter_map - ~f: - (snd >> List.hd - >> Option.map ~f:(fun i -> ((RenderId.render i.ident).path, items))) + |> List.filter_map ~f:(fun (_, items) -> + let* first_item = List.hd items in + Some ((RenderId.render first_item.ident).path, items)) |> List.concat_map ~f:(fun (ns, items) -> let mod_name = module_name ns in let impl, intf = string_of_items ~mod_name ~bundles bo m items in diff --git a/engine/lib/concrete_ident/concrete_ident.ml b/engine/lib/concrete_ident/concrete_ident.ml index c40b66fd8..2fffe4109 100644 --- a/engine/lib/concrete_ident/concrete_ident.ml +++ b/engine/lib/concrete_ident/concrete_ident.ml @@ -84,7 +84,7 @@ end = struct List.mapi ~f:(fun n _ -> mod_name :: List.take suffixes n) suffixes |> List.map ~f:(List.map ~f:(fun m -> m.DisambiguatedString.data)) |> List.map ~f:(String.concat ~sep:"_") - |> List.find ~f:(Set.mem existing_names) + |> List.find ~f:(Set.mem existing_names >> not) |> Option.value_exn ~message: "Broken invariant: in fresh modules the suffix is supposed to be \ @@ -179,10 +179,19 @@ let to_view (ident : t) : Concrete_ident_view.t = in { mod_path; rel_path } +(** Stateful store that maps [def_id]s to implementation informations +(which trait is implemented? for which type? under which constraints?) *) +module ImplInfoStore = struct + include Explicit_def_id.ImplInfoStore + + let lookup_raw (impl : t) : Types.impl_infos option = lookup_raw impl.def_id +end + module MakeToString (R : VIEW_RENDERER) = struct open Concrete_ident_render_sig - let per_module : (string list, (string, t) Hashtbl.t) Hashtbl.t = + let per_module : + (string list, (string, t) Hashtbl.t * (t, string) Hashtbl.t) Hashtbl.t = Hashtbl.create (module struct type t = string list [@@deriving hash, compare, sexp, eq] @@ -193,55 +202,79 @@ module MakeToString (R : VIEW_RENDERER) = struct let path = List.map ~f:R.render_module mod_path in let name = let* name = R.render_name ~namespace:mod_path rel_path in - let name = - match i.suffix with - | Some suffix -> ( - name ^ "_" - ^ - match suffix with - | `Pre -> "pre" - | `Post -> "post" - | `Cast -> "cast_to_repr") - | _ -> name - in - let name_map = + let name_map, id_map = Hashtbl.find_or_add per_module - ~default:(fun _ -> Hashtbl.create (module String)) + ~default:(fun _ -> + (Hashtbl.create (module String), Hashtbl.create (module T))) path in - let moved_into_fresh_ns = Option.is_none i.moved in - let name = - if moved_into_fresh_ns then - let escape_sep = - let re = Re.Pcre.regexp "__(e*)from__" in - let f group = "__e" ^ Re.Group.get group 1 ^ "from__" in - Re.replace ~all:true re ~f + match Hashtbl.find id_map i with + | Some name -> Some name + | None -> + let name = + match i.suffix with + | Some suffix -> ( + name ^ "_" + ^ + match suffix with + | `Pre -> "pre" + | `Post -> "post" + | `Cast -> "cast_to_repr") + | _ -> name in - escape_sep name - else name - in - let name = - match Hashtbl.find name_map name with - | Some i' when [%equal: t] i i' -> name - | None -> name - | Some _i' when not moved_into_fresh_ns -> - failwith "TODO: report duplicate! R is incorrect" - | Some _ -> - let path : View.ModPath.t = (View.of_def_id i.def_id).mod_path in - let path = List.map ~f:R.render_module path in - List.folding_map ~init:[] (List.rev path) ~f:(fun acc chunk -> - let acc = chunk :: acc in - (acc, acc)) - |> List.map ~f:List.rev - |> List.map ~f:(fun path -> - name ^ "__from__" - ^ String.concat ~sep:"__" - path (* This might shadow, we should escape *)) - |> List.find ~f:(Hashtbl.mem name_map >> not) - |> Option.value_exn - in - let _ignored = Hashtbl.add ~key:name ~data:i in - Some name + let moved_into_fresh_ns = Option.is_some i.moved in + let name = + if moved_into_fresh_ns then + let escape_sep = + let re = Re.Pcre.regexp "__(e*)from__" in + let f group = "__e" ^ Re.Group.get group 1 ^ "from__" in + Re.replace ~all:true re ~f + in + escape_sep name + else name + in + let name = + match Hashtbl.find name_map name with + (* If [i'] is an associated item (or under an assoc item), it lives in a separate namespace. + TODO: this is true only for backend that support typeclasses or that + have expressive records. *) + | Some i' + when List.exists + ~f:(fun i -> + [%matches? Types.AssocFn | AssocConst | AssocTy | Field] + (Explicit_def_id.to_def_id i).kind) + (Explicit_def_id.parents i'.def_id) -> + name + | Some _ when moved_into_fresh_ns -> + let path : View.ModPath.t = + (View.of_def_id i.def_id).mod_path + in + let path = List.map ~f:R.render_module path in + List.folding_map ~init:[] (List.rev path) ~f:(fun acc chunk -> + let acc = chunk :: acc in + (acc, acc)) + |> List.map ~f:List.rev + |> List.map ~f:(fun path -> + name ^ "__from__" + ^ String.concat ~sep:"__" + path (* This might shadow, we should escape *)) + |> List.find ~f:(Hashtbl.mem name_map >> not) + |> Option.value_exn + | Some i' -> + let dbg = [%show: t] in + let msg = + "Fatal error in the name rendering: we tried to render\n\n" + ^ dbg i ^ "\n\n as [" ^ name + ^ "], but this name is already taken by the following \ + identifier: \n\n" ^ dbg i' + in + Stdio.prerr_endline msg; + failwith msg + | _ -> name + in + let _ = Hashtbl.add name_map ~key:name ~data:i in + let _ = Hashtbl.add id_map ~key:i ~data:name in + Some name in let name = name |> Option.value ~default:"" in { path; name } @@ -263,13 +296,6 @@ module MakeViewAPI (NP : NAME_POLICY) : RENDER_API = struct let is_reserved_word : string -> bool = Hash_set.mem NP.reserved_words module R : VIEW_RENDERER = struct - let escape_sep = - let re = Re.Pcre.regexp "_(e*)_" in - let f group = "_e" ^ Re.Group.get group 1 ^ "_" in - Re.replace ~all:true re ~f - - let sep = List.map ~f:escape_sep >> String.concat ~sep:"__" - let disambiguator_escape s = match split_str ~on:"_" s |> List.rev with | hd :: _ :: _ when Int.of_string_opt hd |> Option.is_some -> s ^ "_" @@ -281,111 +307,234 @@ module MakeViewAPI (NP : NAME_POLICY) : RENDER_API = struct let render_module = render_disambiguated - let disambiguate_name (n : View.RelPath.Chunk.t) : - (string, string) View.RelPath.Chunk.poly = - View.RelPath.Chunk.add_strings n - |> View.RelPath.Chunk.map_poly render_disambiguated render_disambiguated - - let render_name_plain : View.RelPath.Chunk.t -> string = - View.RelPath.Chunk.(disambiguate_name >> collect) >> sep - - let ( ^: ) x y = if String.is_empty x then y else sep [ x; y ] - - let allowed_prefixes = - [ - "impl"; - "anon_const"; - "foreign"; - "use"; - "opaque"; - "t"; - "C"; - "v"; - "f"; - "i"; - "discriminant"; - ] - - let escape_prefixes (s : string) : string = - match String.lsplit2 ~on:'_' s with - | Some (prefix, _) - when List.mem ~equal:[%equal: string] allowed_prefixes prefix -> - prefix ^ s - | _ -> s - - (** This formats a string as [_] if [requiered_prefix] is true or if [s]'s first letter is uppercase while [prefix]'s first letter is lowercase or vice-versa. *) - let format (prefix : string) (requiered_prefix : bool) (s : string) : string - = - let is_prefix_upper = prefix |> first_letter |> is_uppercase in - let is_s_upper = s |> first_letter |> is_uppercase in - if - Bool.equal is_s_upper is_prefix_upper - && (not requiered_prefix) - && not (is_reserved_word s) - then escape_prefixes s - else prefix ^ if String.is_empty s then "" else "_" ^ s - - let render_last ~namespace (extra : string) (n : View.RelPath.Chunk.t) : - string = - let value_fmt = format "v" false in - let field_fmt = format "f" true in - let type_fmt = format "t" true in - (* let render_last = render_last ~namespace in *) - let constructor_fmt ?(force_prefix = false) = format "C" force_prefix in - match n with - | `AssociatedItem - ((`Type n | `Const n | `Fn n), (`Trait _ | `Impl (_, _, _))) -> - let name = render_disambiguated n in - extra ^: field_fmt name - (* | `AssociatedItem (((`Type n | `Const n | `Fn n) as item), parent) -> - let impl = render_last extra (parent :> _ View.RelPath.Chunk.poly) in - let name = render_disambiguated n in - let name = - match item with `Type _ -> type_fmt name | _ -> value_fmt name - in - impl ^ "__" ^ escape_sep name *) - | `Impl (d, _, impl_infos) -> - let identifier = - let* impl_infos = impl_infos in - let* ty = Thir_simple_types.to_string ~namespace impl_infos.typ in - let*? _no_generics = List.is_empty impl_infos.generics.params in - match impl_infos.trait_ref with - | None -> Some ty - | Some { def_id = trait; generic_args = [ _self ] } -> - let* trait = Explicit_def_id.of_def_id trait in - let trait = View.of_def_id trait in - let*? _same_ns = - [%eq: View.ModPath.t] namespace trait.mod_path - in - let* trait = - match trait.rel_path with - | [ `Trait (n, _) ] - when Int64.equal Int64.zero n.disambiguator -> - Some n.data - | _ -> None - in - let trait = - let re = Re.Pcre.regexp "_((?:e_)*)for_" in - let f group = "_e_" ^ Re.Group.get group 1 ^ "for_" in - Re.replace ~all:true re ~f trait - in - Some (trait ^ "_for_" ^ ty) + module NameAst = struct + module Separator = struct + let separator = "__" + let concat x y = x ^ separator ^ y + + let escape = + let re = Re.Pcre.regexp "_(e*)_" in + let f group = "_e" ^ Re.Group.get group 1 ^ "_" in + Re.replace ~all:true re ~f + end + + module Prefixes : sig + type t = private string [@@deriving eq, show] + + val allowed : t list + (** List of allowed reserved prefixes. *) + + val mk : string -> t + (** Creates a prefix, if it is valid. *) + + val escape : string -> string + (** Escapes reserved prefixes in a string *) + end = struct + type t = string [@@deriving eq, show] + + let allowed = + [ + "impl"; + "anon_const"; + "foreign"; + "use"; + "opaque"; + "t"; + "C"; + "v"; + "f"; + "i"; + "discriminant"; + ] + + let mem = List.mem ~equal:[%eq: string] allowed + + let mk s = + if mem s then s + else + failwith ("broken invariant: [" ^ s ^ "] is not an allowed prefix") + + let escape_char = "e" + + let () = + assert ( + (* Make sure there is no prefix `Cs` such that `C ^ "s"` is a prefix as well. *) + List.for_all allowed ~f:(fun s -> not (mem (first_letter s ^ s)))) + + let () = assert (mem "e" |> not) + + let rec escape (s : string) : string = + match String.lsplit2 ~on:'_' s with + | Some ("", rest) -> "e_" ^ escape rest + | Some (prefix, rest) + when List.mem ~equal:[%equal: string] allowed prefix -> + first_letter prefix ^ prefix ^ "_" ^ escape rest + | _ -> s + end + + type policy = { + prefix : Prefixes.t; + disable_when : [ `SameCase ] list; + mode : [ `Global | `Local | `Both ]; + } + [@@deriving eq, show] + + type t = + | Concat of (t * t) (** Concatenate two names *) + | Policy of (policy * t) + | TrustedString of string (** A string that is already escaped *) + | UnsafeString of string (** A string that needs escaping *) + | Empty + [@@deriving eq, show] + + let rec global_policy ast : _ = + let filter = + Option.filter ~f:(fun p -> [%matches? `Global | `Both] p.mode) + in + let ( <|> ) v f = match v with Some v -> Some v | None -> f () in + match ast with + | Policy (policy, contents) -> + global_policy contents |> filter <|> fun _ -> + policy |> Option.some |> filter + | Concat (l, r) -> + global_policy r |> filter <|> fun _ -> global_policy l |> filter + | _ -> None + + let escape_unsafe_string = Prefixes.escape >> Separator.escape + + let apply_policy (leftmost : bool) (policy : policy) (escaped : string) = + let prefix = (policy.prefix :> string) in + let disable = + List.exists policy.disable_when ~f:(function `SameCase -> + let first_upper = first_letter >> is_uppercase in + Bool.equal (first_upper prefix) (first_upper escaped)) + in + if (not disable) || (leftmost && is_reserved_word escaped) then + prefix ^ "_" ^ escaped + else escaped + + let rec norm' = function + | Concat (Empty, x) | Concat (x, Empty) -> x + | Policy (_, Empty) -> Empty + | Policy (p, x) -> Policy (p, norm' x) + | Concat (x, y) -> Concat (norm' x, norm' y) + | x -> x + + let rec norm x = + let x' = norm' x in + if [%eq: t] x x' then x else norm x' + + let concat_list = + List.fold ~f:(fun l r -> Concat (l, r)) ~init:Empty >> norm + + let rec render' leftmost ast = + match ast with + | Concat (a, b) -> + Separator.concat (render' leftmost a) (render' false b) + | Policy (policy, a) when [%matches? `Global] policy.mode -> + render' leftmost a + | Policy (policy, a) -> + render' leftmost a |> apply_policy leftmost policy + | TrustedString s -> s + | UnsafeString s -> escape_unsafe_string s + | Empty -> "" + + let render ast = + let policy = global_policy ast in + let policy = + Option.map ~f:(apply_policy true) policy + |> Option.value ~default:Fn.id + in + let rendered = norm ast |> render' true |> policy in + if is_reserved_word rendered then rendered ^ "_escape_reserved_word" + else rendered + end + + (** [pretty_impl_name ~namespace impl_infos] computes a pretty impl name given impl informations and a namespace. + A pretty name can be computed when: + - (1) the impl, (2) the type and (3) the trait implemented all live in the same namespace + - the impl block has no generics + - the type implemented is simple enough to be represented as a string (see module {!Thir_simple_types}) + *) + let pretty_impl_name ~namespace (impl_infos : Types.impl_infos) = + let* ty = Thir_simple_types.to_string ~namespace impl_infos.typ in + let*? _no_generics = List.is_empty impl_infos.generics.params in + match impl_infos.trait_ref with + | None -> Some ty + | Some { def_id = trait; generic_args = [ _self ] } -> + let* trait = Explicit_def_id.of_def_id trait in + let trait = View.of_def_id trait in + let*? _same_ns = [%eq: View.ModPath.t] namespace trait.mod_path in + let* trait = + match trait.rel_path with + | [ `Trait (n, _) ] when Int64.equal Int64.zero n.disambiguator -> + Some n.data | _ -> None in - let default = - if Int64.equal Int64.zero d then "" else Int64.to_string d + let trait = + let re = Re.Pcre.regexp "_((?:e_)*)for_" in + let f group = "_e_" ^ Re.Group.get group 1 ^ "for_" in + Re.replace ~all:true re ~f trait in - let name = identifier |> Option.value ~default in - let prefix = "impl" in - let prefix = - if Option.is_some identifier then prefix ^ "_" else prefix + Some (trait ^ "_for_" ^ ty) + | _ -> None + + (** Produces a name for an impl block, only if it is necessary (e.g. the disambiguator is non-null) *) + let impl_name ~namespace ?(always = false) disambiguator + (impl_infos : Types.impl_infos option) = + let pretty = impl_infos |> Option.bind ~f:(pretty_impl_name ~namespace) in + let*? _ = always || Int64.equal Int64.zero disambiguator |> not in + Some (Option.value ~default:(Int64.to_string disambiguator) pretty) + + let rec render_chunk ~namespace (chunk : View.RelPath.Chunk.t) : NameAst.t = + let prefix ?(global = false) ?(disable_when = []) s contents = + NameAst.Policy + ( { + prefix = NameAst.Prefixes.mk s; + mode = (if global then `Both else `Local); + disable_when; + }, + contents ) + in + let prefix_d s d = prefix s (NameAst.UnsafeString (Int64.to_string d)) in + let dstr s = NameAst.UnsafeString (render_disambiguated s) in + let _render_chunk = render_chunk ~namespace in + match chunk with + | `AnonConst d -> prefix_d "anon_const" d + | `Use d -> prefix_d "use" d + | `Foreign d -> prefix_d "foreign" d + | `GlobalAsm d -> prefix_d "global_asm" d + | `Opaque d -> prefix_d "opaque" d + (* The name of a trait impl *) + | `Impl (d, _, impl_infos) -> ( + match impl_name ~namespace d impl_infos with + | Some name -> prefix "impl" (UnsafeString name) + | None -> TrustedString "impl") + (* Print the name of an associated item in a inherent impl *) + | `AssociatedItem + ((`Type n | `Const n | `Fn n), `Impl (d, `Inherent, impl_infos)) -> + let impl = + match impl_name ~always:true ~namespace d impl_infos with + | Some name -> prefix "impl" (UnsafeString name) + | None -> TrustedString "impl" in - format prefix true (extra ^: name) - | `AnonConst d -> format "anon_const" true (extra ^: Int64.to_string d) - | `Use d -> format "use" true (extra ^: Int64.to_string d) - | `Foreign d -> format "foreign" true (extra ^: Int64.to_string d) - | `GlobalAsm d -> format "global_asm" true (extra ^: Int64.to_string d) - | `Opaque d -> format "opaque" true (extra ^: Int64.to_string d) + Concat (impl, dstr n) + (* Print the name of an associated item in a trait impl *) + | `AssociatedItem + ((`Type n | `Const n | `Fn n), (`Trait _ | `Impl (_, `Trait, _))) -> + prefix "f" (dstr n) + (* The constructor of a struct *) + | `Constructor (cons, `Struct _) -> + prefix ~global:true ~disable_when:[ `SameCase ] "C" (dstr cons) + | `Constructor (cons, (`Enum n | `Union n)) -> + (* [TODO] Here, we separate with `_` so that we keep the old behavior: this is dodgy. *) + let n = render_disambiguated n ^ "_" ^ render_disambiguated cons in + prefix ~global:true ~disable_when:[ `SameCase ] "C" (UnsafeString n) + | `Field (n, _) -> prefix "f" (dstr n) + (* Anything function-like *) + | `Macro n | `Static n | `Fn n | `Const n -> + prefix "v" ~disable_when:[ `SameCase ] (dstr n) + (* Anything type-like *) | `ExternCrate n | `Trait (n, _) | `ForeignTy n @@ -394,28 +543,13 @@ module MakeViewAPI (NP : NAME_POLICY) : RENDER_API = struct | `Struct n | `Union n | `Enum n -> - type_fmt (extra ^: render_disambiguated n) - | `Constructor (cons, `Struct _) -> - let cons = extra ^: render_disambiguated cons in - constructor_fmt - ~force_prefix:(String.is_substring cons ~substring:"_") - cons - | `Constructor (cons, parent) -> - let type_name = - extra ^: render_name_plain (parent :> _ View.RelPath.Chunk.poly) - in - if String.is_substring type_name ~substring:"_" then - constructor_fmt ~force_prefix:true - (type_name ^: render_disambiguated cons) - else constructor_fmt (type_name ^ "_" ^ render_disambiguated cons) - | `Macro n | `Static n | `Fn n | `Const n -> - value_fmt (extra ^: render_disambiguated n) - | `Field (n, _) -> field_fmt (extra ^: render_disambiguated n) + prefix "t" (dstr n) - let render_name ~namespace (n : View.RelPath.t) = - let* fake_path, name = last_init n in - let extra = List.map ~f:render_name_plain fake_path |> sep in - Some (render_last ~namespace extra name) + let render_name ~namespace (rel_path : View.RelPath.t) = + let rel_path = + List.map ~f:(render_chunk ~namespace) rel_path |> NameAst.concat_list + in + Some (NameAst.render rel_path) let finalize { path; name } = let path = List.map ~f:(map_first_letter String.uppercase) path in @@ -444,14 +578,6 @@ module MakeViewAPI (NP : NAME_POLICY) : RENDER_API = struct |> Option.value_exn end -(** Stateful store that maps [def_id]s to implementation informations -(which trait is implemented? for which type? under which constraints?) *) -module ImplInfoStore = struct - include Explicit_def_id.ImplInfoStore - - let lookup_raw (impl : t) : Types.impl_infos option = lookup_raw impl.def_id -end - type name = Concrete_ident_generated.t [@@deriving show, yojson, compare, sexp, eq, hash] diff --git a/engine/lib/concrete_ident/explicit_def_id.ml b/engine/lib/concrete_ident/explicit_def_id.ml index 6ad661430..2bc176b7c 100644 --- a/engine/lib/concrete_ident/explicit_def_id.ml +++ b/engine/lib/concrete_ident/explicit_def_id.ml @@ -2,7 +2,18 @@ open! Prelude module T = struct type t = { is_constructor : bool; def_id : Types.def_id_contents } - [@@deriving show, yojson, hash, compare, sexp, hash, eq] + [@@deriving show, yojson, sexp] + + type repr = bool * string * Types.disambiguated_def_path_item list + [@@deriving hash, compare, eq] + + let to_repr { is_constructor; def_id } = + (is_constructor, def_id.krate, def_id.path) + + let hash = to_repr >> hash_repr + let hash_fold_t s = to_repr >> hash_fold_repr s + let equal x y = equal_repr (to_repr x) (to_repr y) + let compare x y = compare_repr (to_repr x) (to_repr y) end include T diff --git a/engine/lib/dependencies.ml b/engine/lib/dependencies.ml index ed1218fde..4f241728f 100644 --- a/engine/lib/dependencies.ml +++ b/engine/lib/dependencies.ml @@ -6,8 +6,34 @@ module Make (F : Features.T) = struct open Ast open AST - let ident_of (item : item) : Concrete_ident.t = - match item.v with Type { name; _ } -> name | _ -> item.ident + (** Get the identifier of an item *) + let ident_of (item : item) : Concrete_ident.t = item.ident + + (** Get all the identifiers declared under an item. This includes the + identifier of the item itself, but also of any sub-item: for instance, + associated items within an impl. *) + let idents_of (item : item) : Concrete_ident.t list = + let is_field_anonymous ident = + match List.last (Concrete_ident.to_view ident).mod_path with + | Some { data = n; _ } -> Option.is_some (Int.of_string_opt n) + | _ -> false + in + ident_of item + :: + (match item.v with + | Type { variants; _ } -> + List.concat_map + ~f:(fun variant -> + let fields = + List.map ~f:fst3 variant.arguments + |> List.filter ~f:is_field_anonymous + in + + variant.name :: fields) + variants + | Trait { items; _ } -> List.map ~f:(fun item -> item.ti_ident) items + | Impl { items; _ } -> List.map ~f:(fun item -> item.ii_ident) items + | _ -> (* No sub items *) []) module Namespace = struct include Concrete_ident.View.ModPath @@ -166,13 +192,12 @@ module Make (F : Features.T) = struct (mod_graph_cycles : Namespace.Set.t list) : Bundle.t list = let item_names = List.map items ~f:(fun x -> x.ident) in let cycles = - List.filter mod_graph_cycles ~f:(fun set -> - Prelude.Set.length set > 1) + List.filter mod_graph_cycles ~f:(fun set -> Set.length set > 1) in let bundles = List.map cycles ~f:(fun set -> List.filter item_names ~f:(fun item -> - Prelude.Set.mem set (Namespace.of_concrete_ident item))) + Set.mem set (Namespace.of_concrete_ident item))) in bundles end @@ -366,103 +391,41 @@ module Make (F : Features.T) = struct in List.filter ~f:(ident_of >> Set.mem selection) items - (* Construct the new item `f item` (say `item'`), and create a - "symbolic link" to `item'`. Returns a pair that consists in the - symbolic link and in `item'`. *) - let shallow_copy (f : item -> item) - (variants_renamings : - concrete_ident * concrete_ident -> - (concrete_ident * concrete_ident) list) (item : item) : item list = - let item' = f item in - let old_new = (ident_of item, ident_of item') in + let fresh_module_for (bundle : item list) = + let fresh_module = + Concrete_ident.fresh_module ~label:"bundle" (List.map ~f:ident_of bundle) + in + let renamings = + bundle + (* Exclude `Use` items: we exclude those from bundling since they are only + user hints. `Use` items don't have proper identifiers, and those + identifiers are never referenced by other Rust items. *) + |> List.filter ~f:(function { v = Use _; _ } -> false | _ -> true) + (* Exclude `NotImplementedYet` items *) + |> List.filter ~f:(function + | { v = NotImplementedYet; _ } -> false + | _ -> true) + |> List.concat_map ~f:(fun item -> + List.map + ~f:(fun id -> + ( item, + (id, Concrete_ident.move_to_fresh_module fresh_module id) )) + (idents_of item)) + in let aliases = - List.map (old_new :: variants_renamings old_new) - ~f:(fun (old_ident, new_ident) -> + List.map renamings ~f:(fun (origin_item, (from_id, to_id)) -> let attrs = - List.filter ~f:(fun att -> Attrs.late_skip [ att ]) item.attrs + List.filter + ~f:(fun att -> Attrs.late_skip [ att ]) + origin_item.attrs in - - { item with v = Alias { name = old_ident; item = new_ident }; attrs }) - in - item' :: aliases - - let bundle_cyclic_modules (items : item list) : item list = - let from_ident ident : item option = - List.find ~f:(fun i -> [%equal: Concrete_ident.t] i.ident ident) items - in - let mut_rec_bundles = - let mod_graph_cycles = ModGraph.of_items items |> ModGraph.cycles in - (* `Use` items shouldn't be bundled as they have no dependencies - and they have dummy names. *) - let non_use_items = - List.filter - ~f:(fun item -> - match item.v with Use _ | NotImplementedYet -> false | _ -> true) - items - in - let bundles = - ItemGraph.CyclicDep.of_mod_sccs non_use_items mod_graph_cycles - in - let f = List.filter_map ~f:from_ident in - List.map ~f bundles + let v = Alias { name = from_id; item = to_id } in + { attrs; span = origin_item.span; ident = from_id; v }) in - - let transform (bundle : item list) = - let ns = - Concrete_ident.fresh_module ~label:"bundle" - (List.map ~f:ident_of bundle) - in - let new_name_under_ns : Concrete_ident.t -> Concrete_ident.t = - Concrete_ident.move_to_fresh_module ns - in - let new_names = List.map ~f:(ident_of >> new_name_under_ns) bundle in - let duplicates = - new_names |> List.find_all_dups ~compare:Concrete_ident.compare - in - (* Verify name clashes *) - (* In case of clash, add hash *) - let add_prefix id = - if - not - (List.mem duplicates (new_name_under_ns id) - ~equal:Concrete_ident.equal) - then id - else failwith "TODO" - (* Concrete_ident.Create.map_last - ~f:(fun name -> name ^ (Concrete_ident.hash id |> Int.to_string)) - id *) - in - let renamings = - List.map - ~f:(ident_of >> (Fn.id &&& (add_prefix >> new_name_under_ns))) - bundle - in - let variants_renamings (previous_name, _new_name) = - match from_ident previous_name with - | Some { v = Type { variants; is_struct = false; _ }; _ } -> - List.map variants ~f:(fun { name; _ } -> - (name, new_name_under_ns name)) - | Some { v = Type { variants; is_struct = true; _ }; _ } -> - List.concat_map variants ~f:(fun { arguments; _ } -> - List.map arguments ~f:(fun (name, _, _) -> - (name, new_name_under_ns name))) - | _ -> [] - in - let variant_and_constructors_renamings = - List.concat_map ~f:variants_renamings renamings - (* |> List.concat_map ~f:(fun (old_name, new_name) -> - [ - (old_name, new_name); - ( Concrete_ident.Create.constructor old_name, - Concrete_ident.Create.constructor new_name ); - ]) *) - in + let rename = + let renamings = List.map ~f:snd renamings in let renamings = - match - Map.of_alist - (module Concrete_ident) - (renamings @ variant_and_constructors_renamings) - with + match Map.of_alist (module Concrete_ident) renamings with | `Duplicate_key dup -> failwith [%string @@ -472,47 +435,25 @@ module Make (F : Features.T) = struct %{[%show: concrete_ident] dup}"] | `Ok value -> value in - let rename = - let renamer _lvl i = Map.find renamings i |> Option.value ~default:i in - (U.Mappers.rename_concrete_idents renamer)#visit_item ExprLevel - in - fun it -> shallow_copy rename variants_renamings it - in - let bundle_transforms = - List.concat_map mut_rec_bundles ~f:(fun bundle -> - let bundle_value = - ( List.map ~f:ident_of bundle - |> ItemGraph.MutRec.Bundle.homogeneous_namespace, - transform bundle ) - in - List.map bundle ~f:(fun item -> (item, bundle_value))) + let renamer _lvl i = Map.find renamings i |> Option.value ~default:i in + (U.Mappers.rename_concrete_idents renamer)#visit_item ExprLevel in - let module ComparableItem = struct - module T = struct - type t = item [@@deriving sexp_of, compare, hash] - end + List.map ~f:rename bundle @ aliases - include T - include Comparable.Make (T) - end in - let bundle_of_item = - match Hashtbl.of_alist (module ComparableItem) bundle_transforms with - | `Duplicate_key dup -> - failwith - [%string - "Fatal error: in dependency analysis, [bundles_transforms] is \ - expected to be a key-value list with a guarantee of unicity in \ - keys. However, we found the following key (an item) twice:\n\ - %{U.Debug.item' dup}"] - | `Ok value -> value - in - let maybe_transform_item item = - match Hashtbl.find bundle_of_item item with - | Some (homogeneous_bundle, transform_bundle) -> - if homogeneous_bundle then [ item ] else transform_bundle item - | None -> [ item ] + let bundle_cyclic_modules (items : item list) : item list = + (* [module_level_scc] is a list of set of strongly connected modules. *) + let module_level_scc = ModGraph.(of_items >> cycles) items in + let items_per_ns = + List.map ~f:(fun i -> (Namespace.of_concrete_ident i.ident, i)) items + |> Map.of_alist_multi (module Namespace) in - List.concat_map items ~f:maybe_transform_item + let items_of_ns = Map.find items_per_ns >> Option.value ~default:[] in + module_level_scc + |> List.concat_map ~f:(fun nss -> + let multiple_heterogeneous_modules = Set.length nss > 1 in + let items = Set.to_list nss |> List.concat_map ~f:items_of_ns in + if multiple_heterogeneous_modules then fresh_module_for items + else items) let recursive_bundles (items : item list) : item list list * item list = let g = ItemGraph.of_items ~original_items:items items in