package provider

  1. Overview
  2. Docs

Source file trait0.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
open! Import

type ('t, 'module_type) ext = ..

type ('t, 'module_type, 'tag) t =
  { ext : ('t, 'module_type) ext
  ; same_witness : 'm2. ('t, 'm2) ext -> ('module_type, 'm2) Type_eq_opt.t
  }

let uid (t : _ t) = Obj.Extension_constructor.id (Obj.Extension_constructor.of_val t.ext)

let same_witness : ('t, 'mt1, _) t -> ('t, 'mt2, _) t -> ('mt1, 'mt2) Type_eq_opt.t =
  fun t1 t2 -> t1.same_witness t2.ext
;;

let same (t1 : _ t) (t2 : _ t) = phys_equal (Obj.repr t1) (Obj.repr t2)

module Create0 (X : sig
    type 'a t
    type module_type
  end) =
struct
  type (_, _) ext += T : ('a X.t, X.module_type) ext

  let same_witness (type a m2) t2 : (X.module_type, m2) Type_eq_opt.t =
    match (t2 : (a X.t, m2) ext) with
    | T -> Type_eq_opt.Equal
    | _ -> Not_equal
  ;;

  let t = { ext = T; same_witness }
end

module Create1 (X : sig
    type (!'a, 'b) t
    type 'a module_type
  end) =
struct
  type (_, _) ext += T : (('a, 'b) X.t, 'a X.module_type) ext

  let same_witness (type a b m2) t2 : (a X.module_type, m2) Type_eq_opt.t =
    match (t2 : ((a, b) X.t, m2) ext) with
    | T -> Type_eq_opt.Equal
    | _ -> Not_equal
  ;;

  let t = { ext = T; same_witness }
end

module Create2 (X : sig
    type (!'a, !'b, 'c) t
    type ('a, 'b) module_type
  end) =
struct
  type (_, _) ext += T : (('a, 'b, 'c) X.t, ('a, 'b) X.module_type) ext

  let same_witness (type a b c m2) t2 : ((a, b) X.module_type, m2) Type_eq_opt.t =
    match (t2 : ((a, b, c) X.t, m2) ext) with
    | T -> Type_eq_opt.Equal
    | _ -> Not_equal
  ;;

  let t = { ext = T; same_witness }
end

module Create (X : sig
    type 'a module_type
  end) =
Create1 (struct
    type (!'a, _) t = 'a
    type 'a module_type = 'a X.module_type
  end)