From bb84d9d6857fd3071e8324c36a49afa60e84a7ff Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Thu, 17 Oct 2024 22:54:49 -0400
Subject: [PATCH] initial commit

---
 .gitignore     |   3 +
 .ocamlformat   |  15 ++++
 Makefile       |  26 +++++++
 dune-project   |  23 +++++++
 nanoev.opam    |  30 ++++++++
 src/dune       |   5 ++
 src/heap.ml    |  61 +++++++++++++++++
 src/heap.mli   |  13 ++++
 src/nanoev.ml  | 182 +++++++++++++++++++++++++++++++++++++++++++++++++
 src/nanoev.mli |  24 +++++++
 10 files changed, 382 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 .ocamlformat
 create mode 100644 Makefile
 create mode 100644 dune-project
 create mode 100644 nanoev.opam
 create mode 100644 src/dune
 create mode 100644 src/heap.ml
 create mode 100644 src/heap.mli
 create mode 100644 src/nanoev.ml
 create mode 100644 src/nanoev.mli

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..ea2c377
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+_build
+_opam
+*.tmp
diff --git a/.ocamlformat b/.ocamlformat
new file mode 100644
index 0000000..7818345
--- /dev/null
+++ b/.ocamlformat
@@ -0,0 +1,15 @@
+version = 0.26.2
+profile=conventional
+margin=80
+if-then-else=k-r
+parens-ite=true
+parens-tuple=multi-line-only
+sequence-style=terminator
+type-decl=sparse
+break-cases=toplevel
+cases-exp-indent=2
+field-space=tight-decl
+leading-nested-match-parens=true
+module-item-spacing=compact
+quiet=true
+ocaml-version=4.08.0
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..8b38dc3
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,26 @@
+
+DUNE_OPTS?=
+build:
+	dune build @install $(DUNE_OPTS)
+
+clean:
+	@dune clean
+
+test:
+	@dune runtest $(DUNE_OPTS)
+
+test-autopromote:
+	@dune runtest $(DUNE_OPTS) --auto-promote
+
+doc:
+	@dune build $(DUNE_OPTS) @doc
+
+format:
+	@dune build $(DUNE_OPTS) @fmt --auto-promote
+
+format-check:
+	@dune build $(DUNE_OPTS) @fmt --display=quiet
+
+WATCH?= @check @runtest
+watch:
+	dune build $(DUNE_OPTS) -w $(WATCH)
diff --git a/dune-project b/dune-project
new file mode 100644
index 0000000..e1d3ceb
--- /dev/null
+++ b/dune-project
@@ -0,0 +1,23 @@
+(lang dune 2.7)
+
+(name nanoev)
+(generate_opam_files true)
+
+(source
+ (github c-cube/nanoev))
+
+(authors "Simon Cruanes")
+
+(maintainers "Simon Cruanes")
+
+(license MIT)
+
+;(documentation https://url/to/documentation)
+
+(package
+ (name nanoev)
+ (synopsis "Tiny event loop around `select`")
+ (depends ocaml dune base-unix)
+ (tags (unix select async)))
+
+; See the complete stanza docs at https://dune.readthedocs.io/en/stable/reference/dune-project/index.html
diff --git a/nanoev.opam b/nanoev.opam
new file mode 100644
index 0000000..2981f11
--- /dev/null
+++ b/nanoev.opam
@@ -0,0 +1,30 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Tiny event loop around `select`"
+maintainer: ["Simon Cruanes"]
+authors: ["Simon Cruanes"]
+license: "MIT"
+tags: ["unix" "select" "async"]
+homepage: "https://github.com/c-cube/nanoev"
+bug-reports: "https://github.com/c-cube/nanoev/issues"
+depends: [
+  "ocaml"
+  "dune" {>= "2.7"}
+  "base-unix"
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/c-cube/nanoev.git"
diff --git a/src/dune b/src/dune
new file mode 100644
index 0000000..8109e16
--- /dev/null
+++ b/src/dune
@@ -0,0 +1,5 @@
+(library
+ (name nanoev)
+ (public_name nanoev)
+ (synopsis "Nano ev loop")
+ (libraries unix))
diff --git a/src/heap.ml b/src/heap.ml
new file mode 100644
index 0000000..a9a9c9e
--- /dev/null
+++ b/src/heap.ml
@@ -0,0 +1,61 @@
+type 'a tree =
+  | E
+  | N of int * 'a * 'a tree * 'a tree
+
+type 'a t = {
+  leq: 'a -> 'a -> bool;
+  mutable t: 'a tree;
+}
+
+let create ~leq () : _ t = { leq; t = E }
+
+let[@inline] is_empty (self : _ t) =
+  match self.t with
+  | E -> true
+  | N _ -> false
+
+exception Empty
+
+open struct
+  (** Rank of the tree *)
+  let[@inline] rank_ = function
+    | E -> 0
+    | N (r, _, _, _) -> r
+
+  (** Make a balanced node labelled with [x], and subtrees [a] and [b].
+     We ensure that the right child's rank is ≤ to the rank of the
+     left child (leftist property). The rank of the resulting node
+     is the length of the rightmost path. *)
+  let[@inline] mk_node_ x a b =
+    if rank_ a >= rank_ b then
+      N (rank_ b + 1, x, a, b)
+    else
+      N (rank_ a + 1, x, b, a)
+
+  let rec merge ~leq t1 t2 =
+    match t1, t2 with
+    | t, E -> t
+    | E, t -> t
+    | N (_, x, a1, b1), N (_, y, a2, b2) ->
+      if leq x y then
+        mk_node_ x a1 (merge ~leq b1 t2)
+      else
+        mk_node_ y a2 (merge ~leq t1 b2)
+end
+
+let clear self = self.t <- E
+
+let[@inline] insert (self : _ t) x : unit =
+  self.t <- merge ~leq:self.leq self.t (N (1, x, E, E))
+
+let[@inline] peek_min_exn (self : _ t) =
+  match self.t with
+  | E -> raise Empty
+  | N (_, x, _, _) -> x
+
+let[@inline] pop_min_exn (self : _ t) =
+  match self.t with
+  | E -> raise Empty
+  | N (_, x, l, r) ->
+    self.t <- merge ~leq:self.leq l r;
+    x
diff --git a/src/heap.mli b/src/heap.mli
new file mode 100644
index 0000000..3efd4c4
--- /dev/null
+++ b/src/heap.mli
@@ -0,0 +1,13 @@
+type 'a t
+
+val create : leq:('a -> 'a -> bool) -> unit -> 'a t
+
+val is_empty : _ t -> bool
+(** [is_empty h] returns [true] if the heap [h] is empty. *)
+
+exception Empty
+
+val clear : _ t -> unit
+val insert : 'a t -> 'a -> unit
+val peek_min_exn : 'a t -> 'a
+val pop_min_exn : 'a t -> 'a
diff --git a/src/nanoev.ml b/src/nanoev.ml
new file mode 100644
index 0000000..2da6ab2
--- /dev/null
+++ b/src/nanoev.ml
@@ -0,0 +1,182 @@
+(* module type BACKEND = Intf.BACKEND *)
+
+let ( let@ ) = ( @@ )
+let now_ : unit -> float = Unix.gettimeofday
+
+(** Callback list *)
+type cbs =
+  | Nil
+  | Sub : 'a * ('a -> unit) * cbs -> cbs
+
+let[@inline] cb_is_empty = function
+  | Nil -> true
+  | Sub _ -> false
+
+type timer_ev =
+  | Timer : {
+      deadline: float;
+      x: 'a;
+      f: 'a -> unit;
+    }
+      -> timer_ev
+
+type per_fd = {
+  fd: Unix.file_descr;
+  mutable r: cbs;
+  mutable w: cbs;
+}
+
+type t = {
+  timer: timer_ev Heap.t;
+  fds: (Unix.file_descr, per_fd) Hashtbl.t;
+  mutable sub_r: Unix.file_descr list;
+  mutable sub_w: Unix.file_descr list;
+  mutable sub_up_to_date: bool;
+      (** are [sub_r] and [sub_w] faithful reflections of [fds]? *)
+  lock: Mutex.t;
+}
+
+let leq_timer (Timer a) (Timer b) = a.deadline <= b.deadline
+
+let create () : t =
+  {
+    timer = Heap.create ~leq:leq_timer ();
+    fds = Hashtbl.create 16;
+    sub_r = [];
+    sub_w = [];
+    sub_up_to_date = true;
+    lock = Mutex.create ();
+  }
+
+let[@inline] with_lock_ (self : t) f =
+  Mutex.lock self.lock;
+  match f self with
+  | exception e ->
+    Mutex.unlock self.lock;
+    raise e
+  | res ->
+    Mutex.unlock self.lock;
+    res
+
+let clear (self : t) =
+  let@ self = with_lock_ self in
+  Heap.clear self.timer;
+  Hashtbl.clear self.fds;
+  self.sub_r <- [];
+  self.sub_w <- [];
+  self.sub_up_to_date <- true;
+  ()
+
+(* TODO: *)
+let wakeup_from_outside _self : unit = ()
+
+let get_fd_ (self : t) fd : per_fd =
+  match Hashtbl.find self.fds fd with
+  | per_fd -> per_fd
+  | exception Not_found ->
+    let per_fd = { fd; r = Nil; w = Nil } in
+    Hashtbl.add self.fds fd per_fd;
+    per_fd
+
+let on_readable self fd x f : unit =
+  let@ self = with_lock_ self in
+  let per_fd = get_fd_ self fd in
+  per_fd.r <- Sub (x, f, per_fd.r)
+
+let on_writable self fd x f : unit =
+  let@ self = with_lock_ self in
+  let per_fd = get_fd_ self fd in
+  per_fd.w <- Sub (x, f, per_fd.w)
+
+let run_after_s self time x f : unit =
+  let@ self = with_lock_ self in
+  let deadline = now_ () +. time in
+  Heap.insert self.timer (Timer { deadline; x; f })
+
+let recompute_if_needed (self : t) =
+  if not self.sub_up_to_date then (
+    self.sub_up_to_date <- true;
+    self.sub_r <- [];
+    self.sub_w <- [];
+    Hashtbl.iter
+      (fun fd per_fd ->
+        if cb_is_empty per_fd.r && cb_is_empty per_fd.w then
+          Hashtbl.remove self.fds fd;
+        if not (cb_is_empty per_fd.r) then self.sub_r <- fd :: self.sub_r;
+        if not (cb_is_empty per_fd.w) then self.sub_w <- fd :: self.sub_w)
+      self.fds
+  )
+
+(*
+    let set fd (ev : Event.t) : unit =
+      needs_recompute := true;
+      match Hashtbl.find subs fd with
+      | exception Not_found -> Hashtbl.add subs fd (ref ev)
+      | old_ev -> old_ev := Event.(!old_ev lor ev)
+
+    let iter_ready f : unit = List.iter (fun (fd, ev) -> f fd ev) !ready_fds
+*)
+
+let next_deadline_ (self : t) : float option =
+  match Heap.peek_min_exn self.timer with
+  | exception Heap.Empty -> None
+  | Timer t -> Some t.deadline
+
+let rec perform_cbs = function
+  | Nil -> ()
+  | Sub (x, f, tail) ->
+    f x;
+    perform_cbs tail
+
+let step (self : t) : unit =
+  (* gather the subscriptions and timeout *)
+  let timeout, sub_r, sub_w =
+    let@ self = with_lock_ self in
+    recompute_if_needed self;
+    let timeout =
+      match next_deadline_ self with
+      | None ->
+        let has_waiters = self.sub_r != [] || self.sub_w != [] in
+        if has_waiters then
+          1e9
+        else
+          0.
+      | Some d -> max 0. (d -. now_ ())
+    in
+    timeout, self.sub_r, self.sub_w
+  in
+
+  let r_reads, r_writes, _ = Unix.select sub_r sub_w [] timeout in
+
+  (* gather the [per_fd] that are ready *)
+  let ready_r = ref [] in
+  let ready_w = ref [] in
+
+  (* gather the [per_fd] that have updates *)
+  (let@ self = with_lock_ self in
+   if r_reads != [] || r_writes != [] then self.sub_up_to_date <- false;
+
+   List.iter
+     (fun fd ->
+       let per_fd = Hashtbl.find self.fds fd in
+       ready_r := per_fd :: !ready_r)
+     r_reads;
+   List.iter
+     (fun fd ->
+       let per_fd = Hashtbl.find self.fds fd in
+       ready_w := per_fd :: !ready_w)
+     r_writes);
+
+  (* call callbacks *)
+  List.iter
+    (fun fd ->
+      perform_cbs fd.r;
+      fd.r <- Nil)
+    !ready_r;
+  List.iter
+    (fun fd ->
+      perform_cbs fd.w;
+      fd.w <- Nil)
+    !ready_w;
+
+  ()
diff --git a/src/nanoev.mli b/src/nanoev.mli
new file mode 100644
index 0000000..8e28c97
--- /dev/null
+++ b/src/nanoev.mli
@@ -0,0 +1,24 @@
+(** Nano event loop *)
+
+(*
+module type BACKEND = Intf.BACKEND
+
+val unix : unit -> (module BACKEND)
+val create : ?backend:(module BACKEND) -> unit -> t
+*)
+
+type t
+
+val create : unit -> t
+
+val clear : t -> unit
+(** Reset the state *)
+
+val wakeup_from_outside : t -> unit
+
+val step : t -> unit
+(** Run one step of the event loop until something happens *)
+
+val on_readable : t -> Unix.file_descr -> 'a -> ('a -> unit) -> unit
+val on_writable : t -> Unix.file_descr -> 'a -> ('a -> unit) -> unit
+val run_after_s : t -> float -> 'a -> ('a -> unit) -> unit