open Nottui open Notty type t = { quit : unit -> unit; message : string -> unit; cursor : Rp.Cursor.cursor; } let make quit message = let cursor = Rp.Cursor.create Rp.empty 0 in { quit; 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 let new_cursor = (position + 1, y) in if new_cursor <> (Lwd.peek cursor) then Lwd.set cursor new_cursor; 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 | `ASCII ('C'..'D'), [`Ctrl] -> state.quit (); `Handled | _ -> `Unhandled let make ~quit ~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 quit message) in let position = Lwd.var (0, 0) in let hook state' = if (Lwd.peek state).cursor != state'.cursor then Lwd.set state 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)