1 (* This module is used by the [hashtable] module, but could also be useful
  2    per se. It offers mutable lists of key-value pairs. *)
  3 
  4 (* -------------------------------------------------------------------------- *)
  5 
  6 (* A bucket is a mutable list of entries. Each entry holds a key and a value. *)
  7 
  8 mutable data bucket k a =
  9   | BNil
 10   | BCons { key: k; value: a; tail: bucket k a }
 11 
 12 (* -------------------------------------------------------------------------- *)
 13 
 14 (* Search. *)
 15 
 16 val rec mem [k, a] (
 17   equal: (k, k) -> bool,
 18   x: k,
 19   b: bucket k a
 20 ) : bool =
 21   match b with
 22   | BNil ->
 23       false
 24   | BCons { key; tail } ->
 25       (* TEMPORARY could use || *)
 26       if equal (x, key) then true else mem (equal, x, tail)
 27   end
 28 
 29 val rec assoc [k, a, p : perm] duplicable a => (
 30   equal: (k, k | p) -> bool,
 31   x: k,
 32   b: bucket k a
 33   | p
 34 ) : option a =
 35   match b with
 36   | BNil ->
 37       none
 38   | BCons { key; value; tail } ->
 39       if equal (x, key) then some value else assoc (equal, x, tail)
 40   end
 41 
 42 val rec assoc_all [k, a, p : perm] duplicable a => (
 43   equal: (k, k | p) -> bool,
 44   x: k,
 45   b: bucket k a
 46   | p
 47 ) : list::list a =
 48   match b with
 49   | BNil ->
 50       list::nil
 51   | BCons { key; value; tail } ->
 52       if equal (x, key) then list::cons (value, assoc_all (equal, x, tail)) else assoc_all (equal, x, tail)
 53   end
 54 
 55 (* -------------------------------------------------------------------------- *)
 56 
 57 (* Removal of a cell. *)
 58 
 59 (* [remove (b, ok)] looks for the first cell whose key satisfies the predicate
 60    [ok] and (if it finds one) removes it. It returns a pair of the new list
 61    head and the value that was found, if one was found. *)
 62 
 63 val remove [k, a, p : perm] (
 64   consumes b: bucket k a,
 65   ok: (k | p) -> bool
 66   | p
 67 ) : (bucket k a, option a) =
 68 
 69   (* Write a loop that works over two consecutive cells. We work under the
 70      assumption that [prev] does not satisfy [ok], so it remains the list
 71      head after the removal. The loop returns the value that was found, if
 72      one was found. *)
 73   let rec loop (
 74     consumes prev: BCons { key: k; value: a; tail = this },
 75     consumes this: bucket k a
 76   | p) : (option a | prev @ bucket k a) =
 77     match this with
 78     | BNil ->
 79         none
 80     | BCons { key; value } ->
 81         if ok key then begin
 82           prev.tail <- this.tail;
 83           some value
 84         end
 85         else
 86           loop (this, this.tail)
 87     end
 88   in
 89 
 90   match b with
 91   | BNil ->
 92       (* If the list is empty, return it. *)
 93       b, none
 94   | BCons { key; value } ->
 95       if ok key then
 96         (* If the first cell matches, return the list tail. *)
 97         b.tail, some value
 98       else
 99         (* Otherwise, enter the above loop, and return the list head. *)
