Skip to content
Browse files

Support timeouts on Ohm.Run

  • Loading branch information...
1 parent fd9ebc9 commit 6474a3b4c4997e289f3e8f3e808fc6333fd177f7 @VictorNicollet committed
Showing with 19 additions and 3 deletions.
  1. +14 −2 src/run.ml
  2. +5 −1 src/run.mli
View
16 src/run.ml
@@ -108,12 +108,20 @@ let opt_bind f = function
(* Evaluation ------------------------------------------------------------------------------ *)
-let eval ctx m =
+exception Timeout
+
+let eval ?timeout ctx m =
let queue = Queue.create () in
let r = ref None in
let emit x = r := Some x ; nop in
-
+
+ let timeout = match timeout with
+ | Some f -> f
+ | None -> (fun () -> false)
+ in
+
let rec loop = function Do step ->
+ if timeout () then raise Timeout ;
match Lazy.force step with
| h :: t -> List.iter (fun x -> Queue.push x queue) t ; loop h
| [] -> match try Some (Queue.pop queue) with Queue.Empty -> None with
@@ -123,3 +131,7 @@ let eval ctx m =
loop (m ctx emit) ;
match !r with None -> assert false | Some result -> result
+
+let timeout duration =
+ let ends = duration +. Unix.gettimeofday () in
+ fun () -> Unix.gettimeofday () > ends
View
6 src/run.mli
@@ -20,7 +20,11 @@ val edit_context : ('ca -> 'cb) -> ('cb,'any) t -> ('ca,'any) t
(** {2 Evaluation} *)
-val eval : 'ctx -> ('ctx,'a) t -> 'a
+exception Timeout
+
+val eval : ?timeout:(unit -> bool) -> 'ctx -> ('ctx,'a) t -> 'a
+
+val timeout : float -> (unit -> bool)
(** {2 Concurrency manipulation} *)

0 comments on commit 6474a3b

Please sign in to comment.
Something went wrong with that request. Please try again.