Commits

Sebastien Mondet committed 2b6c513

Add new module `Light : LIGHT`

  • Participants
  • Parent commits adc0348

Comments (0)

Files changed (1)

File pvem_lwt_unix.ml

 
 end
 
+module type LIGHT = sig
+  (** Basic traffic lights. *)
+
+  type t
+  (** The traffic signal handle (uses {!Lwt.task}). *)
+
+  val create: unit -> t
+  (** Create a “red” traffic light. *)
+
+  val try_to_pass: t -> (unit, 'a) Deferred_result.t
+  (** [try_to_pass t] will block until [t] is “green” or will return
+      immediately if [t] is already green. *)
+
+  val green: t -> unit
+  (** [green t] sets the light to “green”, this will wake up all the threads
+    waiting on [try_to_pass t]. *)
+
+end
 
 module Internal_pervasives = struct
   let (|>) x f = f x
     Lwt.pick l
 
   end
+
+module Light = struct
+
+  type t = {
+    mutable lwt_t: unit Lwt.t;
+    mutable lwt_u: unit Lwt.u;
+    mutable color: [`Red | `Green];
+  }
+  let create () =
+    let lwt_t, lwt_u = Lwt.task () in
+    {lwt_u; lwt_t; color = `Red}
+
+  let try_to_pass w =
+    match w.color with
+    | `Green -> return ()
+    | `Red ->
+      begin match Lwt.state w.lwt_t with
+      | Lwt.Sleep -> ()
+      | Lwt.Return () | Lwt.Fail _ ->
+        (* we need to renew the “task” *)
+        let t, u = Lwt.task () in
+        w.lwt_t <- t;
+        w.lwt_u <- u;
+      end;
+      wrap_deferred ~on_exn:(fun e -> e) (fun () -> w.lwt_t)
+      >>< function
+      | `Error Lwt.Canceled -> return ()
+      | `Error other -> failwith "BUG: THIS SHOULD NOT HAPPEN"
+      | `Ok () -> return ()
+
+  let green t =
+    t.color <- `Green;
+    Lwt.wakeup_exn t.lwt_u Lwt.Canceled
+  (* We use Lwt.Canceled so that can re-wake-up sleepers at will
+    see https://github.com/ocsigen/lwt/blob/master/src/core/lwt.ml#L312
+    where Lwt.Canceled is ignored *)
+
+
+end