# HG changeset patch
# User Malcolm Matalka <malcolm.matalka@acsl.se>
# Date 1563785991 -7200
#      Mon Jul 22 10:59:51 2019 +0200
# Node ID 6584798af16bbc0743a6a73389b03ba6cd5fa332
# Parent  e4d5e0c87c51c4008ab8e9013095bc20e27b50c5
ADD Scheduler and tests

diff --git a/.builds/alpine.yml b/.builds/alpine.yml
--- a/.builds/alpine.yml
+++ b/.builds/alpine.yml
@@ -1,5 +1,6 @@
 image: alpine/edge
 packages:
+  - m4
   - make
   - mercurial
   - opam
diff --git a/code/pds.conf b/code/pds.conf
--- a/code/pds.conf
+++ b/code/pds.conf
@@ -22,5 +22,12 @@
 [src.byocm_fut]
 install = false
 
+[src.byocm_sched]
+install = false
+deps = [ "byocm_fut" ]
+
 [tests.byocm_fut]
-deps = [ "byocm_fut" ]
\ No newline at end of file
+deps = [ "byocm_fut" ]
+
+[tests.byocm_sched]
+deps = [ "byocm_fut", "byocm_sched" ]
diff --git a/code/src/byocm_fut/byocm_fut.ml b/code/src/byocm_fut/byocm_fut.ml
--- a/code/src/byocm_fut/byocm_fut.ml
+++ b/code/src/byocm_fut/byocm_fut.ml
@@ -10,6 +10,10 @@
 external t_of_u : 'a u -> 'a t = "%identity"
 external u_of_t : 'a t -> 'a u = "%identity"
 
+let rec collapse_alias = function
+  | { state = `Alias u } -> collapse_alias u
+  | u -> u
+
 module Promise = struct
   type 'a fut = 'a t
   type 'a t = 'a fut
@@ -26,18 +30,35 @@
         assert false
 end
 
-let rec collapse_alias = function
-  | { state = `Alias u } -> collapse_alias u
-  | u -> u
-
 let return v = t_of_u { state = `Det v }
-let bind t f =
+let bind : 'a t -> ('a -> 'b t) -> 'b t = fun t f ->
   let u = collapse_alias (u_of_t t) in
   match u with
     | { state = `Det v } ->
       f v
-    | { state = `Undet { watchers = watchers } } ->
-      failwith "nyi"
+    | { state = `Undet undet } ->
+      let p = Promise.create () in
+      let fut = Promise.future p in
+      let w =
+        fun v ->
+          let u = collapse_alias (u_of_t (f v)) in
+          match u with
+            | { state = `Det v' } ->
+              Promise.set p v'
+            | { state = `Undet undet' } ->
+              begin match collapse_alias (u_of_t fut) with
+                | { state = `Undet undet'' } as fut' ->
+                  undet'.watchers <- undet'.watchers @ undet''.watchers;
+                  fut'.state <- `Alias u
+                | { state = `Det _ }
+                | { state =  `Alias _ } ->
+                  assert false
+              end
+            | _ ->
+              assert false
+      in
+      undet.watchers <- w::undet.watchers;
+      fut
     | { state = `Alias _ } ->
       assert false
 
diff --git a/code/src/byocm_sched/byocm_sched.ml b/code/src/byocm_sched/byocm_sched.ml
new file mode 100644
--- /dev/null
+++ b/code/src/byocm_sched/byocm_sched.ml
@@ -0,0 +1,44 @@
+module Float_map = Map.Make(struct type t = float let compare = compare end)
+
+let timers = ref Float_map.empty
+
+let rec exec_timers now =
+  match Float_map.min_binding_opt !timers with
+    | Some (n, p) when n <= now ->
+      timers := Float_map.remove n !timers;
+      Byocm_fut.Promise.set p ();
+      exec_timers now
+    | _ ->
+      ()
+
+let rec loop finished =
+  match Byocm_fut.state finished with
+    | `Det v ->
+      v
+    | `Undet ->
+      next_iter ();
+      loop finished
+and next_iter () =
+  let now = Unix.time () in
+  match Float_map.min_binding_opt !timers with
+    | Some (n, _) when n > now ->
+      ignore (Unix.select [] [] [] (n -. now))
+    | _ ->
+      exec_timers now
+
+let sleep time =
+  let trigger_time = Unix.time () +. time in
+  let p =
+    try
+      Float_map.find trigger_time !timers
+    with
+      | Not_found ->
+        let p = Byocm_fut.Promise.create () in
+        timers := Float_map.add trigger_time p !timers;
+        p
+  in
+  Byocm_fut.Promise.future p
+
+let run f =
+  loop (f ())
+
diff --git a/code/src/byocm_sched/byocm_sched.mli b/code/src/byocm_sched/byocm_sched.mli
new file mode 100644
--- /dev/null
+++ b/code/src/byocm_sched/byocm_sched.mli
@@ -0,0 +1,3 @@
+val sleep : float -> unit Byocm_fut.t
+
+val run : (unit -> 'a Byocm_fut.t) -> 'a
diff --git a/code/tests/byocm_fut/test.ml b/code/tests/byocm_fut/test.ml
--- a/code/tests/byocm_fut/test.ml
+++ b/code/tests/byocm_fut/test.ml
@@ -25,7 +25,26 @@
   Byocm_fut.Promise.set p "hello";
   assert (Byocm_fut.state res = `Det "hello world")
 
+let test4 () =
+  let open Byocm_fut.Infix_monad in
+  let p1 = Byocm_fut.Promise.create () in
+  let p2 = Byocm_fut.Promise.create () in
+  let fut = Byocm_fut.Promise.future p1 in
+  let res =
+    fut
+    >>= fun () ->
+    Byocm_fut.Promise.future p2
+    >>= fun s ->
+    Byocm_fut.return (s ^ " world")
+  in
+  assert (Byocm_fut.state res = `Undet);
+  Byocm_fut.Promise.set p1 ();
+  assert (Byocm_fut.state res = `Undet);
+  Byocm_fut.Promise.set p2 "hello";
+  assert (Byocm_fut.state res = `Det "hello world")
+
 let () =
   test1 ();
   test2 ();
-  test3 ()
+  test3 ();
+  test4 ()
diff --git a/code/tests/byocm_sched/test.ml b/code/tests/byocm_sched/test.ml
new file mode 100644
--- /dev/null
+++ b/code/tests/byocm_sched/test.ml
@@ -0,0 +1,37 @@
+let test1 () =
+  let f () = Byocm_sched.sleep 1.0 in
+  let v = Byocm_sched.run f in
+  assert (v = ())
+
+let test2 () =
+  let f () =
+    let open Byocm_fut.Infix_monad in
+    let t1 = Unix.time () in
+    Byocm_sched.sleep 1.0
+    >>= fun () ->
+    let t2 = Unix.time () in
+    Byocm_fut.return (t2 -. t1)
+  in
+  let v = Byocm_sched.run f in
+  assert (v >= 1.0 && v <= 1.5)
+
+let test3 () =
+  let f () =
+    let open Byocm_fut.Infix_monad in
+    let t1 = Unix.time () in
+    let fut1 = Byocm_sched.sleep 1.0 in
+    let fut2 = Byocm_sched.sleep 1.5 in
+    fut1
+    >>= fun () ->
+    fut2
+    >>= fun () ->
+    let t2 = Unix.time () in
+    Byocm_fut.return (t2 -. t1)
+  in
+  let v = Byocm_sched.run f in
+  assert (v >= 1.5 && v <= 2.0)
+
+let () =
+  test1 ();
+  test2 ();
+  test3 ()