diff options
author | Alex AUVOLAT <alex.auvolat@ens.fr> | 2014-05-13 22:44:50 +0200 |
---|---|---|
committer | Alex AUVOLAT <alex.auvolat@ens.fr> | 2014-05-13 22:44:50 +0200 |
commit | acfa0090d68a21be6c83815f484142b4eb814f4a (patch) | |
tree | 49af13f0153ebffb94c63ac98ceb0bd054e7db7b /src/kahn_seq.ml | |
parent | c6313368d3719e507eba4216a4fc4ea9f30db576 (diff) | |
download | SystemeReseaux-Projet-acfa0090d68a21be6c83815f484142b4eb814f4a.tar.gz SystemeReseaux-Projet-acfa0090d68a21be6c83815f484142b4eb814f4a.zip |
Change interface, update some stuff, new example...
Diffstat (limited to 'src/kahn_seq.ml')
-rw-r--r-- | src/kahn_seq.ml | 83 |
1 files changed, 83 insertions, 0 deletions
diff --git a/src/kahn_seq.ml b/src/kahn_seq.ml new file mode 100644 index 0000000..7f0eec5 --- /dev/null +++ b/src/kahn_seq.ml @@ -0,0 +1,83 @@ +open Kahn + +module Seq: S = struct + type 'a process = (('a -> unit) option) -> unit + + type 'a channel = 'a Queue.t + type 'a in_port = 'a channel + type 'a out_port = 'a channel + + type task = unit -> unit + + let tasks = Queue.create () + + let push_cont (cont : ('a -> unit) option) (v : 'a) = + match cont with + | None -> () + | Some cont -> Queue.push (fun () -> cont v) tasks + + let new_channel () = + let q = Queue.create () in + q, q + + let put x c = + fun cont -> + Queue.push x c; + match cont with + | None -> () + | Some cont -> Queue.push cont tasks + + let rec get c = + fun cont -> + try + let v = Queue.pop c in push_cont cont v + with Queue.Empty -> + Queue.push (fun () -> get c cont) tasks + + let rec try_get = function + | [] -> None + | (prt, f)::q -> + try + let v = Queue.pop prt in Some (f v) + with Queue.Empty -> try_get q + + let rec select prt_list = + fun cont -> + match try_get prt_list with + | Some x -> push_cont cont x + | None -> Queue.push (fun () -> select prt_list cont) tasks + + let select_default prt_list def = + fun cont -> + match try_get prt_list with + | Some x -> push_cont cont x + | None -> push_cont cont (def()) + + let doco l = + fun cont -> + List.iter (fun proc -> Queue.push (fun () -> proc None) tasks) l; + push_cont cont () + + let return v = + fun cont -> + push_cont cont v + + let bind e f = + fun cont -> + Queue.push (fun () -> e (Some (fun r -> f r cont))) tasks + let bind_io e f = + fun cont -> + Queue.push (fun () -> e (Some (fun r -> f r cont))) tasks + + let run e = + let ret = ref None in + e (Some (fun v -> ret := Some v)); + while not (Queue.is_empty tasks) do + let task = Queue.pop tasks in + task () + done; + match !ret with + | Some k -> k + | None -> assert false + +end |