Expose Dllist type to allow matchable cursors

Being able to freely point to locations in a double-linked list allows more uses
for a double-linked list.

Author: polytypic

README.md

@@ -1024,7 +1024,12 @@ We can then test that the cache works as expected:
 # let a_cache : (int, string) cache = cache 2
 val a_cache : (int, string) cache =
   {space = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
-   table = <abstr>; order = <abstr>}
+   table = <abstr>;
+   order =
+    Kcas_data.Dllist.List
+     {Kcas_data.Dllist.lhs =
+       Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>};
+      rhs = Kcas.Loc.Loc {Kcas.Loc.state = <poly>; id = <poly>}}}
 
 # Xt.commit { tx = set_blocking a_cache 101 "basics" }
 - : unit = ()

src/kcas_data/dllist.ml

@@ -70,6 +70,9 @@ let create_node_with ~lhs ~rhs value =
   Node { lhs = Loc.make (At lhs); rhs = Loc.make (At rhs); value }
 
 module Xt = struct
+  let get_l ~xt (At at) = Xt.get ~xt (lhs_of at)
+  let get_r ~xt (At at) = Xt.get ~xt (rhs_of at)
+
   let remove ~xt node =
     let (At rhs) = Xt.exchange ~xt (rhs_of node) (At node) in
     if At rhs != At node then begin
@@ -210,6 +213,8 @@ module Xt = struct
   let to_nodes_r ~xt list = to_list_as_r ~xt Fun.id list
 end
 
+let get_l (At at) = Loc.get (lhs_of at)
+let get_r (At at) = Loc.get (rhs_of at)
 let remove node = Kcas.Xt.commit { tx = Xt.remove node }
 let is_empty list = Loc.get (lhs_of list) == At list
 

src/kcas_data/dllist.mli

@@ -33,10 +33,27 @@ open Kcas
 
 (** {1 Common interface} *)
 
-type !'a t
+(** Tagged GADT for doubly-linked lists. *)
+type ('a, _) tdt =
+  | List : {
+      lhs : 'a cursor Loc.t;
+      rhs : 'a cursor Loc.t;
+    }
+      -> ('a, [> `List ]) tdt
+  | Node : {
+      lhs : 'a cursor Loc.t;
+      rhs : 'a cursor Loc.t;
+      value : 'a;
+    }
+      -> ('a, [> `Node ]) tdt
+
+(** Refers to either a {!Node} or to a doubly-linked {!List}. *)
+and 'a cursor = At : ('a, [< `List | `Node ]) tdt -> 'a cursor [@@unboxed]
+
+type 'a t = ('a, [ `List ]) tdt
 (** Type of a doubly-linked list containing {!node}s of type ['a]. *)
 
-type !'a node
+type 'a node = ('a, [ `Node ]) tdt
 (** Type of a node containing a value of type ['a]. *)
 
 val create : unit -> 'a t
@@ -58,6 +75,7 @@ module Xt :
   Dllist_intf.Ops
     with type 'a t := 'a t
     with type 'a node := 'a node
+    with type 'a cursor := 'a cursor
     with type ('x, 'fn) fn := xt:'x Xt.t -> 'fn
     with type ('x, 'fn) blocking_fn := xt:'x Xt.t -> 'fn
 (** Explicit transaction log passing on doubly-linked lists. *)
@@ -68,6 +86,7 @@ include
   Dllist_intf.Ops
     with type 'a t := 'a t
     with type 'a node := 'a node
+    with type 'a cursor := 'a cursor
     with type ('x, 'fn) fn := 'fn
     with type ('x, 'fn) blocking_fn := ?timeoutf:float -> 'fn
 

src/kcas_data/dllist_intf.ml

@@ -1,6 +1,7 @@
 module type Ops = sig
   type 'a t
   type 'a node
+  type 'a cursor
   type ('x, 'fn) fn
   type ('x, 'fn) blocking_fn
 
@@ -95,4 +96,12 @@ module type Ops = sig
 
       {b NOTE}: This operation is linear time, [O(n)], and should typically be
       avoided unless the list is privatized, e.g. by using {!take_all}. *)
+
+  (** {2 Operations on cursors} *)
+
+  val get_l : ('x, 'a cursor -> 'a cursor) fn
+  (** [get_l c] returns the cursor to the left of the current position. *)
+
+  val get_r : ('x, 'a cursor -> 'a cursor) fn
+  (** [get_r c] returns the cursor to the right of the current position. *)
 end

test/kcas_data/dllist_test.ml

@@ -1,5 +1,13 @@
 open Kcas_data
 
+let[@tail_mod_cons] rec to_list get_lr cursor =
+  match get_lr cursor with
+  | Dllist.At (List _) -> []
+  | Dllist.At (Node _ as node) ->
+      Dllist.get node :: to_list get_lr (Dllist.At node)
+
+let to_list get_lr list = to_list get_lr (Dllist.At list)
+
 let[@tail_mod_cons] rec take_as_list take l =
   match take l with None -> [] | Some x -> x :: take_as_list take l
 
@@ -37,7 +45,7 @@ let add () =
   Dllist.add_l 1 l |> ignore;
   Dllist.add_l 3 l |> ignore;
   Dllist.add_r 4 l |> ignore;
-  assert (take_as_list Dllist.take_opt_l l = [ 3; 1; 4 ])
+  assert (to_list Dllist.get_r l = [ 3; 1; 4 ])
 
 let move () =
   let t1 = Dllist.create () in