doc: add some comments in lwd.ml{,i}
This commit is contained in:
parent
ca24d162b9
commit
4abe78c371
132
lib/lwd/lwd.ml
132
lib/lwd/lwd.ml
|
@ -1,15 +1,24 @@
|
|||
(** Create-only version of [Obj.t] *)
|
||||
module Any : sig
|
||||
type t
|
||||
val any : 'a -> t
|
||||
end = struct
|
||||
type t = Obj.t
|
||||
let any = Obj.repr
|
||||
end
|
||||
|
||||
type 'a t =
|
||||
| Pure of 'a
|
||||
| Impure of 'a
|
||||
| Impure of 'a (* NOTE: is this really used anywhere? *)
|
||||
| Operator : {
|
||||
mutable value : 'a option;
|
||||
mutable trace : trace;
|
||||
mutable trace_idx : trace_idx;
|
||||
mutable value : 'a option; (* cached value *)
|
||||
mutable trace : trace; (* list of parents this can invalidate *)
|
||||
mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
|
||||
desc: 'a desc;
|
||||
} -> 'a t
|
||||
| Root : {
|
||||
mutable value : 'a option;
|
||||
mutable trace_idx : trace_idx;
|
||||
mutable value : 'a option; (* cached value *)
|
||||
mutable trace_idx : trace_idx; (* list of direct children that can invalidate this *)
|
||||
mutable on_invalidate : 'a -> unit;
|
||||
mutable acquired : bool;
|
||||
child : 'a t;
|
||||
|
@ -25,6 +34,7 @@ and _ desc =
|
|||
| Prim : { acquire : unit -> 'a;
|
||||
release : 'a -> unit } -> 'a desc
|
||||
|
||||
(* a set of (active) parents for a ['a t], used during invalidation *)
|
||||
and trace =
|
||||
| T0
|
||||
| T1 : _ t -> trace
|
||||
|
@ -32,8 +42,9 @@ and trace =
|
|||
| T3 : _ t * _ t * _ t -> trace
|
||||
| T4 : _ t * _ t * _ t * _ t -> trace
|
||||
| Tn : { mutable active : int; mutable count : int;
|
||||
mutable entries : Obj.t t array } -> trace
|
||||
mutable entries : Any.t t array } -> trace
|
||||
|
||||
(* a set of direct children for a composite document *)
|
||||
and trace_idx =
|
||||
| I0
|
||||
| I1 : { mutable idx : int ;
|
||||
|
@ -48,7 +59,7 @@ let impure = function
|
|||
| Pure x -> Impure x
|
||||
| other -> other
|
||||
|
||||
let dummy = Pure (Obj.repr ())
|
||||
let dummy = Pure (Any.any ())
|
||||
|
||||
let operator desc =
|
||||
Operator { value = None; trace = T0; desc; trace_idx = I0 }
|
||||
|
@ -82,71 +93,78 @@ let bind x f = join (map f x)
|
|||
(* Management of trace indices *)
|
||||
|
||||
external t_equal : _ t -> _ t -> bool = "%eq"
|
||||
external obj_t : 'a t -> Obj.t t = "%identity"
|
||||
external obj_t : 'a t -> Any.t t = "%identity"
|
||||
|
||||
let add_idx obj idx = function
|
||||
| Pure _ | Impure _ -> assert false
|
||||
| Root t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
|
||||
| Operator t' -> t'.trace_idx <- I1 { idx; obj; next = t'.trace_idx }
|
||||
|
||||
let rec rem_idx obj = function
|
||||
let rec rem_idx_rec obj = function
|
||||
| I0 -> assert false
|
||||
| I1 t as self ->
|
||||
if t_equal t.obj obj
|
||||
then (t.idx, t.next)
|
||||
else
|
||||
let idx, result = rem_idx obj t.next in
|
||||
else (
|
||||
let idx, result = rem_idx_rec obj t.next in
|
||||
t.next <- result;
|
||||
(idx, self)
|
||||
)
|
||||
|
||||
(* remove [obj] from the lwd's trace. *)
|
||||
let rem_idx obj = function
|
||||
| Pure _ | Impure _ -> assert false
|
||||
| Root t' ->
|
||||
let idx, trace_idx = rem_idx obj t'.trace_idx in
|
||||
let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
|
||||
t'.trace_idx <- trace_idx; idx
|
||||
| Operator t' ->
|
||||
let idx, trace_idx = rem_idx obj t'.trace_idx in
|
||||
let idx, trace_idx = rem_idx_rec obj t'.trace_idx in
|
||||
t'.trace_idx <- trace_idx; idx
|
||||
|
||||
let rec mov_idx obj oldidx newidx = function
|
||||
(* move [obj] from old index to new index. *)
|
||||
let rec mov_idx_rec obj oldidx newidx = function
|
||||
| I0 -> assert false
|
||||
| I1 t ->
|
||||
if t.idx = oldidx && t_equal t.obj obj
|
||||
then t.idx <- newidx
|
||||
else mov_idx obj oldidx newidx t.next
|
||||
else mov_idx_rec obj oldidx newidx t.next
|
||||
|
||||
let mov_idx obj oldidx newidx = function
|
||||
| Pure _ | Impure _ -> assert false
|
||||
| Root t' -> mov_idx obj oldidx newidx t'.trace_idx
|
||||
| Operator t' -> mov_idx obj oldidx newidx t'.trace_idx
|
||||
| Root t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
|
||||
| Operator t' -> mov_idx_rec obj oldidx newidx t'.trace_idx
|
||||
|
||||
let rec get_idx obj = function
|
||||
let rec get_idx_rec obj = function
|
||||
| I0 -> assert false
|
||||
| I1 t ->
|
||||
if t_equal t.obj obj
|
||||
then t.idx
|
||||
else get_idx obj t.next
|
||||
else get_idx_rec obj t.next
|
||||
|
||||
(* find index of [obj] in the given lwd *)
|
||||
let get_idx obj = function
|
||||
| Pure _ | Impure _ -> assert false
|
||||
| Root t' -> get_idx obj t'.trace_idx
|
||||
| Operator t' -> get_idx obj t'.trace_idx
|
||||
| Root t' -> get_idx_rec obj t'.trace_idx
|
||||
| Operator t' -> get_idx_rec obj t'.trace_idx
|
||||
|
||||
(* Propagating invalidation *)
|
||||
(* Propagating invalidation recursively.
|
||||
Each document is invalidated at most once,
|
||||
and only if it has [t.value = Some _]. *)
|
||||
let rec invalidate_node : type a . a t -> unit = function
|
||||
| Pure _ | Impure _ -> assert false
|
||||
| Root { value = None; _ } -> ()
|
||||
| Root ({ value = Some x; _ } as t) ->
|
||||
t.value <- None;
|
||||
t.on_invalidate x
|
||||
t.on_invalidate x (* user callback that {i observes} this root. *)
|
||||
| Operator t ->
|
||||
begin match t.value with
|
||||
| None -> ()
|
||||
| Some _ ->
|
||||
t.value <- None;
|
||||
invalidate_trace t.trace
|
||||
invalidate_trace t.trace; (* invalidate parents recursively *)
|
||||
end
|
||||
|
||||
(* invalidate recursively documents in the given trace *)
|
||||
and invalidate_trace = function
|
||||
| T0 -> ()
|
||||
| T1 x -> invalidate_node x
|
||||
|
@ -174,9 +192,10 @@ type 'a var = 'a t
|
|||
let var x = operator (Var {binding = x})
|
||||
let get x = x
|
||||
|
||||
let set vx x =
|
||||
let set (vx:_ var) x : unit =
|
||||
match vx with
|
||||
| Operator ({desc = Var v; _}) ->
|
||||
(* set the variable, and invalidate all observers *)
|
||||
invalidate_node vx;
|
||||
v.binding <- x
|
||||
| _ -> assert false
|
||||
|
@ -195,6 +214,7 @@ let invalidate = function
|
|||
| Operator ({ desc = Prim p; _ } as t) ->
|
||||
let value = t.value in
|
||||
t.value <- None;
|
||||
(* the value is invalidated, be sure to invalidate all parents as well *)
|
||||
invalidate_trace t.trace;
|
||||
begin match value with
|
||||
| None -> ()
|
||||
|
@ -205,7 +225,11 @@ let invalidate = function
|
|||
type release_failure = exn * Printexc.raw_backtrace
|
||||
exception Release_failure of release_failure list
|
||||
|
||||
(* [sub_release] cannot raise.
|
||||
(* [sub_release [] origin self] is called when [origin] is released,
|
||||
where [origin] is reachable from [self]'s trace.
|
||||
We're going to remove [origin] from that trace as [origin] is now dead.
|
||||
|
||||
[sub_release] cannot raise.
|
||||
If a primitive raises, the exception is caught and a warning is emitted. *)
|
||||
let rec sub_release
|
||||
: type a b . release_failure list -> a t -> b t -> release_failure list
|
||||
|
@ -213,6 +237,7 @@ let rec sub_release
|
|||
| Root _ -> assert false
|
||||
| Pure _ | Impure _ -> failures
|
||||
| Operator t as self ->
|
||||
(* compute [t.trace \ {origin}] *)
|
||||
let trace = match t.trace with
|
||||
| T0 -> assert false
|
||||
| T1 x -> assert (t_equal x origin); T0
|
||||
|
@ -243,6 +268,7 @@ let rec sub_release
|
|||
tn.entries.(count) <- dummy;
|
||||
if tn.active > count then tn.active <- count;
|
||||
if count = 4 then (
|
||||
(* downgrade to [T4] to save space *)
|
||||
let a = tn.entries.(0) and b = tn.entries.(1) in
|
||||
let c = tn.entries.(2) and d = tn.entries.(3) in
|
||||
ignore (rem_idx self a : int);
|
||||
|
@ -250,17 +276,21 @@ let rec sub_release
|
|||
ignore (rem_idx self c : int);
|
||||
ignore (rem_idx self d : int);
|
||||
T4 (a, b, c, d)
|
||||
) else
|
||||
) else (
|
||||
let len = Array.length tn.entries in
|
||||
if count <= len lsr 2 then
|
||||
Tn { active = tn.active; count = tn.count;
|
||||
entries = Array.sub tn.entries 0 (len lsr 1) }
|
||||
else
|
||||
trace
|
||||
)
|
||||
in
|
||||
t.trace <- trace;
|
||||
match trace with
|
||||
| T0 ->
|
||||
(* [self] is not active anymore, since it's not reachable
|
||||
from any root. We can release its cached value and
|
||||
recursively release its subtree. *)
|
||||
let value = t.value in
|
||||
t.value <- None;
|
||||
begin match t.desc with
|
||||
|
@ -300,6 +330,8 @@ let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
|
|||
| Root _ -> assert false
|
||||
| Pure _ | Impure _ -> ()
|
||||
| Operator t as self ->
|
||||
(* [acquire] is true if this is the first time this operator
|
||||
is used, in which case we need to acquire its children *)
|
||||
let acquire = match t.trace with T0 -> true | _ -> false in
|
||||
let trace = match t.trace with
|
||||
| T0 -> T1 origin
|
||||
|
@ -307,15 +339,16 @@ let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
|
|||
| T2 (x, y) -> T3 (origin, x, y)
|
||||
| T3 (x, y, z) -> T4 (origin, x, y, z)
|
||||
| T4 (x, y, z, w) ->
|
||||
let obj = obj_t origin in
|
||||
let obj_origin = obj_t origin in
|
||||
let entries =
|
||||
[| obj_t x; obj_t y; obj_t z; obj_t w; obj; dummy; dummy; dummy |]
|
||||
[| obj_t x; obj_t y; obj_t z; obj_t w; obj_origin; dummy; dummy; dummy |]
|
||||
in
|
||||
for i = 0 to 4 do add_idx self i entries.(i) done;
|
||||
Tn { active = 5; count = 5; entries }
|
||||
| Tn tn as trace ->
|
||||
let index = tn.count in
|
||||
let entries, trace =
|
||||
(* possibly resize array [entries] *)
|
||||
if index < Array.length tn.entries then (
|
||||
tn.count <- tn.count + 1;
|
||||
(tn.entries, trace)
|
||||
|
@ -325,13 +358,14 @@ let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
|
|||
(entries, Tn { active = tn.active; count = index + 1; entries })
|
||||
)
|
||||
in
|
||||
let obj = obj_t origin in
|
||||
entries.(index) <- obj;
|
||||
add_idx self index obj;
|
||||
let obj_origin = obj_t origin in
|
||||
entries.(index) <- obj_origin;
|
||||
add_idx self index obj_origin;
|
||||
trace
|
||||
in
|
||||
t.trace <- trace;
|
||||
if acquire then
|
||||
if acquire then (
|
||||
(* acquire immediate children, and so on recursively *)
|
||||
match t.desc with
|
||||
| Map (x, _) -> sub_acquire self x
|
||||
| Map2 (x, y, _) ->
|
||||
|
@ -347,18 +381,25 @@ let rec sub_acquire : type a b . a t -> b t -> unit = fun origin ->
|
|||
sub_acquire self child;
|
||||
begin match intermediate with
|
||||
| None -> ()
|
||||
| Some _ -> assert false
|
||||
| Some _ ->
|
||||
assert false (* this can't initialized already, first-time acquire *)
|
||||
end
|
||||
| Var _ -> ()
|
||||
| Prim _ -> ()
|
||||
)
|
||||
|
||||
(* make sure that [origin] is in [self.trace], passed as last arg. *)
|
||||
let activate_tracing self origin = function
|
||||
| Tn tn ->
|
||||
let idx = get_idx self origin in
|
||||
let idx = get_idx self origin in (* index of [self] in [origin.trace_idx] *)
|
||||
let active = tn.active in
|
||||
if idx >= active then
|
||||
(* [idx < active] means [self] is already traced by [origin].
|
||||
We only have to add [self] to the entries if [idx >= active]. *)
|
||||
if idx >= active then (
|
||||
tn.active <- active + 1;
|
||||
);
|
||||
if idx > active then (
|
||||
(* swap with last entry in [tn.entries] *)
|
||||
let old = tn.entries.(active) in
|
||||
tn.entries.(idx) <- old;
|
||||
tn.entries.(active) <- obj_t origin;
|
||||
|
@ -367,7 +408,9 @@ let activate_tracing self origin = function
|
|||
)
|
||||
| _ -> ()
|
||||
|
||||
(* [sub_sample] raise if any user-provided computation raises.
|
||||
(* [sub_sample origin self] computes a value for [self].
|
||||
|
||||
[sub_sample] raise if any user-provided computation raises.
|
||||
Graph will be left in a coherent state but exception will be propagated
|
||||
to the observer. *)
|
||||
let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
|
||||
|
@ -375,6 +418,7 @@ let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
|
|||
| Root _ -> assert false
|
||||
| Pure x | Impure x -> x
|
||||
| Operator t as self ->
|
||||
(* try to use cached value, if present *)
|
||||
match t.value with
|
||||
| Some value -> value
|
||||
| None ->
|
||||
|
@ -396,6 +440,8 @@ let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
|
|||
begin match old_intermediate with
|
||||
| None -> result
|
||||
| Some x' ->
|
||||
(* NOTE: if [intermediate==x'], should we stop there? *)
|
||||
(* release old value [x'], catching potential exceptions *)
|
||||
match sub_release [] self x' with
|
||||
| [] -> result
|
||||
| failures ->
|
||||
|
@ -409,12 +455,16 @@ let rec sub_sample : type a b . a t -> b t -> b = fun origin ->
|
|||
| Prim t -> t.acquire ()
|
||||
in
|
||||
t.value <- Some value;
|
||||
(* [self] just became active, so it may invalidate [origin] in case its
|
||||
value changes because of [t.desc], like if it's a variable and gets
|
||||
mutated, or if it's a primitive that gets invalidated.
|
||||
We need to put [origin] into [self.trace] in case it isn't there yet. *)
|
||||
activate_tracing self origin t.trace;
|
||||
value
|
||||
|
||||
type 'a root = 'a t
|
||||
|
||||
let observe ?(on_invalidate=ignore) child =
|
||||
let observe ?(on_invalidate=ignore) child : _ root =
|
||||
let root = Root {
|
||||
child = child;
|
||||
value = None;
|
||||
|
@ -430,12 +480,13 @@ let sample = function
|
|||
match t.value with
|
||||
| Some value -> value
|
||||
| None ->
|
||||
(* no cached value, compute it now *)
|
||||
if not t.acquired then (
|
||||
t.acquired <- true;
|
||||
sub_acquire self t.child;
|
||||
);
|
||||
let value = sub_sample self t.child in
|
||||
t.value <- Some value;
|
||||
t.value <- Some value; (* cache value *)
|
||||
value
|
||||
|
||||
let is_damaged = function
|
||||
|
@ -447,6 +498,7 @@ let release = function
|
|||
| Pure _ | Impure _ | Operator _ -> assert false
|
||||
| Root t as self ->
|
||||
if t.acquired then (
|
||||
(* release subtree, remove cached value *)
|
||||
t.value <- None;
|
||||
t.acquired <- false;
|
||||
match sub_release [] self t.child with
|
||||
|
|
|
@ -1,25 +1,86 @@
|
|||
type 'a t
|
||||
(** A dynamic document of type ['a]. Documents can be produced in several
|
||||
different ways:
|
||||
|
||||
- operators, such as {!map}, {!bind}, {!app}, {!pair}, etc.
|
||||
combine several documents into one. The result is (lazily)
|
||||
updated whenever the sub-documents are.
|
||||
|
||||
- variables {!var}, a mutable reference.
|
||||
- primitive documents {!prim}, providing custom leaves to trees of
|
||||
documents.
|
||||
*)
|
||||
|
||||
val return : 'a -> 'a t
|
||||
(** The content document with the given value inside *)
|
||||
|
||||
val pure : 'a -> 'a t
|
||||
(** Alias to {!return} *)
|
||||
|
||||
val map : ('a -> 'b) -> 'a t -> 'b t
|
||||
(** [map f d] is the document that has value [f x] whenever [d] has value [x] *)
|
||||
|
||||
val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
|
||||
(** [map2 f d1 d2] is the document that has value [f x y] whenever
|
||||
[d1] has value [x1] and [d2] has value [x2] *)
|
||||
|
||||
val map' : 'a t -> ('a -> 'b) -> 'b t
|
||||
(** Alias to {!map} with arguments flipped *)
|
||||
|
||||
val map2' : 'a t -> 'b t -> ('a -> 'b -> 'c) -> 'c t
|
||||
(** Alias to {!map2} with arguments flipped *)
|
||||
|
||||
val join : 'a t t -> 'a t
|
||||
(** Monadic operator [join d] is the document pointed to by document [d].
|
||||
This is powerful but potentially costly in case of recomputation.
|
||||
*)
|
||||
|
||||
val bind : 'a t -> ('a -> 'b t) -> 'b t
|
||||
(** Monadic bind, a mix of {!join} and {!map} *)
|
||||
|
||||
val app : ('a -> 'b) t -> 'a t -> 'b t
|
||||
(** Applicative: [app df dx] is the document that has value [f x]
|
||||
whenever [df] has value [f] and [dx] has value [x] *)
|
||||
|
||||
val pair : 'a t -> 'b t -> ('a * 'b) t
|
||||
(** [pair a b] is [map2 (fun x y->x,y) a b] *)
|
||||
|
||||
val impure : 'a t -> 'a t
|
||||
|
||||
type 'a var
|
||||
(** The workhorse of Lwd: a mutable variable that also tracks dependencies.
|
||||
Every time {!set} is called, all documents that depend on this variable
|
||||
via {!map}, {!bind}, etc. will be at least partially invalidated
|
||||
and will be recomputed incrementally on demand. *)
|
||||
|
||||
val var : 'a -> 'a var
|
||||
(** Create a new variable with the given initial value *)
|
||||
|
||||
val get : 'a var -> 'a t
|
||||
(** A document that reflects the current content of a variable *)
|
||||
|
||||
val set : 'a var -> 'a -> unit
|
||||
val peek : 'a var -> 'a
|
||||
(** Change the variable's content, invalidating all documents depending
|
||||
on it. *)
|
||||
|
||||
val peek : 'a var -> 'a
|
||||
(** Observe the current value of the variable, without any dependency
|
||||
tracking. *)
|
||||
|
||||
type 'a prim
|
||||
(** A primitive document. It can correspond, for example, to
|
||||
a primitive UI element.
|
||||
|
||||
A primitive is a resource with [acquire] and [release] functions
|
||||
to manage its lifecycle. *)
|
||||
|
||||
val prim : acquire:(unit -> 'a) -> release:('a -> unit) -> 'a prim
|
||||
(** create a new primitive document.
|
||||
@param acquire is called when the document becomes observed (indirectly)
|
||||
via at least one {!root}.
|
||||
@param release is called when the document is no longer observed.
|
||||
Internal resources can be freed. *)
|
||||
|
||||
val get_prim : 'a prim -> 'a t
|
||||
val invalidate : 'a prim -> unit
|
||||
|
||||
|
@ -27,9 +88,27 @@ type release_failure = exn * Printexc.raw_backtrace
|
|||
exception Release_failure of release_failure list
|
||||
|
||||
type 'a root
|
||||
(** A root of computation, whose value(s) over time we're interested in. *)
|
||||
|
||||
val observe : ?on_invalidate:('a -> unit) -> 'a t -> 'a root
|
||||
(** [observe x] creates a root that contains document [x].
|
||||
@param on_invalidate is called whenever the root is invalidated
|
||||
because the content of [x] has changed. This can be useful to
|
||||
perform side-effects such as re-rendering some UI. *)
|
||||
|
||||
val set_on_invalidate : 'a root -> ('a -> unit) -> unit
|
||||
(** Change the callback for the root.
|
||||
@see observe for more details. *)
|
||||
|
||||
val sample : 'a root -> 'a
|
||||
(** Force the computation of the value for this root.
|
||||
The value is cached, so this is idempotent, until the next invalidation. *)
|
||||
|
||||
val is_damaged : 'a root -> bool
|
||||
(** [is_damaged root] is true if the root doesn't have a valid value in
|
||||
cache. This can be the case if the value was never computed, or
|
||||
if it was computed and then invalidated. *)
|
||||
|
||||
val release : 'a root -> unit
|
||||
(** Forget about this root and release sub-values no longer reachable from
|
||||
any root. *)
|
||||
|
|
Loading…
Reference in New Issue