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