Merge pull request #30 from mbarbin/runtime-info

Register custom trait names instead of extensible variant names

CHANGES.md

@@ -1,3 +1,17 @@
+## 0.0.11 (unreleased)
+
+### Added
+
+### Changed
+
+- Register custom trait names instead of extensible variant names (PR, @mbarbin).
+
+### Deprecated
+
+### Fixed
+
+### Removed
+
 ## 0.0.10 (2024-10-27)
 
 ### Added

src/import.ml

@@ -11,6 +11,10 @@ module Array = struct
   ;;
 end
 
+module Hashtbl = struct
+  include MoreLabels.Hashtbl
+end
+
 module Int = struct
   include Int
 

src/import.mli

@@ -6,6 +6,10 @@ module Array : sig
   val for_alli : 'a array -> f:(int -> 'a -> bool) -> bool
 end
 
+module Hashtbl : sig
+  include module type of MoreLabels.Hashtbl
+end
+
 module Int : sig
   include module type of Int
 

src/provider.ml

@@ -14,26 +14,33 @@ let phys_same t1 t2 = phys_equal (Obj.repr t1) (Obj.repr t2)
 module Trait = struct
   type ('t, 'module_type, 'tag) t = ('t, 'module_type, 'tag) Trait0.t = ..
 
-  let extension_constructor =
-    (Obj.Extension_constructor.of_val : _ t -> Obj.Extension_constructor.t)
-  ;;
+  let runtime_trait_info = Runtime_trait_info.default
 
   module Info = struct
-    type t = Obj.Extension_constructor.t
+    type t =
+      { id : int
+      ; name : string option
+      }
 
     let sexp_of_id_default _ = Sexp.Atom "#id"
     let sexp_of_id = ref sexp_of_id_default
 
-    let sexp_of_t t =
+    let sexp_of_t { id; name } =
       let sexp_of_id id = !sexp_of_id id in
       Sexp.List
-        [ List [ Atom "id"; sexp_of_id (Obj.Extension_constructor.id t) ]
-        ; List [ Atom "name"; Atom (Obj.Extension_constructor.name t) ]
+        [ List [ Atom "id"; sexp_of_id id ]
+        ; List [ Atom "name"; Atom (name |> Option.value ~default:"<none>") ]
         ]
     ;;
+
+    let register_name (t : _ Trait0.t) ~name =
+      Runtime_trait_info.set_name runtime_trait_info t ~name
+    ;;
   end
 
-  let info : _ t -> Info.t = extension_constructor
+  let info (t : _ t) =
+    { Info.id = Trait0.uid t; name = Runtime_trait_info.get_name runtime_trait_info t }
+  ;;
 
   module Uid = struct
     type t = int
@@ -45,7 +52,7 @@ module Trait = struct
     let seeded_hash = Int.seeded_hash
   end
 
-  let uid (t : _ t) = Obj.Extension_constructor.id (extension_constructor t)
+  let uid (t : _ t) = Trait0.uid t
   let compare_by_uid id1 id2 = Uid.compare (uid id1) (uid id2)
   let same (id1 : _ t) (id2 : _ t) = phys_same id1 id2
 

src/provider.mli

@@ -37,17 +37,19 @@ module Trait : sig
   (** {1 Dump & debug} *)
 
   module Info : sig
-    (** This type is meant to be used for debugging purposes only.
+    (** Displaying debugging information about a trait.
 
-        A [t] value includes the name of the Trait constructor and the module
-        path where it was defined. It may also include the runtime id for the
-        extensible variant of the Trait, but this is not included by default as
-        its value can be brittle (it may depend on the order in which modules
-        are evaluated).
+        This module provides a way to register, retrieve and display detailed
+        information about a Trait, which can be useful for debugging and
+        understanding the structure and behavior of the provider system.
 
-        This type provides a way to retrieve and display detailed information
-        about a Trait, which can be useful for debugging and understanding the
-        structure and behavior of the provider system. *)
+        This is meant for debugging purposes only. *)
+
+    (** A [t] value includes a unique runtime id for the trait, as well as an
+        optional name that may be registered by the user. The id is not shown
+        by [sexp_of_t] by default because its value can be brittle (it may
+        depend on the order in which modules are evaluated). To display ids,
+        see {!val:sexp_of_id}. *)
     type t
 
     val sexp_of_t : t -> Sexp.t
@@ -57,6 +59,10 @@ module Trait : sig
         temporarily change it, e.g. in a test, for example using
         [Ref.set_temporarily]. *)
     val sexp_of_id : (int -> Sexp.t) ref
