banawa-chat/notty_mirage.ml
2023-05-04 13:49:25 +02:00

148 lines
4.2 KiB
OCaml

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