parent
32051dc351
commit
9a535d897c
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
92
unikernel.ml
92
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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
Loading…
Reference in New Issue