diff --git a/vendor/lwd/LICENSE b/vendor/lwd/LICENSE new file mode 100644 index 000000000000..d9cc7c86a51e --- /dev/null +++ b/vendor/lwd/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Frédéric Bour + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/vendor/lwd/lwd/dune b/vendor/lwd/lwd/dune new file mode 100644 index 000000000000..a0a0d1ecd01d --- /dev/null +++ b/vendor/lwd/lwd/dune @@ -0,0 +1,4 @@ +(library + (name dune_lwd) + (modules lwd lwd_utils) + (wrapped false)) diff --git a/vendor/lwd/lwd/lwd.ml b/vendor/lwd/lwd/lwd.ml new file mode 100644 index 000000000000..3c77a27dab88 --- /dev/null +++ b/vendor/lwd/lwd/lwd.ml @@ -0,0 +1,711 @@ +(** 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 eval = + | Eval_none + | Eval_progress + | Eval_some of 'a + +type 'a t_ = + | Pure of 'a + | Operator : { + mutable value : 'a eval; (* 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 eval; (* 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_; + } -> 'a t_ + +and _ desc = + | Map : 'a t_ * ('a -> 'b) -> 'b desc + | Map2 : 'a t_ * 'b t_ * ('a -> 'b -> 'c) -> 'c desc + | Pair : 'a t_ * 'b t_ -> ('a * 'b) desc + | App : ('a -> 'b) t_ * 'a t_ -> 'b desc + | Join : { child : 'a t_ t_; mutable intermediate : 'a t_ option } -> 'a desc + | Var : { mutable binding : 'a } -> 'a desc + | Prim : { acquire : 'a t -> 'a; + release : 'a t -> 'a -> unit } -> 'a desc + | Fix : { doc : 'a t_; wrt : _ t_ } -> 'a desc + +(* a set of (active) parents for a ['a t], used during invalidation *) +and trace = + | T0 + | T1 : _ t_ -> trace + | T2 : _ t_ * _ t_ -> trace + | T3 : _ t_ * _ t_ * _ t_ -> trace + | T4 : _ t_ * _ t_ * _ t_ * _ t_ -> trace + | Tn : { mutable active : int; mutable count : int; + mutable entries : Any.t t_ array } -> trace + +(* a set of direct children for a composite document *) +and trace_idx = + | I0 + | I1 : { mutable idx : int ; + obj : 'a t_; + mutable next : trace_idx } -> trace_idx + +(* The type system cannot see that t is covariant in its parameter. + Use the Force to convince it. *) +and +'a t +external inj : 'a t_ -> 'a t = "%identity" +external prj : 'a t -> 'a t_ = "%identity" +external prj2 : 'a t t -> 'a t_ t_ = "%identity" + +(* Basic combinators *) +let return x = inj (Pure x) +let pure x = inj (Pure x) + +let is_pure x = match prj x with + | Pure x -> Some x + | _ -> None + +let dummy = Pure (Any.any ()) + +let operator desc = + Operator { value = Eval_none; trace = T0; desc; trace_idx = I0 } + +let map x ~f = inj ( + match prj x with + | Pure vx -> Pure (f vx) + | x -> operator (Map (x, f)) + ) + +let map2 x y ~f = inj ( + match prj x, prj y with + | Pure vx, Pure vy -> Pure (f vx vy) + | x, y -> operator (Map2 (x, y, f)) + ) + +let pair x y = inj ( + match prj x, prj y with + | Pure vx, Pure vy -> Pure (vx, vy) + | x, y -> operator (Pair (x, y)) + ) + +let app f x = inj ( + match prj f, prj x with + | Pure vf, Pure vx -> Pure (vf vx) + | f, x -> operator (App (f, x)) + ) + +let join child = inj ( + match prj2 child with + | Pure v -> v + | child -> operator (Join { child; intermediate = None }) + ) + +let bind x ~f = join (map ~f x) + +(* Management of trace indices *) + +let addr oc obj = + Printf.fprintf oc "0x%08x" (Obj.magic obj : int) + +external t_equal : _ t_ -> _ t_ -> bool = "%eq" +external obj_t : 'a t_ -> Any.t t_ = "%identity" + +let rec dump_trace : type a. a t_ -> unit = + fun obj -> match obj with + | Pure _ -> Printf.eprintf "%a: Pure _\n%!" addr obj + | Operator t -> + Printf.eprintf "%a: Operator _ -> %a\n%!" addr obj dump_trace_aux t.trace; + begin match t.trace with + | T0 -> () + | T1 a -> dump_trace a + | T2 (a,b) -> dump_trace a; dump_trace b + | T3 (a,b,c) -> dump_trace a; dump_trace b; dump_trace c + | T4 (a,b,c,d) -> dump_trace a; dump_trace b; dump_trace c; dump_trace d + | Tn t -> Array.iter dump_trace t.entries + end + | Root _ -> Printf.eprintf "%a: Root _\n%!" addr obj + +and dump_trace_aux oc = function + | T0 -> Printf.fprintf oc "T0" + | T1 a -> Printf.fprintf oc "T1 %a" addr a + | T2 (a,b) -> + Printf.fprintf oc "T2 (%a, %a)" addr a addr b + | T3 (a,b,c) -> + Printf.fprintf oc "T3 (%a, %a, %a)" addr a addr b addr c + | T4 (a,b,c,d) -> + Printf.fprintf oc "T4 (%a, %a, %a, %a)" addr a addr b addr c addr d + | Tn t -> + Printf.fprintf oc "Tn {active = %d; count = %d; entries = " + t.active t.count; + Array.iter (Printf.fprintf oc "(%a)" addr) t.entries; + Printf.fprintf oc "}" + +let dump_trace x = dump_trace (obj_t (prj x)) + +let add_idx obj idx = function + | Pure _ -> 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_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_rec obj t.next in + t.next <- result; + (idx, self) + ) + +(* remove [obj] from the lwd's trace. *) +let rem_idx obj = function + | Pure _ -> assert false + | Root t' -> + 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_rec obj t'.trace_idx in + t'.trace_idx <- trace_idx; idx + +(* 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_rec obj oldidx newidx t.next + +let mov_idx obj oldidx newidx = function + | Pure _ -> assert false + | 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_rec obj = function + | I0 -> assert false + | I1 t -> + if t_equal t.obj obj + then t.idx + else get_idx_rec obj t.next + +(* find index of [obj] in the given lwd *) +let get_idx obj = function + | Pure _ -> assert false + | Root t' -> get_idx_rec obj t'.trace_idx + | Operator t' -> get_idx_rec obj t'.trace_idx + +type status = + | Neutral + | Safe + | Unsafe + +type sensitivity = + | Strong + | Fragile + +(* Propagating invalidation recursively. + Each document is invalidated at most once, + and only if it has [t.value = Some _]. *) +let rec invalidate_node : type a . status ref -> sensitivity -> a t_ -> unit = + fun status sensitivity node -> + match node, sensitivity with + | Pure _, _ -> assert false + | Root ({value; _} as t), _ -> + t.value <- Eval_none; + begin match value with + | Eval_none -> () + | Eval_progress -> + status := Unsafe + | Eval_some x -> + begin match sensitivity with + | Strong -> () + | Fragile -> status := Unsafe + end; + t.on_invalidate x (* user callback that {i observes} this root. *) + end + | Operator {value = Eval_none; _}, Fragile -> + begin match !status with + | Unsafe | Safe -> () + | _ -> status := Safe + end + | Operator {value = Eval_none; _}, _ -> () + | Operator {desc = Fix {wrt = Operator {value = Eval_none; _}; _}; _}, Fragile -> + begin match !status with + | Safe | Unsafe -> () + | Neutral -> status := Safe + end + | Operator {desc = Fix {wrt = Operator {value = Eval_some _; _}; _}; _}, Fragile -> + () + | Operator t, _ -> + let sensitivity = + match t.value with Eval_progress -> Fragile | _ -> sensitivity + in + t.value <- Eval_none; + (* invalidate parents recursively *) + invalidate_trace status sensitivity t.trace + +(* invalidate recursively documents in the given trace *) +and invalidate_trace status sensitivity = function + | T0 -> () + | T1 x -> invalidate_node status sensitivity x + | T2 (x, y) -> + invalidate_node status sensitivity x; + invalidate_node status sensitivity y + | T3 (x, y, z) -> + invalidate_node status sensitivity x; + invalidate_node status sensitivity y; + invalidate_node status sensitivity z + | T4 (x, y, z, w) -> + invalidate_node status sensitivity x; + invalidate_node status sensitivity y; + invalidate_node status sensitivity z; + invalidate_node status sensitivity w + | Tn t -> + let active = t.active in + t.active <- 0; + for i = 0 to active - 1 do + invalidate_node status sensitivity t.entries.(i) + done + +let default_unsafe_mutation_logger () = + let callstack = Printexc.get_callstack 20 in + Printf.fprintf stderr + "Lwd: unsafe mutation (variable invalidated during evaluation) at\n%a" + Printexc.print_raw_backtrace callstack + +let unsafe_mutation_logger = ref default_unsafe_mutation_logger + +let do_invalidate sensitivity node = + let status = ref Neutral in + invalidate_node status sensitivity node; + let unsafe = + match !status with + | Neutral | Safe -> false + | Unsafe -> true + in + if unsafe then !unsafe_mutation_logger () + +(* Variables *) +type 'a var = 'a t_ +let var x = operator (Var {binding = x}) +let get x = inj x + +let set (vx:_ var) x : unit = + match vx with + | Operator ({desc = Var v; _}) -> + (* set the variable, and invalidate all observers *) + do_invalidate Strong vx; + v.binding <- x + | _ -> assert false + +let peek = function + | Operator ({desc = Var v; _}) -> v.binding + | _ -> assert false + +(* Primitives *) +type 'a prim = 'a t +let prim ~acquire ~release = + inj (operator (Prim { acquire; release })) +let get_prim x = x + +let invalidate x = match prj x with + | Operator {desc = Prim p; value; _} as t -> + (* the value is invalidated, be sure to invalidate all parents as well *) + begin match value with + | Eval_none -> () + | Eval_progress -> do_invalidate Fragile t; + | Eval_some v -> + do_invalidate Strong t; + p.release x v + end + | _ -> assert false + +(* Fix point *) + +let fix doc ~wrt = match prj wrt with + | Root _ -> assert false + | Pure _ -> doc + | Operator _ as wrt -> inj (operator (Fix {doc = prj doc; wrt})) + +type release_list = + | Release_done + | Release_more : + { origin : 'a t_; element : 'b t_; next : release_list } -> release_list + +type release_queue = release_list ref +let make_release_queue () = ref Release_done + +type release_failure = exn * Printexc.raw_backtrace + +(* [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 + = fun failures origin -> function + | Root _ -> assert false + | Pure _ -> 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 + | T2 (x, y) -> + if t_equal x origin then T1 y + else if t_equal y origin then T1 x + else assert false + | T3 (x, y, z) -> + if t_equal x origin then T2 (y, z) + else if t_equal y origin then T2 (x, z) + else if t_equal z origin then T2 (x, y) + else assert false + | T4 (x, y, z, w) -> + if t_equal x origin then T3 (y, z, w) + else if t_equal y origin then T3 (x, z, w) + else if t_equal z origin then T3 (x, y, w) + else if t_equal w origin then T3 (x, y, z) + else assert false + | Tn tn as trace -> + let revidx = rem_idx self origin in + assert (t_equal tn.entries.(revidx) origin); + let count = tn.count - 1 in + tn.count <- count; + if revidx < count then ( + let obj = tn.entries.(count) in + tn.entries.(revidx) <- obj; + tn.entries.(count) <- dummy; + mov_idx self count revidx obj + ) else + tn.entries.(revidx) <- 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); + ignore (rem_idx self b : int); + ignore (rem_idx self c : int); + ignore (rem_idx self d : int); + T4 (a, b, c, d) + ) 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 <- Eval_progress; + begin match t.desc with + | Map (x, _) -> sub_release failures self x + | Map2 (x, y, _) -> + sub_release (sub_release failures self x) self y + | Pair (x, y) -> + sub_release (sub_release failures self x) self y + | App (x, y) -> + sub_release (sub_release failures self x) self y + | Join ({ child; intermediate } as t) -> + let failures = sub_release failures self child in + begin match intermediate with + | None -> failures + | Some child' -> + t.intermediate <- None; + sub_release failures self child' + end + | Var _ -> failures + | Fix {doc; wrt} -> + sub_release (sub_release failures self wrt) self doc + | Prim t -> + begin match value with + | Eval_none | Eval_progress -> failures + | Eval_some x -> + begin match t.release (inj self) x with + | () -> failures + | exception exn -> + let bt = Printexc.get_raw_backtrace () in + (exn, bt) :: failures + end + end + end + | _ -> failures + +(* [sub_acquire] cannot raise *) +let rec sub_acquire : type a b . a t_ -> b t_ -> unit = fun origin -> + function + | Root _ -> assert false + | Pure _ -> () + | 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 + | T1 x -> T2 (origin, x) + | T2 (x, y) -> T3 (origin, x, y) + | T3 (x, y, z) -> T4 (origin, x, y, z) + | T4 (x, y, z, w) -> + let obj_origin = obj_t origin in + let entries = + [| 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) + ) else ( + let entries = Array.make (index * 2) dummy in + Array.blit tn.entries 0 entries 0 index; + (entries, Tn { active = tn.active; count = index + 1; entries }) + ) + in + 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 ( + (* acquire immediate children, and so on recursively *) + match t.desc with + | Map (x, _) -> sub_acquire self x + | Map2 (x, y, _) -> + sub_acquire self x; + sub_acquire self y + | Pair (x, y) -> + sub_acquire self x; + sub_acquire self y + | App (x, y) -> + sub_acquire self x; + sub_acquire self y + | Fix {doc; wrt} -> + sub_acquire self doc; + sub_acquire self wrt + | Join { child; intermediate } -> + sub_acquire self child; + begin match intermediate with + | None -> () + | 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 (* index of [self] in [origin.trace_idx] *) + let active = tn.active in + (* [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; + mov_idx self active idx old; + mov_idx self idx active origin + ) + | _ -> () + +let sub_is_damaged = function + | Root _ -> assert false + | Pure _ -> false + | Operator {value; _} -> + match value with + | Eval_none -> true + | Eval_some _ -> false + | Eval_progress -> assert false + +(* [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 sub_sample queue = + let rec aux : type a b . a t_ -> b t_ -> b = fun origin -> + function + | Root _ -> assert false + | Pure x -> x + | Operator t as self -> + (* try to use cached value, if present *) + match t.value with + | Eval_some value -> + activate_tracing self origin t.trace; + value + | _ -> + t.value <- Eval_progress; + let result : b = match t.desc with + | Map (x, f) -> f (aux self x) + | Map2 (x, y, f) -> f (aux self x) (aux self y) + | Pair (x, y) -> (aux self x, aux self y) + | App (f, x) -> (aux self f) (aux self x) + | Fix {doc; wrt} -> + let _ = aux self wrt in + let result = aux self doc in + if sub_is_damaged wrt then + aux origin self + else ( + if sub_is_damaged doc then + do_invalidate Fragile self; + result + ) + | Join x -> + let intermediate = + (* We haven't touched any state yet, + it is safe for [aux] to raise *) + aux self x.child + in + begin match x.intermediate with + | None -> + x.intermediate <- Some intermediate; + sub_acquire self intermediate; + | Some x' when x' != intermediate -> + queue := Release_more { + origin = self; + element = x'; + next = !queue; + }; + x.intermediate <- Some intermediate; + sub_acquire self intermediate; + | Some _ -> () + end; + aux self intermediate + | Var x -> x.binding + | Prim t -> t.acquire (inj self) + in + begin match t.value with + | Eval_progress -> t.value <- Eval_some result; + | Eval_none | Eval_some _ -> () + end; + (* [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; + result + in + aux + +type 'a root = 'a t + +let observe ?(on_invalidate=ignore) child : _ root = + let root = Root { + child = prj child; + value = Eval_none; + on_invalidate; + trace_idx = I0; + acquired = false; + } in + inj root + +exception Release_failure of exn option * release_failure list + +let raw_flush_release_queue queue = + let rec aux failures = function + | Release_done -> failures + | Release_more t -> + let failures = sub_release failures t.origin t.element in + aux failures t.next + in + aux [] queue + +let flush_release_queue queue = + let queue' = !queue in + queue := Release_done; + raw_flush_release_queue queue' + +let sample queue x = match prj x with + | Pure _ | Operator _ -> assert false + | Root t as self -> + match t.value with + | Eval_some value -> value + | _ -> + (* no cached value, compute it now *) + if not t.acquired then ( + t.acquired <- true; + sub_acquire self t.child; + ); + t.value <- Eval_progress; + 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 _ -> () + end; + value + +let is_damaged x = match prj x with + | Pure _ | Operator _ -> assert false + | Root {value = Eval_some _; _} -> false + | Root {value = Eval_none | Eval_progress; _} -> true + +let release queue x = match prj x with + | Pure _ | Operator _ -> assert false + | Root t as self -> + if t.acquired then ( + (* release subtree, remove cached value *) + t.value <- Eval_none; + t.acquired <- false; + queue := Release_more { origin = self; element = t.child; next = !queue } + ) + +let set_on_invalidate x f = + match prj x with + | Pure _ | 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 (>>=) x f = bind x ~f + let (>|=) x f = map x ~f + let (<*>) = app +end + +(*$R + let x = var 0 in + let y = map ~f:succ (get x) in + let o_y = Lwd.observe y in + assert_equal 1 (quick_sample o_y); + set x 10; + assert_equal 11 (quick_sample o_y); + *) diff --git a/vendor/lwd/lwd/lwd.mli b/vendor/lwd/lwd/lwd.mli new file mode 100644 index 000000000000..386dde335858 --- /dev/null +++ b/vendor/lwd/lwd/lwd.mli @@ -0,0 +1,146 @@ +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 t -> f:('a -> 'b) -> 'b t +(** [map d ~f] is the document that has value [f x] whenever [d] has value [x] *) + +val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t +(** [map2 d1 d2 ~f] is the document that has value [f x1 x2] whenever + [d1] has value [x1] and [d2] has value [x2] *) + +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 -> f:('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 is_pure : 'a t -> 'a option +(** [is_pure x] will return [Some v] if [x] was built with [pure v] or + [return v]. + + Normal code should not rely on the "reactive-ness" of a value, but this is + often useful for optimising reactive data structures. +*) + +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 +(** 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:('a prim -> 'a) -> release:('a prim -> 'a -> unit) -> 'a prim +(** create a new primitive document. + @param acquire is called when the document becomes observed (indirectly) + via at least one {!root}. The resulting primitive is passed as an argument + to support certain recursive use cases. + @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 + +(** Some document might change variables during their evaluation. + These are called "unstable" documents. + + Evaluating these might need many passes to eventually converge to a value. + The `fix` operator tries to stabilize a sub-document by repeating + evaluation until a stable condition is reached. +*) +val fix : 'a t -> wrt:_ t -> 'a t + +val default_unsafe_mutation_logger : unit -> unit +val unsafe_mutation_logger : (unit -> unit) ref + +(** Releasing unused graphs *) +type release_failure = exn * Printexc.raw_backtrace + +exception Release_failure of exn option * release_failure list + +type release_queue +val make_release_queue : unit -> release_queue +val flush_release_queue : release_queue -> 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 : 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. *) + +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 : 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 + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +end + +(* For debug purposes *) +val dump_trace : 'a t -> unit diff --git a/vendor/lwd/lwd/lwd_utils.ml b/vendor/lwd/lwd/lwd_utils.ml new file mode 100644 index 000000000000..e46382eab83e --- /dev/null +++ b/vendor/lwd/lwd/lwd_utils.ml @@ -0,0 +1,76 @@ + +type 'a monoid = 'a * ('a -> 'a -> 'a) + +let lift_monoid (zero, plus) = + (Lwd.return zero, Lwd.map2 ~f:plus) + +let map_reduce inj (zero, plus) items = + let rec cons_monoid c xs v = + match xs with + | (c', v') :: xs when c = c' -> + cons_monoid (c + 1) xs (plus v' v) + | xs -> (c, v) :: xs + in + let cons_monoid xs v = cons_monoid 0 xs (inj v) in + match List.fold_left cons_monoid [] items with + | [] -> zero + | (_,x) :: xs -> + List.fold_left (fun acc (_, v) -> plus v acc) x xs + +let reduce monoid items = map_reduce (fun x -> x) monoid items + +let rec cons_lwd_monoid plus c xs v = + match xs with + | (c', v') :: xs when c = c' -> + cons_lwd_monoid plus (c + 1) xs (Lwd.map2 ~f:plus v' v) + | xs -> (c, v) :: xs + +let pack (zero, plus) items = + match List.fold_left (cons_lwd_monoid plus 0) [] items with + | [] -> Lwd.return zero + | (_,x) :: xs -> + List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs + +let pack_seq (zero, plus) items = + match Seq.fold_left (cons_lwd_monoid plus 0) [] items with + | [] -> Lwd.return zero + | (_,x) :: xs -> + List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs + +let rec map_l (f:'a -> 'b Lwd.t) (l:'a list) : 'b list Lwd.t = + match l with + | [] -> Lwd.return [] + | x :: tl -> Lwd.map2 ~f:List.cons (f x) (map_l f tl) + +let flatten_l (l:'a Lwd.t list) : 'a list Lwd.t = + map_l (fun x->x) l + +(** {1 Miscellaneous functions} + + I don't know where to put these, but they are useful, especially for + UI-related computations. +*) + +let mini a b : int = if b < a then b else a + +let maxi a b : int = if b > a then b else a + +let clampi x ~min ~max : int = + if x < min then + min + else if x > max then + max + else + x + +let minf a b : float = if b < a then b else a + +let maxf a b : float = if b > a then b else a + +let clampf x ~min ~max : float = + if x < min then + min + else if x > max then + max + else + x diff --git a/vendor/lwd/lwd/lwd_utils.mli b/vendor/lwd/lwd/lwd_utils.mli new file mode 100644 index 000000000000..8b1e50804abb --- /dev/null +++ b/vendor/lwd/lwd/lwd_utils.mli @@ -0,0 +1,62 @@ +type 'a monoid = 'a * ('a -> 'a -> 'a) +(** A monoid, defined by a default element and an associative operation *) + +val lift_monoid : 'a monoid -> 'a Lwd.t monoid +(** Use a monoid inside [Lwd] *) + +(** {1 List reduction functions} + + All reductions are balanced, relying on operator associativity. + + [fold_left] would compute a chain like: + [fold f [a; b; c; d] = f a (f b (f c d)] + + [reduce] uses tree-shaped computations like: + [reduce f [a; b; c; d] = f (f a b) (f c d)] + + The depth of the computation grows in O(log n) where n is the length of the + input sequence. +*) + +val pack : 'a monoid -> 'a Lwd.t list -> 'a Lwd.t +(** Reduce a list of elements in [Lwd] monad *) + +val pack_seq : 'a monoid -> 'a Lwd.t Seq.t -> 'a Lwd.t +(** Reduce an (OCaml) [Seq.t] with a monoid *) + +val reduce : 'a monoid -> 'a list -> 'a +(** Reduce a list with a monoid **) + +val map_reduce : ('a -> 'b) -> 'b monoid -> 'a list -> 'b +(** Map and reduce a list with a monoid **) + +(** {1 Other Lwd list functions} *) + +val map_l : ('a -> 'b Lwd.t) -> 'a list -> 'b list Lwd.t + +val flatten_l : 'a Lwd.t list -> 'a list Lwd.t +(** Commute [Lwd] and [list] *) + +(** {1 Miscellaneous functions} + + I don't know where to put these, but they are useful, especially for + UI-related computations. +*) + +val mini : int -> int -> int +(** Minimum of two integers *) + +val maxi : int -> int -> int +(** Maximum of two integers *) + +val clampi : int -> min:int -> max:int -> int +(** Clamp an integer between two bounds. *) + +val minf : float -> float -> float +(** Minimum of two floats *) + +val maxf : float -> float -> float +(** Maximum of two floats *) + +val clampf : float -> min:float -> max:float -> float +(** Clamp a float between two bounds. *) diff --git a/vendor/lwd/nottui/dune b/vendor/lwd/nottui/dune new file mode 100644 index 000000000000..e8e4162fa5a3 --- /dev/null +++ b/vendor/lwd/nottui/dune @@ -0,0 +1,4 @@ +(library + (name dune_nottui) + (wrapped false) + (libraries dune_lwd dune_notty dune_notty_unix)) diff --git a/vendor/lwd/nottui/nottui.ml b/vendor/lwd/nottui/nottui.ml new file mode 100644 index 000000000000..8c67a8e4e6d2 --- /dev/null +++ b/vendor/lwd/nottui/nottui.ml @@ -0,0 +1,872 @@ +open Notty +open Lwd_utils + +module Focus : +sig + type var = int Lwd.var + type handle + val make : unit -> handle + val request : handle -> unit + val request_var : var -> unit + val release : handle -> unit + + type status = + | Empty + | Handle of int * var + | Conflict of int + + val empty : status + (*val is_empty : status -> bool*) + val status : handle -> status Lwd.t + val has_focus : status -> bool + val merge : status -> status -> status +end = struct + + type var = int Lwd.var + + type status = + | Empty + | Handle of int * var + | Conflict of int + + type handle = var * status Lwd.t + + let make () = + let v = Lwd.var 0 in + (v, Lwd.map ~f:(fun i -> Handle (i, v)) (Lwd.get v)) + + let empty : status = Empty + + let status (h : handle) : status Lwd.t = snd h + + let has_focus = function + | Empty -> false + | Handle (i, _) | Conflict i -> i > 0 + + let clock = ref 0 + + let request_var (v : var) = + incr clock; + Lwd.set v !clock + + let request (v, _ : handle) = request_var v + let release (v, _ : handle) = incr clock; Lwd.set v 0 + + let merge s1 s2 : status = match s1, s2 with + | Empty, x | x, Empty -> x + | _, Handle (0, _) -> s1 + | Handle (0, _), _ -> s2 + | Handle (i1, _), Handle (i2, _) when i1 = i2 -> s1 + | (Handle (i1, _) | Conflict i1), Conflict i2 when i1 < i2 -> s2 + | (Handle (i1, _) | Conflict i1), Handle (i2, _) when i1 < i2 -> + Conflict i2 + | Conflict _, (Handle (_, _) | Conflict _) -> s1 + | Handle (i1, _), (Handle (_, _) | Conflict _) -> Conflict i1 +end + +module Gravity : +sig + type direction = [ + | `Negative + | `Neutral + | `Positive + ] + val pp_direction : Format.formatter -> direction -> unit + type t + val pp : Format.formatter -> t -> unit + val make : h:direction -> v:direction -> t + val default : t + val h : t -> direction + val v : t -> direction + + type t2 + val pair : t -> t -> t2 + val p1 : t2 -> t + val p2 : t2 -> t +end = +struct + type direction = [ `Negative | `Neutral | `Positive ] + type t = int + type t2 = int + + let default = 0 + + let pack = function + | `Negative -> 0 + | `Neutral -> 1 + | `Positive -> 2 + + let unpack = function + | 0 -> `Negative + | 1 -> `Neutral + | _ -> `Positive + + let make ~h ~v = + (pack h lsl 2) lor pack v + + let h x = unpack (x lsr 2) + let v x = unpack (x land 3) + + let pp_direction ppf dir = + let text = match dir with + | `Negative -> "`Negative" + | `Neutral -> "`Neutral" + | `Positive -> "`Positive" + in + Format.pp_print_string ppf text + + let pp ppf g = + Format.fprintf ppf "{ h = %a; v = %a }" pp_direction (h g) pp_direction (v g) + + let pair t1 t2 = + (t1 lsl 4) lor t2 + + let p1 t = (t lsr 4) land 15 + let p2 t = t land 15 +end +type gravity = Gravity.t + +module Interval : sig + type t = private int + val make : int -> int -> t + val shift : t -> int -> t + val fst : t -> int + val snd : t -> int + (*val size : t -> int*) + val zero : t +end = struct + type t = int + + let half = Sys.word_size lsr 1 + let mask = (1 lsl half) - 1 + + let make x y = + let size = y - x in + (*assert (size >= 0);*) + (x lsl half) lor (size land mask) + + let shift t d = + t + d lsl half + + let fst t = t asr half + let size t = t land mask + let snd t = fst t + size t + + let zero = 0 +end + +module Ui = +struct + type may_handle = [ `Unhandled | `Handled ] + + type mouse_handler = x:int -> y:int -> Unescape.button -> [ + | `Unhandled + | `Handled + | `Grab of (x:int -> y:int -> unit) * (x:int -> y:int -> unit) + ] + + type semantic_key = [ + (* Clipboard *) + | `Copy + | `Paste + (* Focus management *) + | `Focus of [`Next | `Prev | `Left | `Right | `Up | `Down] + ] + + type key = [ + | Unescape.special | `Uchar of Uchar.t | `ASCII of char | semantic_key + ] * Unescape.mods + + type mouse = Unescape.mouse + + type event = [ `Key of key | `Mouse of mouse | `Paste of Unescape.paste ] + + type layout_spec = { w : int; h : int; sw : int; sh : int } + + let pp_layout_spec ppf { w; h; sw; sh } = + Format.fprintf ppf "{ w = %d; h = %d; sw = %d; sh = %d }" w h sw sh + + type flags = int + let flags_none = 0 + let flag_transient_sensor = 1 + let flag_permanent_sensor = 2 + + type size_sensor = w:int -> h:int -> unit + type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit + + type t = { + w : int; sw : int; + h : int; sh : int; + mutable desc : desc; + focus : Focus.status; + mutable flags : flags; + mutable sensor_cache : (int * int * int * int) option; + mutable cache : cache; + } + and cache = { + vx : Interval.t; vy : Interval.t; + image : image; + } + and desc = + | Atom of image + | Size_sensor of t * size_sensor + | Transient_sensor of t * frame_sensor + | Permanent_sensor of t * frame_sensor + | Resize of t * Gravity.t2 * A.t + | Mouse_handler of t * mouse_handler + | Focus_area of t * (key -> may_handle) + | Shift_area of t * int * int + | Event_filter of t * ([`Key of key | `Mouse of mouse] -> may_handle) + | X of t * t + | Y of t * t + | Z of t * t + + + let layout_spec t : layout_spec = + { w = t.w; h = t.h; sw = t.sw; sh = t.sh } + let layout_width t = t.w + let layout_stretch_width t = t.sw + let layout_height t = t.h + let layout_stretch_height t = t.sh + + let cache : cache = + { vx = Interval.zero; vy = Interval.zero; image = I.empty } + + let empty : t = + { w = 0; sw = 0; h = 0; sh = 0; flags = flags_none; + focus = Focus.empty; desc = Atom I.empty; + sensor_cache = None; cache } + + let atom img : t = + { w = I.width img; sw = 0; + h = I.height img; sh = 0; + focus = Focus.empty; flags = flags_none; + desc = Atom img; + sensor_cache = None; cache; } + + let space_1_0 = atom (I.void 1 0) + let space_0_1 = atom (I.void 0 1) + let space_1_1 = atom (I.void 1 1) + + let space x y = + match x, y with + | 0, 0 -> empty + | 1, 0 -> space_1_0 + | 0, 1 -> space_0_1 + | 1, 1 -> space_1_1 + | _ -> atom (I.void x y) + + let mouse_area f t : t = + { t with desc = Mouse_handler (t, f) } + + let keyboard_area ?focus f t : t = + let focus = match focus with + | None -> t.focus + | Some focus -> Focus.merge focus t.focus + in + { t with desc = Focus_area (t, f); focus } + + let shift_area x y t : t = + { t with desc = Shift_area (t, x, y) } + + let size_sensor handler t : t = + { t with desc = Size_sensor (t, handler) } + + let transient_sensor frame_sensor t = + { t with desc = Transient_sensor (t, frame_sensor); + flags = t.flags lor flag_transient_sensor } + + let permanent_sensor frame_sensor t = + { t with desc = Permanent_sensor (t, frame_sensor); + flags = t.flags lor flag_permanent_sensor } + + let prepare_gravity = function + | None, None -> Gravity.(pair default default) + | Some g, None | None, Some g -> Gravity.(pair g g) + | Some pad, Some crop -> Gravity.(pair pad crop) + + let resize ?w ?h ?sw ?sh ?pad ?crop ?(bg=A.empty) t : t = + let g = prepare_gravity (pad, crop) in + match (w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh) with + | (Some w, _ | None, w), (Some h, _ | None, h), + (Some sw, _ | None, sw), (Some sh, _ | None, sh) -> + {t with w; h; sw; sh; desc = Resize (t, g, bg)} + + let resize_to ({w; h; sw; sh} : layout_spec) ?pad ?crop ?(bg=A.empty) t : t = + let g = prepare_gravity (pad, crop) in + {t with w; h; sw; sh; desc = Resize (t, g, bg)} + + let event_filter ?focus f t : t = + let focus = match focus with + | None -> t.focus + | Some focus -> focus + in + { t with desc = Event_filter (t, f); focus } + + let join_x a b = { + w = (a.w + b.w); sw = (a.sw + b.sw); + h = (maxi a.h b.h); sh = (maxi a.sh b.sh); + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; desc = X (a, b); + sensor_cache = None; cache + } + + let join_y a b = { + w = (maxi a.w b.w); sw = (maxi a.sw b.sw); + h = (a.h + b.h); sh = (a.sh + b.sh); + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; desc = Y (a, b); + sensor_cache = None; cache; + } + + let join_z a b = { + w = (maxi a.w b.w); sw = (maxi a.sw b.sw); + h = (maxi a.h b.h); sh = (maxi a.sh b.sh); + flags = a.flags lor b.flags; + focus = Focus.merge a.focus b.focus; desc = Z (a, b); + sensor_cache = None; cache; + } + + let pack_x = (empty, join_x) + let pack_y = (empty, join_y) + let pack_z = (empty, join_z) + + let hcat xs = Lwd_utils.reduce pack_x xs + let vcat xs = Lwd_utils.reduce pack_y xs + let zcat xs = Lwd_utils.reduce pack_z xs + + let has_focus t = Focus.has_focus t.focus + + let rec pp ppf t = + Format.fprintf ppf + "@[{@ w = %d;@ h = %d;@ sw = %d;@ sh = %d;@ desc = @[%a@];@ }@]" + t.w t.h t.sw t.sh pp_desc t.desc + + and pp_desc ppf = function + | Atom _ -> Format.fprintf ppf "Atom _" + | Size_sensor (desc, _) -> + Format.fprintf ppf "Size_sensor (@[%a,@ _@])" pp desc + | Transient_sensor (desc, _) -> + Format.fprintf ppf "Transient_sensor (@[%a,@ _@])" pp desc + | Permanent_sensor (desc, _) -> + Format.fprintf ppf "Permanent_sensor (@[%a,@ _@])" pp desc + | Resize (desc, gravity, _bg) -> + Format.fprintf ppf "Resize (@[%a,@ %a,@ %a@])" pp desc + Gravity.pp (Gravity.p1 gravity) + Gravity.pp (Gravity.p2 gravity) + | Mouse_handler (n, _) -> + Format.fprintf ppf "Mouse_handler (@[%a,@ _@])" pp n + | Focus_area (n, _) -> + Format.fprintf ppf "Focus_area (@[%a,@ _@])" pp n + | Shift_area (n, _, _) -> + Format.fprintf ppf "Shift_area (@[%a,@ _@])" pp n + | Event_filter (n, _) -> + Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n + | X (a, b) -> Format.fprintf ppf "X (@[%a,@ %a@])" pp a pp b + | Y (a, b) -> Format.fprintf ppf "Y (@[%a,@ %a@])" pp a pp b + | Z (a, b) -> Format.fprintf ppf "Z (@[%a,@ %a@])" pp a pp b + + let iter f ui = match ui.desc with + | Atom _ -> () + | Size_sensor (u, _) | Transient_sensor (u, _) | Permanent_sensor (u, _) + | Resize (u, _, _) | Mouse_handler (u, _) + | Focus_area (u, _) | Shift_area (u, _, _) | Event_filter (u, _) + -> f u + | X (u1, u2) | Y (u1, u2) | Z (u1, u2) -> f u1; f u2 +end +type ui = Ui.t + +module Renderer = +struct + open Ui + + type size = int * int + + type grab_function = (x:int -> y:int -> unit) * (x:int -> y:int -> unit) + type t = { + mutable size : size; + mutable view : ui; + mutable mouse_grab : grab_function option; + } + + let make () = { + mouse_grab = None; + size = (0, 0); + view = Ui.empty; + } + + let size t = t.size + + let solve_focus ui i = + let rec aux ui = + match ui.focus with + | Focus.Empty | Focus.Handle (0, _) -> () + | Focus.Handle (i', _) when i = i' -> () + | Focus.Handle (_, v) -> Lwd.set v 0 + | Focus.Conflict _ -> Ui.iter aux ui + in + aux ui + + let split ~a ~sa ~b ~sb total = + let stretch = sa + sb in + let flex = total - a - b in + if stretch > 0 && flex > 0 then + let ratio = + if sa > sb then + flex * sa / stretch + else + flex - flex * sb / stretch + in + (a + ratio, b + flex - ratio) + else + (a, b) + + let pack ~fixed ~stretch total g1 g2 = + let flex = total - fixed in + if stretch > 0 && flex > 0 then + (0, total) + else + let gravity = if flex >= 0 then g1 else g2 in + match gravity with + | `Negative -> (0, fixed) + | `Neutral -> (flex / 2, fixed) + | `Positive -> (flex, fixed) + + let has_transient_sensor flags = flags land flag_transient_sensor <> 0 + let has_permanent_sensor flags = flags land flag_permanent_sensor <> 0 + + let rec update_sensors ox oy sw sh ui = + if has_transient_sensor ui.flags || ( + has_permanent_sensor ui.flags && + match ui.sensor_cache with + | None -> true + | Some (ox', oy', sw', sh') -> + not (ox = ox' && oy = oy' && sw = sw' && sh = sh') + ) + then ( + ui.flags <- ui.flags land lnot flag_transient_sensor; + if has_permanent_sensor ui.flags then + ui.sensor_cache <- Some (ox, oy, sw, sh); + match ui.desc with + | Atom _ -> () + | Size_sensor (t, _) | Mouse_handler (t, _) + | Focus_area (t, _) | Event_filter (t, _) -> + update_sensors ox oy sw sh t + | Transient_sensor (t, sensor) -> + ui.desc <- t.desc; + let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in + update_sensors ox oy sw sh t; + sensor () + | Permanent_sensor (t, sensor) -> + let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in + update_sensors ox oy sw sh t; + sensor () + | Resize (t, g, _) -> + let open Gravity in + let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in + let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in + update_sensors (ox + dx) (oy + dy) rw rh t + | Shift_area (t, sx, sy) -> + update_sensors (ox - sx) (oy - sy) sw sh t + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + update_sensors ox oy aw sh a; + update_sensors (ox + aw) oy bw sh b + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + update_sensors ox oy sw ah a; + update_sensors ox (oy + ah) sw bh b + | Z (a, b) -> + update_sensors ox oy sw sh a; + update_sensors ox oy sw sh b + ) + + let update_focus ui = + match ui.focus with + | Focus.Empty | Focus.Handle _ -> () + | Focus.Conflict i -> solve_focus ui i + + let update t size ui = + t.size <- size; + t.view <- ui; + update_sensors 0 0 (fst size) (snd size) ui; + update_focus ui + + let dispatch_mouse st x y btn w h t = + let handle ox oy f = + match f ~x:(x - ox) ~y:(y - oy) btn with + | `Unhandled -> false + | `Handled -> true + | `Grab f -> st.mouse_grab <- Some f; true + in + let rec aux ox oy sw sh t = + match t.desc with + | Atom _ -> false + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + if x - ox < aw + then aux ox oy aw sh a + else aux (ox + aw) oy bw sh b + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + if y - oy < ah + then aux ox oy sw ah a + else aux ox (oy + ah) sw bh b + | Z (a, b) -> + aux ox oy sw sh b || aux ox oy sw sh a + | Mouse_handler (t, f) -> + let _offsetx, rw = pack ~fixed:t.w ~stretch:t.sw sw `Negative `Negative + and _offsety, rh = pack ~fixed:t.h ~stretch:t.sh sh `Negative `Negative + in + assert (_offsetx = 0 && _offsety = 0); + (x - ox >= 0 && x - ox <= rw && y - oy >= 0 && y - oy <= rh) && + (aux ox oy sw sh t || handle ox oy f) + | Size_sensor (desc, _) + | Transient_sensor (desc, _) | Permanent_sensor (desc, _) + | Focus_area (desc, _) -> + aux ox oy sw sh desc + | Shift_area (desc, sx, sy) -> + aux (ox - sx) (oy - sy) sw sh desc + | Resize (t, g, _bg) -> + let open Gravity in + let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in + let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in + aux (ox + dx) (oy + dy) rw rh t + | Event_filter (n, f) -> + begin match f (`Mouse (`Press btn, (x, y), [])) with + | `Handled -> true + | `Unhandled -> aux ox oy sw sh n + end + in + aux 0 0 w h t + + let release_grab st x y = + match st.mouse_grab with + | None -> () + | Some (_, release) -> + st.mouse_grab <- None; + release ~x ~y + + let dispatch_mouse t (event, (x, y), _mods) = + if + match event with + | `Press btn -> + release_grab t x y; + let w, h = t.size in + dispatch_mouse t x y btn w h t.view + | `Drag -> + begin match t.mouse_grab with + | None -> false + | Some (drag, _) -> drag ~x ~y; true + end + | `Release -> + release_grab t x y; true + then `Handled + else `Unhandled + + let resize_canvas rw rh image = + let w = I.width image in + let h = I.height image in + if w <> rw || h <> rh + then I.pad ~r:(rw - w) ~b:(rh - h) image + else image + + let resize_canvas2 ox oy rw rh image = + let w = I.width image in + let h = I.height image in + I.pad ~l:ox ~t:oy ~r:(rw - w - ox) ~b:(rh - h - oy) image + + let same_size w h image = + w = I.width image && + h = I.height image + + let rec render_node vx1 vy1 vx2 vy2 sw sh t : cache = + if + let cache = t.cache in + vx1 >= Interval.fst cache.vx && vy1 >= Interval.fst cache.vy && + vx2 <= Interval.snd cache.vx && vy2 <= Interval.snd cache.vy && + same_size sw sh cache.image + then t.cache + else if vx2 < 0 || vy2 < 0 || sw < vx1 || sh < vy1 then + let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in + { vx; vy; image = I.void sw sh } + else + let cache = match t.desc with + | Atom image -> + { vx = Interval.make 0 sw; + vy = Interval.make 0 sh; + image = resize_canvas sw sh image } + | Size_sensor (desc, handler) -> + handler ~w:sw ~h:sh; + render_node vx1 vy1 vx2 vy2 sw sh desc + | Transient_sensor (desc, _) | Permanent_sensor (desc, _) -> + render_node vx1 vy1 vx2 vy2 sw sh desc + | Focus_area (desc, _) | Mouse_handler (desc, _) -> + render_node vx1 vy1 vx2 vy2 sw sh desc + | Shift_area (t', sx, sy) -> + let cache = render_node + (vx1 + sx) (vy1 + sy) (vx2 + sx) (vy2 + sy) (sx + sw) (sy + sh) t' + in + let vx = Interval.make vx1 vx2 and vy = Interval.make vy1 vy2 in + let image = resize_canvas sw sh (I.crop ~l:sx ~t:sy cache.image) in + { vx; vy; image } + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + let ca = render_node vx1 vy1 vx2 vy2 aw sh a in + let cb = render_node (vx1 - aw) vy1 (vx2 - aw) vy2 bw sh b in + let vx = Interval.make + (maxi (Interval.fst ca.vx) (Interval.fst cb.vx + aw)) + (mini (Interval.snd ca.vx) (Interval.snd cb.vx + aw)) + and vy = Interval.make + (maxi (Interval.fst ca.vy) (Interval.fst cb.vy)) + (mini (Interval.snd ca.vy) (Interval.snd cb.vy)) + and image = resize_canvas sw sh (I.(<|>) ca.image cb.image) in + { vx; vy; image } + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + let ca = render_node vx1 vy1 vx2 vy2 sw ah a in + let cb = render_node vx1 (vy1 - ah) vx2 (vy2 - ah) sw bh b in + let vx = Interval.make + (maxi (Interval.fst ca.vx) (Interval.fst cb.vx)) + (mini (Interval.snd ca.vx) (Interval.snd cb.vx)) + and vy = Interval.make + (maxi (Interval.fst ca.vy) (Interval.fst cb.vy + ah)) + (mini (Interval.snd ca.vy) (Interval.snd cb.vy + ah)) + and image = resize_canvas sw sh (I.(<->) ca.image cb.image) in + { vx; vy; image } + | Z (a, b) -> + let ca = render_node vx1 vy1 vx2 vy2 sw sh a in + let cb = render_node vx1 vy1 vx2 vy2 sw sh b in + let vx = Interval.make + (maxi (Interval.fst ca.vx) (Interval.fst cb.vx)) + (mini (Interval.snd ca.vx) (Interval.snd cb.vx)) + and vy = Interval.make + (maxi (Interval.fst ca.vy) (Interval.fst cb.vy)) + (mini (Interval.snd ca.vy) (Interval.snd cb.vy)) + and image = resize_canvas sw sh (I.() cb.image ca.image) in + { vx; vy; image } + | Resize (t, g, bg) -> + let open Gravity in + let dx, rw = pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) in + let dy, rh = pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) in + let c = + render_node (vx1 - dx) (vy1 - dy) (vx2 - dx) (vy2 - dy) rw rh t + in + let image = resize_canvas2 dx dy sw sh c.image in + let image = + if bg != A.empty then + I.(image char bg ' ' sw sh) + else + image + in + let vx = Interval.shift c.vx dx in + let vy = Interval.shift c.vy dy in + { vx; vy; image } + | Event_filter (t, _f) -> + render_node vx1 vy1 vx2 vy2 sw sh t + in + t.cache <- cache; + cache + + let image {size = (w, h); view; _} = + (render_node 0 0 w h w h view).image + + let dispatch_raw_key st key = + let rec iter (st: ui list) : [> `Unhandled] = + match st with + | [] -> `Unhandled + | ui :: tl -> + begin match ui.desc with + | Atom _ -> iter tl + | X (a, b) | Y (a, b) | Z (a, b) -> + (* Try left/top most branch first *) + let st' = + if Focus.has_focus b.focus + then b :: tl + else a :: b :: tl + in + iter st' + | Focus_area (t, f) -> + begin match iter [t] with + | `Handled -> `Handled + | `Unhandled -> + match f key with + | `Handled -> `Handled + | `Unhandled -> iter tl + end + | Mouse_handler (t, _) | Size_sensor (t, _) + | Transient_sensor (t, _) | Permanent_sensor (t, _) + | Shift_area (t, _, _) | Resize (t, _, _) -> + iter (t :: tl) + | Event_filter (t, f) -> + begin match f (`Key key) with + | `Unhandled -> iter (t :: tl) + | `Handled -> `Handled + end + end + in + iter [st.view] + + exception Acquired_focus + + let grab_focus ui = + let rec aux ui = + match ui.focus with + | Focus.Empty -> () + | Focus.Handle (_, v) -> Focus.request_var v; raise Acquired_focus + | Focus.Conflict _ -> iter aux ui + in + try aux ui; false with Acquired_focus -> true + + let rec dispatch_focus t dir = + match t.desc with + | Atom _ -> false + | Mouse_handler (t, _) | Size_sensor (t, _) + | Transient_sensor (t, _) | Permanent_sensor (t, _) + | Shift_area (t, _, _) | Resize (t, _, _) | Event_filter (t, _) -> + dispatch_focus t dir + | Focus_area (t', _) -> + if Focus.has_focus t'.focus then + dispatch_focus t' dir || grab_focus t + else if Focus.has_focus t.focus then + false + else + grab_focus t + | X (a, b) -> + begin if Focus.has_focus a.focus then + dispatch_focus a dir || + (match dir with + | `Next | `Right -> dispatch_focus b dir + | _ -> false + ) + else if Focus.has_focus b.focus then + dispatch_focus b dir || + (match dir with + | `Prev | `Left -> dispatch_focus a dir + | _ -> false + ) + else + match dir with + | `Prev | `Left | `Up -> dispatch_focus b dir || dispatch_focus a dir + | `Next | `Down | `Right -> dispatch_focus a dir || dispatch_focus b dir + end + | Y (a, b) -> + begin if Focus.has_focus a.focus then + dispatch_focus a dir || + (match dir with + | `Next | `Down -> dispatch_focus b dir + | _ -> false + ) + else if Focus.has_focus b.focus then + dispatch_focus b dir || + (match dir with + | `Prev | `Up -> dispatch_focus a dir + | _ -> false + ) + else match dir with + | `Prev | `Up -> dispatch_focus b dir || dispatch_focus a dir + | `Next | `Left | `Down | `Right -> dispatch_focus a dir || dispatch_focus b dir + end + | Z (a, b) -> + if Focus.has_focus a.focus then + dispatch_focus a dir + else + dispatch_focus b dir || dispatch_focus a dir + + let rec dispatch_key st key = + match dispatch_raw_key st key, key with + | `Handled, _ -> `Handled + | `Unhandled, (`Arrow dir, [`Meta]) -> + let dir : [`Down | `Left | `Right | `Up] :> + [`Down | `Left | `Right | `Up | `Next | `Prev] = dir in + dispatch_key st (`Focus dir, [`Meta]) + | `Unhandled, (`Tab, mods) -> + let dir = if List.mem `Shift mods then `Prev else `Next in + dispatch_key st (`Focus dir, mods) + | `Unhandled, (`Focus dir, _) -> + if dispatch_focus st.view dir then `Handled else `Unhandled + | `Unhandled, _ -> `Unhandled + + let dispatch_event t = function + | `Key key -> dispatch_key t key + | `Mouse mouse -> dispatch_mouse t mouse + | `Paste _ -> `Unhandled +end + +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.quick_sample root in + Renderer.update renderer size tree; + let image = Renderer.image renderer in + if Lwd.is_damaged root + then stabilize () + else image + in + stabilize () + in + Term.image term image; + if process_event then + let i, _ = Term.fds term in + let has_event = + let rec select () = + match Unix.select [i] [] [i] timeout with + | [], [], [] -> false + | _ -> true + | exception (Unix.Unix_error (Unix.EINTR, _, _)) -> select () + in + select () + in + if has_event then + match Term.event term with + | `End -> () + | `Resize _ -> () + | #Unescape.event as event -> + let event = (event : Unescape.event :> Ui.event) in + ignore (Renderer.dispatch_event renderer event : [`Handled | `Unhandled]) + + let run_with_term term ?tick_period ?(tick=ignore) ~renderer quit t = + let quit = Lwd.observe (Lwd.get quit) in + let root = Lwd.observe t in + let rec loop () = + let quit = Lwd.quick_sample quit in + if not quit then ( + step ~process_event:true ?timeout:tick_period ~renderer term root; + tick (); + loop () + ) + in + loop (); + ignore (Lwd.quick_release root); + ignore (Lwd.quick_release quit) + + let run ?tick_period ?tick ?term ?(renderer=Renderer.make ()) + ?quit ?(quit_on_escape=true) ?(quit_on_ctrl_q=true) t = + let quit = match quit with + | Some quit -> quit + | None -> Lwd.var false + in + let t = Lwd.map t ~f:(Ui.event_filter (function + | `Key (`ASCII 'Q', [`Ctrl]) when quit_on_ctrl_q -> + Lwd.set quit true; `Handled + | `Key (`Escape, []) when quit_on_escape -> + Lwd.set quit true; `Handled + | _ -> `Unhandled + )) + in + match term with + | Some term -> run_with_term term ?tick_period ?tick ~renderer quit t + | None -> + let term = Term.create () in + run_with_term term ?tick_period ?tick ~renderer quit t; + Term.release term + +end diff --git a/vendor/lwd/nottui/nottui.mli b/vendor/lwd/nottui/nottui.mli new file mode 100644 index 000000000000..a4c72fe081ea --- /dev/null +++ b/vendor/lwd/nottui/nottui.mli @@ -0,0 +1,370 @@ +open Notty + +(** + Nottui augments Notty with primitives for laying out user interfaces (in the + terminal) and reacting to input events. +*) + +(** {1 Focus (defining and managing active objects)} *) + +module Focus : +sig + + type handle + (** A [handle] represents a primitive area that can request, receive and lose + the focus. A visible UI is made of many handles, of which at most one can + be active. *) + + val make : unit -> handle + (** Create a new handle *) + + val request : handle -> unit + (** Request the focus *) + + val release : handle -> unit + (** Release the focus (if the handle has it) *) + + type status + (** [status] represents the state in which a handle can be. + Externally we care about having or not the focus, which can be queried + with the [has_focus] function. Internally, [status] also keeps track of + conflicts (if multiple handles [request]ed the focus). + *) + + val empty : status + (** A status that has no focus and no conflicts *) + + val status : handle -> status Lwd.t + (** Get the status of a focus [handle]. The [status] is a reactive value: + it will evolve over time, as focus is received or lost. *) + + val has_focus : status -> bool + (** Check if this [status] corresponds to an active focus *) + + (** TODO + This implements a more general concept of "reactive auction": + + - multiple parties are competing for a single resource (focus here, but + for instance a tab component can only display a single tab among many). + + - the result can evolve over time, parties can join or leave, or bid + "more". + *) +end + +(** {1 Gravity (horizontal and vertical alignments)} *) + +module Gravity : +sig + + type direction = [ + | `Negative + | `Neutral + | `Positive + ] + (** A gravity is a pair of directions along the horizontal and vertical + axis. + + Horizontal axis goes from left to right and vertical axis from top to + bottom. + + [`Negative] direction means left / top bounds, [`Neutral] means center + and [`Positive] means right / bottom. + *) + + val pp_direction : Format.formatter -> direction -> unit + (** Printing directions *) + + type t + (** The gravity type is a pair of an horizontal and a vertical gravity *) + + val pp : Format.formatter -> t -> unit + (** Printing gravities *) + + val make : h:direction -> v:direction -> t + (** Make a gravity value from an [h]orizontal and a [v]ertical directions. *) + + val default : t + (** Default (negative, aligning to the top-left) gravity. *) + + val h : t -> direction + (** Get the horizontal direction *) + + val v : t -> direction + (** Get the vertical direction *) + +end + +type gravity = Gravity.t + +(** {1 Primitive combinators for making user interfaces} *) + +module Ui : +sig + + type t + (* Type of UI elements *) + + val pp : Format.formatter -> t -> unit + (** Printing UI element *) + + (** {1 Layout specifications} *) + + type layout_spec = { w : int; h : int; sw : int; sh : int; } + (** The type of layout specifications. + + For each axis, layout is specified as a pair of integers: + - a fixed part that is expressed as a number of columns or rows + - a stretchable part that represents a strength used to share the + remaining space (or 0 if the UI doesn't extend over free space) + *) + + val pp_layout_spec : Format.formatter -> layout_spec -> unit + (** Printing layout specification *) + + val layout_spec : t -> layout_spec + (** Get the layout spec for an UI element *) + + val layout_width : t -> int + (** Get the layout width component of an UI element *) + + val layout_stretch_width : t -> int + (** Get the layout stretch width strength of an UI element *) + + val layout_height : t -> int + (** Get the layout height component of an UI element *) + + val layout_stretch_height : t -> int + (** Get the layout height strength of an UI element *) + + (** {1 Primitive images} *) + + val empty : t + (** The empty surface: it occupies no space and does not do anything *) + + val atom : image -> t + (** Primitive surface that displays a Notty image *) + + val space : int -> int -> t + (** Void space of dimensions [x,y]. Useful for padding and interstitial + space. *) + + (** {1 Event handles} *) + + type may_handle = [ `Unhandled | `Handled ] + (** An event is propagated until it gets handled. + Handler functions return a value of type [may_handle] to indicate + whether the event was handled or not. *) + + type mouse_handler = x:int -> y:int -> Unescape.button -> [ + | may_handle + | `Grab of (x:int -> y:int -> unit) * (x:int -> y:int -> unit) + ] + (** The type of handlers for mouse events. They receive the (absolute) + coordinates of the mouse, the button that was clicked. + + In return they indicate whether the event was handled or if the mouse is + "grabbed". + + When grabbed, two functions [on_move] and [on_release] should be + provided. The [on_move] function will be called when the mouse move while + the button is pressed and the [on_release] function is called when the + button is released. + + During that time, no other mouse input events can be dispatched. + *) + + type semantic_key = [ + (* Clipboard *) + | `Copy + | `Paste + (* Focus management *) + | `Focus of [`Next | `Prev | `Left | `Right | `Up | `Down] + ] + (** Key handlers normally reacts to keyboard input but a few special keys are + defined to represent higher-level actions. + Copy and paste, as well as focus movements. *) + + type key = [ + | Unescape.special | `Uchar of Uchar.t | `ASCII of char | semantic_key + ] * Unescape.mods + (** A key is the pair of a main key and a list of modifiers *) + + type mouse = Unescape.mouse + (** Specification of mouse inputs, taken from Notty *) + + type event = [ `Key of key | `Mouse of mouse | `Paste of Unescape.paste ] + (* The type of input events. *) + + val mouse_area : mouse_handler -> t -> t + (** Handle mouse events that happens over an ui. *) + + val keyboard_area : ?focus:Focus.status -> (key -> may_handle) -> t -> t + (** Define a focus receiver, handle keyboard events over the focused area *) + + val has_focus : t -> bool + (** Check if this UI has focus, either directly (it is a focused + [keyboard_area]), or inherited (one of the child is a focused + [keyboard_area]). *) + + val event_filter : + ?focus:Focus.status -> + ([`Key of key | `Mouse of mouse] -> may_handle) -> t -> t + (** A hook that intercepts and can interrupt events when they reach a + sub-part of the UI. *) + + (** {1 Sensors} + + Sensors are used to observe the physical dimensions after layout has been + resolved. + *) + + type size_sensor = w:int -> h:int -> unit + (** The size sensor callback tells you the [w]idth and [h]eight of UI. + The sensor is invoked only when the UI is visible. *) + + val size_sensor : size_sensor -> t -> t + (** Attach a size sensor to an image *) + + type frame_sensor = x:int -> y:int -> w:int -> h:int -> unit -> unit + (** The frame sensor callback gives you the whole rectangle where the widget + is displayed. + + The first for components are applied during before visiting children, + the last unit is applied after visiting children. + *) + + val transient_sensor : frame_sensor -> t -> t + (** Attach a transient frame sensor: the callback will be invoked only once, + on next frame. *) + + val permanent_sensor : frame_sensor -> t -> t + (** Attach a permanent sensor: the callback will be invoked on every frame. + Note that this can have a significant impact on performance. *) + + (** {1 Composite images} *) + + val resize : + ?w:int -> ?h:int -> ?sw:int -> ?sh:int -> + ?pad:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t + (** Override the layout specification of an image with provided [w], [h], + [sw] or [sh]. + + [pad] and [crop] are used to determine how to align the UI when there is + too much or not enough space. + + [bg] is used to fill the padded background. + *) + + val resize_to : + layout_spec -> + ?pad:Gravity.t -> ?crop:Gravity.t -> ?bg:attr -> t -> t + + val shift_area : int -> int -> t -> t + (** Shift the contents of a UI by a certain amount. + Positive values crop the image while negative values pad. + + This primitive is used to implement scrolling. + *) + + val join_x : t -> t -> t + (** Horizontally join two images *) + + val join_y : t -> t -> t + (** Vertically join two images *) + + val join_z : t -> t -> t + (** Superpose two images. The right one will be on top. *) + + val pack_x : t Lwd_utils.monoid + (** Horizontal concatenation monoid *) + + val pack_y : t Lwd_utils.monoid + (** Vertical concatenation monoid *) + + val pack_z : t Lwd_utils.monoid + (** Superposition monoid *) + + val hcat : t list -> t + (** Short-hand for horizontally joining a list of images *) + + val vcat : t list -> t + (** Short-hand for vertically joining a list of images *) + + val zcat : t list -> t + (** Short-hand for superposing a list of images *) +end + +type ui = Ui.t + +(** {1 Rendering user interfaces and dispatching input events} *) + +module Renderer : +sig + + type t + (** The type of a renderer *) + + type size = int * int + (** Size of a rendering surface, as a pair of width and height *) + + val make : unit -> t + (** Create a new renderer. + + It maintains state to update output image and to dispatch events. *) + + val update : t -> size -> Ui.t -> unit + (** Update the contents to be rendered to the given UI at a specific size *) + + val size : t -> size + (** Get the size of the last update *) + + val image : t -> image + (** Render and return actual image *) + + val dispatch_mouse : t -> Ui.mouse -> Ui.may_handle + (** Dispatch a mouse event *) + + val dispatch_key : t -> Ui.key -> Ui.may_handle + (** Dispatch a keyboard event *) + + val dispatch_event : t -> Ui.event -> Ui.may_handle + (** Dispatch an event *) + +end + +(** {1 Main loop} + + Outputting an interface to a TTY and interacting with it +*) + +module Ui_loop : +sig + open Notty_unix + + val step : ?process_event:bool -> ?timeout:float -> renderer:Renderer.t -> + Term.t -> ui Lwd.root -> unit + (** Run one step of the main loop. + + Update output image describe by the provided [root]. + If [process_event], wait up to [timeout] seconds for an input event, then + consume and dispatch it. *) + + val run : + ?tick_period:float -> ?tick:(unit -> unit) -> + ?term:Term.t -> ?renderer:Renderer.t -> + ?quit:bool Lwd.var -> ?quit_on_escape:bool -> + ?quit_on_ctrl_q:bool -> ui Lwd.t -> unit + (** Repeatedly run steps of the main loop, until either: + - [quit] becomes true, + - the ui computation raises an exception, + - if [quit_on_ctrl_q] was true or not provided, wait for Ctrl-Q event + - if [quit_on_escape] was true or not provided, wait for Escape event + + Specific [term] or [renderer] instances can be provided, otherwise new + ones will be allocated and released. + + To simulate concurrency in a polling fashion, tick function and period + can be provided. Use the [Lwt] backend for real concurrency. + *) +end diff --git a/vendor/update-lwd.sh b/vendor/update-lwd.sh new file mode 100755 index 000000000000..416808230268 --- /dev/null +++ b/vendor/update-lwd.sh @@ -0,0 +1,29 @@ +#!/bin/bash + +version=3c446b45b2d9e81bc72b57ada168fe7923f9b02c + +set -e -o pipefail + +TMP="$(mktemp -d)" +trap "rm -rf $TMP" EXIT + +rm -rf lwd +mkdir -p lwd/lwd lwd/nottui + +( + cd $TMP + git clone https://github.com/let-def/lwd.git + cd lwd + git checkout $version +) + +SRC=$TMP/lwd/ + +cp -v $SRC/LICENSE lwd/ +cp -v -R $SRC/lib/lwd/lwd.{ml,mli} lwd/lwd +cp -v -R $SRC/lib/lwd/lwd_utils.{ml,mli} lwd/lwd +cp -v -R $SRC/lib/nottui/nottui.{ml,mli} lwd/nottui + + +git checkout lwd/{lwd,nottui}/dune +git add -A .