From 484941c3ce818f188e48ce142e4e7335328e368b Mon Sep 17 00:00:00 2001
From: tali <iitalics@gmail.com>
Date: Wed, 31 Jan 2024 16:02:40 -0500
Subject: [PATCH] vendored lwt-dllist, moved data structures to separate
 library

---
 lib/{server => data}/cache.ml      |   4 --
 lib/data/dllist.ml                 | 101 +++++++++++++++++++++++++++++
 lib/data/dllist.mli                |  66 +++++++++++++++++++
 lib/data/dune                      |   5 ++
 lib/data/list.ml                   |  21 ++++++
 lib/{server => data}/test_cache.ml |   0
 lib/{server => data}/test_list.ml  |   2 -
 lib/{server => data}/test_wheel.ml |   0
 lib/{server => data}/wheel.ml      |   6 +-
 lib/server/dune                    |   4 +-
 lib/server/import.ml               |  26 +-------
 lib/server/outbox.ml               |   2 +-
 lib/server/router.ml               |   4 +-
 lib/server/user.ml                 |  17 ++---
 14 files changed, 205 insertions(+), 53 deletions(-)
 rename lib/{server => data}/cache.ml (94%)
 create mode 100644 lib/data/dllist.ml
 create mode 100644 lib/data/dllist.mli
 create mode 100644 lib/data/dune
 create mode 100644 lib/data/list.ml
 rename lib/{server => data}/test_cache.ml (100%)
 rename lib/{server => data}/test_list.ml (98%)
 rename lib/{server => data}/test_wheel.ml (100%)
 rename lib/{server => data}/wheel.ml (81%)

