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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
module type S = Univ_map_intf.S
module Make
(Info : sig
type 'a t
end)
() =
struct
module Key = struct
type 'a info = 'a Info.t
module Witness = struct
type 'a t = ..
end
module type T = sig
type t
type 'a Witness.t += T : t Witness.t
val id : int
val info : t Info.t
end
type 'a t = (module T with type t = 'a)
let next = ref 0
let create (type a) info =
let n = !next in
next := n + 1;
let module M = struct
type t = a
type 'a Witness.t += T : t Witness.t
let id = n
let info = info
end
in
(module M : T with type t = a)
;;
let id (type a) (module M : T with type t = a) = M.id
let eq (type a b) (module A : T with type t = a) (module B : T with type t = b)
: (a, b) Type_eq.t
=
match A.T with
| B.T -> Type_eq.T
| _ -> assert false
;;
end
module Binding = struct
type t = T : 'a Key.t * 'a -> t
end
type t = Binding.t Int.Map.t
let empty = Int.Map.empty
let is_empty = Int.Map.is_empty
let set (type a) t (key : a Key.t) x =
let (module M) = key in
let data = Binding.T (key, x) in
Int.Map.set t M.id data
;;
let add (type a) t (key : a Key.t) (x : a) : (t, a) Result.t =
let (module M) = key in
let data = Binding.T (key, x) in
match Int.Map.add t M.id data with
| Ok x -> Ok x
| Error (Binding.T (key', x)) ->
let eq = Key.eq key' key in
Error (Type_eq.cast eq x)
;;
let update (type a) t (key : a Key.t) ~f =
let (module M) = key in
Int.Map.update t M.id ~f:(function
| None -> f None |> Option.map ~f:(fun x -> Binding.T (key, x))
| Some (Binding.T (key', x)) ->
let eq = Key.eq key' key in
let x = Type_eq.cast eq x in
f (Some x) |> Option.map ~f:(fun x -> Binding.T (key, x)))
;;
let mem t key = Int.Map.mem t (Key.id key)
let remove t key = Int.Map.remove t (Key.id key)
let find t key =
match Int.Map.find t (Key.id key) with
| None -> None
| Some (Binding.T (key', v)) ->
let eq = Key.eq key' key in
Some (Type_eq.cast eq v)
;;
let find_exn t key =
match Int.Map.find t (Key.id key) with
| None -> failwith "Univ_map.find_exn"
| Some (Binding.T (key', v)) ->
let eq = Key.eq key' key in
Type_eq.cast eq v
;;
let singleton key v = Int.Map.singleton (Key.id key) (Binding.T (key, v))
let superpose = Int.Map.superpose
type 'acc fold = { fold : 'a. 'a Info.t -> 'a -> 'acc -> 'acc }
let fold (t : t) ~init ~f =
Int.Map.fold t ~init ~f:(fun (Binding.T (key, v)) acc ->
let (module K) = key in
f.fold K.info v acc)
;;
end
module Info = struct
type 'a t =
{ name : string
; to_dyn : 'a -> Dyn.t
}
end
module T = Make (Info) ()
module Key = struct
include T.Key
type 'a info = 'a Info.t
let create ~name to_dyn = create { Info.to_dyn; name }
end
include (T : S with type t = T.t and module Key := Key)
let to_dyn t =
Dyn.Map
(let f =
{ T.fold = (fun info a acc -> (Dyn.string info.name, info.to_dyn a) :: acc) }
in
T.fold t ~init:[] ~f)
;;