Remove use of Obj.magic and make the library Type-Safe

CHANGES.md

@@ -4,6 +4,7 @@
 
 ### Changed
 
+- Change the API to make the library Type-Safe (breaking change). (#PR, @mbarbin, @v-gb).
 - Register custom trait names instead of extensible variant names (#31, @mbarbin).
 
 ### Deprecated

doc/docs/reference/hello_world.md

@@ -13,12 +13,9 @@ type show = [ `Show ]
 
 module Show : sig
   val t : ('t, (module S with type t = 't), [> show ]) Provider.Trait.t
-end  = struct
-  type (_, _, _) Provider.Trait.t +=
-    | Show : ('t, (module S with type t = 't), [> show ]) Provider.Trait.t
-
-  let t = Show
-end
+end = Provider.Trait.Create (struct
+  type 'a module_type = (module S with type t = 'a)
+end)
 
 let print (Provider.T { t; handler }) =
   let module M = (val Provider.Handler.lookup handler ~trait:Show.t) in

doc/docs/tutorials/getting-started/README.md

@@ -121,19 +121,16 @@ If you are not using opam or dune, we'll assume you're an expert and know what t
 To use Provider, first we have to create a new tag and a new type constructor that will be attached to our `READER` Trait. To do this, we:
 
 - Create a tag type with a polymorphic variant that will be dedicated to our Trait.
-- Add dynamically a new constructor to the `Provider.Trait.t` extensible variant. This uses an OCaml Language Extension named [Extensible variant types](https://ocaml.org/manual/5.2/extensiblevariants.html). This one has the particularity that it is also a [GADT](https://ocaml.org/manual/5.2/gadts.html#start-section)!
+- Create a new trait with one of the `Provider.Trait.Create*` functors.
 
 ```ocaml
 type reader = [ `Reader ]
 
 module Reader : sig
   val t : ('t, (module READER with type t = 't), [> reader ]) Provider.Trait.t
-end = struct
-  type (_, _, _) Provider.Trait.t +=
-    Reader : ('t, (module READER with type t = 't), [> reader ]) Provider.Trait.t
-
-  let t = Reader
-end
+end = Provider.Trait.Create (struct
+  type 't module_type =  (module READER with type t = 't)
+end)
 ```
 
 ### Parametrized Library

doc/docs/tutorials/handler-explicit/README.md

@@ -24,12 +24,9 @@ type id = [ `Id ]
 
 module Id : sig
   val t : ('a, (module Id with type t = 'a), [> id]) Provider.Trait.t
-end = struct
-  type (_, _, _) Provider.Trait.t +=
-    | Id : ('a, (module Id with type t = 'a), [> id]) Provider.Trait.t
-
-  let t = Id
-end
+end = Provider.Trait.Create (struct
+  type 'a module_type = (module Id with type t = 'a)
+end)
 
 let id : type a. (a, [> id]) Provider.Handler.t -> a -> a =
   fun handler x ->
@@ -67,13 +64,9 @@ type doublable = [ `Doublable ]
 
 module Doublable : sig
   val t : ('a, (module Doublable with type t = 'a), [> doublable ]) Provider.Trait.t
-end = struct
-
-  type (_, _, _) Provider.Trait.t +=
-    | Doublable : ('a, (module Doublable with type t = 'a), [> doublable ]) Provider.Trait.t
-
-  let t = Doublable
-end
+end = Provider.Trait.Create (struct
+  type 'a module_type = (module Doublable with type t = 'a)
+end)
 ```
 
 ### Writing Parametrized Code
@@ -152,12 +145,9 @@ type repeatable = [ `Repeatable ]
 
 module Repeatable : sig
   val t : ('a, (module Repeatable with type t = 'a), [> repeatable ]) Provider.Trait.t