diff --git a/lib/server/cache.ml b/lib/data/cache.ml
similarity index 94%
rename from lib/server/cache.ml
rename to lib/data/cache.ml
index 753a6fb..1ab159e 100644
--- a/lib/server/cache.ml
+++ b/lib/data/cache.ml
@@ -1,7 +1,3 @@
-open! Import
-
-include (val Logging.sublogs logger "Wheel")
-
 type ('k, 'v) t = {
   mutable index : int;
   entries : ('k, 'v) entry array;
diff --git a/lib/data/dllist.ml b/lib/data/dllist.ml
new file mode 100644
index 0000000..7941f83
--- /dev/null
+++ b/lib/data/dllist.ml
@@ -0,0 +1,101 @@
+(* This file was originally part of lwt-dllist, which is licensed
+   under MIT: https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+type 'a t = {
+  mutable prev : 'a t;
+  mutable next : 'a t;
+}
+
+type 'a node = {
+  mutable node_prev : 'a t;
+  mutable node_next : 'a t;
+  mutable node_active : bool;
+  node_data : 'a;
+}
+(* XXX: technically [.node_next]/[.node_prev] *are* mutated in [remove] but they are [Obj.magic]'d
+   into ['a t] first.*)
+[@@warning "-69"]
+
+external seq_of_node : 'a node -> 'a t = "%identity"
+external node_of_seq : 'a t -> 'a node = "%identity"
+
+let create () =
+  let rec seq = { prev = seq; next = seq } in
+  seq
+
+let is_empty seq = seq.next == seq
+
+let remove node =
+  if node.node_active then begin
+    node.node_active <- false;
+    let seq = seq_of_node node in
+    seq.prev.next <- seq.next;
+    seq.next.prev <- seq.prev
+  end
+
+let add_l data seq =
+  let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in
+  seq.next.prev <- seq_of_node node;
+  seq.next <- seq_of_node node;
+  node
+
+let add_r data seq =
+  let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in
+  seq.prev.next <- seq_of_node node;
+  seq.prev <- seq_of_node node;
+  node
+
+let take_l seq =
+  if is_empty seq then raise Not_found;
+  begin
+    let node = node_of_seq seq.next in
+    remove node;
+    node.node_data
+  end
+
+let take_r seq =
+  if is_empty seq then raise Not_found;
+  begin
+    let node = node_of_seq seq.prev in
+    remove node;
+    node.node_data
+  end
+
+let fold_r f seq acc =
+  let rec loop curr acc =
+    if curr == seq then
+      acc
+    else
+      let node = node_of_seq curr in
+      if node.node_active then
+        loop node.node_prev (f node.node_data acc)
+      else
+        loop node.node_prev acc
+  in
+  loop seq.prev acc
+
+let find f seq =
+  let rec loop curr =
+    if curr == seq then
+      raise Not_found
+    else
+      let node = node_of_seq curr in
+      if node.node_active && f node.node_data then
+        node.node_data
+      else
+        loop node.node_next
+  in
+  loop seq.next
+
+let exists f seq =
+  let rec loop curr =
+    if curr == seq then
+      false
+    else
+      let node = node_of_seq curr in
+      if node.node_active && f node.node_data then
+        true
+      else
+        loop node.node_next
+  in
+  loop seq.next
diff --git a/lib/data/dllist.mli b/lib/data/dllist.mli
new file mode 100644
index 0000000..a88ff8d
--- /dev/null
+++ b/lib/data/dllist.mli
@@ -0,0 +1,66 @@
+(* This file was originally part of lwt-dllist, which is licensed
+   under MIT: https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+type 'a t
+  (** Type of a sequence holding values of type ['a] *)
+
+type 'a node
+  (** Type of a node holding one value of type ['a] in a sequence *)
+
+(** {2 Operation on nodes} *)
+
+val remove : 'a node -> unit
+  (** Removes a node from the sequence it is part of. It does nothing
+      if the node has already been removed. *)
+
+(** {2 Operations on sequence} *)
+
+val create : unit -> 'a t
+  (** [create ()] creates a new empty sequence *)
+
+val is_empty : 'a t -> bool
+  (** Returns [true] iff the given sequence is empty *)
+
+val add_l : 'a -> 'a t -> 'a node
+  (** [add_l x s] adds [x] to the left of the sequence [s] *)
+
+val add_r : 'a -> 'a t -> 'a node
+  (** [add_r x s] adds [x] to the right of the sequence [s] *)
+
+val take_l : 'a t -> 'a
+  (** [take_l x s] removes and returns the leftmost element of [s]
+
+      @raise Not_found if the sequence is empty *)
+
+val take_r : 'a t -> 'a
+  (** [take_l x s] removes and returns the rightmost element of [s]
+
+      @raise Not_found if the sequence is empty *)
+
+(** {2 Sequence iterators} *)
+
+(** Note: it is OK to remove a node while traversing a sequence *)
+
+(* val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b *)
+(*   (\** [fold_l f s] is: *)
+(*       {[ *)
+(*         fold_l f s x = f en (... (f e2 (f e1 x))) *)
+(*       ]} *)
+(*       where [e1], [e2], ..., [en] are the elements of [s] *)
+(*   *\) *)
+
+val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  (** [fold_r f s] is:
+      {[
+        fold_r f s x = f e1 (f e2 (... (f en x)))
+      ]}
+      where [e1], [e2], ..., [en] are the elements of [s]
+  *)
+
+val find : ('a -> bool) -> 'a t -> 'a
+  (** [find_node_l f s] returns the first element of [s] starting from the left
+      that satisfies [f] or raises [Not_found] if none exists. *)
+
+val exists : ('a -> bool) -> 'a t -> bool
+  (** [find_node_l f s] returns [true] if some node [s] starting from the left
+      that satisfies [f] or returns [false] if none exists. *)
diff --git a/lib/data/dune b/lib/data/dune
new file mode 100644
index 0000000..10f3f6c
--- /dev/null
+++ b/lib/data/dune
@@ -0,0 +1,5 @@
+(library
+ (package talircd)
+ (name data)
+ (inline_tests)
+ (preprocess (pps ppx_expect)))
diff --git a/lib/data/list.ml b/lib/data/list.ml
new file mode 100644
index 0000000..6b90697
--- /dev/null
+++ b/lib/data/list.ml
@@ -0,0 +1,21 @@
+include Stdlib.List
+
+let flat_map f xs =
+  let rec iter = function
+    | [] -> []
+    | x :: xs -> append_then_iter xs (f x)
+  [@@tail_mod_cons]
+  and append_then_iter xs = function
+    | [] -> iter xs
+    | y :: ys -> y :: append_then_iter xs ys
+  [@@tail_mod_cons]
+  in
+  iter xs
+
+let iter_up_to f xs ~limit =
+  let rec iter n = function
+    | x :: xs when n > 0 ->
+      f x; iter (n - 1) xs
+    | _ -> ()
+  in
+  iter limit xs
diff --git a/lib/server/test_cache.ml b/lib/data/test_cache.ml
similarity index 100%
rename from lib/server/test_cache.ml
rename to lib/data/test_cache.ml
diff --git a/lib/server/test_list.ml b/lib/data/test_list.ml
similarity index 98%
rename from lib/server/test_list.ml
rename to lib/data/test_list.ml
index 37285e3..9d9cc0e 100644
--- a/lib/server/test_list.ml
+++ b/lib/data/test_list.ml
@@ -1,5 +1,3 @@
-open Import
-
 let%expect_test _ =
   let print_list print_ele xs =
     let rec iter pre post = function
diff --git a/lib/server/test_wheel.ml b/lib/data/test_wheel.ml
similarity index 100%
rename from lib/server/test_wheel.ml
rename to lib/data/test_wheel.ml
diff --git a/lib/server/wheel.ml b/lib/data/wheel.ml
similarity index 81%
rename from lib/server/wheel.ml
rename to lib/data/wheel.ml
index 3cd30f8..1352cfb 100644
--- a/lib/server/wheel.ml
+++ b/lib/data/wheel.ml
@@ -1,7 +1,3 @@
-open Import
-
-include (val Logging.sublogs logger "Wheel")
-
 type 'a t = {
   entries : 'a Dllist.t array;
   mutable index : int;
@@ -21,7 +17,7 @@ let add t v =
 let[@tail_mod_cons] rec empty t =
   match Dllist.take_l (queue t) with
   | x -> x :: empty t
-  | exception Dllist.Empty -> []
+  | exception Not_found -> []
 
 let tick t =
   t.index <- (t.index + 1) mod Array.length t.entries;
diff --git a/lib/server/dune b/lib/server/dune
index d9862b6..2f21d0b 100644
--- a/lib/server/dune
+++ b/lib/server/dune
@@ -2,7 +2,7 @@
  (package talircd)
  (name server)
  (libraries
-   lwt lwt.unix lwt-dllist fmt
-   logging irc)
+   lwt lwt.unix fmt
+   logging irc data)
  (inline_tests)
  (preprocess (pps ppx_expect)))
diff --git a/lib/server/import.ml b/lib/server/import.ml
index 4bd8601..860ba42 100644
--- a/lib/server/import.ml
+++ b/lib/server/import.ml
@@ -1,5 +1,5 @@
+include Data
 include Irc
-module Dllist = Lwt_dllist
 
 type sockaddr = Unix.sockaddr
 type fd = Lwt_unix.file_descr
@@ -16,28 +16,4 @@ module Result_syntax = struct
   let ( let+ ) r f = Result.map f r
 end
 
-module List = struct
-  include List
-
-  let flat_map f xs =
-    let rec iter = function
-      | [] -> []
-      | x :: xs -> append_then_iter xs (f x)
-    [@@tail_mod_cons]
-    and append_then_iter xs = function
-      | [] -> iter xs
-      | y :: ys -> y :: append_then_iter xs ys
-    [@@tail_mod_cons]
-    in
-    iter xs
-
-  let iter_up_to f xs ~limit =
-    let rec iter n = function
-      | x :: xs when n > 0 ->
-        f x; iter (n - 1) xs
-      | _ -> ()
-    in
-    iter limit xs
-end
-
 include (val Logging.logs "Irc")
diff --git a/lib/server/outbox.ml b/lib/server/outbox.ml
index eeb6c3d..05bd628 100644
--- a/lib/server/outbox.ml
+++ b/lib/server/outbox.ml
@@ -36,5 +36,5 @@ module Bcc = struct
   let rec send_all msg =
     match Dllist.take_l _recipients with
     | obx -> obx.bcc_incl <- false; send obx msg; send_all msg
-    | exception Dllist.Empty -> ()
+    | exception Not_found -> ()
 end
diff --git a/lib/server/router.ml b/lib/server/router.ml
index 5458c85..d48cbf4 100644
--- a/lib/server/router.ml
+++ b/lib/server/router.ml
@@ -57,8 +57,8 @@ let join chan user =
   end
 
 let membership chan user =
-  Dllist.find_node_l (fun mem -> mem.mem_chan == chan)
-    user.membership |> Dllist.get
+  Dllist.find (fun mem -> mem.mem_chan == chan)
+    user.membership
 
 let part mem =
   try
diff --git a/lib/server/user.ml b/lib/server/user.ml
index f7363ba..41d65ee 100644
--- a/lib/server/user.ml
+++ b/lib/server/user.ml
@@ -46,19 +46,12 @@ let channels t =
   Dllist.fold_r (fun m xs -> m.mem_chan :: xs) t.membership []
 
 let highest_membership_priv t =
-  Dllist.fold_l (fun m p -> max m.mem_priv p) t.membership Normal
+  Dllist.fold_r (fun m p -> max m.mem_priv p) t.membership Normal
 
 let is_member t chan =
-  try
-    Dllist.find_node_l (fun m -> m.mem_chan == chan)
-      t.membership |> ignore;
-    true
-  with Not_found ->
-    false
+  Dllist.exists (fun m -> m.mem_chan == chan)
+    t.membership
 
 let find_common_channel t1 t2 =
-  let node =
-    Dllist.find_node_l (fun m -> is_member t2 m.mem_chan)
-      t1.membership
-  in
-  (Dllist.get node).mem_chan
+  let mem = Dllist.find (fun m -> is_member t2 m.mem_chan) t1.membership in
+  mem.mem_chan