diff --git a/.Makefile.lint b/.Makefile.lint
index 7d18f22eed17986328f25354182e7a0ccd4fb06a..be7cf8332cd7b62bf8f1223ca3091ed24277adb2 100644
--- a/.Makefile.lint
+++ b/.Makefile.lint
@@ -188,8 +188,6 @@ ML_LINT_KO+=src/libraries/utils/qstack.ml
ML_LINT_KO+=src/libraries/utils/qstack.mli
ML_LINT_KO+=src/libraries/utils/rangemap.ml
ML_LINT_KO+=src/libraries/utils/rangemap.mli
-ML_LINT_KO+=src/libraries/utils/task.ml
-ML_LINT_KO+=src/libraries/utils/task.mli
ML_LINT_KO+=src/libraries/utils/vector.ml
ML_LINT_KO+=src/libraries/utils/vector.mli
ML_LINT_KO+=src/libraries/utils/wto.ml
diff --git a/src/libraries/utils/task.ml b/src/libraries/utils/task.ml
index 2f39dcfb9ebbc31493a48aca056321387c48e122..7750a6c5c9a1e6d78f4d6bc40b3c5bcea52576f3 100644
--- a/src/libraries/utils/task.ml
+++ b/src/libraries/utils/task.ml
@@ -79,19 +79,19 @@ sig
val waiting : 'a t -> bool
end =
struct
-
+
type 'a t =
| UNIT of 'a
| WAIT of int * (coin -> 'a t)
| YIELD of (coin -> 'a t)
let unit a = UNIT a
-
+
let rec bind m f = match m with
| UNIT a -> f a
| WAIT(d,m) -> WAIT (d, fun c -> bind (m c) f)
| YIELD m -> YIELD (fun c -> bind (m c) f)
-
+
let put c m = match m with
| UNIT _ -> m
| WAIT(_,f) | YIELD f -> f c
@@ -103,7 +103,7 @@ struct
| Wait d -> WAIT(d,ping f)
| Yield -> YIELD(ping f)
| Return a -> UNIT a
-
+
let async f = YIELD (ping f)
let rec wait = function
@@ -114,7 +114,7 @@ struct
let finished = function UNIT a -> Some a | YIELD _ | WAIT _ -> None
let waiting = function UNIT _ -> false | YIELD _ | WAIT _ -> true
-
+
end
(* ------------------------------------------------------------------------ *)
@@ -141,20 +141,20 @@ let failed text =
let bind = Monad.bind
let async = Monad.async
-let sequence a k =
+let sequence a k =
Monad.bind a (function
| Result r -> k r
| Failed e -> Monad.unit (Failed e)
| Timeout n -> Monad.unit (Timeout n)
| Canceled -> Monad.unit Canceled)
-
+
let nop = return ()
let nof _ = ()
let later ?(canceled=nof) f x = Monad.yield
begin fun coin ->
try match coin with
- | Coin -> f x
+ | Coin -> f x
| Kill -> canceled x ; Monad.unit Canceled
with e -> raised e
end
@@ -245,35 +245,35 @@ let start_command ~timeout ?time ?stdout ?stderr cmd args =
let ping_command cmd coin =
try
match cmd.async () with
-
+
| Command.Not_ready kill ->
- if coin = Kill then (kill () ; Wait 100)
- else
- let time_now = if cmd.timed then Unix.gettimeofday () else 0.0 in
- if cmd.timeout > 0 && time_now > cmd.time_stop then
- begin
- set_time cmd (time_now -. cmd.time_start) ;
- Kernel.debug ~dkey:Kernel.dkey_task "timeout '%s'" cmd.name ;
- cmd.time_killed <- true ;
- kill () ;
- end ;
- Wait 100
+ if coin = Kill then (kill () ; Wait 100)
+ else
+ let time_now = if cmd.timed then Unix.gettimeofday () else 0.0 in
+ if cmd.timeout > 0 && time_now > cmd.time_stop then
+ begin
+ set_time cmd (time_now -. cmd.time_start) ;
+ Kernel.debug ~dkey:Kernel.dkey_task "timeout '%s'" cmd.name ;
+ cmd.time_killed <- true ;
+ kill () ;
+ end ;
+ Wait 100
| Command.Result (Unix.WEXITED s|Unix.WSIGNALED s|Unix.WSTOPPED s)
when cmd.time_killed ->
- set_chrono cmd ;
- Kernel.debug ~dkey:Kernel.dkey_task "timeout '%s' [%d]" cmd.name s ;
- Return (Timeout cmd.timeout)
+ set_chrono cmd ;
+ Kernel.debug ~dkey:Kernel.dkey_task "timeout '%s' [%d]" cmd.name s ;
+ Return (Timeout cmd.timeout)
| Command.Result (Unix.WEXITED s) ->
- set_chrono cmd ;
- Kernel.debug ~dkey:Kernel.dkey_task "exit '%s' [%d]" cmd.name s ;
- Return (Result s)
+ set_chrono cmd ;
+ Kernel.debug ~dkey:Kernel.dkey_task "exit '%s' [%d]" cmd.name s ;
+ Return (Result s)
| Command.Result (Unix.WSIGNALED s|Unix.WSTOPPED s) ->
- set_chrono cmd ;
- Kernel.debug ~dkey:Kernel.dkey_task "signal '%s' [%d]" cmd.name s ;
- Return Canceled
+ set_chrono cmd ;
+ Kernel.debug ~dkey:Kernel.dkey_task "signal '%s' [%d]" cmd.name s ;
+ Return Canceled
with e ->
set_chrono cmd ;
@@ -309,25 +309,25 @@ let retry_shared sh = function
let ping_shared sh = function
| Coin ->
- begin match Monad.finished sh.shared with
- | Some r ->
- if retry_shared sh r then sh.shared <- todo sh.builder ;
- Return r
- | None -> sh.shared <- Monad.progress sh.shared ; Yield
+ begin match Monad.finished sh.shared with
+ | Some r ->
+ if retry_shared sh r then sh.shared <- todo sh.builder ;
+ Return r
+ | None -> sh.shared <- Monad.progress sh.shared ; Yield
+ end
+ | Kill ->
+ if sh.clients > 1 then
+ begin
+ sh.clients <- pred sh.clients ;
+ Return Canceled
end
- | Kill ->
- if sh.clients > 1 then
- begin
- sh.clients <- pred sh.clients ;
- Return Canceled
- end
- else
- ( if sh.clients = 1 then
- begin
- sh.clients <- 0 ;
- sh.shared <- Monad.cancel sh.shared ;
- end ;
- Yield )
+ else
+ ( if sh.clients = 1 then
+ begin
+ sh.clients <- 0 ;
+ sh.shared <- Monad.cancel sh.shared ;
+ end ;
+ Yield )
let share sh = todo
begin fun () ->
@@ -338,7 +338,7 @@ let share sh = todo
(* -------------------------------------------------------------------------- *)
(* --- IDLE --- *)
(* -------------------------------------------------------------------------- *)
-
+
let on_idle = ref
(fun f -> try
while f () do Extlib.usleep 50000 (* wait for 50ms *) done
@@ -505,4 +505,3 @@ let rec run_server server () =
let launch server =
if server.scheduled > server.terminated
then ( fire server.start ; !on_idle (run_server server) )
-
diff --git a/src/libraries/utils/task.mli b/src/libraries/utils/task.mli
index fb1f38ad0738bd4dcf55596ce6818ec4abcab7ad..355f2d9368ce02efc3bc9e3f028f157f3108bdb3 100644
--- a/src/libraries/utils/task.mli
+++ b/src/libraries/utils/task.mli
@@ -46,24 +46,24 @@ val pretty : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a status -
(* ************************************************************************* *)
val nop : unit task
- (** The task that immediately returns unit *)
+(** The task that immediately returns unit *)
val return : 'a -> 'a task
- (** The task that immediately returns a result *)
+(** The task that immediately returns a result *)
val raised : exn -> 'a task
- (** The task that immediately fails with an exception *)
+(** The task that immediately fails with an exception *)
val canceled : unit -> 'a task
- (** The task that is immediately canceled *)
+(** The task that is immediately canceled *)
val failed : ('a,Format.formatter,unit,'b task) format4 -> 'a
- (** The task that immediately fails by raising a [Failure] exception.
- Typically: [[let exit d : 'a task = failed "exit status %d" k]] *)
+(** The task that immediately fails by raising a [Failure] exception.
+ Typically: [[let exit d : 'a task = failed "exit status %d" k]] *)
val call : ?canceled:('a -> unit) -> ('a -> 'b) -> 'a -> 'b task
- (** The task that, when started, invokes a function and immediately
- returns the result. *)
+(** The task that, when started, invokes a function and immediately
+ returns the result. *)
val later : ?canceled:('a -> unit) -> ('a -> 'b task) -> 'a -> 'b task
(** The task that, when started, compute a task to continue with. *)
@@ -72,31 +72,31 @@ val todo : ?canceled:(unit -> unit) -> (unit -> 'a task) -> 'a task
(** Specialized version of [later]. *)
val status : 'a status -> 'a task
- (** The task that immediately finishes with provided status *)
+(** The task that immediately finishes with provided status *)
val bind : 'a task -> ('a status -> 'b task) -> 'b task
- (** [bind t k] first runs [t]. Then, when [t] exit with status [s],
- it starts task [k s].
+(** [bind t k] first runs [t]. Then, when [t] exit with status [s],
+ it starts task [k s].
- <b>Remark:</b> If [t] was cancelled, [k s] is still evaluated, but
- immediately canceled as well. This allows [finally]-like behaviors to
- be implemented. To evaluate [k r] only when [t] terminates normally,
- make use of the [sequence] operator. *)
+ <b>Remark:</b> If [t] was cancelled, [k s] is still evaluated, but
+ immediately canceled as well. This allows [finally]-like behaviors to
+ be implemented. To evaluate [k r] only when [t] terminates normally,
+ make use of the [sequence] operator. *)
val sequence : 'a task -> ('a -> 'b task) -> 'b task
- (** [sequence t k] first runs [t]. If [t] terminates with [Result r],
- then task [k r] is started.
- Otherwise, failure or cancelation of [t] is returned. *)
+(** [sequence t k] first runs [t]. If [t] terminates with [Result r],
+ then task [k r] is started.
+ Otherwise, failure or cancelation of [t] is returned. *)
val job : 'a task -> unit task
val finally : 'a task -> ('a status -> unit) -> 'a task
- (** [finally t cb] runs task [t] and {i always} calls [cb s] when [t] exits
- with status [s]. Then [s] is returned. If the callback [cb]
- raises an exception, the returned status is emitted. *)
+(** [finally t cb] runs task [t] and {i always} calls [cb s] when [t] exits
+ with status [s]. Then [s] is returned. If the callback [cb]
+ raises an exception, the returned status is emitted. *)
val callback : 'a task -> ('a status -> unit) -> unit task
- (** Same as [finally] but the status of the task is discarded. *)
+(** Same as [finally] but the status of the task is discarded. *)
type 'a async =
| Yield (** give up the control *)
@@ -136,10 +136,10 @@ val command :
?stdout:Buffer.t ->
?stderr:Buffer.t ->
string -> string array -> int task
- (** Immediately launch a system-process.
- Default timeout is [0], which means no-timeout at all.
- Standard outputs are discarded unless optional buffers are provided.
- To make the task start later, simply use [todo (command ...)]. *)
+(** Immediately launch a system-process.
+ Default timeout is [0], which means no-timeout at all.
+ Standard outputs are discarded unless optional buffers are provided.
+ To make the task start later, simply use [todo (command ...)]. *)
(* ************************************************************************* *)
(** {2 Shared Tasks}
@@ -147,7 +147,7 @@ val command :
When two tasks [A] and [B] share a common sub-task [S],
cancelling [A] will make [B] fail either. To prevent this, it is
necessary to make [S] {i shareable} and to use two distinct {i
- instances} of [S] in [A] and [B].
+ instances} of [S] in [A] and [B].
Shared tasks manage the number of their instance and actually run
or cancel a unique task on demand. In particular, shared tasks can
@@ -156,17 +156,17 @@ val command :
@since Oxygen-20120901 *)
(* ************************************************************************* *)
-type 'a shared
- (** Shareable tasks. *)
+type 'a shared
+(** Shareable tasks. *)
-val shared : descr:string -> retry:bool -> (unit -> 'a task) -> 'a shared
+val shared : descr:string -> retry:bool -> (unit -> 'a task) -> 'a shared
(** Build a shareable task. The build function is called whenever a new
instance is required but no shared instance task is actually running.
Interrupted tasks (by Cancel or Timeout) are retried for further
instances. If the task failed, it can be re-launch if [retry] is [true].
Otherwise, further instances will return [Failed] status. *)
-val share : 'a shared -> 'a task
+val share : 'a shared -> 'a task
(** New instance of shared task. *)
(* ************************************************************************* *)
@@ -181,11 +181,11 @@ val progress : thread -> bool
(** Make the thread progress and return [true] if still running *)
val is_running : thread -> bool
-(** Don't make the thread progress, just returns [true]
+(** Don't make the thread progress, just returns [true]
if not terminated or not started yet *)
-
+
val run : thread -> unit
-(** Runs one single task in the background.
+(** Runs one single task in the background.
Typically using [on_idle]. *)
(* ************************************************************************* *)
@@ -209,23 +209,23 @@ val server :
?stages:int ->
?procs:int ->
unit -> server
- (** Creates a server of commands.
- @param stages number of queues in the server.
- Stage 0 tasks are issued first. Default is 1.
- @param procs maximum number of running tasks. Default is 4. *)
+(** Creates a server of commands.
+ @param stages number of queues in the server.
+ Stage 0 tasks are issued first. Default is 1.
+ @param procs maximum number of running tasks. Default is 4. *)
val spawn : server -> ?pool:pool -> ?stage:int -> thread -> unit
- (** Schedules a task on the server.
- The task is not immediately started. *)
+(** Schedules a task on the server.
+ The task is not immediately started. *)
val launch : server -> unit
- (** Starts the server if not running yet *)
+(** Starts the server if not running yet *)
val cancel_all : server -> unit
- (** Cancel all scheduled tasks *)
+(** Cancel all scheduled tasks *)
val set_procs : server -> int -> unit
- (** Adjusts the maximum number of running process. *)
+(** Adjusts the maximum number of running process. *)
val on_server_activity : server -> (unit -> unit) -> unit
(** Idle server callback *)
@@ -249,8 +249,7 @@ val waiting : server -> int option
(* ************************************************************************* *)
val on_idle : ((unit -> bool) -> unit) ref
- (** Typically modified by GUI.
- [!on_idle f] should repeatedly calls [f] until it returns [false].
- Default implementation rely on [Unix.sleep 1] and [Db.progress].
- See also [Gtk_helper] module implementation. *)
-
+(** Typically modified by GUI.
+ [!on_idle f] should repeatedly calls [f] until it returns [false].
+ Default implementation rely on [Unix.sleep 1] and [Db.progress].
+ See also [Gtk_helper] module implementation. *)