diff --git a/config.ml b/config.ml index 3ba1d12..b10342e 100644 --- a/config.ml +++ b/config.ml @@ -10,7 +10,14 @@ let hostkey = let main = let packages = [ + package "banawa" ~pin:"git+https://github.com/sorbusursina/banawa-ssh.git"; package "banawa-mirage" ~pin:"git+https://github.com/sorbusursina/banawa-ssh.git"; + package "notty"; + package "nottui" + ~pin:"git+https://github.com/dinosaure/lwd.git#9e78758d5987597bac65fe73bd30ff80741cfe83"; + package "lwd" + ~pin:"git+https://github.com/dinosaure/lwd.git#9e78758d5987597bac65fe73bd30ff80741cfe83"; + package "art"; ] in let keys = [ Key.v port ; Key.v hostkey ] in foreign ~keys ~packages "Unikernel.Main" (random @-> time @-> mclock @-> stackv4v6 @-> job) diff --git a/message.ml b/message.ml new file mode 100644 index 0000000..05fb916 --- /dev/null +++ b/message.ml @@ -0,0 +1,20 @@ +type t = { nickname : string; message : string } + +let nickname { nickname; _ } = nickname +let message { message; _ } = message + +let split_at ~len:max str = + let rec go acc off len = + if len <= max then String.sub str off len :: acc + else go (String.sub str off max :: acc) (off + max) (len - max) + in + if max <= 0 then invalid_arg "split_at"; + go [] 0 (String.length str) |> List.rev + +let split_at ~len { message; _ } = + split_at ~len message + +let make ~nickname message = { nickname; message } + +let msgf ?(nickname="Banawá") fmt = + Fmt.kstr (fun message -> { nickname; message }) fmt diff --git a/message.mli b/message.mli new file mode 100644 index 0000000..2156327 --- /dev/null +++ b/message.mli @@ -0,0 +1,11 @@ +type t + +val split_at : len:int -> t -> string list +val make : nickname:string -> string -> t +val nickname : t -> string +val message : t -> string + +val msgf : + ?nickname:string + -> ('a, Format.formatter, unit, t) format4 + -> 'a diff --git a/nottui_mirage.ml b/nottui_mirage.ml new file mode 100644 index 0000000..a42d9d9 --- /dev/null +++ b/nottui_mirage.ml @@ -0,0 +1,87 @@ +let src = Logs.Src.create "nottui.mirage" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make (Time : Mirage_time.S) = struct + open Notty_mirage.Make (Time) + + let copy_until quit ~f input = + let quit = Lwt.map (fun () -> None) quit in + let stream, push = Lwt_stream.create () in + let rec go () = + Lwt.bind (Lwt.choose [ quit; Lwt_stream.peek input ]) @@ function + | None -> + push None; + Lwt.return_unit + | Some x -> + push (Some (f x)); + Lwt.bind (Lwt_stream.junk input) go + in + Lwt.async go; + stream + + let render ?quit ~size events document = + let renderer = Nottui.Renderer.make () in + let refresh_stream, push_refresh = Lwt_stream.create () in + let root = + Lwd.observe + ~on_invalidate:(fun _ -> + if not (Lwt_stream.is_closed refresh_stream) then + push_refresh (Some ())) + document + in + let quit, _do_quit = + match quit with + | Some quit -> (quit, None) + | None -> + let t, u = Lwt.wait () in + (t, Some u) + in + let events = + copy_until quit events ~f:(fun e -> + (e + : [ `Resize of _ | Notty.Unescape.event ] + :> [ `Resize of _ | Nottui.Ui.event ])) + in + let size = ref size in + let result, push = Lwt_stream.create () in + let refresh () = + let ui = Lwd.quick_sample root in + Nottui.Renderer.update renderer !size ui; + push (Some (Nottui.Renderer.image renderer)) + in + refresh (); + let process_event = function + | #Nottui.Ui.event as event -> + ignore (Nottui.Renderer.dispatch_event renderer event) + | `Resize size' -> + size := size'; + refresh () + in + Lwt.async (fun () -> + Lwt.finalize + (fun () -> Lwt_stream.iter process_event events) + (fun () -> + push None; + Lwt.return_unit)); + Lwt.async (fun () -> Lwt_stream.iter refresh refresh_stream); + result + + let run ?cursor ?quit (size, sigwinch) document ic oc = + let term = Term.create (size, sigwinch) ic oc in + let images = render ?quit ~size (Term.events term) document in + let cursor () = + let cursor = + cursor + |> Option.map @@ fun cursor -> + Lwd.quick_sample (Lwd.observe (Lwd.get cursor)) + in + Term.cursor term cursor + in + Lwt.finalize + (fun () -> + Lwt_stream.iter_s + (fun image -> Lwt.join [ Term.image term image; cursor () ]) + images) + (fun () -> Term.release term) +end diff --git a/notty_mirage.ml b/notty_mirage.ml new file mode 100644 index 0000000..5079662 --- /dev/null +++ b/notty_mirage.ml @@ -0,0 +1,147 @@ +let src = Logs.Src.create "notty.mirage" + +module Log = (val Logs.src_log src : Logs.LOG) +open Lwt.Infix +open Notty + +let ( ) a b = Lwt.pick [ a >|= Either.left; b >|= Either.right ] +let ( ) a b = a >|= Either.left (b >|= Either.right) + +module Make (Time : Mirage_time.S) = struct + module Lwt_condition = struct + include Lwt_condition + + let map f v = + let v' = create () in + let rec go () = + wait v >>= fun x -> + broadcast v' (f x); + go () + in + Lwt.async go; + v' + + let unburst ~timeout v = + let v' = create () in + let rec delay x = + Time.sleep_ns timeout wait v >>= function + | Either.Left () -> + broadcast v' x; + start () + | Either.Right x -> delay x + and start () = wait v >>= delay in + Lwt.async start; + v' + end + + module Term = struct + let input_stream ic stop = + let flt = Unescape.create () in + let ibuf = Bytes.create 1024 in + let rec next () = + match Unescape.next flt with + | #Unescape.event as r -> Lwt.return_some r + | `End -> Lwt.return_none + | `Await -> ( + ic () stop >>= function + | Either.Right _ -> Lwt.return_none + | Either.Left `Eof -> + Unescape.input flt ibuf 0 0; + next () + | Either.Left (`Data cs) -> + let rec go cs = + if Cstruct.length cs > 0 then ( + let len = min (Bytes.length ibuf) (Cstruct.length cs) in + Cstruct.blit_to_bytes cs 0 ibuf 0 len; + Unescape.input flt ibuf 0 len; + go (Cstruct.shift cs len)) + else Lwt.return_unit + in + go cs >>= next) + in + Lwt_stream.from next + + type t = + { oc : Cstruct.t -> unit Lwt.t + ; trm : Notty.Tmachine.t + ; buf : Buffer.t + ; events : [ Unescape.event | `Resize of int * int ] Lwt_stream.t + ; stop : unit -> unit + } + + let write t = + Tmachine.output t.trm t.buf; + let out = Buffer.contents t.buf in + Buffer.clear t.buf; + t.oc (Cstruct.of_string out) + + let refresh t = + Tmachine.refresh t.trm; + write t + + let image t image = + Tmachine.image t.trm image; + write t + + let cursor t curs = + Tmachine.cursor t.trm curs; + write t + + let set_size t dim = Tmachine.set_size t.trm dim + let size t = Tmachine.size t.trm + + let release t = + if Tmachine.release t.trm then ( + t.stop (); + write t (* TODO(dinosaure): send [`Eof] *)) + else Lwt.return_unit + + let resize dim stop on_resize = + (* TODO(dinosaure): we can save some allocations here but I mostly followed `notty-lwt`. *) + let rcond = + Lwt_condition.unburst ~timeout:1000L dim + |> Lwt_condition.map Option.some + in + let rec monitor () = + Lwt_condition.wait rcond stop >>= function + | Some dim -> + on_resize dim; + monitor () + | None -> Lwt.return_unit + in + Lwt.dont_wait monitor (fun exn -> + Logs.err @@ fun m -> + m "Got an exception from the resizer: %S" (Printexc.to_string exn)); + Lwt_stream.from (fun () -> Lwt_condition.wait rcond stop) + |> Lwt_stream.map (fun dim -> `Resize dim) + + let create ?(dispose = true) ?(bpaste = true) ?(mouse = true) + (size, sigwinch) ic oc = + let stop, do_stop = Lwt.wait () in + let rec t = + lazy + { trm = + Tmachine.create ~mouse ~bpaste + Cap.ansi (* XXX(dinosaure): we assume! *) + ; oc + ; buf = Buffer.create 4096 + ; stop = (fun () -> Lwt.wakeup do_stop None) + ; events = + Lwt_stream.choose + [ input_stream ic stop + ; ( resize sigwinch stop @@ fun dim -> + let t = Lazy.force t in + Buffer.reset t.buf; + set_size t dim ) + ] + } + in + let t = Lazy.force t in + set_size t size; + Lwt.async (fun () -> write t); + if dispose then Mirage_runtime.at_exit (fun () -> release t); + t + + let events t = t.events + end +end diff --git a/prompt.ml b/prompt.ml new file mode 100644 index 0000000..94621d9 --- /dev/null +++ b/prompt.ml @@ -0,0 +1,129 @@ +open Nottui +open Notty + +type t = { + message : string -> unit; + cursor : Rp.Cursor.cursor; +} + +let make message = + let cursor = Rp.Cursor.create Rp.empty 0 in + { message; cursor } + +let map_cursor f state = + { state with cursor = f state.cursor } + +module Utils = struct + let move_cursor ?(visual = true) ~hook cursor = function + | `Left -> + let position = Rp.Cursor.position cursor in + (if position > 0 then + let cursor = Rp.Cursor.move_backward cursor 1 in + hook cursor); + `Handled + | `Right -> + let position = Rp.Cursor.position cursor in + let rope = Rp.Cursor.to_rope cursor in + let len = Rp.length rope in + let len = if visual then len - 1 else len in + (if position < len then + let cursor = Rp.Cursor.move_forward cursor 1 in + hook cursor); + `Handled + + let is_print = function '\x21' .. '\x7e' | ' ' -> true | _ -> false + + let render_cursor ~width cursor = + let rope = Rp.Cursor.to_rope cursor in + let position = Rp.Cursor.position cursor in + let length = Rp.length rope in + let offset = if position >= width then position - width else 0 in + let rope = Rp.sub rope offset (length - offset) in + (* XXX(dinosaure): shift our text according to [offset]. *) + let length = Rp.length rope in + let left, middle, right = + match position >= 0 && position < length with + | true -> + ( Rp.sub rope 0 position + , Some (Rp.get rope position) + , Rp.sub rope (position + 1) (length - position - 1) ) + | false -> (rope, None, Rp.empty) + in + let middle = + match middle with + | None -> I.uchar A.empty (Uchar.of_char ' ') 1 1 + | Some uchar -> I.uchar A.empty uchar 1 1 + in + ( I.hcat [ I.strf "%a" Rp.print left; middle; I.strf "%a" Rp.print right ] + , position - offset ) +end + +module User_prompt = struct + let render ~cursor ~y ~w state = + let text, position = + Utils.render_cursor ~width:(max 0 (w - 3)) state.cursor + in + Lwd.set cursor (position + 1, y); + I.hcat [ I.char A.empty ' ' 1 1 ; text ] +end + +let handler ~hook state = function + | `ASCII chr, [] when Utils.is_print chr -> + map_cursor (fun cursor -> + let cursor = Rp.Cursor.insert_char cursor (Uchar.of_char chr) in + Rp.Cursor.move_forward cursor 1) + state + |> hook; + `Handled + | `Uchar uchar, [] -> + map_cursor (fun cursor -> + let cursor = Rp.Cursor.insert_char cursor uchar in + Rp.Cursor.move_forward cursor 1) + state + |> hook; + `Handled + | `Backspace, [] -> + if Rp.Cursor.position state.cursor > 0 then + map_cursor (fun cursor -> + let cursor = Rp.Cursor.move_backward cursor 1 in + Rp.Cursor.delete cursor) + state + |> hook; + `Handled + | `Arrow (`Left | `Right as direction), [] -> + let hook cursor = hook { state with cursor } in + Utils.move_cursor ~visual:false ~hook state.cursor direction + | `Enter, [] -> + let rope = Rp.Cursor.to_rope state.cursor in + let msg = + let len = Rp.length rope in + let buf = Buffer.create len in + Rp.iter_range (Uutf.Buffer.add_utf_8 buf) rope 0 len; + Buffer.contents buf + in + state.message msg; + hook { state with cursor = Rp.Cursor.create Rp.empty 0 }; + `Handled + | _ -> `Unhandled + +let make ~message cursor = + let ( let* ) x f = Lwd.bind x ~f in + let ( let+ ) x f = Lwd.map ~f x in + let ( and+ ) = Lwd.map2 ~f:(fun x y -> (x, y)) in + let state = Lwd.var (make message) in + let position = Lwd.var (0, 0) in + let hook = Lwd.set state in + let update_prompt state (y, w) = + let user = User_prompt.render ~cursor ~y ~w state in + Ui.keyboard_area (handler ~hook state) (Ui.atom user) + in + let update_position ~x:_ ~y ~w ~h:_ () = + let y', w' = Lwd.peek position in + if y' <> y || w' <> w then Lwd.set position (y, w) + in + let* prompts = + let+ state = Lwd.get state + and+ position = Lwd.get position in + update_prompt state position + in + Lwd.return (Ui.transient_sensor update_position prompts) diff --git a/rb.ml b/rb.ml new file mode 100644 index 0000000..c1ed988 --- /dev/null +++ b/rb.ml @@ -0,0 +1,69 @@ +type ('c, 'a) t = + { arr : 'a option array; mutable rd_cursor : int; mutable wr_cursor : int } + constraint 'c = < .. > + +type ro = < rd : unit > +type wo = < wr : unit > +type rdwr = < rd : unit ; wr : unit > +type 'a rd = < rd : unit ; .. > as 'a +type 'a wr = < wr : unit ; .. > as 'a + +let make len = { arr = Array.make len None; rd_cursor = 0; wr_cursor = 0 } + +exception Full +exception Empty + +let length t = + if t.rd_cursor <= t.wr_cursor then t.wr_cursor - t.rd_cursor + else + let len = Array.length t.arr in + len - t.rd_cursor + t.wr_cursor + +let is_empty t = length t = 0 +let available t = Array.length t.arr - length t +let is_full t = length t = Array.length t.arr +let mask t v = v mod Array.length t.arr + +let push t v = + if is_full t then raise Full; + t.arr.(t.wr_cursor) <- Some v; + t.wr_cursor <- mask t (t.wr_cursor + 1) + +let pop t = + if is_empty t then raise Empty; + let[@warning "-8"] (Some v) = t.arr.(t.rd_cursor) in + t.rd_cursor <- mask t (t.rd_cursor + 1); + v + +let fit_and_push t v = + if is_full t then ignore (pop t); + push t v + +let drop t = + if is_empty t then raise Empty; + t.wr_cursor <- mask t (t.wr_cursor - 1) + +let iter ~f t a = + let i = ref t.rd_cursor in + let a = ref a in + while !i <> t.wr_cursor do + a := f (Option.get t.arr.(mask t !i)) !a; + incr i + done; + !a + +let rev_iter ~f t a = + let i = ref (t.wr_cursor - 1) in + let a = ref a in + while !i >= t.rd_cursor do + a := f (Option.get t.arr.(mask t !i)) !a; + decr i + done; + !a + +let ( .%[] ) t idx = + if idx >= length t then invalid_arg "Out of bounds"; + Option.get t.arr.(mask t (t.rd_cursor + idx)) + +external to_ro : ('c rd, 'a) t -> (ro, 'a) t = "%identity" +external to_wo : ('c wr, 'a) t -> (wo, 'a) t = "%identity" diff --git a/rb.mli b/rb.mli new file mode 100644 index 0000000..d1b053f --- /dev/null +++ b/rb.mli @@ -0,0 +1,25 @@ +(** A simple ring-buffer. *) + +type ('c, 'a) t constraint 'c = < .. > +(** The type of a ring-buffer whose elements have type ['a]. *) + +type ro = < rd : unit > +type wo = < wr : unit > +type rdwr = < rd : unit ; wr : unit > +type 'a rd = < rd : unit ; .. > as 'a +type 'a wr = < wr : unit ; .. > as 'a + +val make : int -> (< rd : unit ; wr : unit >, 'a) t +val length : ('c rd, 'a) t -> int +val is_empty : ('c rd, 'a) t -> bool +val available : ('c rd, 'a) t -> int +val is_full : ('c rd, 'a) t -> bool +val push : ('c wr, 'a) t -> 'a -> unit +val pop : ('c wr, 'a) t -> 'a +val fit_and_push : ('c wr, 'a) t -> 'a -> unit +val drop : ('c wr, 'a) t -> unit +val iter : f:('a -> 'acc -> 'acc) -> ('c rd, 'a) t -> 'acc -> 'acc +val rev_iter : f:('a -> 'acc -> 'acc) -> ('c rd, 'a) t -> 'acc -> 'acc +val ( .%[] ) : ('c rd, 'a) t -> int -> 'a +val to_ro : ('c rd, 'a) t -> (ro, 'a) t +val to_wo : ('c wr, 'a) t -> (wo, 'a) t diff --git a/rope.ml b/rope.ml new file mode 100644 index 0000000..b7c89ca --- /dev/null +++ b/rope.ml @@ -0,0 +1,539 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +exception Out_of_bounds + +module type STRING = sig + type t + type char + + val length : t -> int + val empty : t + val singleton : char -> t + val append : t -> t -> t + val get : t -> int -> char + val sub : t -> int -> int -> t + val iter_range : (char -> unit) -> t -> int -> int -> unit + val print : Format.formatter -> t -> unit +end + +module type ROPE = sig + include STRING + + val is_empty : t -> bool + val set : t -> int -> char -> t + val delete : t -> int -> t + val insert_char : t -> int -> char -> t + val insert : t -> int -> t -> t + + module Cursor : sig + type cursor + + val empty : cursor + val create : t -> int -> cursor + val position : cursor -> int + val to_rope : cursor -> t + val move_forward : cursor -> int -> cursor + val move_backward : cursor -> int -> cursor + val move : cursor -> int -> cursor + val get : cursor -> char + val set : cursor -> char -> cursor + val insert_char : cursor -> char -> cursor + val insert : cursor -> t -> cursor + val delete : cursor -> cursor + val print : Format.formatter -> cursor -> unit + end +end + +module type CONTROL = sig + val small_length : int + val maximal_height : int +end + +module Make (S : STRING) (C : CONTROL) = struct + type t = + (* s,ofs,len with 0 <= ofs < len(s), ofs+len <= len(s) *) + | Str of S.t * int * int + (* t1,t2,len,height with 0 < len t1, len t2 *) + | App of t * t * int * int + + type char = S.char + + let empty = Str (S.empty, 0, 0) + let length = function Str (_, _, n) | App (_, _, n, _) -> n + let of_string s = Str (s, 0, S.length s) + let singleton c = of_string (S.singleton c) + let height = function Str _ -> 0 | App (_, _, _, h) -> h + + (* smart constructor *) + let mk_app t1 t2 = + App (t1, t2, length t1 + length t2, 1 + max (height t1) (height t2)) + + let app = function + | Str (_, _, 0), t | t, Str (_, _, 0) -> t + | Str (s1, ofs1, len1), Str (s2, ofs2, len2) + when len1 <= C.small_length && len2 <= C.small_length -> + Str (S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2), 0, len1 + len2) + | App (t1, Str (s1, ofs1, len1), _, _), Str (s2, ofs2, len2) + when len1 <= C.small_length && len2 <= C.small_length -> + App + ( t1 + , Str + ( S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2) + , 0 + , len1 + len2 ) + , length t1 + len1 + len2 + , 1 + height t1 ) + | Str (s1, ofs1, len1), App (Str (s2, ofs2, len2), t2, _, _) + when len1 <= C.small_length && len2 <= C.small_length -> + App + ( Str + ( S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2) + , 0 + , len1 + len2 ) + , t2 + , len1 + len2 + length t2 + , 1 + height t2 ) + | t1, t2 -> + App (t1, t2, length t1 + length t2, 1 + max (height t1) (height t2)) + + let append t1 t2 = app (t1, t2) + let ( ++ ) = append + + let _balance t = + let rec to_list ((n, l) as acc) = function + | Str _ as x -> (n + 1, x :: l) + | App (t1, t2, _, _) -> to_list (to_list acc t2) t1 + in + let rec build n l = + assert (n >= 1); + if n = 1 then match l with [] -> assert false | x :: r -> (x, r) + else + let n' = n / 2 in + let t1, l = build n' l in + let t2, l = build (n - n') l in + (mk_app t1 t2, l) + in + let n, l = to_list (0, []) t in + let t, l = build n l in + assert (l = []); + t + + let rec unsafe_get t i = + match t with + | Str (s, ofs, _) -> S.get s (ofs + i) + | App (t1, t2, _, _) -> + let n1 = length t1 in + if i < n1 then unsafe_get t1 i else unsafe_get t2 (i - n1) + + let get t i = + if i < 0 || i >= length t then raise Out_of_bounds; + unsafe_get t i + + let is_empty t = length t = 0 + + (* assumption: 0 <= start < stop <= len(t) *) + let rec mksub start stop t = + if start = 0 && stop = length t then t + else + match t with + | Str (s, ofs, _) -> Str (s, ofs + start, stop - start) + | App (t1, t2, _, _) -> + let n1 = length t1 in + if stop <= n1 then mksub start stop t1 + else if start >= n1 then mksub (start - n1) (stop - n1) t2 + else app (mksub start n1 t1, mksub 0 (stop - n1) t2) + + let sub t ofs len = + let stop = ofs + len in + if ofs < 0 || len < 0 || stop > length t then raise Out_of_bounds; + if len = 0 then empty else mksub ofs stop t + + let rec safe_iter_range f i n = function + | Str (s, ofs, _) -> S.iter_range f s (ofs + i) n + | App (t1, t2, _, _) -> + let n1 = length t1 in + if i + n <= n1 then safe_iter_range f i n t1 + else if i >= n1 then safe_iter_range f (i - n1) n t2 + else ( + safe_iter_range f i n1 t1; + safe_iter_range f (i - n1) (n - n1) t2) + + let iter_range f t ofs len = + if ofs < 0 || len < 0 || ofs + len > length t then raise Out_of_bounds; + safe_iter_range f ofs len t + + let rec print fmt = function + | Str (s, ofs, len) -> S.print fmt (S.sub s ofs len) (* TODO: improve? *) + | App (t1, t2, _, _) -> + print fmt t1; + print fmt t2 + + (* assumption: 0 <= i < len t *) + let rec set_rec i c = function + | Str (s, ofs, len) when i = 0 -> + app (singleton c, Str (s, ofs + 1, len - 1)) + | Str (s, ofs, len) when i = len - 1 -> + app (Str (s, ofs, len - 1), singleton c) + | Str (s, ofs, len) -> + app + (Str (s, ofs, i), app (singleton c, Str (s, ofs + i + 1, len - i - 1))) + | App (t1, t2, _, _) -> + let n1 = length t1 in + if i < n1 then app (set_rec i c t1, t2) + else app (t1, set_rec (i - n1) c t2) + + (* set t i c = sub t 0 i ++ singleton c ++ sub t (i+1) (length t-i-1) *) + let set t i c = + let n = length t in + if i < 0 || i >= n then raise Out_of_bounds; + set_rec i c t + + (* assumption: 0 <= i < len t *) + let rec delete_rec i = function + | Str (_, _, 1) -> + assert (i = 0); + empty + | Str (s, ofs, len) when i = 0 -> Str (s, ofs + 1, len - 1) + | Str (s, ofs, len) when i = len - 1 -> Str (s, ofs, len - 1) + | Str (s, ofs, len) -> + app (Str (s, ofs, i), Str (s, ofs + i + 1, len - i - 1)) + | App (t1, t2, _, _) -> + let n1 = length t1 in + if i < n1 then app (delete_rec i t1, t2) + else app (t1, delete_rec (i - n1) t2) + + (* delete t i = sub t 0 i ++ sub t (i + 1) (length t - i - 1) *) + let delete t i = + let n = length t in + if i < 0 || i >= n then raise Out_of_bounds; + delete_rec i t + + (* assumption: 0 <= i < len t *) + let rec insert_rec i r = function + | Str _ as s when i = 0 -> app (r, s) + | Str (_, _, len) as s when i = len -> app (s, r) + | Str (s, ofs, len) -> Str (s, ofs, i) ++ r ++ Str (s, ofs + i, len - i) + | App (t1, t2, _, _) -> + let n1 = length t1 in + if i < n1 then app (insert_rec i r t1, t2) + else app (t1, insert_rec (i - n1) r t2) + + (* insert t i r = sub t 0 i ++ r ++ sub t i (length t - i) *) + let insert t i r = + let n = length t in + if i < 0 || i > n then raise Out_of_bounds; + insert_rec i r t + + let insert_char t i c = insert t i (singleton c) + + (* cursors *) + module Cursor = struct + type path = Top | Left of path * t | Right of t * path + + type cursor = + { rpos : int (* position of the cursor relative to the current leaf *) + ; lofs : int (* offset of the current leaf wrt whole rope *) + ; leaf : t (* the leaf i.e. Str (s,ofs,len) *) + ; path : path (* context = zipper *) + } + (* INVARIANT: 0 <= rpos <= len + rpos = len iff we are located at the end of the whole rope *) + (* TODO(dinosaure): prove that [leaf] contains only a concrete [Str] value. *) + + let position c = c.lofs + c.rpos + + (* cursor -> rope *) + let rec unzip t = function + | Top -> t + | Left (p, tr) -> unzip (app (t, tr)) p + | Right (tl, p) -> unzip (app (tl, t)) p + + let to_rope c = unzip c.leaf c.path + + let create r i = + let rec zip lofs p = function + | Str (_, _, len) as leaf -> + assert (lofs <= i && i <= lofs + len); + { rpos = i - lofs; lofs; leaf; path = p } + | App (t1, t2, _, _) -> + let n1 = length t1 in + if i < lofs + n1 then zip lofs (Left (p, t2)) t1 + else zip (lofs + n1) (Right (t1, p)) t2 + in + if i < 0 || i > length r then raise Out_of_bounds; + zip 0 Top r + + let get c = + match c.leaf with + | Str (s, ofs, len) -> + let i = c.rpos in + if i = len then raise Out_of_bounds; + S.get s (ofs + i) + | App _ -> assert false + + (* TODO: improve using concatenations when lengths <= small_length *) + let set c x = + match c.leaf with + | Str (s, ofs, len) -> + let i = c.rpos in + if i = len then raise Out_of_bounds; + let leaf = Str (S.singleton x, 0, 1) in + if i = 0 then + if len = 1 then { c with leaf } + else + { c with leaf; path = Left (c.path, Str (s, ofs + 1, len - 1)) } + else if i = len - 1 then + { lofs = c.lofs + len - 1 + ; rpos = 0 + ; leaf + ; path = Right (Str (s, ofs, len - 1), c.path) + } + else + { lofs = c.lofs + i + ; rpos = 0 + ; leaf + ; path = + Left + ( Right (Str (s, ofs, i), c.path) + , Str (s, ofs + i + 1, len - i - 1) ) + } + | App _ -> assert false + + let rec concat_path p1 p2 = + match p1 with + | Top -> p2 + | Left (p, r) -> Left (concat_path p p2, r) + | Right (l, p) -> Right (l, concat_path p p2) + + (* TODO: improve using concatenations when lengths <= small_length *) + let insert c r = + match c.leaf with + | Str (s, ofs, len) -> + let i = c.rpos in + let cr = create r 0 in + if i = 0 then + { cr with + lofs = c.lofs + ; path = concat_path cr.path (Left (c.path, c.leaf)) + } + else if i = len then + { cr with + lofs = c.lofs + len + ; path = concat_path cr.path (Right (c.leaf, c.path)) + } + else + { cr with + lofs = c.lofs + i + ; path = + concat_path cr.path + (Left + (Right (Str (s, ofs, i), c.path), Str (s, ofs + i, len - i))) + } + | App _ -> assert false + + let insert_char c x = insert c (of_string (S.singleton x)) + + (* moves to start of next leaf (on the right) if any, + or raises [Out_of_bounds] *) + let next_leaf c = + let lofs = c.lofs + length c.leaf in + let rec down p = function + | Str _ as leaf -> { rpos = 0; lofs; leaf; path = p } + | App (t1, t2, _, _) -> down (Left (p, t2)) t1 + in + let rec up t = function + | Top -> raise Out_of_bounds + | Right (l, p) -> up (mk_app l t) p + | Left (p, r) -> down (Right (t, p)) r + in + up c.leaf c.path + + let rec move_forward_rec c n = + match c.leaf with + | Str (_, _, len) -> + let rpos' = c.rpos + n in + if rpos' < len then { c with rpos = rpos' } + else if rpos' = len then + try next_leaf c with Out_of_bounds -> { c with rpos = rpos' } + else + (* rpos' > len *) + let c = next_leaf c in + move_forward_rec c (rpos' - len) + (* TODO: improve? *) + | App _ -> assert false + + let move_forward c n = + if n < 0 then invalid_arg "Rop.move_forward"; + if n = 0 then c else move_forward_rec c n + + (* moves to the end of previous leaf (on the left) if any, + raises [Out_of_bounds] otherwise *) + let prev_leaf c = + let rec down p = function + | Str (_, _, len) as leaf -> + { rpos = len; lofs = c.lofs - len; leaf; path = p } + | App (t1, t2, _, _) -> down (Right (t1, p)) t2 + in + let rec up t = function + | Top -> raise Out_of_bounds + | Right (l, p) -> down (Left (p, t)) l + | Left (p, r) -> up (mk_app t r) p + in + up c.leaf c.path + + let rec move_backward_rec c n = + match c.leaf with + | Str (_, _, _len) -> + let rpos' = c.rpos - n in + if rpos' >= 0 then { c with rpos = rpos' } + else + (* rpos' < 0 *) + let c = prev_leaf c in + move_backward_rec c (-rpos') + | App _ -> assert false + + let move_backward c n = + if n < 0 then invalid_arg "Rop.move_backward"; + if n = 0 then c else move_backward_rec c n + + let move c n = + if n = 0 then c + else if n > 0 then move_forward_rec c n + else move_backward_rec c (-n) + + let rec _leftmost lofs p = function + | Str _ as leaf -> { rpos = 0; lofs; leaf; path = p } + | App (t1, t2, _, _) -> _leftmost lofs (Left (p, t2)) t1 + + (* XXX(dinosaure): the code does not work when we + delete the last character and redo the operation. + Actually, this impl. works with: + - next_leaf { c with leaf = Str (s, ofs, len - 1) } + + try next_leaf { c with leaf = Str (s, ofs, len - 1) } + + with Out_of_bounds (* Top *) -> + + { c with leaf= Str (s, ofs, len - 1) } + + But we need to fuzz and prove it! *) + let delete c = + match c.leaf with + | Str (s, ofs, len) -> + let i = c.rpos in + if i = len then raise Out_of_bounds; + if i = 0 then + if len = 1 then + match c.path with + | Top -> { c with leaf = empty } + | Left (p, t) -> + (* leftmost c.lofs p r *) + let r = to_rope { c with leaf = t; path = p } in + create r c.lofs + | Right (t, p) -> + (* TODO: improve *) + let r = to_rope { c with leaf = t; path = p } in + create r c.lofs + else { c with leaf = Str (s, ofs + 1, len - 1) } + else if i = len - 1 then + try next_leaf { c with leaf = Str (s, ofs, len - 1) } + with Out_of_bounds (* Top *) -> + { c with leaf = Str (s, ofs, len - 1) } + else + { lofs = c.lofs + i + ; rpos = 0 + ; leaf = Str (s, ofs + i + 1, len - i - 1) + ; path = Right (Str (s, ofs, i), c.path) + } + | App _ -> assert false + + let print fmt c = + (* TODO: improve *) + let r = to_rope c in + let i = position c in + let before = sub r 0 i in + let after = sub r i (length r - i) in + print fmt before; + Format.fprintf fmt "|"; + print fmt after + + let empty = { rpos = 0; lofs = 0; leaf = Str (S.empty, 0, 0); path = Top } + end +end + +(* flat strings *) +module Str = struct + include String + + let get = unsafe_get + + type char = Char.t + + let empty = "" + let singleton = String.make 1 + let append = ( ^ ) + let print = Format.pp_print_string + + let iter_range f s ofs len = + (* safe *) + for i = ofs to ofs + len - 1 do + f (String.unsafe_get s i) + done +end + +module Control = struct + let small_length = 256 + let maximal_height = max_int +end + +module String = Make (Str) (Control) + +(* ropes of any type (using arrays as flat sequences) *) + +module type Print = sig + type t + + val print : Format.formatter -> t -> unit +end + +module Make_array (X : Print) = struct + module A = struct + type char = X.t + type t = X.t array + + let length = Array.length + let empty = [||] + let singleton l = [| l |] + let append = Array.append + let get = Array.get + let sub = Array.sub + + let iter_range f a ofs len = + for i = ofs to ofs + len - 1 do + f a.(i) + done + + let print fmt a = Array.iter (X.print fmt) a + end + + module C = struct + let small_length = 256 + let maximal_height = max_int + end + + include Make (A) (C) + + let of_array = of_string + let create n v = of_string (Array.make n v) + let init n f = of_string (Array.init n f) +end diff --git a/rope.mli b/rope.mli new file mode 100644 index 0000000..ebc051d --- /dev/null +++ b/rope.mli @@ -0,0 +1,220 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(** Ropes are persistent data structures for long sequences. Elements + are of any type. When elements are characters, ropes thus implement + strings (with an interface identical to that of [String]) but with + far better performances w.r.t. concatenation of substring + extraction, especially on very large strings. *) + +(** Ropes are naturally implemented as a functor turning a (possibly + inefficient) data structure of ``strings'' into another (more + efficient) data structure with the same signature. *) + +exception Out_of_bounds + +(** Input signature for the functor *) + +module type STRING = sig + type t + type char + + val length : t -> int + val empty : t + val singleton : char -> t + val append : t -> t -> t + val get : t -> int -> char + + val sub : t -> int -> int -> t + (** [sub t ofs len] extracts the substring of length [len] at offset + [ofs], that is [t[ofs..ofs+len-1]]. + Will always be called with a valid range. *) + + val iter_range : (char -> unit) -> t -> int -> int -> unit + (** [iter_range f t ofs len] successively iterates [f] over characters + of [t] at offsets [ofs], [ofs+1], ..., [ofs+len-1], in this order. + Will always be called with a valid range. *) + + val print : Format.formatter -> t -> unit +end + +(** Output signature of the functor. Note that it extends signature + [STRING] and thus functor [Make] below can be iterated several + times. *) + +module type ROPE = sig + include STRING + + val is_empty : t -> bool + (** [is_empty t] returns [true] if the given rope is empty. *) + + val set : t -> int -> char -> t + (** [set t i c] returns a new rope identical to [t], + apart character [i] which is set to [c]. + Raises [Out_of_bounds] if [i < 0 || i >= length t]. + It is more equivalent to (but more efficient than) + [sub t 0 i ++ singleton c ++ sub t (i+1) (length t-i-1)] *) + + val delete : t -> int -> t + (** [delete t i] returns a new rope obtained by removing character [i] + in [t]. Raises [Out_of_bounds] if [i < 0 || i >= length t]. + It is more equivalent to (but more efficient than) + [sub t 0 i ++ sub t (i + 1) (length t - i - 1)] *) + + val insert_char : t -> int -> char -> t + (** [insert t i c] returns a new rope resulting from the insertion of + character [c] at position [i] in [t], that right before character [i]. + Raises [Out_of_bounds] if [i < 0 || i > length t]. + It is more equivalent to (but more efficient than) + [sub t 0 i ++ singleton c ++ sub t i (length t - i)] *) + + val insert : t -> int -> t -> t + (** [insert t i r] returns a new rope resulting from the insertion + of rope [r] at position [i] in [t]. + Raises [Out_of_bounds] if [i < 0 || i > length t]. + It is more equivalent to (but more efficient than) + [sub t 0 i ++ r ++ sub t i (length t - i)] *) + + (** Cursors are persistent data structures to navigate within ropes. + When several operations are to be performed locally on a rope + (such as local deletions, insertions or even simple accesses), + then the use of cursors can be more efficient than the use of + rope operations. + It is convenient to see the cursor as placed between two characters, + so that a rope of length [n] has [n+1] cursor positions. *) + + module Cursor : sig + type cursor + + val empty : cursor + (** [empty] is a cursor for an empty rope. *) + + val create : t -> int -> cursor + (** [create t i] returns a cursor placed before character [i] of rope + [t]. Raises [Out_of_bounds] is [i < 0 || i > length t]. + Note that [i = length t] is a valid argument, resulting in a cursor + placed right after the last character of the rope (i.e. at the + end of the rope). *) + + val position : cursor -> int + (** [position c] returns the position of cursor [c] in its rope. *) + + val to_rope : cursor -> t + (** [to_rope c] returns the rope corresponding to cursor [c]. *) + + val move_forward : cursor -> int -> cursor + (** [move_forward c n] moves cursor [c] [n] characters forward. + Raises [Invalid_argument] if [n < 0]. + Raises [Out_of_bounds] if it moves the cursor beyond the end of + the rope. *) + + val move_backward : cursor -> int -> cursor + (** [move_backward c n] moves cursor [c] [n] characters + backward. Raises [Invalid_argument] if [n < 0]. Raises + [Out_of_bounds] if it moves the cursor beyond the start of + the rope. *) + + val move : cursor -> int -> cursor + (** [move c n] moves cursor [c] [n] characters away from its current + location, relatively to the sign of [n] (i.e. forward if [n > 0] and + backward if [n < 0]). Raises [Out_of_bounds] if it moves the cursor + beyond the start or the end of the rope. *) + + val get : cursor -> char + (** [get c] returns the character right after cursor + [c]. Raises [Out_of_bounds] if the cursor is located at the + end of the rope. *) + + val set : cursor -> char -> cursor + (** [set c x] returns a new cursor identical to [c] apart from + the character right after the cursor position, which is set + to [x]. Raises [Out_of_bounds] if the cursor is located at + the end of the rope. *) + + val insert_char : cursor -> char -> cursor + (** [insert_char c x] returns a new cursor obtained from [c] by + inserting character [x] at the cursor position. The new + cursor is located right before the newly inserted character + (i.e. at the same absolute position in the rope). *) + + val insert : cursor -> t -> cursor + (** [insert c r] is similar to [insert_char] but inserts a rope [r] at + the cursor point instead of a character. *) + + val delete : cursor -> cursor + (** [delete c] deletes the character right after the cursor location. + Raises [Out_of_bounds] if the cursor is located at the end of the + rope. *) + + val print : Format.formatter -> cursor -> unit + (** [print fmt c] prints cursor [c] on formatter [fmt], as a string + ["abc...|def..."] where ["abc..."] is the portion of the rope + before the cursor position and ["def..."] the portion after. *) + end +end + +(** The functor to build ropes, turning an implemention of strings [S] + into an implemention of ropes. + + It is controlled by two parameters: + - [small_length] is the maximal length under which we perform + concatenation of flat strings, i.e. when two ropes of length at most + [small_length] are concatenated, then the corresponding flat string is + built. + - [maximal_height] is the threshold for rebalancing: when a rope has + height at least [maximal_height] it is then rebalanced; setting + [small_length] to [max_int] will result in ropes that are never + rebalanced (which is perfectly fine in many applications). +*) + +module type CONTROL = sig + val small_length : int + val maximal_height : int +end + +module Make (S : STRING) (C : CONTROL) : sig + include ROPE with type char = S.char + + val of_string : S.t -> t +end + +(** Instance: usual strings (i.e. with [type char = Char.t]) is a + particular instance of functor [Make] above, which is directly + provided here as module [S] *) + +module String : sig + include ROPE with type char = Char.t + + val of_string : string -> t +end + +(** Elements of ropes can be of any type, of course. In that case, + they must rather be seen as arrays instead of strings. The + following functor builds ropes for a given (printable) type of + elements (using arrays internally for flat strings). *) + +module type Print = sig + type t + + val print : Format.formatter -> t -> unit +end + +module Make_array (X : Print) : sig + include ROPE with type char = X.t + + val of_array : X.t array -> t + val create : int -> X.t -> t + val init : int -> (int -> X.t) -> t +end diff --git a/rp.ml b/rp.ml new file mode 100644 index 0000000..1556f27 --- /dev/null +++ b/rp.ml @@ -0,0 +1,30 @@ +include Rope.Make_array (struct + include Uchar + + let uchar_to_utf_8 = + let buf = Buffer.create 16 in + fun uchar -> + Uutf.Buffer.add_utf_8 buf uchar; + let res = Buffer.contents buf in + Buffer.clear buf; + res + + let print = + Fmt.if_utf_8 + Fmt.(using uchar_to_utf_8 string) + Fmt.(using Uchar.to_int (any "U+04X")) +end) + +let to_utf_8_string rope = + let len = length rope in + let buf = Buffer.create len in + iter_range (Uutf.Buffer.add_utf_8 buf) rope 0 len; + Buffer.contents buf + +let of_utf_8_string str = + Uutf.String.fold_utf_8 + (fun (rope, upos) _bpos -> function + | `Malformed _ -> (insert_char rope upos Uutf.u_rep, succ upos) + | `Uchar uchr -> (insert_char rope upos uchr, succ upos)) + (empty, 0) str + |> fst diff --git a/unikernel.ml b/unikernel.ml index e993214..4a2fff0 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -1,14 +1,16 @@ open Lwt.Syntax +type state = + { env : (string, string) Hashtbl.t + ; sigwinch : (int * int) Lwt_condition.t + ; mutable size : int * int + } + module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) (Stack : Tcpip.Stack.V4V6) = struct module Ssh = Banawa_mirage.Make(Stack.TCP)(T)(M) + module Nottui' = Nottui_mirage.Make(T) - type message = - | Message of { sender : string; message : string } - | Join of string - | Part of string - - let c : message Lwt_condition.t = Lwt_condition.create () + let c : Message.t Lwt_condition.t = Lwt_condition.create () let read username ic = let rec loop () = @@ -19,36 +21,28 @@ module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) if String.equal message "" then loop () else - let m = Message { - sender = username; - message = String.trim message; - } in + let m = Message.make ~nickname:username (String.trim message) in Lwt_condition.broadcast c m; loop () | `Eof -> - Lwt_condition.broadcast c (Part username); + Lwt_condition.broadcast c (Message.make ~nickname:"<--" username); Lwt.return_unit in loop () let rec write me oc = let* m = Lwt_condition.wait c in - match m with - | Message { sender; message=_ } when String.equal sender me -> + if String.equal (Message.nickname m) me then write me oc - | Message { sender; message } -> - let* () = oc (Printf.ksprintf Cstruct.of_string "\x07%s: %s\r\n" sender message) in + else + let* () = + oc (Printf.ksprintf Cstruct.of_string "\x07%s: %s\r\n" + (Message.nickname m) (Message.message m)) + in write me oc - | Join username -> - let* () = oc (Printf.ksprintf Cstruct.of_string "--> %s joined!\r\n" username) in - write me oc - | Part username -> - let* () = oc (Printf.ksprintf Cstruct.of_string "<-- %s left\r\n" username) in - write me oc - let chat flow stop username ic oc = - Lwt_condition.broadcast c (Join username); + Lwt_condition.broadcast c (Message.make ~nickname:"-->" username); let* () = oc (Cstruct.of_string (Printf.sprintf "Hello, %s!\r\n" username)) in let* () = Lwt.pick [ @@ -59,16 +53,46 @@ module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) let* () = Lwt_switch.turn_off stop in Stack.TCP.close flow - let callback flow stop ~username r = + let callback flow stop t ~username r = match r with - | Ssh.Pty_req _ | Ssh.Pty_set _ | Ssh.Set_env _ -> + | Ssh.Pty_req { width; height; _ } -> + t.size <- (Int32.to_int width, Int32.to_int height); Lwt.return_unit - | Ssh.Channel { cmd; ic; oc; ec; } -> - chat flow stop username ic oc - | Ssh.Shell { ic; oc; ec; } -> - let* () = ec (Cstruct.of_string "Banawá-chat does currently not work well with TTY.\r\n\ - Consider reconnecting without tty (ssh -T)\r\n") in + | Ssh.Pty_set { width; height; _ } -> + Lwt_condition.broadcast t.sigwinch + (Int32.to_int width, Int32.to_int height); + Lwt.return_unit + | Ssh.Set_env _ -> Lwt.return_unit + | Ssh.Channel { cmd=_; ic; oc; ec=_ } -> chat flow stop username ic oc + | Ssh.Shell { ic; oc; ec=_ } -> + let ic () = + let+ r = ic () in + match r with + | `Data cs -> `Data (Cstruct.map (function '\r' -> '\n' | c -> c) cs) + | `Eof -> `Eof + in + let cursor = Lwd.var (0, 0) in + let message m = Lwt_condition.broadcast c (Message.make ~nickname:username m) in + let buffer = Rb.make 100 in + Rb.push buffer (Message.msgf "Welcome, %s!" username); + let buffer_var = Lwd.var buffer in + let ui = + let ( let* ) x f = Lwd.bind x ~f in + let* prompt = Prompt.make ~message cursor in + let* window = Window.make buffer_var in + Lwd.return (Nottui.Ui.vcat [window; prompt]) + in + let rec handle_receive () = + let* msg = Lwt_condition.wait c in + Lwd.set buffer_var (Rb.push buffer msg; buffer); + handle_receive () + in + Lwt_condition.broadcast c (Message.make ~nickname:"-->" username); + Lwt.join [ + Nottui'.run ~cursor (t.size, t.sigwinch) ui ic oc; + handle_receive (); + ] let start _random _time _mtime stack = let port = Key_gen.port () in @@ -84,7 +108,13 @@ module Main (_ : Mirage_random.S) (T : Mirage_time.S) (M : Mirage_clock.MCLOCK) Stack.TCP.listen (Stack.tcp stack) ~port (fun flow -> let stop = Lwt_switch.create () in - let _ssh = Ssh.spawn_server ~stop server msgs flow (callback flow stop) in + let state = + { env = Hashtbl.create 0x10 + ; sigwinch = Lwt_condition.create () + ; size = (0, 0) + } + in + let _ssh = Ssh.spawn_server ~stop server msgs flow (callback flow stop state) in Lwt.return_unit); fst (Lwt.wait ()) end diff --git a/window.ml b/window.ml new file mode 100644 index 0000000..9a8ae07 --- /dev/null +++ b/window.ml @@ -0,0 +1,78 @@ +open Nottui +open Notty + +type t = { w : int; h : int; p : int } + +let render_message ~width ~width_nicknames msg = + let width_message = + max 1 (width - width_nicknames - 1) + in + let message = Message.split_at ~len:width_message msg in + let color = A.white in + let rest = + List.map @@ fun msg -> + I.hcat + [ I.void width_nicknames 1 + ; I.strf "│" + ; I.strf "%s" msg + ] + in + I.vcat + (I.hcat + [ I.strf " " + ; I.hsnap ~align:`Right width_nicknames + (I.strf ~attr:A.(fg color) "%s" (Message.nickname msg)) + ; I.strf "│" + ; I.strf "%s" (List.hd message) + ] + :: rest (List.tl message)) + +let width_nicknames msgs = + let f msg acc = max (String.length (Message.nickname msg)) acc in + Rb.iter ~f msgs 0 + +let render { w; h; p } msgs = + let idx = ref (Rb.length msgs - 1 - p) in + let image = ref I.empty in + let message = ref I.empty in + let width_nicknames = width_nicknames msgs in + while + !idx >= 0 + && + (message := + render_message ~width_nicknames ~width:w msgs.Rb.%[!idx]; + I.height !message + I.height !image <= h) + do + (image := I.(!message <-> !image)); + decr idx + done; + Ui.atom (I.vsnap ~align:`Bottom h !image) + +let handler ~hook:_ _state _buffer _key = `Unhandled + +let make w = + let ( let* ) x f = Lwd.bind ~f x in + let ( let+ ) x f = Lwd.map ~f x in + let ( and+ ) = Lwd.map2 ~f:(fun x y -> (x, y)) in + + let state = Lwd.var { w = 0; h = 0; p = 0 } in + let hook = Lwd.set state in + + let* document = + let+ state = Lwd.get state + and+ buffer = Lwd.get w in + Ui.keyboard_area + (handler ~hook state buffer) + (render state buffer) + in + + let update_size ~w ~h = + let state' = Lwd.peek state in + if state'.w <> w || state'.h <> h then Lwd.set state { state' with w; h } + in + + let measure_size document = + Ui.size_sensor update_size (Ui.resize ~sh:1 document) + in + + Lwd.return (measure_size document)