Merge pull request #608 from talex5/clock-variants

Convert clocks to new resource system

Author: talex5

doc/prelude.ml

@@ -5,9 +5,13 @@ module Eio_main = struct
 
   let now = ref 1623940778.27033591
 
-  let fake_clock real_clock = object (_ : #Eio.Time.clock)
-    method now = !now
-    method sleep_until time =
+  module Fake_clock = struct
+    type time = float
+    type t = time Eio.Time.clock_ty r  (* The real clock *)
+
+    let make real_clock = (real_clock :> t)
+
+    let sleep_until real_clock time =
       (* The fake times are all in the past, so we just ask to wait until the
          fake time is due and it will happen immediately. If we wait for
          multiple times, they'll get woken in the right order. At the moment,
@@ -16,8 +20,14 @@ module Eio_main = struct
          TODO: This is no longer true (since #213). *)
       Eio.Time.sleep_until real_clock time;
       now := max !now time
+
+    let now _ = !now
   end
 
+  let fake_clock =
+    let handler = Eio.Time.Pi.clock (module Fake_clock) in
+    fun real_clock -> Eio.Resource.T (Fake_clock.make real_clock, handler)
+
   (* To avoid non-deterministic output, we run the examples a single domain. *)
   let fake_domain_mgr = object (_ : #Eio.Domain_manager.t)
     method run fn =

lib_eio/eio.ml

@@ -28,8 +28,8 @@ module Stdenv = struct
   let net (t : <net : _ Net.t; ..>) = t#net
   let process_mgr (t : <process_mgr : #Process.mgr; ..>) = t#process_mgr
   let domain_mgr (t : <domain_mgr : #Domain_manager.t; ..>) = t#domain_mgr
-  let clock (t : <clock : #Time.clock; ..>) = t#clock
-  let mono_clock (t : <mono_clock : #Time.Mono.t; ..>) = t#mono_clock
+  let clock (t : <clock : _ Time.clock; ..>) = t#clock
+  let mono_clock (t : <mono_clock : _ Time.Mono.t; ..>) = t#mono_clock
   let secure_random (t: <secure_random : _ Flow.source; ..>) = t#secure_random
   let fs (t : <fs : _ Path.t; ..>) = t#fs
   let cwd (t : <cwd : _ Path.t; ..>) = t#cwd

lib_eio/eio.mli

@@ -213,10 +213,10 @@ module Stdenv : sig
       To use this, see {!Time}.
   *)
 
-  val clock : <clock : #Time.clock as 'a; ..> -> 'a
+  val clock : <clock : _ Time.clock as 'a; ..> -> 'a
   (** [clock t] is the system clock (used to get the current time and date). *)
 
-  val mono_clock : <mono_clock : #Time.Mono.t as 'a; ..> -> 'a
+  val mono_clock : <mono_clock : _ Time.Mono.t as 'a; ..> -> 'a
   (** [mono_clock t] is a monotonic clock (used for measuring intervals). *)
 
   (** {1 Randomness} *)

lib_eio/mock/clock.ml

@@ -1,13 +1,11 @@
 open Eio.Std
 
+type 'time ty = [`Mock | 'time Eio.Time.clock_ty]
+
 module type S = sig
   type time
 
-  type t = <
-    time Eio.Time.clock_base;
-    advance : unit;
-    set_time : time -> unit;
-  >
+  type t = time ty r
 
   val make : unit -> t
   val advance : t -> unit
@@ -22,11 +20,7 @@ module type TIME = sig
 end
 
 module Make(T : TIME) : S with type time := T.t = struct
-  type t = <
-    T.t Eio.Time.clock_base;
-    advance : unit;
-    set_time : T.t -> unit;
-  >
+  type t = T.t ty r
 
   module Key = struct
     type t = < >
@@ -44,49 +38,68 @@ module Make(T : TIME) : S with type time := T.t = struct
 
   module Q = Psq.Make(Key)(Job)
 
+  module Impl = struct
+    type time = T.t
+
+    type t = {
+      mutable now : T.t;
+      mutable q : Q.t;
+    }
+
+    let make () =
+      {
+        now = T.zero;
+        q = Q.empty;
+      }
+
+    let now t = t.now
+
+    let sleep_until t time =
+      if T.compare time t.now <= 0 then Fiber.yield ()
+      else (
+        let p, r = Promise.create () in
+        let k = object end in
+        t.q <- Q.add k { time; resolver = r } t.q;
+        try
+          Promise.await p
+        with Eio.Cancel.Cancelled _ as ex ->
+          t.q <- Q.remove k t.q;
+          raise ex
+      )
+
+    let set_time t time =
+      let rec drain () =
+        match Q.min t.q with
+        | Some (_, v) when T.compare v.time time <= 0 ->
+          Promise.resolve v.resolver ();
+          t.q <- Option.get (Q.rest t.q);
+          drain ()
+        | _ -> ()
+      in
+      drain ();
+      t.now <- time;
+      traceln "mock time is now %a" T.pp t.now
+
+    let advance t =
+      match Q.min t.q with
+      | None -> invalid_arg "No further events scheduled on mock clock"
+      | Some (_, v) -> set_time t v.time
+
+    type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, T.t ty) Eio.Resource.pi
+    let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t
+  end
+
+  let handler =
+    Eio.Resource.handler (
+      H (Impl.Raw, Fun.id) ::
+      Eio.Resource.bindings (Eio.Time.Pi.clock (module Impl));
+    )
+
   let make () =
-    object (self)
-      inherit [T.t] Eio.Time.clock_base
-
-      val mutable now = T.zero
-      val mutable q = Q.empty
-
-      method now = now
-
-      method sleep_until time =
-        if T.compare time now <= 0 then Fiber.yield ()
-        else (
-          let p, r = Promise.create () in
-          let k = object end in
-          q <- Q.add k { time; resolver = r } q;
-          try
-            Promise.await p
-          with Eio.Cancel.Cancelled _ as ex ->
-            q <- Q.remove k q;
-            raise ex
-        )
-
-      method set_time time =
-        let rec drain () =
-          match Q.min q with
-          | Some (_, v) when T.compare v.time time <= 0 ->
-            Promise.resolve v.resolver ();
-            q <- Option.get (Q.rest q);
-            drain ()
-          | _ -> ()
-        in
-        drain ();
-        now <- time;
-        traceln "mock time is now %a" T.pp now
-
-      method advance =
-        match Q.min q with
-        | None -> invalid_arg "No further events scheduled on mock clock"
-        | Some (_, v) -> self#set_time v.time
-    end
-
-    let set_time (t:t) time = t#set_time time
-    let advance (t:t) = t#advance
+    Eio.Resource.T (Impl.make (), handler)
+
+  let set_time t v = Impl.set_time (Impl.raw t) v
+  let advance t = Impl.advance (Impl.raw t)
 end
 
 module Old_time = struct

lib_eio/mock/clock.mli

@@ -1,11 +1,11 @@
+open Eio.Std
+
+type 'time ty = [`Mock | 'time Eio.Time.clock_ty]
+
 module type S = sig
   type time
 
-  type t = <
-    time Eio.Time.clock_base;
-    advance : unit;
-    set_time : time -> unit;
-  >
+  type t = time ty r
 
   val make : unit -> t
   (** [make ()] is a new clock.

lib_eio/time.ml

@@ -1,24 +1,42 @@
+open Std
+
 exception Timeout
 
-class virtual ['a] clock_base = object
-  method virtual now : 'a
-  method virtual sleep_until : 'a -> unit
-end
+type 'a clock_ty = [`Clock of 'a]
+type 'a clock_base = 'a r constraint 'a = [> _ clock_ty]
+
+module Pi = struct
+  module type CLOCK = sig
+    type t
+    type time
+    val now : t -> time
+    val sleep_until : t -> time -> unit
+  end
 
-class virtual clock = object
-  inherit [float] clock_base
+  type (_, _, _) Resource.pi +=
+    | Clock : ('t, (module CLOCK with type t = 't and type time = 'time), [> 'time clock_ty]) Resource.pi
+
+  let clock (type t time) (module X : CLOCK with type t = t and type time = time) =
+    Resource.handler [ H (Clock, (module X)) ]
 end
 
-let now (t : _ #clock_base) = t#now
+type 'a clock = ([> float clock_ty] as 'a) r
+
+let now (type time) (t : [> time clock_ty] r) =
+  let Resource.T (t, ops) = t in
+  let module X = (val (Resource.get ops Pi.Clock)) in
+  X.now t
 
-let sleep_until (t : _ #clock_base) time = t#sleep_until time
+let sleep_until (type time) (t : [> time clock_ty] r) time =
+  let Resource.T (t, ops) = t in
+  let module X = (val (Resource.get ops Pi.Clock)) in
+  X.sleep_until t time
 
 let sleep t d = sleep_until t (now t +. d)
 
 module Mono = struct
-  class virtual t = object
-    inherit [Mtime.t] clock_base
-  end
+  type ty = Mtime.t clock_ty
+  type 'a t = ([> ty] as 'a) r
 
   let now = now
   let sleep_until = sleep_until
@@ -39,7 +57,7 @@ module Mono = struct
       else Mtime.Span.of_uint64_ns (Int64.of_float ns)
     ) else Mtime.Span.zero      (* Also happens for NaN and negative infinity *)
 
-  let sleep (t : #t) s =
+  let sleep t s =
     sleep_span t (span_of_s s)
 end
 
@@ -48,11 +66,11 @@ let with_timeout_exn t d = Fiber.first (fun () -> sleep t d; raise Timeout)
 
 module Timeout = struct
   type t =
-    | Timeout of Mono.t * Mtime.Span.t
+    | Timeout of Mono.ty r * Mtime.Span.t
     | Unlimited
 
   let none = Unlimited
-  let v clock time = Timeout ((clock :> Mono.t), time)
+  let v clock time = Timeout ((clock :> Mono.ty r), time)
 
   let seconds clock time =
     v clock (Mono.span_of_s time)

lib_eio/time.mli

@@ -1,19 +1,17 @@
-class virtual ['a] clock_base : object
-  method virtual now : 'a
-  method virtual sleep_until : 'a -> unit
-end
+open Std
 
-class virtual clock : object
-  inherit [float] clock_base
-end
+type 'a clock_ty = [`Clock of 'a]
+type 'a clock_base = 'a r constraint 'a = [> _ clock_ty]
+
+type 'a clock = ([> float clock_ty] as 'a) r
 
-val now : #clock -> float
+val now : _ clock -> float
 (** [now t] is the current time since 00:00:00 GMT, Jan. 1, 1970 - in seconds - according to [t]. *)
 
-val sleep_until : #clock -> float -> unit
+val sleep_until : _ clock -> float -> unit
 (** [sleep_until t time] waits until the given time is reached. *)
 
-val sleep : #clock -> float -> unit
+val sleep : _ clock -> float -> unit
 (** [sleep t d] waits for [d] seconds. *)
 
 (** Monotonic clocks. *)
@@ -24,43 +22,42 @@ module Mono : sig
 
       A monotonic clock may or may not include time while the computer is suspended. *)
 
-  class virtual t : object
-    inherit [Mtime.t] clock_base
-  end
+  type ty = Mtime.t clock_ty
+  type 'a t = ([> ty] as 'a) r
 
-  val now : #t -> Mtime.t
+  val now : _ t -> Mtime.t
   (** [now t] is the current time according to [t]. *)
 
-  val sleep_until : #t -> Mtime.t -> unit
+  val sleep_until : _ t -> Mtime.t -> unit
   (** [sleep_until t time] waits until [time] before returning. *)
 
-  val sleep : #t -> float -> unit
+  val sleep : _ t -> float -> unit
   (** [sleep t d] waits for [d] seconds. *)
 
-  val sleep_span : #t -> Mtime.span -> unit
+  val sleep_span : _ t -> Mtime.span -> unit
   (** [sleep_span t d] waits for duration [d]. *)
 end
 
 (** {2 Timeouts} *)
 
 exception Timeout
 
-val with_timeout : #clock -> float -> (unit -> ('a, 'e) result) -> ('a, [> `Timeout] as 'e) result
+val with_timeout : _ clock -> float -> (unit -> ('a, 'e) result) -> ('a, [> `Timeout] as 'e) result
 (** [with_timeout clock d fn] runs [fn ()] but cancels it after [d] seconds. *)
 
-val with_timeout_exn : #clock -> float -> (unit -> 'a) -> 'a
+val with_timeout_exn : _ clock -> float -> (unit -> 'a) -> 'a
 (** [with_timeout_exn clock d fn] runs [fn ()] but cancels it after [d] seconds,
     raising exception {!exception-Timeout}. *)
 
 (** Timeout values. *)
 module Timeout : sig
   type t
 
-  val v : #Mono.t -> Mtime.Span.t -> t
+  val v : _ Mono.t -> Mtime.Span.t -> t
   (** [v clock duration] is a timeout of [duration], as measured by [clock].
       Internally, this is just the tuple [(clock, duration)]. *)
 
-  val seconds : #Mono.t -> float -> t
+  val seconds : _ Mono.t -> float -> t
   (** [seconds clock duration] is a timeout of [duration] seconds, as measured by [clock]. *)
 
   val none : t
@@ -77,3 +74,21 @@ module Timeout : sig
   (** [pp] formats a timeout as a duration (e.g. "5s").
       This is intended for use in error messages and logging and is rounded. *)
 end
+
+module Pi : sig
+  module type CLOCK = sig
+    type t
+    type time
+
+    val now : t -> time
+    val sleep_until : t -> time -> unit
+  end
+
+  type (_, _, _) Resource.pi +=
+      Clock : ('t, (module CLOCK with type t = 't and type time = 'time),
+         [> 'time clock_ty ]) Resource.pi
+
+  val clock :
+    (module CLOCK with type t = 't and type time = 'time) ->
+    ('t, [> 'time clock_ty]) Resource.handler
+end