+
+    (** Register a string mnemonic to attach to the trait for display purposes.
+        By default, trait do not have any name. *)
+    val register_name : _ Trait0.t -> name:string -> unit
   end
 
   val info : _ t -> Info.t

src/runtime_trait_info.ml

@@ -0,0 +1,8 @@
+open! Import
+
+type t = (int, string) Hashtbl.t
+
+let create () = Hashtbl.create 16
+let default = create ()
+let set_name t trait ~name = Hashtbl.add t ~key:(Trait0.uid trait) ~data:name
+let get_name t trait = Hashtbl.find_opt t (Trait0.uid trait)

src/runtime_trait_info.mli

@@ -0,0 +1,16 @@
+(** A mutable data structure to attach names to trait uids.
+
+    This is meant to be used in tests only to make the information attached to
+    trait more meaningful. *)
+
+(** A mutable data structure to store the names. *)
+type t
+
+val create : unit -> t
+
+(** [default] is the one and only hashtbl used by the provider library. This is
+    where info is stored when [Provider.Trait.Info.register_name] is called. *)
+val default : t
+
+val set_name : t -> _ Trait0.t -> name:string -> unit
+val get_name : t -> _ Trait0.t -> string option

src/trait0.ml

@@ -4,3 +4,5 @@ let is_valid (t : _ t) =
   let extension_constructor = Obj.Extension_constructor.of_val t in
   Obj.repr t == Obj.repr extension_constructor
 ;;
+
+let uid (t : _ t) = Obj.Extension_constructor.id (Obj.Extension_constructor.of_val t)

src/trait0.mli

@@ -4,3 +4,6 @@ type ('t, 'module_type, 'tag) t = ..
     This function is used to check that, and used to validate traits built by
     the user to detect invalid usage of the library. *)
 val is_valid : _ t -> bool
+
+(** Return a id that is unique to this trait for the lifetime of the program. *)
+val uid : _ t -> int

test/test__extensible_variant.ml

@@ -41,11 +41,23 @@ type ('t, 'module_type, 'tag) Provider.Trait.t +=
   | No_arg_A : ('t, (module T with type t = 't), [> `T ]) Provider.Trait.t
   | No_arg_B : ('t, (module T with type t = 't), [> `T ]) Provider.Trait.t
 
+let () =
+  Provider.Trait.Info.register_name No_arg_A ~name:"No_arg_A";
+  Provider.Trait.Info.register_name No_arg_B ~name:"No_arg_B";
+  ()
+;;
+
 let%expect_test "extension_constructor" =
   print_s [%sexp (Provider.Trait.info No_arg_A : Provider.Trait.Info.t)];
