← Back to branch summary

~ubuntu-branches/ubuntu/vivid/typerep/vivid

« back to all changes in this revision

Viewing changes to lib/typename.ml

  • Committer: Package Import Robot
  • Author(s): Hilko Bengen
  • Date: 2014-09-24 23:51:02 UTC
  • Revision ID: package-import@ubuntu.com-20140924235102-0qeq851f02otnnxp
Tags: upstream-111.17.00
Import upstream version 111.17.00

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/typename.ml
 
1
(* this lib should not depend on core *)
 
2
module List = struct
 
3
  include List
 
4
  let compare a b ~cmp =
 
5
    let rec loop a b =
 
6
      match a, b with
 
7
      | [], [] -> 0
 
8
      | [], _  -> -1
 
9
      | _ , [] -> 1
 
10
      | x :: xs, y :: ys ->
 
11
        let n = cmp x y in
 
12
        if n = 0 then loop xs ys
 
13
        else n
 
14
    in
 
15
    loop a b
 
16
end
 
17
 
 
18
module Uid : sig
 
19
  type t
 
20
  val compare : t -> t -> int
 
21
  val equal : t -> t -> bool
 
22
  val next : string -> t
 
23
  val hash : t -> int
 
24
  val name : t -> string
 
25
  val static : t
 
26
end = struct
 
27
  type t = {
 
28
    code : int;
 
29
    name : string;
 
30
  }
 
31
  let compare a b = Pervasives.compare (a.code : int) b.code
 
32
  let equal a b = Pervasives.(=) (a.code : int) b.code
 
33
  let uid = ref 0
 
34
  let next name = let code = !uid in incr uid; {code; name}
 
35
  let hash a = Hashtbl.hash a.code
 
36
  let name a = a.name
 
37
  let static = next "static"
 
38
end
 
39
 
 
40
module Key = struct
 
41
  type t = {
 
42
    uid : Uid.t;
 
43
    params : t list;
 
44
  }
 
45
  let rec compare k1 k2 =
 
46
    if k1 == k2 then 0 else
 
47
    let cmp = Uid.compare k1.uid k2.uid in
 
48
    if cmp <> 0 then cmp else
 
49
      List.compare ~cmp:compare k1.params k2.params
 
50
  let equal a b = compare a b = 0
 
51
  let hash = (Hashtbl.hash : t -> int)
 
52
  let static = { uid = Uid.static ; params = [] }
 
53
end
 
54
 
 
55
type 'a t = Key.t
 
56
type 'a typename = 'a t
 
57
 
 
58
let key t = t
 
59
let uid t = t.Key.uid
 
60
let name t = Uid.name t.Key.uid
 
61
let static = Key.static
 
62
 
 
63
let create ?(name="Typename.create") () = { Key.uid = Uid.next name ; params = [] }
 
64
 
 
65
include struct
 
66
  (* The argument for Obj.magic here is the same as the one in core/type_equal *)
 
67
 
 
68
  let same (type a) (type b) (nm1 : a t) (nm2 : b t) = Key.compare nm1 nm2 = 0
 
69
 
 
70
  let same_witness (type a) (type b) (nm1 : a t) (nm2 : b t) =
 
71
    if Key.compare nm1 nm2 = 0
 
72
    then Some (Obj.magic Type_equal.refl : (a, b) Type_equal.t)
 
73
    else None
 
74
 
 
75
  let same_witness_exn (type a) (type b) (nm1 : a t) (nm2 : b t) =
 
76
    if Key.compare nm1 nm2 = 0
 
77
    then (Obj.magic Type_equal.refl : (a, b) Type_equal.t)
 
78
    else failwith "Typename.same_witness_exn"
 
79
 
 
80
end
 
81
 
 
82
module type S0 = sig
 
83
  type t
 
84
  val typename_of_t : t typename
 
85
end
 
86
 
 
87
module type S1 = sig
 
88
  type 'a t
 
89
  val typename_of_t : 'a typename -> 'a t typename
 
90
end
 
91
 
 
92
module type S2 = sig
 
93
  type ('a, 'b) t
 
94
  val typename_of_t :
 
95
    'a typename
 
96
    -> 'b typename
 
97
    -> ('a, 'b) t typename
 
98
end
 
99
 
 
100
module type S3 = sig
 
