unikernel/duniverse/dune_/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.

unikernel/duniverse/dune_/vendor/lwd/lwd/dune

@@ -0,0 +1,4 @@
+(library
+ (name dune_lwd)
+ (modules lwd lwd_utils)
+ (wrapped false))

unikernel/duniverse/dune_/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);
+  *)

unikernel/duniverse/dune_/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

unikernel/duniverse/dune_/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

unikernel/duniverse/dune_/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. *)

unikernel/duniverse/dune_/vendor/lwd/nottui/dune

@@ -0,0 +1,4 @@
+(library
+ (name dune_nottui)
+ (wrapped false)
+ (libraries unix dune_lwd dune_notty dune_notty_unix))

unikernel/duniverse/dune_/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
+      "@[<hov>{@ 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

unikernel/duniverse/dune_/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