Source file store_Dict.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
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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
module type S2 = sig
type 'k key
type ('k, 'v) t
type create_params
val trail_params : create_params
val create : create_params -> ('k, 'v) t
(** @raise Not_found *)
val find : ('k, 'v) t -> 'k key -> 'v
val mem : ('k, 'v) t -> 'k key -> bool
val replace : ('k, 'v) t -> 'k key -> 'v -> unit
(** no-op on missing keys *)
val remove : ('k, 'v) t -> 'k key -> unit
val iter : ('k key -> 'v -> unit) -> ('k, 'v) t -> unit
end
module type S = sig
type key
type 'v t
include S2 with type 'k key := key and type ('k, 'v) t := 'v t
end
module Make2 (D : S2) = struct
type 'k key = 'k D.key
type create_params = D.create_params
type 'v action = Add of 'v | Remove
type 'v vtrail = 'v action ref
type ('k, 'v) trail = ('k, 'v vtrail) D.t
let record (_ : ('k, 'v) D.t) =
D.create D.trail_params
let apply t k = function
| Add v -> D.replace t k v
| Remove -> D.remove t k
let rollback t trail =
D.iter (fun k act -> apply t k !act) trail
let append tr1 tr2 =
D.iter (fun k act ->
if not (D.mem tr1 k) then
D.replace tr1 k act
) tr2
let invert t trail =
D.iter (fun k act ->
let anti_act = match D.find t k with
| v -> Add v
| exception Not_found -> Remove
in
apply t k !act;
act := anti_act
) trail
let undo t trail =
invert t trail;
trail
let redo t op trail =
assert (op == trail);
invert t op
let descr : (('k, 'v) D.t, ('k, 'v) trail, ('k, 'v) trail) Store.Custom.descr =
{
record;
append;
rollback;
undo;
redo;
}
type ('k, 'v) t = (('k, 'v) D.t, ('k, 'v) trail) Store.Custom.t
let create (_ : Store.t) params =
Store.Custom.make descr (D.create params)
let replace store dict k v =
let log = Store.Custom.modify store dict in
begin
match D.find log k with
| {contents = Add v'} when v' == v -> D.remove log k
| {contents = (Add _ | Remove)} -> ()
| exception Not_found ->
let act = match D.find (Store.Custom.get dict) k with
| v -> Add v
| exception Not_found -> Remove
in
D.replace log k (ref act)
end;
D.replace (Store.Custom.get dict) k v
let remove store (dict : ('k, 'v) t) k =
let log = Store.Custom.modify store dict in
begin match D.find log k with
| {contents = Remove} -> D.remove log k
| {contents = Add _} -> ()
| exception Not_found ->
match D.find (Store.Custom.get dict) k with
| v ->
D.replace log k (ref (Add v))
| exception Not_found -> ()
end;
D.remove (Store.Custom.get dict) k
let find (_ : Store.t) dict k =
D.find (Store.Custom.get dict) k
let mem (_ : Store.t) dict k : bool =
D.mem (Store.Custom.get dict) k
let iter (_ : Store.t) f dict =
D.iter f (Store.Custom.get dict)
let unsafe_view (_ : Store.t) dict =
Store.Custom.get dict
end
module Make (D : S) = struct
module D' = struct
include (D : S with type create_params = D.create_params
and type key := D.key
and type 'v t := 'v D.t)
type 'k key = D.key
type ('k, 'v) t = 'v D.t
end
include Make2 (D')
type key = D.key
type nonrec 'v t = (unit, 'v) t
end
module Hashtbl = struct
module H = struct
type 'k key = 'k
include Hashtbl
type create_params = { random: bool option; size : int }
let create params = Hashtbl.create ?random:params.random params.size
let trail_params = { random = None; size = 17 }
end
include Make2(H)
let create store ?random size =
create store { random; size }
end