101
  type ('a, 'b, 'c) t
 
102
  val typename_of_t :
 
103
    'a typename
 
104
    -> 'b typename
 
105
    -> 'c typename
 
106
    -> ('a, 'b, 'c) t typename
 
107
end
 
108
 
 
109
module type S4 = sig
 
110
  type ('a, 'b, 'c, 'd) t
 
111
  val typename_of_t :
 
112
    'a typename
 
113
    -> 'b typename
 
114
    -> 'c typename
 
115
    -> 'd typename
 
116
    -> ('a, 'b, 'c, 'd) t typename
 
117
end
 
118
 
 
119
module type S5 = sig
 
120
  type ('a, 'b, 'c, 'd, 'e) t
 
121
  val typename_of_t :
 
122
    'a typename
 
123
    -> 'b typename
 
124
    -> 'c typename
 
125
    -> 'd typename
 
126
    -> 'e typename
 
127
    -> ('a, 'b, 'c, 'd, 'e) t typename
 
128
end
 
129
 
 
130
module Make0 (X : Named_intf.S0) = struct
 
131
  let uid = Uid.next X.name
 
132
  let typename_of_t = { Key.uid ; params = [] }
 
133
end
 
134
 
 
135
module Make1 (X : Named_intf.S1) = struct
 
136
  let uid = Uid.next X.name
 
137
  let typename_of_t a = { Key.uid ; params = [ a ] }
 
138
end
 
139
 
 
140
module Make2 (X : Named_intf.S2) = struct
 
141
  let uid = Uid.next X.name
 
142
  let typename_of_t a b = { Key.uid ; params = [ a ; b ] }
 
143
end
 
144
 
 
145
module Make3 (X : Named_intf.S3) = struct
 
146
  let uid = Uid.next X.name
 
147
  let typename_of_t a b c = { Key.uid ; params = [ a ; b ; c ] }
 
148
end
 
149
 
 
150
module Make4 (X : Named_intf.S4) = struct
 
151
  let uid = Uid.next X.name
 
152
  let typename_of_t a b c d = { Key.uid ; params = [ a ; b ; c ; d ] }
 
153
end
 
154
 
 
155
module Make5 (X : Named_intf.S5) = struct
 
156
  let uid = Uid.next X.name
 
157
  let typename_of_t a b c d e = { Key.uid ; params = [ a ; b ; c ; d ; e ] }
 
158
end
 
159
 
 
160
module Key_table = Hashtbl.Make (Key)
 
161
 
 
162
module Table (X : sig
 
163
  type 'a t
 
164
end) = struct
 
165
 
 
166
  type data = Data : 'a t * 'a X.t -> data
 
167
  type t = data Key_table.t
 
168
 
 
169
  let create int = Key_table.create int
 
170
 
 
171
  let mem table name = Key_table.mem table (key name)
 
172
 
 
173
  let set table name data =
 
174
    Key_table.replace table (key name) (Data (name, data))
 
175
 
 
176
  let find (type a) table (name : a typename) =
 
177
    let data =
 
178
      try Some (Key_table.find table (key name))
 
179
      with Not_found -> None
 
180
    in
 
181
    match data with
 
182
    | None -> None
 
183
    | Some (Data (name', data)) ->
 
184
      (fun (type b) (name' : b typename) (data : b X.t) ->
 
185
        let Type_equal.T = (same_witness_exn name' name : (b, a) Type_equal.t) in
 
186
        Some (data : a X.t)
 
187
      ) name' data
 
188
end
 
189
 
 
190
let fail uid_a uid_b =
 
191
  let msg =
 
192
    Printf.sprintf "Typename.Same_witness_exn %S %S" (Uid.name uid_a) (Uid.name uid_b)
 
193
  in
 
194
  failwith msg
 
195
 
 
196
module Same_witness_exn_1 (A : S1) (B : S1) = struct
 
197
  type t = { eq : 'a. ('a A.t, 'a B.t) Type_equal.t }
 
198
 
 
199
  let witness =
 
200
    let uid_a = uid (A.typename_of_t static) in
 
201
    let uid_b = uid (B.typename_of_t static) in
 
202
    if Uid.equal uid_a uid_b
 
203
    then { eq = Obj.magic Type_equal.refl }
 
204
    else fail uid_a uid_b
 
205
end
 
206
 
 
207
module Same_witness_exn_2 (A : S2) (B : S2) = struct
 
208
  type t = {
 
209
    eq : 'a 'b. ( ('a, 'b) A.t,
 
210
                  ('a, 'b) B.t ) Type_equal.t
 
211
  }
 
212
 
 
213
  let witness =
 
214
    let uid_a = uid (A.typename_of_t static static) in
 
215
    let uid_b = uid (B.typename_of_t static static) in
 
216
    if Uid.equal uid_a uid_b
 
217
    then { eq = Obj.magic Type_equal.refl }
 
218
    else fail uid_a uid_b
 
219
end
 
220
 
 
221
module Same_witness_exn_3 (A : S3) (B : S3) = struct
 
222
  type t = {
 
223
    eq : 'a 'b 'c. ( ('a, 'b, 'c) A.t,
 
224
                     ('a, 'b, 'c) B.t ) Type_equal.t
 
225
  }
 
226
 
 
227
  let witness =
 
228
    let uid_a = uid (A.typename_of_t static static static) in
 
229
    let uid_b = uid (B.typename_of_t static static static) in
 
230
    if Uid.equal uid_a uid_b
 
231
    then { eq = Obj.magic Type_equal.refl }
 
232
    else fail uid_a uid_b
 
233
end
 
234
 
 
235
module Same_witness_exn_4 (A : S4) (B : S4) = struct
 
236
  type t = {
 
237
    eq : 'a 'b 'c 'd. ( ('a, 'b, 'c, 'd) A.t,
 
238
                        ('a, 'b, 'c, 'd) B.t ) Type_equal.t
 
239
  }
 
240
 
 
241
  let witness =
 
242
    let uid_a = uid (A.typename_of_t static static static static) in
 
243
    let uid_b = uid (B.typename_of_t static static static static) in
 
244
    if Uid.equal uid_a uid_b
 
245
    then { eq = Obj.magic Type_equal.refl }
 
246
    else fail uid_a uid_b
 
247
end
 
248
 
 
249
module Same_witness_exn_5 (A : S5) (B : S5) = struct
 
250
  type t = {
 
251
    eq : 'a 'b 'c 'd 'e. ( ('a, 'b, 'c, 'd, 'e) A.t,
 
252
                           ('a, 'b, 'c, 'd, 'e) B.t ) Type_equal.t
 
253
  }
 
254
 
 
255
  let witness =
 
256
    let uid_a = uid (A.typename_of_t static static static static static) in
 
257
    let uid_b = uid (B.typename_of_t static static static static static) in
 
258
    if Uid.equal uid_a uid_b
 
259
    then { eq = Obj.magic Type_equal.refl }
 
260
    else fail uid_a uid_b
 
261
end