diff --git a/src/provider.ml b/src/provider.ml index c0ea41b..aa9c5b2 100644 --- a/src/provider.ml +++ b/src/provider.ml @@ -46,32 +46,29 @@ module Trait = struct let compare_by_uid id1 id2 = Uid.compare (uid id1) (uid id2) let same (id1 : _ t) (id2 : _ t) = phys_same id1 id2 + let implement = Implementation0.implement +end - module Implementation = struct - type ('t, 'module_type, 'tag) trait = ('t, 'module_type, 'tag) t - - type 'a t = 'a Implementation0.t = private - | T : - { trait : ('t, 'module_type, _) trait - ; impl : 'module_type - } - -> 't t - - let uid (T { trait; impl = _ }) = uid trait - let info (T { trait; impl = _ }) = info trait +module Implementation = struct + type 'a t = 'a Implementation0.t = private + | T : + { trait : ('t, 'module_type, _) Trait.t + ; impl : 'module_type + } + -> 't t - let compare_by_uid (T { trait = id1; _ }) (T { trait = id2; _ }) = - compare_by_uid id1 id2 - ;; - end + let uid (T { trait; impl = _ }) = Trait.uid trait + let info (T { trait; impl = _ }) = Trait.info trait - let implement = Implementation0.implement + let compare_by_uid (T { trait = id1; _ }) (T { trait = id2; _ }) = + Trait.compare_by_uid id1 id2 + ;; end module Interface = struct (* We sort the element by their extension_id in increasing order. Element.(0) is a cache of the most recently looked up method. *) - type ('t, -'tags) t = 't Trait.Implementation.t array + type ('t, -'tags) t = 't Implementation.t array let dedup_sorted_keep_last = let[@tail_mod_cons] rec aux list ~cmp = @@ -84,11 +81,11 @@ module Interface = struct aux ;; - let make (type a) (implementations : a Trait.Implementation.t list) : (a, _) t = + let make (type a) (implementations : a Implementation.t list) : (a, _) t = let implementations = implementations - |> List.stable_sort ~cmp:Trait.Implementation.compare_by_uid - |> dedup_sorted_keep_last ~cmp:Trait.Implementation.compare_by_uid + |> List.stable_sort ~cmp:Implementation.compare_by_uid + |> dedup_sorted_keep_last ~cmp:Implementation.compare_by_uid in match implementations with | [] -> [||] @@ -104,11 +101,11 @@ module Interface = struct then false else Array.for_alli t1 ~f:(fun i implementation -> - i = 0 || 0 = Trait.Implementation.compare_by_uid implementation t2.(i)) + i = 0 || 0 = Implementation.compare_by_uid implementation t2.(i)) ;; let is_empty t = Array.length t = 0 - let cache t = if Array.length t = 0 then None else Some (Trait.Implementation.uid t.(0)) + let cache t = if Array.length t = 0 then None else Some (Implementation.uid t.(0)) let implementations t = match Array.to_list t with @@ -134,7 +131,7 @@ module Interface = struct then if_not_found ~trait_info:(Trait.info trait) else ( let mid = (from + to_) / 2 in - let (Trait.Implementation.T { trait = elt; impl } as implementation) = t.(mid) in + let (Implementation.T { trait = elt; impl } as implementation) = t.(mid) in match Trait.compare_by_uid elt trait |> Ordering.of_int with | Equal -> if update_cache then t.(0) <- implementation; @@ -158,7 +155,7 @@ module Interface = struct if Array.length t = 0 then if_not_found ~trait_info:(Trait.info trait) else ( - let (Trait.Implementation.T { trait = cached_id; impl }) = t.(0) in + let (Implementation.T { trait = cached_id; impl }) = t.(0) in if Trait.same trait cached_id then if_found (Stdlib.Obj.magic impl) else diff --git a/src/provider.mli b/src/provider.mli index cbae44e..e974e13 100644 --- a/src/provider.mli +++ b/src/provider.mli @@ -7,6 +7,7 @@ The module is divided into several submodules: - {!module:Trait}: To identify and implement functionality. + - {!module:Implementation}: Represents an implementation for a trait. - {!module:Interface}: Manages the set of traits that a provider implements. - {!module:Private}: Used for testing purposes. @@ -81,24 +82,6 @@ module Trait : sig val same : _ t -> _ t -> bool - module Implementation : sig - (** Representing an implementation for a trait. *) - - type ('t, 'module_type, 'tag) trait := ('t, 'module_type, 'tag) t - - type 'a t = 'a Implementation0.t = private - | T : - { trait : ('t, 'module_type, _) trait - ; impl : 'module_type - } - -> 't t - - (** {1 Dump & debug} *) - - val uid : _ t -> Uid.t - val info : _ t -> Info.t - end - (** [implement trait ~impl:(module Impl)] says to implement [trait] with [Impl]. The module [Impl] provided must have the right module type as specified by the type of [trait]. @@ -108,7 +91,23 @@ module Trait : sig granularity of each trait. This means that the {!val:implement} function focuses solely on creating the implementation, without considering the tags that indicate which traits are supported by the provider. *) - val implement : ('t, 'module_type, _) t -> impl:'module_type -> 't Implementation.t + val implement : ('t, 'module_type, _) t -> impl:'module_type -> 't Implementation0.t +end + +module Implementation : sig + (** Representing an implementation for a trait. *) + + type 'a t = 'a Implementation0.t = private + | T : + { trait : ('t, 'module_type, _) Trait.t + ; impl : 'module_type + } + -> 't t + + (** {1 Dump & debug} *) + + val uid : _ t -> Trait.Uid.t + val info : _ t -> Trait.Info.t end module Interface : sig @@ -152,18 +151,18 @@ module Interface : sig trait. This means that the resulting interface will not contain any duplicate traits, and the order of the implementations in the input list can affect its contents. *) - val make : 't Trait.Implementation.t list -> ('t, _) t + val make : 't Implementation.t list -> ('t, _) t (** [implementations t] returns a list of trait implementations that the interface [t] supports. See also {!extend}. *) - val implementations : ('t, _) t -> 't Trait.Implementation.t list + val implementations : ('t, _) t -> 't Implementation.t list (** [extend t ~with_] extends the interface [t] and returns a new interface that includes both the original and additional implementations. The resulting interface only contains the last occurrence of each trait, prioritizing the rightmost elements in the combined list [implementations t @ with_]. *) - val extend : ('t, _) t -> with_:'t Trait.Implementation.t list -> ('t, _) t + val extend : ('t, _) t -> with_:'t Implementation.t list -> ('t, _) t (** {1 Lookup} diff --git a/test/test__introspection.ml b/test/test__introspection.ml index 1450b7c..ec88bf3 100644 --- a/test/test__introspection.ml +++ b/test/test__introspection.ml @@ -6,7 +6,7 @@ let print_implemented_traits (Provider.T { t = _; interface }) = let info = List.map (Provider.Interface.implementations interface) ~f:(fun implementation -> - [%sexp (Provider.Trait.Implementation.info implementation : Provider.Trait.Info.t)]) + [%sexp (Provider.Implementation.info implementation : Provider.Trait.Info.t)]) in print_s [%sexp (info : Sexp.t list)] ;; diff --git a/test/test__lookup.ml b/test/test__lookup.ml index af108b4..7fe0925 100644 --- a/test/test__lookup.ml +++ b/test/test__lookup.ml @@ -151,7 +151,7 @@ end let uids (Provider.T { t = _; interface }) = interface |> Provider.Interface.implementations - |> List.map ~f:Provider.Trait.Implementation.uid + |> List.map ~f:Provider.Implementation.uid |> Set.of_list (module Uid) ;; diff --git a/test/test__make_interface.ml b/test/test__make_interface.ml index 93186a6..d998494 100644 --- a/test/test__make_interface.ml +++ b/test/test__make_interface.ml @@ -47,8 +47,8 @@ let%expect_test "make interface" = require_equal [%here] (module Provider.Trait.Uid) - (Provider.Trait.Implementation.uid c1) - (Provider.Trait.Implementation.uid trait1); + (Provider.Implementation.uid c1) + (Provider.Implementation.uid trait1); [%expect {||}] | _ -> assert false); let empty = Provider.Interface.make [] in diff --git a/test/test__override.ml b/test/test__override.ml index 10d15f9..251f730 100644 --- a/test/test__override.ml +++ b/test/test__override.ml @@ -26,8 +26,7 @@ let%expect_test "override" = let print_implemented_traits (Provider.T { t = _; interface }) = let info = List.map (Provider.Interface.implementations interface) ~f:(fun implementation -> - [%sexp - (Provider.Trait.Implementation.info implementation : Provider.Trait.Info.t)]) + [%sexp (Provider.Implementation.info implementation : Provider.Trait.Info.t)]) in print_s [%sexp (info : Sexp.t list)] in