├── message.mli ├── message.ml ├── config.ml ├── rp.ml ├── rb.mli ├── README.md ├── rb.ml ├── window.ml ├── nottui_mirage.ml ├── unikernel.ml ├── notty_mirage.ml ├── prompt.ml ├── rope.mli └── rope.ml /message.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val split_at : len:int -> t -> string list 4 | val make : nickname:string -> string -> t 5 | val nickname : t -> string 6 | val message : t -> string 7 | 8 | val msgf : 9 | ?nickname:string 10 | -> ('a, Format.formatter, unit, t) format4 11 | -> 'a 12 | -------------------------------------------------------------------------------- /message.ml: -------------------------------------------------------------------------------- 1 | type t = { nickname : string; message : string } 2 | 3 | let nickname { nickname; _ } = nickname 4 | let message { message; _ } = message 5 | 6 | let split_at ~len:max str = 7 | let rec go acc off len = 8 | if len <= max then String.sub str off len :: acc 9 | else go (String.sub str off max :: acc) (off + max) (len - max) 10 | in 11 | if max <= 0 then invalid_arg "split_at"; 12 | go [] 0 (String.length str) |> List.rev 13 | 14 | let split_at ~len { message; _ } = 15 | split_at ~len message 16 | 17 | let make ~nickname message = { nickname; message } 18 | 19 | let msgf ?(nickname="Banawá") fmt = 20 | Fmt.kstr (fun message -> { nickname; message }) fmt 21 | -------------------------------------------------------------------------------- /config.ml: -------------------------------------------------------------------------------- 1 | (* mirage >= 4.9.0 *) 2 | open Mirage 3 | 4 | let main = 5 | let runtime_args = [ 6 | runtime_arg ~pos:__POS__ "Unikernel.K.port"; 7 | runtime_arg ~pos:__POS__ "Unikernel.K.hostkey"; 8 | ] in 9 | let packages = [ 10 | package "banawa-mirage" ~pin:"git+https://github.com/sorbusursina/banawa-ssh.git#banawa"; 11 | package "awa" ~pin:"git+https://github.com/mirage/awa-ssh.git#authie"; 12 | package "notty"; 13 | package "nottui" 14 | ~pin:"git+https://github.com/reynir/lwd.git#split-out-unix"; 15 | package "lwd" 16 | ~pin:"git+https://github.com/reynir/lwd.git#split-out-unix"; 17 | package "art"; 18 | ] in 19 | main ~runtime_args ~packages "Unikernel.Main" (stackv4v6 @-> job) 20 | 21 | let () = 22 | register "banawa-chat" [ 23 | main $ generic_stackv4v6 default_network 24 | ] 25 | -------------------------------------------------------------------------------- /rp.ml: -------------------------------------------------------------------------------- 1 | include Rope.Make_array (struct 2 | include Uchar 3 | 4 | let uchar_to_utf_8 = 5 | let buf = Buffer.create 16 in 6 | fun uchar -> 7 | Uutf.Buffer.add_utf_8 buf uchar; 8 | let res = Buffer.contents buf in 9 | Buffer.clear buf; 10 | res 11 | 12 | let print = 13 | Fmt.if_utf_8 14 | Fmt.(using uchar_to_utf_8 string) 15 | Fmt.(using Uchar.to_int (any "U+04X")) 16 | end) 17 | 18 | let to_utf_8_string rope = 19 | let len = length rope in 20 | let buf = Buffer.create len in 21 | iter_range (Uutf.Buffer.add_utf_8 buf) rope 0 len; 22 | Buffer.contents buf 23 | 24 | let of_utf_8_string str = 25 | Uutf.String.fold_utf_8 26 | (fun (rope, upos) _bpos -> function 27 | | `Malformed _ -> (insert_char rope upos Uutf.u_rep, succ upos) 28 | | `Uchar uchr -> (insert_char rope upos uchr, succ upos)) 29 | (empty, 0) str 30 | |> fst 31 | -------------------------------------------------------------------------------- /rb.mli: -------------------------------------------------------------------------------- 1 | (** A simple ring-buffer. *) 2 | 3 | type ('c, 'a) t constraint 'c = < .. > 4 | (** The type of a ring-buffer whose elements have type ['a]. *) 5 | 6 | type ro = < rd : unit > 7 | type wo = < wr : unit > 8 | type rdwr = < rd : unit ; wr : unit > 9 | type 'a rd = < rd : unit ; .. > as 'a 10 | type 'a wr = < wr : unit ; .. > as 'a 11 | 12 | val make : int -> (< rd : unit ; wr : unit >, 'a) t 13 | val length : ('c rd, 'a) t -> int 14 | val is_empty : ('c rd, 'a) t -> bool 15 | val available : ('c rd, 'a) t -> int 16 | val is_full : ('c rd, 'a) t -> bool 17 | val push : ('c wr, 'a) t -> 'a -> unit 18 | val pop : ('c wr, 'a) t -> 'a 19 | val fit_and_push : ('c wr, 'a) t -> 'a -> unit 20 | val drop : ('c wr, 'a) t -> unit 21 | val iter : f:('a -> 'acc -> 'acc) -> ('c rd, 'a) t -> 'acc -> 'acc 22 | val rev_iter : f:('a -> 'acc -> 'acc) -> ('c rd, 'a) t -> 'acc -> 'acc 23 | val ( .%[] ) : ('c rd, 'a) t -> int -> 'a 24 | val to_ro : ('c rd, 'a) t -> (ro, 'a) t 25 | val to_wo : ('c wr, 'a) t -> (wo, 'a) t 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Banawá chat - Trust On First Use SSH Chat 2 | 3 | Banawa-chat is a [MirageOS](https://mirage.io/) unikernel that acts as a special SSH server that provides a chat room for connecting clients. 4 | Clients connect with a SSH key, and if the username has not been used before the key is then associated with that user. 5 | This is a [trust of first use (TOFU)](https://en.wikipedia.org/wiki/Trust_on_first_use) scheme for user authentication. 6 | The user database and chat log is kept in the memory of the unikernel, and the user interface is rendered on the server. 7 | Users don't require any other software than an SSH client in order to use the chat room. 8 | 9 | Banawa-chat was written in May 2023 at the 12th [MirageOS hack retreat](http://retreat.mirage.io/). 10 | As the server was written in only a few days it suffers from a number of bugs and warts (though mostly usable). 11 | The [awa-ssh](https://github.com/mirage/awa-ssh) was [forked](https://github.com/sorbusursina/banawa-ssh) in order to support the TOFU scheme. 12 | During development of this application three bugs were discovered, and two of them fixed. 13 | See https://github.com/mirage/awa-ssh/pull/55, https://github.com/mirage/awa-ssh/pull/56 and https://github.com/mirage/awa-ssh/issues/57. 14 | 15 | Thanks a lot to [@dinosaure](https://github.com/dinosaure) who provided code that I could steal for the nice terminal user interface and helped me debug many things. 16 | Thanks as well to [@wyn](https://github.com/wyn) who helped me test and debug RSA authentication from newer ssh clients. 17 | -------------------------------------------------------------------------------- /rb.ml: -------------------------------------------------------------------------------- 1 | type ('c, 'a) t = 2 | { arr : 'a option array; mutable rd_cursor : int; mutable wr_cursor : int } 3 | constraint 'c = < .. > 4 | 5 | type ro = < rd : unit > 6 | type wo = < wr : unit > 7 | type rdwr = < rd : unit ; wr : unit > 8 | type 'a rd = < rd : unit ; .. > as 'a 9 | type 'a wr = < wr : unit ; .. > as 'a 10 | 11 | let make len = { arr = Array.make len None; rd_cursor = 0; wr_cursor = 0 } 12 | 13 | exception Full 14 | exception Empty 15 | 16 | let length t = 17 | if t.rd_cursor <= t.wr_cursor then t.wr_cursor - t.rd_cursor 18 | else 19 | let len = Array.length t.arr in 20 | len - t.rd_cursor + t.wr_cursor 21 | 22 | let is_empty t = length t = 0 23 | let available t = Array.length t.arr - length t 24 | let is_full t = length t = Array.length t.arr 25 | let mask t v = v mod Array.length t.arr 26 | 27 | let push t v = 28 | if is_full t then raise Full; 29 | t.arr.(t.wr_cursor) <- Some v; 30 | t.wr_cursor <- mask t (t.wr_cursor + 1) 31 | 32 | let pop t = 33 | if is_empty t then raise Empty; 34 | let[@warning "-8"] (Some v) = t.arr.(t.rd_cursor) in 35 | t.rd_cursor <- mask t (t.rd_cursor + 1); 36 | v 37 | 38 | let fit_and_push t v = 39 | if is_full t then ignore (pop t); 40 | push t v 41 | 42 | let drop t = 43 | if is_empty t then raise Empty; 44 | t.wr_cursor <- mask t (t.wr_cursor - 1) 45 | 46 | let iter ~f t a = 47 | let i = ref t.rd_cursor in 48 | let a = ref a in 49 | while !i <> t.wr_cursor do 50 | a := f (Option.get t.arr.(mask t !i)) !a; 51 | incr i 52 | done; 53 | !a 54 | 55 | let rev_iter ~f t a = 56 | let i = ref (t.wr_cursor - 1) in 57 | let a = ref a in 58 | while !i >= t.rd_cursor do 59 | a := f (Option.get t.arr.(mask t !i)) !a; 60 | decr i 61 | done; 62 | !a 63 | 64 | let ( .%[] ) t idx = 65 | if idx >= length t then invalid_arg "Out of bounds"; 66 | Option.get t.arr.(mask t (t.rd_cursor + idx)) 67 | 68 | external to_ro : ('c rd, 'a) t -> (ro, 'a) t = "%identity" 69 | external to_wo : ('c wr, 'a) t -> (wo, 'a) t = "%identity" 70 | -------------------------------------------------------------------------------- /window.ml: -------------------------------------------------------------------------------- 1 | open Nottui 2 | open Notty 3 | 4 | type t = { w : int; h : int; } 5 | 6 | let render_message ~width ~width_nicknames msg = 7 | (* (* FIXME: split doesn't work *) 8 | let width_message = 9 | max 1 (width - width_nicknames - 1) 10 | in 11 | let message = Message.split_at ~len:width_message msg in *) 12 | let _ = width in 13 | let message = [Message.message msg] in 14 | let color = A.white in 15 | let rest = 16 | List.map @@ fun msg -> 17 | I.hcat 18 | [ I.void width_nicknames 1 19 | ; I.strf "│" 20 | ; I.strf "%s" msg 21 | ] 22 | in 23 | I.vcat 24 | (I.hcat 25 | [ I.strf " " 26 | ; I.hsnap ~align:`Right width_nicknames 27 | (I.strf ~attr:A.(fg color) "%s" (Message.nickname msg)) 28 | ; I.strf "│" 29 | ; I.strf "%s" (List.hd message) 30 | ] 31 | :: rest (List.tl message)) 32 | 33 | let width_nicknames msgs = 34 | let f msg acc = max (String.length (Message.nickname msg)) acc in 35 | Rb.iter ~f msgs 0 36 | 37 | let render { w; h } msgs = 38 | let idx = ref (Rb.length msgs - 1) in 39 | let image = ref I.empty in 40 | let message = ref I.empty in 41 | let width_nicknames = width_nicknames msgs in 42 | while 43 | !idx >= 0 44 | && 45 | (message := 46 | render_message ~width_nicknames ~width:w msgs.Rb.%[!idx]; 47 | I.height !message + I.height !image <= h) 48 | do 49 | (image := I.(!message <-> !image)); 50 | decr idx 51 | done; 52 | Ui.atom (I.vsnap ~align:`Bottom h !image) 53 | 54 | let make w = 55 | let ( let* ) x f = Lwd.bind ~f x in 56 | let ( let+ ) x f = Lwd.map ~f x in 57 | let ( and+ ) = Lwd.map2 ~f:(fun x y -> (x, y)) in 58 | 59 | let state = Lwd.var { w = 0; h = 0 } in 60 | 61 | let* document = 62 | let+ state = Lwd.get state 63 | and+ buffer = Lwd.get w in 64 | render state buffer 65 | in 66 | 67 | let update_size ~w ~h = 68 | let state' = Lwd.peek state in 69 | if state'.w <> w || state'.h <> h then Lwd.set state { w; h } 70 | in 71 | 72 | let measure_size document = 73 | Ui.size_sensor update_size (Ui.resize ~sh:1 document) 74 | in 75 | 76 | Lwd.return (measure_size document) 77 | -------------------------------------------------------------------------------- /nottui_mirage.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "nottui.mirage" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | 5 | module Make = struct 6 | open Notty_mirage.Make 7 | 8 | let copy_until quit ~f input = 9 | let quit = Lwt.map (fun () -> None) quit in 10 | let stream, push = Lwt_stream.create () in 11 | let rec go () = 12 | Lwt.bind (Lwt.choose [ quit; Lwt_stream.peek input ]) @@ function 13 | | None -> 14 | push None; 15 | Lwt.return_unit 16 | | Some x -> 17 | push (Some (f x)); 18 | Lwt.bind (Lwt_stream.junk input) go 19 | in 20 | Lwt.async go; 21 | stream 22 | 23 | let render ?quit ~size events document = 24 | let renderer = Nottui.Renderer.make () in 25 | let refresh_stream, push_refresh = Lwt_stream.create () in 26 | let root = 27 | Lwd.observe 28 | ~on_invalidate:(fun _ -> 29 | if not (Lwt_stream.is_closed refresh_stream) then 30 | push_refresh (Some ())) 31 | document 32 | in 33 | let quit, _do_quit = 34 | match quit with 35 | | Some quit -> (quit, None) 36 | | None -> 37 | let t, u = Lwt.wait () in 38 | (t, Some u) 39 | in 40 | let events = 41 | copy_until quit events ~f:(fun e -> 42 | (e 43 | : [ `Resize of _ | Notty.Unescape.event ] 44 | :> [ `Resize of _ | Nottui.Ui.event ])) 45 | in 46 | let size = ref size in 47 | let result, push = Lwt_stream.create () in 48 | let refresh () = 49 | let ui = Lwd.quick_sample root in 50 | Nottui.Renderer.update renderer !size ui; 51 | push (Some (Nottui.Renderer.image renderer)) 52 | in 53 | refresh (); 54 | let process_event = function 55 | | #Nottui.Ui.event as event -> 56 | ignore (Nottui.Renderer.dispatch_event renderer event) 57 | | `Resize size' -> 58 | size := size'; 59 | refresh () 60 | in 61 | Lwt.async (fun () -> 62 | Lwt.finalize 63 | (fun () -> Lwt_stream.iter process_event events) 64 | (fun () -> 65 | push None; 66 | Lwt.return_unit)); 67 | Lwt.async (fun () -> Lwt_stream.iter refresh refresh_stream); 68 | result 69 | 70 | let run ?cursor ?quit (size, sigwinch) document ic oc = 71 | let term = Term.create (size, sigwinch) ic oc in 72 | let images = render ?quit ~size (Term.events term) document in 73 | let cursor () = 74 | let cursor = 75 | cursor 76 | |> Option.map @@ fun cursor -> 77 | Lwd.quick_sample (Lwd.observe (Lwd.get cursor)) 78 | in 79 | Term.cursor term cursor 80 | in 81 | Lwt.finalize 82 | (fun () -> 83 | Lwt_stream.iter_s 84 | (fun image -> Lwt.join [ Term.image term image; cursor () ]) 85 | images) 86 | (fun () -> Term.release term) 87 | end 88 | -------------------------------------------------------------------------------- /unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | type state = 4 | { env : (string, string) Hashtbl.t 5 | ; sigwinch : (int * int) Lwt_condition.t 6 | ; mutable size : int * int 7 | } 8 | 9 | module K = struct 10 | open Cmdliner 11 | let port = 12 | let doc = Arg.info ~doc:"The TCP port for listening for SSH connections" ["port"] in 13 | Arg.(value & opt int 22 doc) 14 | 15 | let hostkey = 16 | let doc = Arg.info ~doc:"SSH host key" ["hostkey"] in 17 | Arg.(required & opt (some string) None doc) 18 | end 19 | 20 | module Main (Stack : Tcpip.Stack.V4V6) = struct 21 | module Ssh = Banawa_mirage.Make(Stack.TCP) 22 | module Nottui' = Nottui_mirage.Make 23 | 24 | let buffer = Rb.make 1024 25 | let buffer_var = Lwd.var buffer 26 | 27 | let callback flow stop t ~username r = 28 | match r with 29 | | Ssh.Pty_req { width; height; _ } -> 30 | t.size <- (Int32.to_int width, Int32.to_int height); 31 | Lwt.return_unit 32 | | Ssh.Pty_set { width; height; _ } -> 33 | Lwt_condition.broadcast t.sigwinch 34 | (Int32.to_int width, Int32.to_int height); 35 | Lwt.return_unit 36 | | Ssh.Set_env _ -> Lwt.return_unit 37 | | Ssh.Channel { cmd; ic=_; oc=_; ec } -> 38 | let* () = 39 | ec (Printf.ksprintf Cstruct.of_string 40 | "Thanks for logging in! Currently, %S is unsupported\r\n\ 41 | Check back later." cmd) 42 | in 43 | let* () = Lwt_switch.turn_off stop in 44 | Stack.TCP.close flow 45 | | Ssh.Shell { ic; oc; ec=_ } -> 46 | let ic () = 47 | let+ r = ic () in 48 | match r with 49 | | `Data cs -> `Data (Cstruct.map (function '\r' -> '\n' | c -> c) cs) 50 | | `Eof -> `Eof 51 | in 52 | let cursor = Lwd.var (0, 0) in 53 | let message m = 54 | let msg = Message.make ~nickname:username m in 55 | Lwd.set buffer_var (Rb.push buffer msg; buffer); 56 | in 57 | let quit () = 58 | let msg = Message.msgf "%s tried to quit, but it is not implemented" username in 59 | Lwd.set buffer_var (Rb.push buffer msg; buffer); 60 | in 61 | Lwd.set buffer_var 62 | (Rb.push buffer (Message.msgf "Welcome, %s!" username); buffer); 63 | let ui = 64 | let ( let* ) x f = Lwd.bind x ~f in 65 | let* prompt = Prompt.make ~quit ~message cursor in 66 | let* window = Window.make buffer_var in 67 | Lwd.return (Nottui.Ui.vcat [window; prompt]) 68 | in 69 | Lwt.join [ 70 | Nottui'.run ~cursor (t.size, t.sigwinch) ui ic oc; 71 | ] 72 | 73 | let start stack port hostkey = 74 | let hostkey = 75 | match Awa.Keys.of_string hostkey with 76 | | Ok k -> k 77 | | Error `Msg e -> 78 | Logs.err (fun m -> m "%s" e); exit 1 79 | in 80 | let server, msgs = Awa.Server.make hostkey in 81 | Stack.TCP.listen (Stack.tcp stack) ~port 82 | (fun flow -> 83 | let stop = Lwt_switch.create () in 84 | let state = 85 | { env = Hashtbl.create 0x10 86 | ; sigwinch = Lwt_condition.create () 87 | ; size = (0, 0) 88 | } 89 | in 90 | let db = Banawa_mirage.Auth.empty 42 in 91 | let _ssh = Ssh.spawn_server ~stop server db msgs flow (callback flow stop state) in 92 | Lwt.return_unit); 93 | fst (Lwt.wait ()) 94 | end 95 | -------------------------------------------------------------------------------- /notty_mirage.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "notty.mirage" 2 | 3 | module Log = (val Logs.src_log src : Logs.LOG) 4 | open Lwt.Infix 5 | open Notty 6 | 7 | let ( ) a b = Lwt.pick [ a >|= Either.left; b >|= Either.right ] 8 | let ( ) a b = a >|= Either.left (b >|= Either.right) 9 | 10 | module Make = struct 11 | module Lwt_condition = struct 12 | include Lwt_condition 13 | 14 | let map f v = 15 | let v' = create () in 16 | let rec go () = 17 | wait v >>= fun x -> 18 | broadcast v' (f x); 19 | go () 20 | in 21 | Lwt.async go; 22 | v' 23 | 24 | let unburst ~timeout v = 25 | let v' = create () in 26 | let rec delay x = 27 | Mirage_sleep.ns timeout wait v >>= function 28 | | Either.Left () -> 29 | broadcast v' x; 30 | start () 31 | | Either.Right x -> delay x 32 | and start () = wait v >>= delay in 33 | Lwt.async start; 34 | v' 35 | end 36 | 37 | module Term = struct 38 | let input_stream ic stop = 39 | let flt = Unescape.create () in 40 | let ibuf = Bytes.create 1024 in 41 | let rec next () = 42 | match Unescape.next flt with 43 | | #Unescape.event as r -> Lwt.return_some r 44 | | `End -> Lwt.return_none 45 | | `Await -> ( 46 | ic () stop >>= function 47 | | Either.Right _ -> Lwt.return_none 48 | | Either.Left `Eof -> 49 | Unescape.input flt ibuf 0 0; 50 | next () 51 | | Either.Left (`Data cs) -> 52 | let rec go cs = 53 | if Cstruct.length cs > 0 then ( 54 | let len = min (Bytes.length ibuf) (Cstruct.length cs) in 55 | Cstruct.blit_to_bytes cs 0 ibuf 0 len; 56 | Unescape.input flt ibuf 0 len; 57 | go (Cstruct.shift cs len)) 58 | else Lwt.return_unit 59 | in 60 | go cs >>= next) 61 | in 62 | Lwt_stream.from next 63 | 64 | type t = 65 | { oc : Cstruct.t -> unit Lwt.t 66 | ; trm : Notty.Tmachine.t 67 | ; buf : Buffer.t 68 | ; events : [ Unescape.event | `Resize of int * int ] Lwt_stream.t 69 | ; stop : unit -> unit 70 | } 71 | 72 | let write t = 73 | Tmachine.output t.trm t.buf; 74 | let out = Buffer.contents t.buf in 75 | Buffer.clear t.buf; 76 | t.oc (Cstruct.of_string out) 77 | 78 | let refresh t = 79 | Tmachine.refresh t.trm; 80 | write t 81 | 82 | let image t image = 83 | Tmachine.image t.trm image; 84 | write t 85 | 86 | let cursor t curs = 87 | Tmachine.cursor t.trm curs; 88 | write t 89 | 90 | let set_size t dim = Tmachine.set_size t.trm dim 91 | let size t = Tmachine.size t.trm 92 | 93 | let release t = 94 | if Tmachine.release t.trm then ( 95 | t.stop (); 96 | write t (* TODO(dinosaure): send [`Eof] *)) 97 | else Lwt.return_unit 98 | 99 | let resize dim stop on_resize = 100 | (* TODO(dinosaure): we can save some allocations here but I mostly followed `notty-lwt`. *) 101 | let rcond = 102 | Lwt_condition.unburst ~timeout:1000L dim 103 | |> Lwt_condition.map Option.some 104 | in 105 | let rec monitor () = 106 | Lwt_condition.wait rcond stop >>= function 107 | | Some dim -> 108 | on_resize dim; 109 | monitor () 110 | | None -> Lwt.return_unit 111 | in 112 | Lwt.dont_wait monitor (fun exn -> 113 | Logs.err @@ fun m -> 114 | m "Got an exception from the resizer: %S" (Printexc.to_string exn)); 115 | Lwt_stream.from (fun () -> Lwt_condition.wait rcond stop) 116 | |> Lwt_stream.map (fun dim -> `Resize dim) 117 | 118 | let create ?(dispose = true) ?(bpaste = true) ?(mouse = true) 119 | (size, sigwinch) ic oc = 120 | let stop, do_stop = Lwt.wait () in 121 | let rec t = 122 | lazy 123 | { trm = 124 | Tmachine.create ~mouse ~bpaste 125 | Cap.ansi (* XXX(dinosaure): we assume! *) 126 | ; oc 127 | ; buf = Buffer.create 4096 128 | ; stop = (fun () -> Lwt.wakeup do_stop None) 129 | ; events = 130 | Lwt_stream.choose 131 | [ input_stream ic stop 132 | ; ( resize sigwinch stop @@ fun dim -> 133 | let t = Lazy.force t in 134 | Buffer.reset t.buf; 135 | set_size t dim ) 136 | ] 137 | } 138 | in 139 | let t = Lazy.force t in 140 | set_size t size; 141 | Lwt.async (fun () -> write t); 142 | if dispose then Mirage_runtime.at_exit (fun () -> release t); 143 | t 144 | 145 | let events t = t.events 146 | end 147 | end 148 | -------------------------------------------------------------------------------- /prompt.ml: -------------------------------------------------------------------------------- 1 | open Nottui 2 | open Notty 3 | 4 | type t = { 5 | quit : unit -> unit; 6 | message : string -> unit; 7 | cursor : Rp.Cursor.cursor; 8 | } 9 | 10 | let make quit message = 11 | let cursor = Rp.Cursor.create Rp.empty 0 in 12 | { quit; message; cursor } 13 | 14 | let map_cursor f state = 15 | { state with cursor = f state.cursor } 16 | 17 | module Utils = struct 18 | let move_cursor ?(visual = true) ~hook cursor = function 19 | | `Left -> 20 | let position = Rp.Cursor.position cursor in 21 | (if position > 0 then 22 | let cursor = Rp.Cursor.move_backward cursor 1 in 23 | hook cursor); 24 | `Handled 25 | | `Right -> 26 | let position = Rp.Cursor.position cursor in 27 | let rope = Rp.Cursor.to_rope cursor in 28 | let len = Rp.length rope in 29 | let len = if visual then len - 1 else len in 30 | (if position < len then 31 | let cursor = Rp.Cursor.move_forward cursor 1 in 32 | hook cursor); 33 | `Handled 34 | 35 | let is_print = function '\x21' .. '\x7e' | ' ' -> true | _ -> false 36 | 37 | let render_cursor ~width cursor = 38 | let rope = Rp.Cursor.to_rope cursor in 39 | let position = Rp.Cursor.position cursor in 40 | let length = Rp.length rope in 41 | let offset = if position >= width then position - width else 0 in 42 | let rope = Rp.sub rope offset (length - offset) in 43 | (* XXX(dinosaure): shift our text according to [offset]. *) 44 | let length = Rp.length rope in 45 | let left, middle, right = 46 | match position >= 0 && position < length with 47 | | true -> 48 | ( Rp.sub rope 0 position 49 | , Some (Rp.get rope position) 50 | , Rp.sub rope (position + 1) (length - position - 1) ) 51 | | false -> (rope, None, Rp.empty) 52 | in 53 | let middle = 54 | match middle with 55 | | None -> I.uchar A.empty (Uchar.of_char ' ') 1 1 56 | | Some uchar -> I.uchar A.empty uchar 1 1 57 | in 58 | ( I.hcat [ I.strf "%a" Rp.print left; middle; I.strf "%a" Rp.print right ] 59 | , position - offset ) 60 | end 61 | 62 | module User_prompt = struct 63 | let render ~cursor ~y ~w state = 64 | let text, position = 65 | Utils.render_cursor ~width:(max 0 (w - 3)) state.cursor 66 | in 67 | let new_cursor = (position + 1, y) in 68 | if new_cursor <> (Lwd.peek cursor) then 69 | Lwd.set cursor new_cursor; 70 | I.hcat [ I.char A.empty ' ' 1 1 ; text ] 71 | end 72 | 73 | let handler ~hook state = function 74 | | `ASCII chr, [] when Utils.is_print chr -> 75 | map_cursor (fun cursor -> 76 | let cursor = Rp.Cursor.insert_char cursor (Uchar.of_char chr) in 77 | Rp.Cursor.move_forward cursor 1) 78 | state 79 | |> hook; 80 | `Handled 81 | | `Uchar uchar, [] -> 82 | map_cursor (fun cursor -> 83 | let cursor = Rp.Cursor.insert_char cursor uchar in 84 | Rp.Cursor.move_forward cursor 1) 85 | state 86 | |> hook; 87 | `Handled 88 | | `Backspace, [] -> 89 | if Rp.Cursor.position state.cursor > 0 then 90 | map_cursor (fun cursor -> 91 | let cursor = Rp.Cursor.move_backward cursor 1 in 92 | Rp.Cursor.delete cursor) 93 | state 94 | |> hook; 95 | `Handled 96 | | `Arrow (`Left | `Right as direction), [] -> 97 | let hook cursor = hook { state with cursor } in 98 | Utils.move_cursor ~visual:false ~hook state.cursor direction 99 | | `Enter, [] -> 100 | let rope = Rp.Cursor.to_rope state.cursor in 101 | let msg = 102 | let len = Rp.length rope in 103 | let buf = Buffer.create len in 104 | Rp.iter_range (Uutf.Buffer.add_utf_8 buf) rope 0 len; 105 | Buffer.contents buf 106 | in 107 | state.message msg; 108 | hook { state with cursor = Rp.Cursor.create Rp.empty 0 }; 109 | `Handled 110 | | `ASCII ('C'..'D'), [`Ctrl] -> 111 | state.quit (); 112 | `Handled 113 | | _ -> `Unhandled 114 | 115 | let make ~quit ~message cursor = 116 | let ( let* ) x f = Lwd.bind x ~f in 117 | let ( let+ ) x f = Lwd.map ~f x in 118 | let ( and+ ) = Lwd.map2 ~f:(fun x y -> (x, y)) in 119 | let state = Lwd.var (make quit message) in 120 | let position = Lwd.var (0, 0) in 121 | let hook state' = 122 | if (Lwd.peek state).cursor != state'.cursor then 123 | Lwd.set state state' 124 | in 125 | let update_prompt state (y, w) = 126 | let user = User_prompt.render ~cursor ~y ~w state in 127 | Ui.keyboard_area (handler ~hook state) (Ui.atom user) 128 | in 129 | let update_position ~x:_ ~y ~w ~h:_ () = 130 | let y', w' = Lwd.peek position in 131 | if y' <> y || w' <> w then Lwd.set position (y, w) 132 | in 133 | let* prompts = 134 | let+ state = Lwd.get state 135 | and+ position = Lwd.get position in 136 | update_prompt state position 137 | in 138 | Lwd.return (Ui.transient_sensor update_position prompts) 139 | -------------------------------------------------------------------------------- /rope.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Copyright (C) Jean-Christophe Filliatre *) 4 | (* *) 5 | (* This software is free software; you can redistribute it and/or *) 6 | (* modify it under the terms of the GNU Library General Public *) 7 | (* License version 2.1, with the special exception on linking *) 8 | (* described in file LICENSE. *) 9 | (* *) 10 | (* This software is distributed in the hope that it will be useful, *) 11 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 12 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | (** Ropes are persistent data structures for long sequences. Elements 17 | are of any type. When elements are characters, ropes thus implement 18 | strings (with an interface identical to that of [String]) but with 19 | far better performances w.r.t. concatenation of substring 20 | extraction, especially on very large strings. *) 21 | 22 | (** Ropes are naturally implemented as a functor turning a (possibly 23 | inefficient) data structure of ``strings'' into another (more 24 | efficient) data structure with the same signature. *) 25 | 26 | exception Out_of_bounds 27 | 28 | (** Input signature for the functor *) 29 | 30 | module type STRING = sig 31 | type t 32 | type char 33 | 34 | val length : t -> int 35 | val empty : t 36 | val singleton : char -> t 37 | val append : t -> t -> t 38 | val get : t -> int -> char 39 | 40 | val sub : t -> int -> int -> t 41 | (** [sub t ofs len] extracts the substring of length [len] at offset 42 | [ofs], that is [t[ofs..ofs+len-1]]. 43 | Will always be called with a valid range. *) 44 | 45 | val iter_range : (char -> unit) -> t -> int -> int -> unit 46 | (** [iter_range f t ofs len] successively iterates [f] over characters 47 | of [t] at offsets [ofs], [ofs+1], ..., [ofs+len-1], in this order. 48 | Will always be called with a valid range. *) 49 | 50 | val print : Format.formatter -> t -> unit 51 | end 52 | 53 | (** Output signature of the functor. Note that it extends signature 54 | [STRING] and thus functor [Make] below can be iterated several 55 | times. *) 56 | 57 | module type ROPE = sig 58 | include STRING 59 | 60 | val is_empty : t -> bool 61 | (** [is_empty t] returns [true] if the given rope is empty. *) 62 | 63 | val set : t -> int -> char -> t 64 | (** [set t i c] returns a new rope identical to [t], 65 | apart character [i] which is set to [c]. 66 | Raises [Out_of_bounds] if [i < 0 || i >= length t]. 67 | It is more equivalent to (but more efficient than) 68 | [sub t 0 i ++ singleton c ++ sub t (i+1) (length t-i-1)] *) 69 | 70 | val delete : t -> int -> t 71 | (** [delete t i] returns a new rope obtained by removing character [i] 72 | in [t]. Raises [Out_of_bounds] if [i < 0 || i >= length t]. 73 | It is more equivalent to (but more efficient than) 74 | [sub t 0 i ++ sub t (i + 1) (length t - i - 1)] *) 75 | 76 | val insert_char : t -> int -> char -> t 77 | (** [insert t i c] returns a new rope resulting from the insertion of 78 | character [c] at position [i] in [t], that right before character [i]. 79 | Raises [Out_of_bounds] if [i < 0 || i > length t]. 80 | It is more equivalent to (but more efficient than) 81 | [sub t 0 i ++ singleton c ++ sub t i (length t - i)] *) 82 | 83 | val insert : t -> int -> t -> t 84 | (** [insert t i r] returns a new rope resulting from the insertion 85 | of rope [r] at position [i] in [t]. 86 | Raises [Out_of_bounds] if [i < 0 || i > length t]. 87 | It is more equivalent to (but more efficient than) 88 | [sub t 0 i ++ r ++ sub t i (length t - i)] *) 89 | 90 | (** Cursors are persistent data structures to navigate within ropes. 91 | When several operations are to be performed locally on a rope 92 | (such as local deletions, insertions or even simple accesses), 93 | then the use of cursors can be more efficient than the use of 94 | rope operations. 95 | It is convenient to see the cursor as placed between two characters, 96 | so that a rope of length [n] has [n+1] cursor positions. *) 97 | 98 | module Cursor : sig 99 | type cursor 100 | 101 | val empty : cursor 102 | (** [empty] is a cursor for an empty rope. *) 103 | 104 | val create : t -> int -> cursor 105 | (** [create t i] returns a cursor placed before character [i] of rope 106 | [t]. Raises [Out_of_bounds] is [i < 0 || i > length t]. 107 | Note that [i = length t] is a valid argument, resulting in a cursor 108 | placed right after the last character of the rope (i.e. at the 109 | end of the rope). *) 110 | 111 | val position : cursor -> int 112 | (** [position c] returns the position of cursor [c] in its rope. *) 113 | 114 | val to_rope : cursor -> t 115 | (** [to_rope c] returns the rope corresponding to cursor [c]. *) 116 | 117 | val move_forward : cursor -> int -> cursor 118 | (** [move_forward c n] moves cursor [c] [n] characters forward. 119 | Raises [Invalid_argument] if [n < 0]. 120 | Raises [Out_of_bounds] if it moves the cursor beyond the end of 121 | the rope. *) 122 | 123 | val move_backward : cursor -> int -> cursor 124 | (** [move_backward c n] moves cursor [c] [n] characters 125 | backward. Raises [Invalid_argument] if [n < 0]. Raises 126 | [Out_of_bounds] if it moves the cursor beyond the start of 127 | the rope. *) 128 | 129 | val move : cursor -> int -> cursor 130 | (** [move c n] moves cursor [c] [n] characters away from its current 131 | location, relatively to the sign of [n] (i.e. forward if [n > 0] and 132 | backward if [n < 0]). Raises [Out_of_bounds] if it moves the cursor 133 | beyond the start or the end of the rope. *) 134 | 135 | val get : cursor -> char 136 | (** [get c] returns the character right after cursor 137 | [c]. Raises [Out_of_bounds] if the cursor is located at the 138 | end of the rope. *) 139 | 140 | val set : cursor -> char -> cursor 141 | (** [set c x] returns a new cursor identical to [c] apart from 142 | the character right after the cursor position, which is set 143 | to [x]. Raises [Out_of_bounds] if the cursor is located at 144 | the end of the rope. *) 145 | 146 | val insert_char : cursor -> char -> cursor 147 | (** [insert_char c x] returns a new cursor obtained from [c] by 148 | inserting character [x] at the cursor position. The new 149 | cursor is located right before the newly inserted character 150 | (i.e. at the same absolute position in the rope). *) 151 | 152 | val insert : cursor -> t -> cursor 153 | (** [insert c r] is similar to [insert_char] but inserts a rope [r] at 154 | the cursor point instead of a character. *) 155 | 156 | val delete : cursor -> cursor 157 | (** [delete c] deletes the character right after the cursor location. 158 | Raises [Out_of_bounds] if the cursor is located at the end of the 159 | rope. *) 160 | 161 | val print : Format.formatter -> cursor -> unit 162 | (** [print fmt c] prints cursor [c] on formatter [fmt], as a string 163 | ["abc...|def..."] where ["abc..."] is the portion of the rope 164 | before the cursor position and ["def..."] the portion after. *) 165 | end 166 | end 167 | 168 | (** The functor to build ropes, turning an implemention of strings [S] 169 | into an implemention of ropes. 170 | 171 | It is controlled by two parameters: 172 | - [small_length] is the maximal length under which we perform 173 | concatenation of flat strings, i.e. when two ropes of length at most 174 | [small_length] are concatenated, then the corresponding flat string is 175 | built. 176 | - [maximal_height] is the threshold for rebalancing: when a rope has 177 | height at least [maximal_height] it is then rebalanced; setting 178 | [small_length] to [max_int] will result in ropes that are never 179 | rebalanced (which is perfectly fine in many applications). 180 | *) 181 | 182 | module type CONTROL = sig 183 | val small_length : int 184 | val maximal_height : int 185 | end 186 | 187 | module Make (S : STRING) (C : CONTROL) : sig 188 | include ROPE with type char = S.char 189 | 190 | val of_string : S.t -> t 191 | end 192 | 193 | (** Instance: usual strings (i.e. with [type char = Char.t]) is a 194 | particular instance of functor [Make] above, which is directly 195 | provided here as module [S] *) 196 | 197 | module String : sig 198 | include ROPE with type char = Char.t 199 | 200 | val of_string : string -> t 201 | end 202 | 203 | (** Elements of ropes can be of any type, of course. In that case, 204 | they must rather be seen as arrays instead of strings. The 205 | following functor builds ropes for a given (printable) type of 206 | elements (using arrays internally for flat strings). *) 207 | 208 | module type Print = sig 209 | type t 210 | 211 | val print : Format.formatter -> t -> unit 212 | end 213 | 214 | module Make_array (X : Print) : sig 215 | include ROPE with type char = X.t 216 | 217 | val of_array : X.t array -> t 218 | val create : int -> X.t -> t 219 | val init : int -> (int -> X.t) -> t 220 | end 221 | -------------------------------------------------------------------------------- /rope.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* Copyright (C) Jean-Christophe Filliatre *) 4 | (* *) 5 | (* This software is free software; you can redistribute it and/or *) 6 | (* modify it under the terms of the GNU Library General Public *) 7 | (* License version 2.1, with the special exception on linking *) 8 | (* described in file LICENSE. *) 9 | (* *) 10 | (* This software is distributed in the hope that it will be useful, *) 11 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 12 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | exception Out_of_bounds 17 | 18 | module type STRING = sig 19 | type t 20 | type char 21 | 22 | val length : t -> int 23 | val empty : t 24 | val singleton : char -> t 25 | val append : t -> t -> t 26 | val get : t -> int -> char 27 | val sub : t -> int -> int -> t 28 | val iter_range : (char -> unit) -> t -> int -> int -> unit 29 | val print : Format.formatter -> t -> unit 30 | end 31 | 32 | module type ROPE = sig 33 | include STRING 34 | 35 | val is_empty : t -> bool 36 | val set : t -> int -> char -> t 37 | val delete : t -> int -> t 38 | val insert_char : t -> int -> char -> t 39 | val insert : t -> int -> t -> t 40 | 41 | module Cursor : sig 42 | type cursor 43 | 44 | val empty : cursor 45 | val create : t -> int -> cursor 46 | val position : cursor -> int 47 | val to_rope : cursor -> t 48 | val move_forward : cursor -> int -> cursor 49 | val move_backward : cursor -> int -> cursor 50 | val move : cursor -> int -> cursor 51 | val get : cursor -> char 52 | val set : cursor -> char -> cursor 53 | val insert_char : cursor -> char -> cursor 54 | val insert : cursor -> t -> cursor 55 | val delete : cursor -> cursor 56 | val print : Format.formatter -> cursor -> unit 57 | end 58 | end 59 | 60 | module type CONTROL = sig 61 | val small_length : int 62 | val maximal_height : int 63 | end 64 | 65 | module Make (S : STRING) (C : CONTROL) = struct 66 | type t = 67 | (* s,ofs,len with 0 <= ofs < len(s), ofs+len <= len(s) *) 68 | | Str of S.t * int * int 69 | (* t1,t2,len,height with 0 < len t1, len t2 *) 70 | | App of t * t * int * int 71 | 72 | type char = S.char 73 | 74 | let empty = Str (S.empty, 0, 0) 75 | let length = function Str (_, _, n) | App (_, _, n, _) -> n 76 | let of_string s = Str (s, 0, S.length s) 77 | let singleton c = of_string (S.singleton c) 78 | let height = function Str _ -> 0 | App (_, _, _, h) -> h 79 | 80 | (* smart constructor *) 81 | let mk_app t1 t2 = 82 | App (t1, t2, length t1 + length t2, 1 + max (height t1) (height t2)) 83 | 84 | let app = function 85 | | Str (_, _, 0), t | t, Str (_, _, 0) -> t 86 | | Str (s1, ofs1, len1), Str (s2, ofs2, len2) 87 | when len1 <= C.small_length && len2 <= C.small_length -> 88 | Str (S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2), 0, len1 + len2) 89 | | App (t1, Str (s1, ofs1, len1), _, _), Str (s2, ofs2, len2) 90 | when len1 <= C.small_length && len2 <= C.small_length -> 91 | App 92 | ( t1 93 | , Str 94 | ( S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2) 95 | , 0 96 | , len1 + len2 ) 97 | , length t1 + len1 + len2 98 | , 1 + height t1 ) 99 | | Str (s1, ofs1, len1), App (Str (s2, ofs2, len2), t2, _, _) 100 | when len1 <= C.small_length && len2 <= C.small_length -> 101 | App 102 | ( Str 103 | ( S.append (S.sub s1 ofs1 len1) (S.sub s2 ofs2 len2) 104 | , 0 105 | , len1 + len2 ) 106 | , t2 107 | , len1 + len2 + length t2 108 | , 1 + height t2 ) 109 | | t1, t2 -> 110 | App (t1, t2, length t1 + length t2, 1 + max (height t1) (height t2)) 111 | 112 | let append t1 t2 = app (t1, t2) 113 | let ( ++ ) = append 114 | 115 | let _balance t = 116 | let rec to_list ((n, l) as acc) = function 117 | | Str _ as x -> (n + 1, x :: l) 118 | | App (t1, t2, _, _) -> to_list (to_list acc t2) t1 119 | in 120 | let rec build n l = 121 | assert (n >= 1); 122 | if n = 1 then match l with [] -> assert false | x :: r -> (x, r) 123 | else 124 | let n' = n / 2 in 125 | let t1, l = build n' l in 126 | let t2, l = build (n - n') l in 127 | (mk_app t1 t2, l) 128 | in 129 | let n, l = to_list (0, []) t in 130 | let t, l = build n l in 131 | assert (l = []); 132 | t 133 | 134 | let rec unsafe_get t i = 135 | match t with 136 | | Str (s, ofs, _) -> S.get s (ofs + i) 137 | | App (t1, t2, _, _) -> 138 | let n1 = length t1 in 139 | if i < n1 then unsafe_get t1 i else unsafe_get t2 (i - n1) 140 | 141 | let get t i = 142 | if i < 0 || i >= length t then raise Out_of_bounds; 143 | unsafe_get t i 144 | 145 | let is_empty t = length t = 0 146 | 147 | (* assumption: 0 <= start < stop <= len(t) *) 148 | let rec mksub start stop t = 149 | if start = 0 && stop = length t then t 150 | else 151 | match t with 152 | | Str (s, ofs, _) -> Str (s, ofs + start, stop - start) 153 | | App (t1, t2, _, _) -> 154 | let n1 = length t1 in 155 | if stop <= n1 then mksub start stop t1 156 | else if start >= n1 then mksub (start - n1) (stop - n1) t2 157 | else app (mksub start n1 t1, mksub 0 (stop - n1) t2) 158 | 159 | let sub t ofs len = 160 | let stop = ofs + len in 161 | if ofs < 0 || len < 0 || stop > length t then raise Out_of_bounds; 162 | if len = 0 then empty else mksub ofs stop t 163 | 164 | let rec safe_iter_range f i n = function 165 | | Str (s, ofs, _) -> S.iter_range f s (max 0 (ofs + i)) n 166 | | App (t1, t2, _, _) -> 167 | let n1 = length t1 in 168 | if i + n <= n1 then safe_iter_range f i n t1 169 | else if i >= n1 then safe_iter_range f (i - n1) n t2 170 | else ( 171 | safe_iter_range f i n1 t1; 172 | safe_iter_range f (i - n1) (n - n1) t2) 173 | 174 | let iter_range f t ofs len = 175 | if ofs < 0 || len < 0 || ofs + len > length t then raise Out_of_bounds; 176 | safe_iter_range f ofs len t 177 | 178 | let rec print fmt = function 179 | | Str (s, ofs, len) -> S.print fmt (S.sub s ofs len) (* TODO: improve? *) 180 | | App (t1, t2, _, _) -> 181 | print fmt t1; 182 | print fmt t2 183 | 184 | (* assumption: 0 <= i < len t *) 185 | let rec set_rec i c = function 186 | | Str (s, ofs, len) when i = 0 -> 187 | app (singleton c, Str (s, ofs + 1, len - 1)) 188 | | Str (s, ofs, len) when i = len - 1 -> 189 | app (Str (s, ofs, len - 1), singleton c) 190 | | Str (s, ofs, len) -> 191 | app 192 | (Str (s, ofs, i), app (singleton c, Str (s, ofs + i + 1, len - i - 1))) 193 | | App (t1, t2, _, _) -> 194 | let n1 = length t1 in 195 | if i < n1 then app (set_rec i c t1, t2) 196 | else app (t1, set_rec (i - n1) c t2) 197 | 198 | (* set t i c = sub t 0 i ++ singleton c ++ sub t (i+1) (length t-i-1) *) 199 | let set t i c = 200 | let n = length t in 201 | if i < 0 || i >= n then raise Out_of_bounds; 202 | set_rec i c t 203 | 204 | (* assumption: 0 <= i < len t *) 205 | let rec delete_rec i = function 206 | | Str (_, _, 1) -> 207 | assert (i = 0); 208 | empty 209 | | Str (s, ofs, len) when i = 0 -> Str (s, ofs + 1, len - 1) 210 | | Str (s, ofs, len) when i = len - 1 -> Str (s, ofs, len - 1) 211 | | Str (s, ofs, len) -> 212 | app (Str (s, ofs, i), Str (s, ofs + i + 1, len - i - 1)) 213 | | App (t1, t2, _, _) -> 214 | let n1 = length t1 in 215 | if i < n1 then app (delete_rec i t1, t2) 216 | else app (t1, delete_rec (i - n1) t2) 217 | 218 | (* delete t i = sub t 0 i ++ sub t (i + 1) (length t - i - 1) *) 219 | let delete t i = 220 | let n = length t in 221 | if i < 0 || i >= n then raise Out_of_bounds; 222 | delete_rec i t 223 | 224 | (* assumption: 0 <= i < len t *) 225 | let rec insert_rec i r = function 226 | | Str _ as s when i = 0 -> app (r, s) 227 | | Str (_, _, len) as s when i = len -> app (s, r) 228 | | Str (s, ofs, len) -> Str (s, ofs, i) ++ r ++ Str (s, ofs + i, len - i) 229 | | App (t1, t2, _, _) -> 230 | let n1 = length t1 in 231 | if i < n1 then app (insert_rec i r t1, t2) 232 | else app (t1, insert_rec (i - n1) r t2) 233 | 234 | (* insert t i r = sub t 0 i ++ r ++ sub t i (length t - i) *) 235 | let insert t i r = 236 | let n = length t in 237 | if i < 0 || i > n then raise Out_of_bounds; 238 | insert_rec i r t 239 | 240 | let insert_char t i c = insert t i (singleton c) 241 | 242 | (* cursors *) 243 | module Cursor = struct 244 | type path = Top | Left of path * t | Right of t * path 245 | 246 | type cursor = 247 | { rpos : int (* position of the cursor relative to the current leaf *) 248 | ; lofs : int (* offset of the current leaf wrt whole rope *) 249 | ; leaf : t (* the leaf i.e. Str (s,ofs,len) *) 250 | ; path : path (* context = zipper *) 251 | } 252 | (* INVARIANT: 0 <= rpos <= len 253 | rpos = len iff we are located at the end of the whole rope *) 254 | (* TODO(dinosaure): prove that [leaf] contains only a concrete [Str] value. *) 255 | 256 | let position c = c.lofs + c.rpos 257 | 258 | (* cursor -> rope *) 259 | let rec unzip t = function 260 | | Top -> t 261 | | Left (p, tr) -> unzip (app (t, tr)) p 262 | | Right (tl, p) -> unzip (app (tl, t)) p 263 | 264 | let to_rope c = unzip c.leaf c.path 265 | 266 | let create r i = 267 | let rec zip lofs p = function 268 | | Str (_, _, len) as leaf -> 269 | assert (lofs <= i && i <= lofs + len); 270 | { rpos = i - lofs; lofs; leaf; path = p } 271 | | App (t1, t2, _, _) -> 272 | let n1 = length t1 in 273 | if i < lofs + n1 then zip lofs (Left (p, t2)) t1 274 | else zip (lofs + n1) (Right (t1, p)) t2 275 | in 276 | if i < 0 || i > length r then raise Out_of_bounds; 277 | zip 0 Top r 278 | 279 | let get c = 280 | match c.leaf with 281 | | Str (s, ofs, len) -> 282 | let i = c.rpos in 283 | if i = len then raise Out_of_bounds; 284 | S.get s (ofs + i) 285 | | App _ -> assert false 286 | 287 | (* TODO: improve using concatenations when lengths <= small_length *) 288 | let set c x = 289 | match c.leaf with 290 | | Str (s, ofs, len) -> 291 | let i = c.rpos in 292 | if i = len then raise Out_of_bounds; 293 | let leaf = Str (S.singleton x, 0, 1) in 294 | if i = 0 then 295 | if len = 1 then { c with leaf } 296 | else 297 | { c with leaf; path = Left (c.path, Str (s, ofs + 1, len - 1)) } 298 | else if i = len - 1 then 299 | { lofs = c.lofs + len - 1 300 | ; rpos = 0 301 | ; leaf 302 | ; path = Right (Str (s, ofs, len - 1), c.path) 303 | } 304 | else 305 | { lofs = c.lofs + i 306 | ; rpos = 0 307 | ; leaf 308 | ; path = 309 | Left 310 | ( Right (Str (s, ofs, i), c.path) 311 | , Str (s, ofs + i + 1, len - i - 1) ) 312 | } 313 | | App _ -> assert false 314 | 315 | let rec concat_path p1 p2 = 316 | match p1 with 317 | | Top -> p2 318 | | Left (p, r) -> Left (concat_path p p2, r) 319 | | Right (l, p) -> Right (l, concat_path p p2) 320 | 321 | (* TODO: improve using concatenations when lengths <= small_length *) 322 | let insert c r = 323 | match c.leaf with 324 | | Str (s, ofs, len) -> 325 | let i = c.rpos in 326 | let cr = create r 0 in 327 | if i = 0 then 328 | { cr with 329 | lofs = c.lofs 330 | ; path = concat_path cr.path (Left (c.path, c.leaf)) 331 | } 332 | else if i = len then 333 | { cr with 334 | lofs = c.lofs + len 335 | ; path = concat_path cr.path (Right (c.leaf, c.path)) 336 | } 337 | else 338 | { cr with 339 | lofs = c.lofs + i 340 | ; path = 341 | concat_path cr.path 342 | (Left 343 | (Right (Str (s, ofs, i), c.path), Str (s, ofs + i, len - i))) 344 | } 345 | | App _ -> assert false 346 | 347 | let insert_char c x = insert c (of_string (S.singleton x)) 348 | 349 | (* moves to start of next leaf (on the right) if any, 350 | or raises [Out_of_bounds] *) 351 | let next_leaf c = 352 | let lofs = c.lofs + length c.leaf in 353 | let rec down p = function 354 | | Str _ as leaf -> { rpos = 0; lofs; leaf; path = p } 355 | | App (t1, t2, _, _) -> down (Left (p, t2)) t1 356 | in 357 | let rec up t = function 358 | | Top -> raise Out_of_bounds 359 | | Right (l, p) -> up (mk_app l t) p 360 | | Left (p, r) -> down (Right (t, p)) r 361 | in 362 | up c.leaf c.path 363 | 364 | let rec move_forward_rec c n = 365 | match c.leaf with 366 | | Str (_, _, len) -> 367 | let rpos' = c.rpos + n in 368 | if rpos' < len then { c with rpos = rpos' } 369 | else if rpos' = len then 370 | try next_leaf c with Out_of_bounds -> { c with rpos = rpos' } 371 | else 372 | (* rpos' > len *) 373 | let c = next_leaf c in 374 | move_forward_rec c (rpos' - len) 375 | (* TODO: improve? *) 376 | | App _ -> assert false 377 | 378 | let move_forward c n = 379 | if n < 0 then invalid_arg "Rop.move_forward"; 380 | if n = 0 then c else move_forward_rec c n 381 | 382 | (* moves to the end of previous leaf (on the left) if any, 383 | raises [Out_of_bounds] otherwise *) 384 | let prev_leaf c = 385 | let rec down p = function 386 | | Str (_, _, len) as leaf -> 387 | { rpos = len; lofs = c.lofs - len; leaf; path = p } 388 | | App (t1, t2, _, _) -> down (Right (t1, p)) t2 389 | in 390 | let rec up t = function 391 | | Top -> raise Out_of_bounds 392 | | Right (l, p) -> down (Left (p, t)) l 393 | | Left (p, r) -> up (mk_app t r) p 394 | in 395 | up c.leaf c.path 396 | 397 | let rec move_backward_rec c n = 398 | match c.leaf with 399 | | Str (_, _, _len) -> 400 | let rpos' = c.rpos - n in 401 | if rpos' >= 0 then { c with rpos = rpos' } 402 | else 403 | (* rpos' < 0 *) 404 | let c = prev_leaf c in 405 | move_backward_rec c (-rpos') 406 | | App _ -> assert false 407 | 408 | let move_backward c n = 409 | if n < 0 then invalid_arg "Rop.move_backward"; 410 | if n = 0 then c else move_backward_rec c n 411 | 412 | let move c n = 413 | if n = 0 then c 414 | else if n > 0 then move_forward_rec c n 415 | else move_backward_rec c (-n) 416 | 417 | let rec _leftmost lofs p = function 418 | | Str _ as leaf -> { rpos = 0; lofs; leaf; path = p } 419 | | App (t1, t2, _, _) -> _leftmost lofs (Left (p, t2)) t1 420 | 421 | (* XXX(dinosaure): the code does not work when we 422 | delete the last character and redo the operation. 423 | Actually, this impl. works with: 424 | - next_leaf { c with leaf = Str (s, ofs, len - 1) } 425 | + try next_leaf { c with leaf = Str (s, ofs, len - 1) } 426 | + with Out_of_bounds (* Top *) -> 427 | + { c with leaf= Str (s, ofs, len - 1) } 428 | 429 | But we need to fuzz and prove it! *) 430 | let delete c = 431 | match c.leaf with 432 | | Str (s, ofs, len) -> 433 | let i = c.rpos in 434 | if i = len then raise Out_of_bounds; 435 | if i = 0 then 436 | if len = 1 then 437 | match c.path with 438 | | Top -> { c with leaf = empty } 439 | | Left (p, t) -> 440 | (* leftmost c.lofs p r *) 441 | let r = to_rope { c with leaf = t; path = p } in 442 | create r c.lofs 443 | | Right (t, p) -> 444 | (* TODO: improve *) 445 | let r = to_rope { c with leaf = t; path = p } in 446 | create r c.lofs 447 | else { c with leaf = Str (s, ofs + 1, len - 1) } 448 | else if i = len - 1 then 449 | try next_leaf { c with leaf = Str (s, ofs, len - 1) } 450 | with Out_of_bounds (* Top *) -> 451 | { c with leaf = Str (s, ofs, len - 1) } 452 | else 453 | { lofs = c.lofs + i 454 | ; rpos = 0 455 | ; leaf = Str (s, ofs + i + 1, len - i - 1) 456 | ; path = Right (Str (s, ofs, i), c.path) 457 | } 458 | | App _ -> assert false 459 | 460 | let print fmt c = 461 | (* TODO: improve *) 462 | let r = to_rope c in 463 | let i = position c in 464 | let before = sub r 0 i in 465 | let after = sub r i (length r - i) in 466 | print fmt before; 467 | Format.fprintf fmt "|"; 468 | print fmt after 469 | 470 | let empty = { rpos = 0; lofs = 0; leaf = Str (S.empty, 0, 0); path = Top } 471 | end 472 | end 473 | 474 | (* flat strings *) 475 | module Str = struct 476 | include String 477 | 478 | let get = unsafe_get 479 | 480 | type char = Char.t 481 | 482 | let empty = "" 483 | let singleton = String.make 1 484 | let append = ( ^ ) 485 | let print = Format.pp_print_string 486 | 487 | let iter_range f s ofs len = 488 | (* safe *) 489 | for i = ofs to ofs + len - 1 do 490 | f (String.unsafe_get s i) 491 | done 492 | end 493 | 494 | module Control = struct 495 | let small_length = 256 496 | let maximal_height = max_int 497 | end 498 | 499 | module String = Make (Str) (Control) 500 | 501 | (* ropes of any type (using arrays as flat sequences) *) 502 | 503 | module type Print = sig 504 | type t 505 | 506 | val print : Format.formatter -> t -> unit 507 | end 508 | 509 | module Make_array (X : Print) = struct 510 | module A = struct 511 | type char = X.t 512 | type t = X.t array 513 | 514 | let length = Array.length 515 | let empty = [||] 516 | let singleton l = [| l |] 517 | let append = Array.append 518 | let get = Array.get 519 | let sub = Array.sub 520 | 521 | let iter_range f a ofs len = 522 | for i = ofs to ofs + len - 1 do 523 | f a.(i) 524 | done 525 | 526 | let print fmt a = Array.iter (X.print fmt) a 527 | end 528 | 529 | module C = struct 530 | let small_length = 256 531 | let maximal_height = max_int 532 | end 533 | 534 | include Make (A) (C) 535 | 536 | let of_array = of_string 537 | let create n v = of_string (Array.make n v) 538 | let init n f = of_string (Array.init n f) 539 | end 540 | --------------------------------------------------------------------------------