Terminal User Interface!

Thanks @dinosaure
This commit is contained in:
Reynir Björnsson 2023-05-04 13:49:25 +02:00
parent 32051dc351
commit 9a535d897c
13 changed files with 1423 additions and 31 deletions

View file

@ -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)

20
message.ml Normal file
View file

@ -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

11
message.mli Normal file
View file

@ -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

87
nottui_mirage.ml Normal file
View file

@ -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

147
notty_mirage.ml Normal file
View file

@ -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

129
prompt.ml Normal file
View file

@ -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)

69
rb.ml Normal file
View file

@ -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"

25
rb.mli Normal file
View file

@ -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

539
rope.ml Normal file
View file

@ -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

220
rope.mli Normal file
View file

@ -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

30
rp.ml Normal file
View file

@ -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

View file

@ -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 =