-end = struct
-  type (_, _, _) Provider.Trait.t +=
-    | Repeatable : ('a, (module Repeatable with type t = 'a), [> repeatable ]) Provider.Trait.t
-
-  let t = Repeatable
-end
+end = Provider.Trait.Create (struct
+  type 'a module_type = (module Repeatable with type t = 'a)
+end)
 ```
 
 ### Writing Parametrized Code
@@ -268,12 +258,9 @@ Note, you cannot write this (the `'a 't` syntax doesn't mean anything):
 ```ocaml
 module Mappable : sig
   val t : ('a 't, (module Mappable with type 'a t = 'a 't), [> mappable ]) Provider.Trait.t
-end = struct
-  type (_, _, _) Provider.Trait.t +=
-    | Mappable : ('a 't, (module Mappable with type 'a t = 'a 't), [> mappable ]) Provider.Trait.t
-
-  let t = Mappable
-end
+end = Provider.Trait.Create (struct
+  type 'a 't module_type =  (module Mappable with type 'a t = 'a 't)
+end)
 ```
 ```mdx-error
 Line 2, characters 17-18:
@@ -285,20 +272,14 @@ This is where `Higher_kinded` comes to the rescue:
 ```ocaml
 module Mappable : sig
   val t :
-       ( ('a -> 'higher_kinded) Higher_kinded.t
-          , (module Mappable with type higher_kinded = 'higher_kinded)
-          , [> mappable ] )
-          Provider.Trait.t
-end = struct
-  type (_, _, _) Provider.Trait.t +=
-    | Mappable :
-        ( ('a -> 'higher_kinded) Higher_kinded.t
-          , (module Mappable with type higher_kinded = 'higher_kinded)
-          , [> mappable ] )
-          Provider.Trait.t
-
-  let t = Mappable
-end
+      ( ('a -> 'higher_kinded) Higher_kinded.t
+        , (module Mappable with type higher_kinded = 'higher_kinded)
+        , [> mappable ] )
+        Provider.Trait.t
+end = Provider.Trait.Create1 (struct
+  type (!'higher_kinded, 'a) t = ('a -> 'higher_kinded) Higher_kinded.t
+  type 'higher_kinded module_type = (module Mappable with type higher_kinded = 'higher_kinded)
+end)
 ```
 
 ### Writing Parametrized Code

src/provider.ml

@@ -9,10 +9,14 @@ let () =
 ;;
 
 let raise_s msg sexp = raise (E (Sexp.List [ Atom msg; sexp ]))
-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 = ..
+  type ('t, 'module_type, 'tag) t = ('t, 'module_type, 'tag) Trait0.t
+
+  module Create = Trait0.Create
+  module Create0 = Trait0.Create0
+  module Create1 = Trait0.Create1
+  module Create2 = Trait0.Create2
 
   let runtime_trait_info = Runtime_trait_info.default
 
@@ -52,44 +56,10 @@ module Trait = struct
     let seeded_hash = Int.seeded_hash
   end
 
-  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
-
-  let check_trait_exn (t : _ t) =
-    if not (Trait0.is_valid t)
-    then
-      raise_s
-        "Invalid usage of [Provider.Trait]: trait is not a valid extensible variant for \
-         this library"
-        (Sexp.List [ List [ Atom "trait"; info t |> Info.sexp_of_t ] ])
-  ;;
-
-  let implement trait ~impl =
-    check_trait_exn trait;
-    Binding0.implement trait ~impl
-  ;;
-
-  module Unsafe_cast : sig
-    type (_, _) eq_opt =
-      | Equal : ('a, 'a) eq_opt
-      | Not_equal : ('a, 'b) eq_opt
-
-    (* We limit unsafe casting to cases where the first parameter is already
-       determined to be the same. *)
-    val same_witness : ('a, 'i1, _) t -> ('a, 'i2, _) t -> ('i1, 'i2) eq_opt
-  end = struct
-    type (_, _) eq_opt =
-      | Equal : ('a, 'a) eq_opt
-      | Not_equal : ('a, 'b) eq_opt
-
-    let same_witness : type a i1 i2. (a, i1, _) t -> (a, i2, _) t -> (i1, i2) eq_opt =
-      fun t1 t2 ->
-      if same t1 t2
-      then (Obj.magic (Obj.repr (Equal : _ eq_opt)) : (i1, i2) eq_opt)
-      else Not_equal
-    ;;
-  end
+  let uid = Trait0.uid
+  let compare_by_uid t1 t2 = Uid.compare (uid t1) (uid t2)
+  let same = Trait0.same
+  let implement = Binding0.implement
 end
 
 module Binding = struct
@@ -178,19 +148,16 @@ module Handler = struct
       | Greater ->
         binary_search t ~trait ~update_cache ~if_not_found ~if_found ~from ~to_:(mid - 1)
       | Equal ->
-        (match Trait.Unsafe_cast.same_witness elt trait with
+        (match Trait0.same_witness elt trait with
          | Equal ->
            if update_cache then t.(0) <- binding;
            if_found implementation
          | Not_equal ->
-           (* [same_witness a b => (uid a = uid b)] but the converse might not
-              hold. We treat as invalid usages cases where traits (t1, t2) would
-              have the same uids without being physically equal. *)
-           raise_s
-             "Invalid usage of [Provider.Trait]: Extensible variants with the same id \
-              are expected to be physically equal through the use of this library"
-             (Sexp.List
-                [ List [ Atom "trait"; Trait.info trait |> Trait.Info.sexp_of_t ] ])))
+           (* Because [Trait0.t] is abstract, traits are necessarily created
+              through the [Trait0.Create*] functors, which only create 0-arg [T]
+              extensible variants. As a result, for all traits (a, b) the
+              following holds: [(uid a = uid b) => phys_equal a b]. *)
+           assert false))
   ;;
 
   let make_lookup
@@ -207,7 +174,7 @@ module Handler = struct
     then if_not_found ~trait_info:(Trait.info trait)
     else (
       let (Binding.T { trait = cached_id; implementation }) = t.(0) in
-      match Trait.Unsafe_cast.same_witness trait cached_id with
+      match Trait0.same_witness trait cached_id with
       | Equal -> if_found implementation
       | Not_equal ->
         binary_search
@@ -270,13 +237,6 @@ type -'tags t =
 
 module Private = struct
   module Import = Import
-
-  module Trait = struct
-    let implement_unsafe trait ~impl ~check_trait =
-      if check_trait then Trait.check_trait_exn trait;
-      Binding0.implement trait ~impl
-    ;;
-  end
-
   module Handler = Handler
+  module Trait0 = Trait0
 end

src/provider.mli

@@ -23,16 +23,65 @@ module Trait : sig
 
       - ['t] is the internal state of the provider itself.
       - ['module_type] is the signature of a module implementing the Trait.
-      - ['tag] is the tag (or tags) indicating the supported Trait. It's a
-        phantom type designed to make {!val:Handler.lookup} more type-safe.
+      - ['tag] is the tag (or tags) indicating the supported Trait(s). It's a
+        phantom type designed to help using {!val:Handler.lookup} correctly.
 
-      ['module_type] is expected to be a module type (Eio supports single
-      functions but this is discouraged through the use of this library).
+      ['module_type] is typically expected to be a module type, but it doesn't
+      have too (functions, constants are fine too, etc.). *)
+  type ('t, 'module_type, 'tag) t = ('t, 'module_type, 'tag) Trait0.t
 
-      Beware, traits constructors must be such that they are physically equal
-      when they have the same extension id. In particular they should have zero
-      arguments. *)
-  type ('t, 'module_type, 'tag) t = ('t, 'module_type, 'tag) Trait0.t = ..
+  (** {1 Creating traits}
+
+      Traits are abstract and must be created using the following functors. The
+      most common one is {!module:Create}. It is to be used when the trait is
+      defined by a module type with a single type t. For example:
+
+      {[
+        module type Show = sig
+          type t
+
+          val show : t -> string
+        end
+
+        module Show : sig
+          val t : ('a, (module Show with type t = 'a), [> `Show ]) Provider.Trait.t
+        end = Provider.Trait.Create (struct
+            type 'a module_type = (module Show with type t = 'a)
+          end)
+      ]}
+
+      The other functors are reserved for less common cases. The number suffix
+      indicates the number of parameters of the [module_type] type, each of
+      which must be present and injective in [X.t]. We added one extra parameter
+      to [X.t] to allow for more flexibility in what can be expressed, but not
+      all parameters have to be used. *)
+
+  module Create (X : sig
+      type 'a module_type
+    end) : sig
+    val t : ('a, 'a X.module_type, _) t
+  end
+
+  module Create0 (X : sig
+      type 'a t
+      type module_type
+    end) : sig
+    val t : ('a X.t, X.module_type, _) t
+  end
+
+  module Create1 (X : sig
+      type (!'a, 'b) t
+      type 'a module_type
+    end) : sig
+    val t : (('a, 'b) X.t, 'a X.module_type, _) t
+  end
+
+  module Create2 (X : sig
+      type (!'a, !'b, 'c) t
+      type ('a, 'b) module_type
+    end) : sig
+    val t : (('a, 'b, 'c) X.t, ('a, 'b) X.module_type, _) t
+  end
 
   (** {1 Dump & debug} *)
 
@@ -246,19 +295,6 @@ module Private : sig
     val dedup_sorted_keep_last : 'a list -> compare:('a -> 'a -> int) -> 'a list
   end
 
-  module Trait : sig
-    (** Some error cases of the implementation have been made non-reachable
-        thanks to additional checks run early. However, we'd like to cover
-        these cases in tests, thus this constructor is exposed to optionally
-        bypass the trait validation happening during [implement]. To be used
-        by tests only, do not use in user code. *)
-    val implement_unsafe
-      :  ('t, 'module_type, _) Trait.t
-      -> impl:'module_type
-      -> check_trait:bool
-      -> 't Binding.t
-  end
-
   module Import : sig
     (** Exported things from the import module we'd like to test separately. *)
 
@@ -275,4 +311,6 @@ module Private : sig
       val of_int : int -> t
     end
   end
+
+  module Trait0 = Trait0
 end