100         b, loop (b, b.tail)
101   end
102 
103 (* -------------------------------------------------------------------------- *)
104 
105 (* The following two functions serve in the definition of [update] below. *)
106 
107 (* Optional insertion. *)
108 
109 val insert [k, a] (
110   consumes x: k,
111   consumes ov: option a,
112   consumes b: bucket k a
113 ) : bucket k a =
114   (* There is a merge warning here; this is because we're actually merging [ov]
115    * into [option unknown]. Indeed, we first perform a subtraction (when the
116    * context provides a type annotation), and then we try to merge the remaining
117    * pieces. This allows the user to provide partial hints for merge situations.
118    * *)
119   match ov with
120   | None ->
121       b
122   | Some { contents = v } ->
123       BCons { key = x; value = v; tail = b }
124   end
125 
126 (* Update or removal of the list head. *)
127 
128 val update_or_remove [k, a] (
129   consumes b: BCons { key: k; value: unknown; tail: bucket k a },
130   consumes ov: option a
131 ) : bucket k a =
132   match ov with
133   | None ->
134       b.tail
135   | Some { contents = v } ->
136       b.value <- v;
137       b
138   end
139 
140 (* -------------------------------------------------------------------------- *)
141 
142 (* Update. *)
143 
144 (* [update (equal, b, x, f)] looks for an entry whose key is [equal] to [x]
145    in the bucket [b]. It calls the user-supplied function [f] exactly once,
146    and passes it either the value [v] that is associated with the key [x],
147    or nothing, if the key [x] does not appear in the bucket. The function
148    [f] returns either a new value, or nothing. In the former case, the new
149    value replaces the value [v]. In the latter case, the key [x] is removed
150    (if it was there at all). An updated bucket is returned. *)
151 
152 val update [k, a, pre : perm, post : perm] (
153   equal: (k, k) -> bool,
154   consumes b: bucket k a,
155   consumes x: k,
156   f: (consumes (option a | pre)) -> (option a | post)
157   | consumes pre
158 ) : (bucket k a | post) =
159 
160   (* Write a loop that works over two consecutive cells. We work under the
161      assumption that [prev] does not satisfy [ok], so it remains the list
162      head after the loop. *)
163   let rec loop (
164     consumes prev: BCons { key: k; value: a; tail = this },
165     consumes this: bucket k a
166   | consumes x @ k * consumes pre
167   ) : (| prev @ bucket k a | post) =
168     match this with
169     | BNil ->
170         (* The desired key was not found. Invoke [f] with argument [none]. *)
171         prev.tail <- insert (x, f none, this)
172     | BCons { key; value } ->
173         if equal (x, key) then
174           (* The desired key was found. Invoke [f] with argument [some value]. *)
175           prev.tail <- update_or_remove (this, f (some value))
176         else
177           loop (this, this.tail)
178     end
179   in
180 
181   match b with
182   | BNil ->
183       (* The desired key was not found. Invoke [f] with argument [none]. *)
184       insert (x, f none, b)
185   | BCons { key; value } ->
186       if equal (x, key) then
187         (* The desired key was found. Invoke [f] with argument [some value]. *)
188         update_or_remove (b, f (some value))
189       else begin
190         (* Otherwise, enter the above loop. The list head does not change. *)
191         loop (b, b.tail);
192         b
193       end
194   end
195 
196 (* -------------------------------------------------------------------------- *)
197 
198 (* Iteration. *)
199 
200 (* Non-destructive iteration over the elements of a bucket. *)
201 
202 (* For simplicity, we assign [fold] a type that does not allow performing
203    a strong update on the keys or values. A more general type exists. *)
204 
205 val rec fold [k, a, b] (
206   this: bucket k a,
207   consumes accu: b,
208   f: (k, a, consumes b) -> b
209 ) : b =
210   match this with
211   | BNil ->
212       accu
213   | BCons { key; value; tail } ->
214       fold (tail, f (key, value, accu), f)
215   end
216 
217 (* -------------------------------------------------------------------------- *)
218 
219 (* Destructive iteration over the cells of a bucket. Each cell is presented in
220    turn to the function [f]. Note that the cells that are presented to [f] are
221    detached, i.e., their [tail] field is garbage. *)
222 
223 val rec iter_bucket_down [k, a, p : perm] (
224   consumes b: bucket k a,
225   f: (consumes b: BCons { key: k; value: a; tail: unknown } | p) -> ()
226   | p
227 ) : () =
228   match b with
229   | BNil ->
230       ()
231   | BCons ->
232       (* Iteration from the end down to the beginning of the list. *)
233       iter_bucket_down (b.tail, f);
234       f b
235   end
236 
237 (* -------------------------------------------------------------------------- *)
238 
239 (* Length. *)
240 
241 val length [k, a] (b: bucket k a) : int =
242   let rec loop (b: bucket k a, accu: int) : int =
243     match b with
244     | BNil ->
245         accu
246     | BCons ->
247         loop (b.tail, accu + 1)
248     end
249   in
250   loop (b, 0)
251 
252 (*
253 Local Variables:
254 compile-command: "../mezzo bucket.mz"
255 End:
256 *)