-  [%expect {| ((id #id) (name Provider_test.Test__extensible_variant.No_arg_A)) |}];
+  [%expect {|
+    ((id   #id)
+     (name No_arg_A))
+    |}];
   print_s [%sexp (Provider.Trait.info No_arg_B : Provider.Trait.Info.t)];
-  [%expect {| ((id #id) (name Provider_test.Test__extensible_variant.No_arg_B)) |}];
+  [%expect {|
+    ((id   #id)
+     (name No_arg_B))
+    |}];
   let extension_constructor_A = Obj.Extension_constructor.of_val No_arg_A in
   print_s [%sexp (Obj.Extension_constructor.name extension_constructor_A : string)];
   [%expect {| Provider_test.Test__extensible_variant.No_arg_A |}];
@@ -101,6 +113,8 @@ module Name_override = struct
     | No_arg_A : ('t, (module T with type t = 't), [> `T ]) Provider.Trait.t
 end
 
+let () = Provider.Trait.Info.register_name Name_override.No_arg_A ~name:"No_arg_A"
+
 let%expect_test "name override" =
   require [%here] (not (phys_equal No_arg_A Name_override.No_arg_A));
   [%expect {||}];
@@ -172,6 +186,8 @@ type show = [ `Show ]
 type (_, _, _) Provider.Trait.t +=
   | Show : { arg : int } -> ('t, (module S with type t = 't), [> show ]) Provider.Trait.t
 
+let () = Provider.Trait.Info.register_name (Show { arg = 0 }) ~name:"Show"
+
 let%expect_test "ids" =
   let trait1 = Show { arg = 0 } in
   let trait2 = Show { arg = 1 } in
@@ -214,7 +230,7 @@ let%expect_test "invalid_trait" =
      ((
        trait (
          (id   #id)
-         (name Provider_test.Test__extensible_variant.Show)))))
+         (name Show)))))
     |}];
   require_does_raise [%here] (fun () ->
     print (string_provider "Hello World" ~check_trait:false));
@@ -224,7 +240,7 @@ let%expect_test "invalid_trait" =
      ((
        trait (
          (id   #id)
-         (name Provider_test.Test__extensible_variant.Show)))))
+         (name Show)))))
     |}];
   ()
 ;;

test/test__info.ml

@@ -0,0 +1,32 @@
+type (_, _, _) Provider.Trait.t +=
+  | T : ('t, (module T with type t = 't), [> `T ]) Provider.Trait.t
+
+let%expect_test "info" =
+  (* By default, id are not shown, and trait do not have names. *)
+  let print_info () = print_s [%sexp (Provider.Trait.info T : Provider.Trait.Info.t)] in
+  [%expect {||}];
+  (* It is possible to show the id with custom functions. *)
+  Ref.set_temporarily
+    Provider.Trait.Info.sexp_of_id
+    (fun (_ : int) -> Sexp.Atom "#customized-id")
+    ~f:(fun () -> print_info ());
+  [%expect {|
+    ((id   #customized-id)
+     (name <none>))
+    |}];
+  (* It is also possible to register a name for a trait. *)
+  let () = Provider.Trait.Info.register_name T ~name:"Hello Name!" in
+  print_info ();
+  [%expect {|
+    ((id   #id)
+     (name "Hello Name!"))
+    |}];
+  (* The name can be changed. Whether this is desirable is up to the user. *)
+  let () = Provider.Trait.Info.register_name T ~name:"Goodbye Name!" in
+  print_info ();
+  [%expect {|
+    ((id   #id)
+     (name "Goodbye Name!"))
+    |}];
+  ()
+;;

test/test__introspection.ml

@@ -82,14 +82,16 @@ let%expect_test "introspection" =
   in
   Ref.set_temporarily Provider.Trait.Info.sexp_of_id sexp_of_id ~f:(fun () ->
     print_implemented_traits int_printer;
-    [%expect
-      {| (((id 0) (name Test_interfaces.Int_printer.Provider_interface.Int_printer))) |}];
+    [%expect {|
+      ((
+        (id   0)
+        (name Int_printer)))
+      |}];
     print_implemented_traits num_printer;
     [%expect
       {|
-      (((id 0) (name Test_interfaces.Int_printer.Provider_interface.Int_printer))
-       ((id 1)
-        (name Test_interfaces.Float_printer.Provider_interface.Float_printer)))
+      (((id 0) (name Int_printer))
+       ((id 1) (name Float_printer)))
       |}];
     ());
   ()

test/test__invalid_tags.ml

@@ -20,8 +20,8 @@ let%expect_test "invalid tags" =
     {|
     ("Trait not implemented" ((
       trait_info (
-        (id #id)
-        (name Test_interfaces.Int_printer.Provider_interface.Int_printer)))))
+        (id   #id)
+        (name Int_printer)))))
     |}];
   ()
 ;;

test/test__magic.ml

@@ -16,6 +16,7 @@ type (_, _, _) Provider.Trait.t +=
 
 let id_int = Type_equal.Id.create ~name:"int" [%sexp_of: int]
 let id_string = Type_equal.Id.create ~name:"string" [%sexp_of: string]
+let () = Provider.Trait.Info.register_name (A id_int) ~name:"A"
 
 let impl (type a) id value ~check_trait =
   Provider.Private.Trait.implement_unsafe
@@ -44,7 +45,7 @@ let%expect_test "magic" =
      ((
        trait (
          (id   #id)
-         (name Provider_test.Test__magic.A)))))
+         (name A)))))
     |}];
   let handler = make_handler ~check_trait:false in
   require_does_raise [%here] (fun () ->
@@ -56,7 +57,7 @@ let%expect_test "magic" =
      ((
        trait (
          (id   #id)
-         (name Provider_test.Test__magic.A)))))
+         (name A)))))
     |}];
   ()
 ;;

test/test__magic2.ml

@@ -9,6 +9,8 @@ end
 type (_, _, _) Provider.Trait.t +=
   | A : 'a -> (_, (module S with type t = 'a), [> `A ]) Provider.Trait.t
 
