Browse Source

Rework release_queue API

nottui-full-sensor
Frédéric Bour 2 years ago
parent
commit
589112cfb3
  1. 51
      lib/lwd/lwd.ml
  2. 8
      lib/lwd/lwd.mli
  3. 3
      lib/nottui-lwt/nottui_lwt.ml
  4. 11
      lib/nottui/nottui.ml

51
lib/lwd/lwd.ml

@ -506,26 +506,7 @@ let flush_release_queue queue =
queue := Release_done;
raw_flush_release_queue queue'
let flush_or_fail main_exn queue =
match raw_flush_release_queue queue with
| [] -> ()
| failures -> raise (Release_failure (main_exn, failures))
let start_sub_sample queue self child =
let queue, internal_queue = match queue with
| None -> (ref Release_done, true)
| Some queue -> (queue, false)
in
match sub_sample queue self child with
| result ->
if internal_queue then
flush_or_fail None !queue;
result
| exception exn when internal_queue ->
flush_or_fail (Some exn) !queue;
raise exn
let sample ?release_queue = function
let sample queue = function
| Pure _ | Impure _ | Operator _ -> assert false
| Root t as self ->
match t.value with
@ -537,7 +518,7 @@ let sample ?release_queue = function
sub_acquire self t.child;
);
t.value <- Eval_progress;
let value = start_sub_sample release_queue self t.child in
let value = sub_sample queue self t.child in
begin match t.value with
| Eval_progress -> t.value <- Eval_some value; (* cache value *)
| Eval_none | Eval_some _ -> ()
@ -549,22 +530,14 @@ let is_damaged = function
| Root {value = Eval_some _; _} -> false
| Root {value = Eval_none | Eval_progress; _} -> true
let release ?release_queue = function
let release queue = function
| Pure _ | Impure _ | Operator _ -> assert false
| Root t as self ->
if t.acquired then (
(* release subtree, remove cached value *)
t.value <- Eval_none;
t.acquired <- false;
begin match release_queue with
| Some batch ->
batch :=
Release_more { origin = self; element = t.child; next = !batch }
| None ->
match sub_release [] self t.child with
| [] -> ()
| failures -> raise (Release_failure (None, failures))
end
queue := Release_more { origin = self; element = t.child; next = !queue }
)
let set_on_invalidate x f =
@ -572,6 +545,22 @@ let set_on_invalidate x f =
| Pure _ | Impure _ | Operator _ -> assert false
| Root t -> t.on_invalidate <- f
let flush_or_fail main_exn queue =
match flush_release_queue queue with
| [] -> ()
| failures -> raise (Release_failure (main_exn, failures))
let quick_sample root =
let queue = ref Release_done in
match sample queue root with
| result -> flush_or_fail None queue; result
| exception exn -> flush_or_fail (Some exn) queue; raise exn
let quick_release root =
let queue = ref Release_done in
release queue root;
flush_or_fail None queue
module Infix = struct
let (>>=) = bind
let (>|=) = map'

8
lib/lwd/lwd.mli

@ -106,7 +106,7 @@ val set_on_invalidate : 'a root -> ('a -> unit) -> unit
(** Change the callback for the root.
@see observe for more details. *)
val sample : ?release_queue:release_queue -> 'a root -> 'a
val sample : release_queue -> 'a root -> 'a
(** Force the computation of the value for this root.
The value is cached, so this is idempotent, until the next invalidation. *)
@ -115,10 +115,14 @@ val is_damaged : 'a root -> bool
cache. This can be the case if the value was never computed, or
if it was computed and then invalidated. *)
val release : ?release_queue:release_queue -> 'a root -> unit
val release : release_queue -> 'a root -> unit
(** Forget about this root and release sub-values no longer reachable from
any root. *)
val quick_sample : 'a root -> 'a
val quick_release : 'a root -> unit
module Infix : sig
val (>|=) : 'a t -> ('a -> 'b) -> 'b t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t

3
lib/nottui-lwt/nottui_lwt.ml

@ -44,7 +44,8 @@ let render ?quit ~size events doc =
let size = ref size in
let result, push = Lwt_stream.create () in
let refresh () =
let ui = Lwd.sample root in
(* FIXME This should use [Lwd.sample] with proper release management. *)
let ui = Lwd.quick_sample root in
Renderer.update renderer !size ui;
push (Some (Renderer.image renderer))
in

11
lib/nottui/nottui.ml

@ -734,11 +734,14 @@ module Ui_loop =
struct
open Notty_unix
(* FIXME Uses of [quick_sample] and [quick_release] should be replaced by
[sample] and [release] with the appropriate release management. *)
let step ?(process_event=true) ?(timeout=(-1.0)) ~renderer term root =
let size = Term.size term in
let image =
let rec stabilize () =
let tree = Lwd.sample root in
let tree = Lwd.quick_sample root in
Renderer.update renderer size tree;
let image = Renderer.image renderer in
if Lwd.is_damaged root
@ -771,7 +774,7 @@ struct
let quit = Lwd.observe (Lwd.get quit) in
let root = Lwd.observe t in
let rec loop () =
let quit = Lwd.sample quit in
let quit = Lwd.quick_sample quit in
if not quit then (
step ~process_event:true ?timeout:tick_period ~renderer term root;
tick ();
@ -779,8 +782,8 @@ struct
)
in
loop ();
Lwd.release root;
Lwd.release quit
ignore (Lwd.quick_release root);
ignore (Lwd.quick_release quit)
let run ?tick_period ?tick ?term ?(renderer=Renderer.make ())
?quit t =

Loading…
Cancel
Save