+let () = Provider.Trait.Info.register_name (A ()) ~name:"A"
+
 let impl (type a) arg ~check_trait =
   Provider.Private.Trait.implement_unsafe
     (A arg)
@@ -33,7 +35,7 @@ let%expect_test "magic" =
      ((
        trait (
          (id   #id)
-         (name Provider_test.Test__magic2.A)))))
+         (name A)))))
     |}];
   let handler = make_handler ~check_trait:false in
   require_does_raise [%here] (fun () ->
@@ -45,7 +47,7 @@ let%expect_test "magic" =
      ((
        trait (
          (id   #id)
-         (name Provider_test.Test__magic2.A)))))
+         (name A)))))
     |}];
   ()
 ;;

test/test__make_handler.ml

@@ -46,11 +46,8 @@ let%expect_test "make interface" =
          }];
      [%expect
        {|
-       ((trait1 (
-          (id #id) (name Test_interfaces.Int_printer.Provider_interface.Int_printer)))
-        (trait2 (
-          (id #id)
-          (name Test_interfaces.Float_printer.Provider_interface.Float_printer))))
+       ((trait1 ((id #id) (name Int_printer)))
+        (trait2 ((id #id) (name Float_printer))))
        |}];
      require [%here] (not (Provider.Trait.same t1.trait t2.trait));
      [%expect {||}];

test/test__override.ml

@@ -38,9 +38,8 @@ let%expect_test "override" =
   print_implemented_traits num_printer;
   [%expect
     {|
-    (((id #id) (name Test_interfaces.Int_printer.Provider_interface.Int_printer))
-     ((id #id)
-      (name Test_interfaces.Float_printer.Provider_interface.Float_printer)))
+    (((id #id) (name Int_printer))
+     ((id #id) (name Float_printer)))
     |}];
   test num_printer;
   [%expect {|
@@ -50,9 +49,8 @@ let%expect_test "override" =
   print_implemented_traits hum_printer;
   [%expect
     {|
-    (((id #id) (name Test_interfaces.Int_printer.Provider_interface.Int_printer))
-     ((id #id)
-      (name Test_interfaces.Float_printer.Provider_interface.Float_printer)))
+    (((id #id) (name Int_printer))
+     ((id #id) (name Float_printer)))
     |}];
   test hum_printer;
   (* Now there's an additional underscore separator in '1_234'. *)

test/test_interfaces/directory_reader.ml

@@ -11,6 +11,8 @@ module Provider_interface = struct
   type (_, _, _) Provider.Trait.t +=
     | Directory_reader : ('t, (module S with type t = 't), [> tag ]) Provider.Trait.t
 
+  let () = Provider.Trait.Info.register_name Directory_reader ~name:"Directory_reader"
+
   let make (type t) (module M : S with type t = t) =
     Provider.Handler.make [ Provider.Trait.implement Directory_reader ~impl:(module M) ]
   ;;