From 055c743c55bde27f4475d3434c26d8383c0c3ea1 Mon Sep 17 00:00:00 2001 From: Federico Igne Date: Thu, 11 Jan 2024 19:31:31 +0100 Subject: bulk: add PoC of vim-like modular editor --- bin/main.ml | 9 +- lib/command.ml | 115 ++++++++++++++++++++++ lib/config.ml | 9 ++ lib/editor.ml | 271 ++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/editorBuffer.ml | 72 ++++++++++++++ lib/key.ml | 72 ++++++++++++++ lib/modes.ml | 18 ++++ lib/terminal.ml | 130 +++++++++++++++++++++++++ lib/terminal.mli | 67 +++++++++++++ lib/text.ml | 10 ++ lib/util.ml | 26 +++++ lib/zipper.ml | 131 +++++++++++++++++++++++++ lib/zipper.mli | 258 +++++++++++++++++++++++++++++++++++++++++++++++++ 13 files changed, 1187 insertions(+), 1 deletion(-) create mode 100644 lib/command.ml create mode 100644 lib/config.ml create mode 100644 lib/editor.ml create mode 100644 lib/editorBuffer.ml create mode 100644 lib/key.ml create mode 100644 lib/modes.ml create mode 100644 lib/terminal.ml create mode 100644 lib/terminal.mli create mode 100644 lib/text.ml create mode 100644 lib/util.ml create mode 100644 lib/zipper.ml create mode 100644 lib/zipper.mli diff --git a/bin/main.ml b/bin/main.ml index 7bf6048..75328c9 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1 +1,8 @@ -let () = print_endline "Hello, World!" +open Sand + +let () = + let open Editor in + let cli = Config.parse Sys.argv in + let editor = Editor.init cli in + let rec loop () = Action.(render *> handle_next_command2 >>= loop) in + Action.eval ~editor loop diff --git a/lib/command.ml b/lib/command.ml new file mode 100644 index 0000000..7dedc6c --- /dev/null +++ b/lib/command.ml @@ -0,0 +1,115 @@ +open Base +open Key + +type register = char option +type count = int option +type operation = Noop | Yank | Paste | Delete | Change +type scope = Line | To_bol | To_eol | Down | Left | Right | Up + +type command = + | Type of char + | Simple of Key.t + | Partial of Key.t + | Shortcut of register * count * operation * scope + | Chord of register * count * operation * count * scope + +type t = command + +let shortcut ?r ?n c s = Shortcut (r, n, c, s) +let chord ?r ?n1 c ?n2 m = Chord (r, n1, c, n2, m) + +let i_stream = + let step s k = + let open Sequence.Step in + match (s, k) with + | `start, Key c -> Yield { value = Type c; state = `start } + | `start, _ -> Yield { value = Simple k; state = `start } + | _, _ -> Skip { state = `start } + in + Sequence.unfold_with ~init:`start ~f:step Key.stream + +let simple_movements = + [ + Key 'h'; + Key 'j'; + Key 'k'; + Key 'l'; + Key ' '; + Arrow_up; + Arrow_down; + Arrow_left; + Arrow_right; + Backspace; + ] + +let to_scope = function + | Key 'j' | Arrow_down -> Down + | Key 'h' | Arrow_left | Backspace -> Left + | Key 'l' | Key ' ' | Arrow_right -> Right + | Key 'k' | Arrow_up -> Up + | _ -> failwith "Invalid motion." + +let n_stream = + let step s k = + let open Sequence.Step in + let is_chord_op c = String.contains "ydc" (Char.lowercase c) in + let is_simple_movement k = List.mem ~equal:Poly.equal simple_movements k in + let to_op c = + match Char.lowercase c with + | 'y' -> Yank + | 'p' -> Paste + | 'd' -> Delete + | 'c' -> Change + | _ -> failwith "Invalid operation in chord." + in + match (s, k) with + | `start, Key '"' -> Yield { value = Partial k; state = `chord_reg_pre } + | `chord_reg_pre, Key c -> Yield { value = Partial k; state = `chord_reg c } + | `chord_reg r, Key n when Char.('1' <= n && n <= '9') -> + let n = Char.to_int n - 48 in + Yield { value = Partial k; state = `chord_n (Some r, n) } + | `start, Key n when Char.('1' <= n && n <= '9') -> + let n = Char.to_int n - 48 in + Yield { value = Partial k; state = `chord_n (None, n) } + | `chord_n (r, m), Key n when Char.('0' <= n && n <= '9') -> + let n = (10 * m) + Char.to_int n - 48 in + Yield { value = Partial k; state = `chord_n (r, n) } + | `start, Key c when is_chord_op c -> + if Char.is_uppercase c then + Yield { value = shortcut (to_op c) To_eol; state = `start } + else + Yield { value = Partial k; state = `chord_cmd (None, None, to_op c) } + | `chord_reg r, Key c when is_chord_op c -> + if Char.is_uppercase c then + Yield { value = shortcut ~r (to_op c) To_eol; state = `start } + else + Yield + { value = Partial k; state = `chord_cmd (Some r, None, to_op c) } + | `chord_n (r, n), Key c when is_chord_op c -> + if Char.is_uppercase c then + Yield { value = shortcut ?r ~n (to_op c) To_eol; state = `start } + else + Yield { value = Partial k; state = `chord_cmd (r, Some n, to_op c) } + | `chord_cmd (r, n, c), Key ch when is_chord_op ch && Poly.(c = to_op ch) -> + if Char.is_uppercase ch then + Yield { value = shortcut ?r ?n c To_bol; state = `start } + else Yield { value = shortcut ?r ?n c Line; state = `start } + | (`start | `chord_reg _), k when is_simple_movement k -> + Yield { value = chord Noop (to_scope k); state = `start } + | `chord_n (_, n), k when is_simple_movement k -> + Yield { value = chord ~n1:n Noop (to_scope k); state = `start } + | `chord_cmd (r, n, c), k when is_simple_movement k -> + Yield { value = chord ?r ?n1:n c (to_scope k); state = `start } + | `chord_cmd (r, n1, c), Key n when Char.('1' <= n && n <= '9') -> + let n = Char.to_int n - 48 in + Yield { value = Partial k; state = `chord_mv_n (r, n1, c, n) } + | `chord_mv_n (r, n1, c, n2), Key n when Char.('0' <= n && n <= '9') -> + let n2 = (10 * n2) + Char.to_int n - 48 in + Yield { value = Partial k; state = `chord_mv_n (r, n1, c, n2) } + | `chord_mv_n (r, n1, c, n2), k when is_simple_movement k -> + Yield { value = chord ?r ?n1 c ~n2 (to_scope k); state = `start } + (* Catch-all rules *) + | `start, _ -> Yield { value = Simple k; state = `start } + | _, _ -> Skip { state = `start } + in + Sequence.unfold_with ~init:`start ~f:step Key.stream diff --git a/lib/config.ml b/lib/config.ml new file mode 100644 index 0000000..4ebf436 --- /dev/null +++ b/lib/config.ml @@ -0,0 +1,9 @@ +open Base + +type config = { + files : string list; +} +type t = config + +let parse args = + { files = List.(of_array args |> tl_exn) } diff --git a/lib/editor.ml b/lib/editor.ml new file mode 100644 index 0000000..c3e298e --- /dev/null +++ b/lib/editor.ml @@ -0,0 +1,271 @@ +open Base +module Buffer = EditorBuffer +open Util + +type mode = Normal | Insert +type cursor = int * int + +type editor = { + term : Terminal.state; + mode : mode; + offset : int * int; + cursor : cursor; + buffer : Buffer.t option; + pending : Key.t Sequence.t; + i_pending : Command.t Sequence.t; + n_pending : Command.t Sequence.t; +} + +type t = editor + +let init (c : Config.t) : editor = + { + term = Terminal.init (); + mode = Normal; + offset = (0, 0); + cursor = (1, 1); + buffer = List.hd c.files |> Option.map ~f:Buffer.from_file; + pending = Key.stream; + i_pending = Command.i_stream; + n_pending = Command.n_stream; + } + +type 'a action = t -> 'a * t + +module Action = struct + let run ~editor action = action () editor + let eval ~editor action = run ~editor action |> fst + let exec ~editor action = run ~editor action |> snd + + include Applicative.Make (struct + type 'a t = 'a action + + let return a s = (a, s) + + let apply f a e = + let f, e' = f e in + let x, e'' = a e' in + (f x, e'') + + let map = `Define_using_apply + end) + + include Monad.Make (struct + type 'a t = 'a action + + let return x s = (x, s) + + let bind a ~f x = + let y, a' = a x in + f y a' + + let map = `Define_using_bind + end) + + let get e = (e, e) + let put e _ = ((), e) + let modify ~f e = ((), f e) + + let update_cursor = + let aux e = + let dx, dy = e.offset and rs, cs = e.term.size in + match Option.map ~f:Buffer.cursor e.buffer with + | None -> { e with cursor = (1, 1); offset = (0, 0) } + | Some (cx, cy) -> + let dx' = Int.clamp_exn ~min:(cx - rs) ~max:cx dx + and dy' = Int.clamp_exn ~min:(cy - cs) ~max:cy dy in + { e with cursor = (cx - dx' + 1, cy - dy' + 1); offset = (dx', dy') } + in + modify ~f:aux + + let get_mode s = (s.mode, s) + let set_mode m s = ((), { s with mode = m }) + let get_focused_buffer e = (e.buffer, e) + let set_focused_buffer b e = ((), { e with buffer = Some b }) + + let on_focused_buffer f = + let f e = { e with buffer = Option.map ~f e.buffer } in + modify ~f *> update_cursor + + let on_focused_buffer_or_new f = + (get_focused_buffer + >>| Option.value ~default:Buffer.empty + >>| f >>= set_focused_buffer) + *> update_cursor + + let render = + let welcome (r, c) = + let open Text in + let hfill = ' ' and vfill = Sequence.empty in + "Welcome to the sand editor!" |> String.to_list |> Sequence.of_list + |> center ~fill:hfill c |> Sequence.singleton |> center ~fill:vfill r + in + let aux e = + let x, y = e.offset + and ((r, c) as size) = e.term.size + and fill = Sequence.singleton '~' in + let view = + Option.( + e.buffer >>| Buffer.view x y r c + |> value ~default:(welcome size) + |> Text.extend ~fill r) + in + Terminal.redraw view e.cursor + in + get >>| aux + + (* TODO: save logic *) + let quit n = Stdlib.exit n + let noop = return () +end + +let move ?(up = 0) ?(down = 0) ?(left = 0) ?(right = 0) (x, y) = + (x + down - up, y + right - left) + +let move_to ?x ?y (sx, sy) = Option.(value x ~default:sx, value y ~default:sy) + +(* let get_next_command s = *) +(* match Sequence.next s.pending with *) +(* | None -> (None, s) *) +(* | Some (h, t) -> (Some h, { s with pending = t }) *) + +(* let handle_insert_key = *) +(* let open Action in *) +(* let open Key in *) +(* function *) +(* | Arrow_down -> Buffer.Action.down |> on_focused_buffer *) +(* | Arrow_left -> Buffer.Action.left |> on_focused_buffer *) +(* | Arrow_right -> Buffer.Action.right |> on_focused_buffer *) +(* | Arrow_up -> Buffer.Action.up |> on_focused_buffer *) +(* | Backspace -> Buffer.Action.delete_before |> on_focused_buffer *) +(* | Ctrl 'Q' -> quit 0 *) +(* | Delete -> Buffer.Action.delete_after |> on_focused_buffer *) +(* | Enter -> Buffer.Action.newline |> on_focused_buffer *) +(* | Esc -> (Buffer.Action.left |> on_focused_buffer) *> set_mode Normal *) +(* | Key k -> Buffer.Action.insert k |> on_focused_buffer *) +(* | _ -> noop *) + +(* let handle_normal_key = *) +(* let open Action in *) +(* let open Key in *) +(* function *) +(* | Arrow_down | Key 'j' -> Buffer.Action.down |> on_focused_buffer *) +(* | Arrow_left | Backspace | Key 'h' -> Buffer.Action.left |> on_focused_buffer *) +(* | Arrow_right | Key ' ' | Key 'l' -> Buffer.Action.right |> on_focused_buffer *) +(* | Arrow_up | Key 'k' -> Buffer.Action.up |> on_focused_buffer *) +(* | Ctrl 'Q' -> quit 0 *) +(* | Key '0' -> Buffer.Action.bol |> on_focused_buffer_or_new *) +(* | Key 'A' -> *) +(* (Buffer.Action.eol |> on_focused_buffer_or_new) *> set_mode Insert *) +(* | Key 'a' -> *) +(* (Buffer.Action.right |> on_focused_buffer_or_new) *> set_mode Insert *) +(* | Key 'G' -> Buffer.Action.eof |> on_focused_buffer_or_new *) +(* | Key 'I' -> *) +(* noop *) +(* (1* (Buffer.Action.bol |> on_focused_buffer_or_new) *> set_mode Insert *1) *) +(* | Key 'i' -> (Fn.id |> on_focused_buffer_or_new) *> set_mode Insert *) +(* | Key 's' -> *) +(* (Buffer.Action.delete_after |> on_focused_buffer_or_new) *) +(* *> set_mode Insert *) +(* | Key 'x' -> Buffer.Action.delete_after |> on_focused_buffer_or_new *) +(* | Key 'X' -> Buffer.Action.delete_before |> on_focused_buffer_or_new *) +(* | Key '$' -> Buffer.Action.eol |> on_focused_buffer_or_new *) +(* | _ -> noop *) + +(* let handle_next_command = *) +(* let f m = function *) +(* | None -> Action.return () *) +(* | Some k -> ( *) +(* match m with *) +(* | Insert -> handle_insert_key k *) +(* | Normal -> handle_normal_key k) *) +(* in *) +(* Action.(map2 ~f get_mode get_next_command |> join) *) + +let handle_insert_command = + let open Command in + let open Action in + function + | Simple Arrow_down -> Buffer.Action.down |> on_focused_buffer + | Simple Arrow_left -> Buffer.Action.left |> on_focused_buffer + | Simple Arrow_right -> Buffer.Action.right |> on_focused_buffer + | Simple Arrow_up -> Buffer.Action.up |> on_focused_buffer + | Simple Backspace -> Buffer.Action.delete_before ~n:1 |> on_focused_buffer + | Simple (Ctrl 'Q') -> quit 0 + | Simple Delete -> Buffer.Action.delete_after ~n:1 |> on_focused_buffer + | Simple Enter -> Buffer.Action.newline |> on_focused_buffer + | Simple Esc -> (Buffer.Action.left |> on_focused_buffer) *> set_mode Normal + | Type k -> Buffer.Action.insert k |> on_focused_buffer + | _ -> noop + +let handle_normal_command = + let open Command in + let open Action in + function + (* Movements *) + | Chord (_, n, Noop, _, Down) -> Buffer.Action.down ?n |> on_focused_buffer + | Chord (_, n, Noop, _, Left) -> Buffer.Action.left ?n |> on_focused_buffer + | Chord (_, n, Noop, _, Right) -> Buffer.Action.right ?n |> on_focused_buffer + | Chord (_, n, Noop, _, Up) -> Buffer.Action.up ?n |> on_focused_buffer + | Simple (Ctrl 'Q') -> quit 0 + (* | Key '0' -> Buffer.Action.bol |> on_focused_buffer_or_new *) + | Simple (Key 'A') -> + (Buffer.Action.eol |> on_focused_buffer_or_new) *> set_mode Insert + | Simple (Key 'a') -> + (Buffer.Action.right |> on_focused_buffer_or_new) *> set_mode Insert + (* | Key 'G' -> Buffer.Action.eof |> on_focused_buffer_or_new *) + (* | Key 'I' -> noop *) + | Simple (Key 'i') -> (Fn.id |> on_focused_buffer_or_new) *> set_mode Insert + (* | Key 's' -> *) + (* (Buffer.Action.delete_after |> on_focused_buffer_or_new) *) + (* *> set_mode Insert *) + (* | Key 'x' -> Buffer.Action.delete_after |> on_focused_buffer_or_new *) + (* | Key 'X' -> Buffer.Action.delete_before |> on_focused_buffer_or_new *) + (* | Key '$' -> Buffer.Action.eol |> on_focused_buffer_or_new *) + | Shortcut (_, n, Change, Line) -> + let n = Option.value ~default:1 n - 1 in + (Buffer.Action.(delete_lines ~n &> bol &> delete_to_eol) + |> on_focused_buffer_or_new) + *> set_mode Insert + | Shortcut (_, _, Change, To_eol) -> + (Buffer.Action.delete_to_eol |> on_focused_buffer_or_new) + *> set_mode Insert + | Shortcut (_, _, Change, To_bol) -> + (Buffer.Action.delete_to_bol |> on_focused_buffer_or_new) + *> set_mode Insert + (* Delete *) + | Chord (_, n1, Delete, n2, Down) -> + let n = Option.((value ~default:1 n1 * value ~default:1 n2) + 1) in + Buffer.Action.delete_lines ~n |> on_focused_buffer_or_new + | Chord (_, n1, Delete, n2, Left) -> + let n = Option.(value ~default:1 n1 * value ~default:1 n2) in + Buffer.Action.delete_before ~n |> on_focused_buffer_or_new + | Chord (_, n1, Delete, n2, Right) -> + let n = Option.(value ~default:1 n1 * value ~default:1 n2) in + Buffer.Action.delete_after ~n |> on_focused_buffer_or_new + | Chord (_, n1, Delete, n2, Up) -> + let n = Option.((value ~default:1 n1 * value ~default:1 n2) + 1) in + Buffer.Action.delete_lines_before ~n |> on_focused_buffer_or_new + | Shortcut (_, n, Delete, Line) -> + Buffer.Action.delete_lines ~n:Option.(value ~default:1 n) + |> on_focused_buffer_or_new + | Shortcut (_, _, Delete, To_eol) -> + Buffer.Action.delete_to_eol |> on_focused_buffer_or_new + | Shortcut (_, _, Delete, To_bol) -> + Buffer.Action.delete_to_bol |> on_focused_buffer_or_new + | _ -> noop + +let handle_next_command2 m e = + match m with + | Insert -> ( + match Sequence.next e.i_pending with + | None -> ((), e) + | Some (h, t) -> handle_insert_command h { e with i_pending = t }) + | Normal -> ( + match Sequence.next e.n_pending with + | None -> ((), e) + | Some (h, t) -> handle_normal_command h { e with n_pending = t }) + +let handle_next_command2 = + let open Action in + get_mode >>= handle_next_command2 diff --git a/lib/editorBuffer.ml b/lib/editorBuffer.ml new file mode 100644 index 0000000..5104549 --- /dev/null +++ b/lib/editorBuffer.ml @@ -0,0 +1,72 @@ +open Base +open Zipper +open Util + +type kind = File of string | No_name | Scratch +type error = No_such_file | Other +type buffer = { kind : kind; content : (char zipper zipper, error) Result.t } +type t = buffer + +let empty = + { kind = No_name; content = empty |> push_after empty |> Result.return } + +module Action = struct + let on_content f b = { b with content = Result.map ~f b.content } + + let up, down, left, right = + let vertical f ?(n = 1) = + on_content (fun z -> + let col = focus_or ~default:Zipper.empty z |> left_length in + Fn.apply_n_times ~n f z |> map_focus (goto col)) + and horizontal f ?(n = 1) = + Fn.apply_n_times ~n (map_focus f) |> on_content + in + (vertical left, vertical right, horizontal left, horizontal right) + + let bol = map_focus far_left |> on_content + let eol = map_focus far_right |> on_content + let bof = far_left |> on_content + let eof = far_right |> on_content + let insert k = map_focus (push k) |> on_content + let delete_after ~n = Fn.apply_n_times ~n (map_focus pop_after) |> on_content + let delete_before ~n = Fn.apply_n_times ~n (map_focus pop) |> on_content + let delete_to_eol = map_focus (split &> fst) |> on_content + let delete_to_bol = map_focus (split &> snd) |> on_content + let delete_lines ~n = Fn.apply_n_times ~n pop_after |> on_content + + let delete_lines_before ~n = + on_content (fun z -> pop_after z |> Fn.apply_n_times ~n:(n - 1) pop_before) + + let newline = + let aux z = + let l1, l2 = focus_or ~default:Zipper.empty z |> split in + push_before l1 z |> map_focus (Fn.const l2) + in + on_content aux + + (* let save_history_to ?(clear = true) r = () *) +end + +let from_file f = + let lines = Stdio.In_channel.read_lines f in + let line_to_zipper l = String.to_list l |> Sequence.of_list |> of_seq in + let content = Sequence.(of_list lines |> map ~f:line_to_zipper) |> of_seq in + { kind = File f; content = Ok content } + +let cursor b = + let open Option in + let x = Result.(map ~f:left_length b.content |> ok |> value ~default:0) + and y = + Result.(map ~f:focus b.content |> ok) + |> join |> map ~f:left_length |> value ~default:0 + in + (x, y) + +let view x y h w b = + match b.content with + | Error _ -> Sequence.empty + | Ok z -> + let cx, _ = cursor b in + context ~b:(cx - x) ~a:(x + h - cx) z + |> to_seq + |> Sequence.map ~f:(window ~from:y ~len:w) diff --git a/lib/key.ml b/lib/key.ml new file mode 100644 index 0000000..85aa282 --- /dev/null +++ b/lib/key.ml @@ -0,0 +1,72 @@ +open Base + +type key = + | Arrow_down + | Arrow_left + | Arrow_right + | Arrow_up + | Backspace + | Ctrl of char + | Delete + | End + | Enter + | Esc + | Home + | Key of char + | Nul + | Page_down + | Page_up + +type t = key + +let ctrl c = Ctrl c +let key c = Key c + +let of_char = function + | '\000' -> Nul + | '\013' -> Enter + | '\027' -> Esc + | '\127' -> Backspace + | c when Char.(c < ' ') -> Char.to_int c + 64 |> Char.of_int_exn |> ctrl + | c -> Key c + +let stream = + let step s c = + let open Sequence.Step in + let escaped = function + | 'A' -> Some Arrow_up + | 'B' -> Some Arrow_down + | 'C' -> Some Arrow_right + | 'D' -> Some Arrow_left + | 'F' -> Some End + | 'H' -> Some Home + | _ -> None + and tilda = function + | '1' -> Some Home + | '3' -> Some Delete + | '4' -> Some End + | '5' -> Some Page_up + | '6' -> Some Page_down + | '7' -> Some Home + | '8' -> Some End + | _ -> None + in + match (s, c) with + | `start, Some '\027' -> Skip { state = `esc } + | `esc, None -> Yield { value = Esc; state = `start } + | `esc, Some '[' | `escaped, Some 'O' -> Skip { state = `escaped } + | `escaped, Some i when Char.(i = '1' || ('3' <= i && i <= '8')) -> + Skip { state = `tilda i } + | `escaped, c -> ( + match Option.(c >>= escaped) with + | None -> Skip { state = `state } + | Some c -> Yield { value = c; state = `start }) + | `tilda i, Some '~' -> ( + match tilda i with + | None -> Skip { state = `start } + | Some k -> Yield { value = k; state = `start }) + | `esc, Some _ | `tilda _, _ -> Skip { state = `start } + | _, None -> Skip { state = `start } + | _, Some c -> Yield { value = of_char c; state = `start } + in + Sequence.unfold_with ~init:`start ~f:step Terminal.char_stream diff --git a/lib/modes.ml b/lib/modes.ml new file mode 100644 index 0000000..3d0e354 --- /dev/null +++ b/lib/modes.ml @@ -0,0 +1,18 @@ +type mode = Normal | Insert +type t = mode +type state = int +type 'a state_monad = state -> 'a * state + +let run (f : 'a state_monad) (s : state) : 'a = f s |> fst +let return (a : 'a) : 'a state_monad = fun s -> (a, s) + +let ( >>= ) (f : 'a state_monad) (g : 'a -> 'b state_monad) : 'b state_monad = + fun s -> + let a, s' = f s in + g a s' + +let draw () : unit state_monad = return () +let get_keypress () : char state_monad = return 'a' +let handle_key (_ : char) : unit state_monad = return () +let rec loop () = () |> draw >>= get_keypress >>= handle_key >>= loop +let test = run (loop ()) 0 diff --git a/lib/terminal.ml b/lib/terminal.ml new file mode 100644 index 0000000..408f7a8 --- /dev/null +++ b/lib/terminal.ml @@ -0,0 +1,130 @@ +open Base +open Unix +open Util + +type terminal_size = int * int +type state = { tio : terminal_io; size : terminal_size } + +let escape ?(prefix = "") ?(args = []) op = + let open Bytes in + let args = List.map ~f:Int.to_string args |> String.concat ~sep:";" in + let lenp = String.length prefix in + let lena = String.length args in + let lenb = 3 + lena + lenp in + let dst = Bytes.create lenb in + set dst 0 '\x1b'; + set dst 1 '['; + From_string.blit ~src:prefix ~src_pos:0 ~dst ~dst_pos:2 ~len:lenp; + From_string.blit ~src:args ~src_pos:0 ~dst ~dst_pos:(2 + lenp) ~len:lena; + set dst (length dst - 1) op; + sequence_of_bytes dst + +let clear_screen = escape 'J' ~args:[ 2 ] +let clear_to_eol = escape 'K' +let move_cursor x y = escape 'H' ~args:[ x; y ] +let move_down n = escape 'B' ~args:[ n ] +let move_right n = escape 'C' ~args:[ n ] +let query_cursor_pos = escape 'n' ~args:[ 6 ] +let reset_cursor = move_cursor 1 1 + +let show_cursor show = + let cmd = if show then 'h' else 'l' in + escape cmd ~prefix:"?" ~args:[ 25 ] + +let input_bytes = Bytes.create 1 + +let get_char () = + let syscall () = read stdin input_bytes 0 1 in + match handle_unix_error syscall () with + | 0 -> None + | _ -> Some (Bytes.get input_bytes 0) + +let char_stream : char option Sequence.t = + Sequence.unfold ~init:() ~f:(fun s -> Some (get_char (), s)) + +let write_seq = + let syscall s = + let buf = Sequence.to_list s |> Bytes.of_char_list in + single_write stdout buf 0 (Bytes.length buf) |> ignore + in + handle_unix_error syscall + +let write_lines (lines : char Sequence.t Sequence.t) = + let crnl = Sequence.of_list [ '\r'; '\n' ] in + let clear s = Sequence.append s clear_to_eol in + let syscall seq = + let buf = + Sequence.(map ~f:clear seq |> intersperse ~sep:crnl |> concat |> to_list) + |> Bytes.of_char_list + in + single_write stdout buf 0 (Bytes.length buf) |> ignore + in + handle_unix_error syscall lines + +let cmds_to_sequence l = Sequence.(of_list l |> concat) + +let restore_screen () = + cmds_to_sequence [ clear_screen; reset_cursor; show_cursor true ] |> write_seq + +let redraw screen (x, y) = + let pre = cmds_to_sequence [ show_cursor false; reset_cursor ] + and post = cmds_to_sequence [ move_cursor x y; show_cursor true ] in + write_seq pre; + write_lines screen; + write_seq post + +let get_state () = { tio = handle_unix_error tcgetattr stdin; size = (-1, -1) } + +let size = + let query () = + cmds_to_sequence [ move_right 999; move_down 999; query_cursor_pos ] + |> write_seq + and get_reply () = + Sequence.( + char_stream + |> take_while ~f:Option.is_some + |> Fn.flip drop_eagerly 2 (* Drop escape sequence '[' *) + |> map ~f:(Option.value ~default:'R') + |> take_while ~f:(fun c -> Char.(c <> 'R')) + |> to_list |> String.of_char_list |> Stdlib.Scanf.sscanf + |> fun scanner -> scanner "%d;%d" (fun a b -> (a, b))) + in + query &> get_reply + +let enable_raw_mode tio = + let syscall () = + tcsetattr stdin TCSAFLUSH + { + tio with + c_brkint = false; + c_csize = 8; + c_echo = false; + c_echonl = false; + c_icanon = false; + c_icrnl = false; + c_ignbrk = false; + c_igncr = false; + c_inlcr = false; + c_inpck = false; + c_isig = false; + c_istrip = false; + c_ixon = false; + c_opost = false; + c_parenb = false; + c_parmrk = false; + c_vmin = 0; + c_vtime = 1; + } + in + handle_unix_error syscall + +let restore_status tio = + let syscall () = tcsetattr stdin TCSAFLUSH tio in + handle_unix_error syscall + +let init () = + let state = get_state () in + enable_raw_mode state.tio (); + restore_status state.tio |> Stdlib.at_exit; + restore_screen |> Stdlib.at_exit; + { state with size = size () } diff --git a/lib/terminal.mli b/lib/terminal.mli new file mode 100644 index 0000000..0fd11ed --- /dev/null +++ b/lib/terminal.mli @@ -0,0 +1,67 @@ +(** A module to simplify communication with the underlying terminal + emulator. *) + +open Base +open Unix + +type terminal_size = int * int +(** Size of the terminal window. *) + +type state = { + tio : terminal_io; (** Status flags for the terminal window *) + size : terminal_size; (** Size of the terminal window *) +} +(** Global state of the terminal window. *) + +val get_char : unit -> char option +(** Non-blocking request for a keypress. + Use {!val:Terminal.char_stream} for an infinite sequence of input + bytes. + + @return A [char] if a key was pressed, nothing otherwise. *) + +val char_stream : char option Sequence.t +(** The infinite stream of input bytes from stdin. + Returns [None] if no key was pressed; this is to be able to + interpret the absense of a keypress as an action. *) + +val write_seq : char Sequence.t -> unit +(** Write a sequence of strings to standard output. + + @param seq The sequence of strings to output. *) + +val restore_screen : unit -> unit +(** Clear screen and show cursor. Meant to be called on exit. *) + +val redraw : char Sequence.t Sequence.t -> int * int -> unit +(** Redraw the screen, using the provided sequence of lines. + + @param seq A sequence of lines. + @param cur Cursor position. *) + +val get_state : unit -> state +(** Get current state for the terminal window *) + +val size : unit -> int * int +(** Compute the current size of the terminal. + + This is done by moving the cursor to the far bottom right position + and querying for the cursor position using the appropriate escape + sequences. + + @return size of the terminal window in terms of character rows and columns. *) + +val enable_raw_mode : terminal_io -> unit -> unit +(** Turn on raw mode by overriding the correct terminal flags. + This is done according to [man 3 termios]. + + @param tio The current status of the terminal for [stdin]. *) + +val restore_status : terminal_io -> unit -> unit +(** Override the terminal status. + + @param tio The new terminal status for [stdin]. *) + +val init : unit -> state +(** Turns on raw mode and makes sure to restore the previous terminal + status on exit. *) diff --git a/lib/text.ml b/lib/text.ml new file mode 100644 index 0000000..ff1f727 --- /dev/null +++ b/lib/text.ml @@ -0,0 +1,10 @@ +open Base +open Sequence +open Sequence.Infix + +let center ~fill n text = + let padding = repeat fill and len_t = length text in + let len_p = (n - len_t) / 2 in + take (take padding len_p @ text @ padding) n + +let extend ~fill n text = take (text @ repeat fill) n diff --git a/lib/util.ml b/lib/util.ml new file mode 100644 index 0000000..9ad3b59 --- /dev/null +++ b/lib/util.ml @@ -0,0 +1,26 @@ +(** The infamous [Util] module. A graveyard of broken expressions. *) + +open Base + +(** [f &> g] composes [g] with [f] to obrain [fun x -> g (f x)]; + in other words, it applies [f] {i and then} [g]. + + @param f the first funtion to apply. + @param g the second function to apply. + @return the composition of [g] with [f]. *) +let ( &> ) f g = Fn.compose g f + +(** Turn a sequence of bytes into a sequence. + + @param b the input bytes. + @return a sequence of bytes. *) +let sequence_of_bytes (b : Bytes.t) : char Sequence.t = + let open Sequence.Generator in + let traverse b = + let len = Bytes.length b in + let rec loop i _ = + if i >= len then return () else yield (Bytes.get b i) >>= loop (i + 1) + in + loop 0 () + in + traverse b |> run diff --git a/lib/zipper.ml b/lib/zipper.ml new file mode 100644 index 0000000..2322a58 --- /dev/null +++ b/lib/zipper.ml @@ -0,0 +1,131 @@ +(* Module [Zipper]: functional zippers *) + +open Base + +type !+'a zipper = { + pos : int; + popped : 'a Sequence.t; + before : 'a Sequence.t; + after : 'a Sequence.t; +} + +type !+'a t = 'a zipper + +let empty = + { + pos = 0; + popped = Sequence.empty; + before = Sequence.empty; + after = Sequence.empty; + } + +let before z = z.before +let after z = z.after +let focus z = after z |> Sequence.next |> Option.map ~f:fst +let focus_or z ~default = Option.value ~default (focus z) +let history z = z.popped +let is_far_left z = before z |> Sequence.is_empty +let is_far_right z = after z |> Sequence.is_empty +let is_empty z = is_far_left z && is_far_right z +let left_length z = z.pos +let right_length z = after z |> Sequence.length +let length z = left_length z + right_length z + +let left z = + match Sequence.next z.before with + | None -> z + | Some (h, t) -> + { + z with + pos = z.pos - 1; + before = t; + after = Sequence.shift_right z.after h; + } + +let rec left_while f z = + if (not (is_far_left z)) && Option.(focus z |> map ~f |> value ~default:false) + then left z |> left_while f + else z + +let rec far_left z = if is_far_left z then z else z |> left |> far_left + +let right z = + match Sequence.next z.after with + | None -> z + | Some (h, t) -> + { + z with + pos = z.pos + 1; + before = Sequence.shift_right z.before h; + after = t; + } + +let rec right_while f z = + if + (not (is_far_right z)) && Option.(focus z |> map ~f |> value ~default:false) + then right z |> right_while f + else z + +let rec far_right z = if is_far_right z then z else z |> right |> far_right + +let goto n z = + let n = n - z.pos in + let step = if n < 0 then left else right in + Fn.apply_n_times ~n:(abs n) step z + +let pop_after z = { z with after = Sequence.drop_eagerly z.after 1 } +let pop_before z = if is_far_left z then z else z |> left |> pop_after +let pop = pop_before +let push_after x z = { z with after = Sequence.shift_right z.after x } + +let push_before x z = + { z with pos = z.pos + 1; before = Sequence.shift_right z.before x } + +let push = push_before + +let split z = + ( { z with after = Sequence.empty }, + { z with pos = 0; before = Sequence.empty } ) + +let iter_before f z = Sequence.iter ~f z.before +let iter_after f z = Sequence.iter ~f z.after + +let iter f z = + iter_before f z; + iter_after f z + +let for_all f z = Sequence.(for_all ~f z.before && for_all ~f z.after) +let exists f z = Sequence.(exists ~f z.before || exists ~f z.after) +let find_before f z = Sequence.find ~f z.before +let find_after f z = Sequence.find ~f z.after +let map_before f z = { z with before = Sequence.map ~f z.before } +let map_after f z = { z with after = Sequence.map ~f z.after } + +let map_focus f z = + match Sequence.next z.after with + | None -> z + | Some (h, t) -> { z with after = Sequence.shift_right t (f h) } + +let map f z = + { z with before = Sequence.map ~f z.before; after = Sequence.map ~f z.after } + +let mapi_before f z = { z with before = Sequence.mapi ~f z.before } +let mapi_after f z = { z with after = Sequence.mapi ~f z.after } + +let mapi f z = + { + z with + before = Sequence.mapi ~f z.before; + after = Sequence.mapi ~f z.after; + } + +let filter_before f z = { z with before = Sequence.filter ~f z.before } +let filter_after f z = { z with after = Sequence.filter ~f z.after } +let filter p z = z |> filter_before p |> filter_after p +let context_before n z = { z with before = Sequence.take z.before n } +let context_after n z = { z with after = Sequence.take z.after n } +let context ~b ?(a = b) z = z |> context_before b |> context_after a +let clear_history z = { z with popped = Sequence.empty } +let of_seq s = { empty with after = s } +let to_seq z = z |> far_left |> after +let window ~from ~len z = goto from z |> context_after len |> after diff --git a/lib/zipper.mli b/lib/zipper.mli new file mode 100644 index 0000000..c3c79a6 --- /dev/null +++ b/lib/zipper.mli @@ -0,0 +1,258 @@ +open Base + +(** Linear zippers. + + A zipper represents {b a paused traversal} of a certain data + structure. A linear zipper of type ['a zipper] represents a zipper + over a sequence of ['a] elements. + + One can access the {b focused element} of the zipper with [focus]. + The focus of a zipper is also known as the the {b cursor} of the + zipper, and can be moved back and forth with [left] and [right]. + + Elements can be added or removed at the cursor's position with + [push] and [pop] operations. Variants are available, e.g., to act + before the cursor, with suffix [_before], or after the cursor, with + suffix [_after]. *) + +type !+'a zipper +(** A zipper is represented as a {b pair} of sequences of type ['a]. The + focus of the zipper is the element at the head of the second + sequence, if any. + + Note that the first sequence is reversed. Given a sequence + [[1; 2; 3; 4; {5}; 6; 7]], where we represent the cursor using + curly braces [{_}], its representation as a zipper is + [([4; 3; 2; 1], [5; 6; 7])]. *) + +type !+'a t = 'a zipper +(** An alias for the ['a zipper] type. *) + +val empty : 'a zipper +(** Return an empty zipper *) + +val before : 'a zipper -> 'a Sequence.t +(** Return the sequence before the cursor *) + +val after : 'a zipper -> 'a Sequence.t +(** Return the sequence after the cursor *) + +val focus : 'a zipper -> 'a option +(** Return the focus of the zipper, if any. *) + +val focus_or : 'a zipper -> default:'a -> 'a +(** Return the focus of the zipper, or a user-provided default, otherwise. *) + +val history : 'a zipper -> 'a Sequence.t +(** Returns the sequence of elements [pop]ped so far from the zipper. *) + +val is_far_left : 'a zipper -> bool +(** Return whether the cursor is at the beginning of the zipper. *) + +val is_far_right : 'a zipper -> bool +(** Return whether the cursor is at the end of the zipper. *) + +val is_empty : 'a zipper -> bool +(** Return whether the zipper is empty. *) + +val left_length : 'a zipper -> int +(** Return the number of elements before the cursor. *) + +val right_length : 'a zipper -> int +(** Return the number of elements after the cursor. *) + +val length : 'a zipper -> int +(** Return the length of the zipper. *) + +(** {1 Moving the cursor} *) + +val left : 'a zipper -> 'a zipper +(** Move the cursor one step to the left, if possible. + Calling [left z], + + - if [z] is [([3; 2; 1], [4; 5])], the result is [([2; 1], [3; 4; 5])], + - if [z] is [([], [1; 2; 3])], the result is [([], [1; 2; 3])]. + *) + +val left_while : ('a -> bool) -> 'a zipper -> 'a zipper +(** [left_while f z] moves the cursor in [z] to the left as long as the + predicate [f] is [true] when applied to the focus, or the left end + of the zipper is reached. *) + +val far_left : 'a zipper -> 'a zipper +(** Move the cursor to the left, as much as possible. *) + +val right : 'a zipper -> 'a zipper +(** Move the cursor one step to the right, if possible. + Calling [right z], + + - if [z] is [([3; 2; 1], [4; 5])], the result is [([4; 3; 2; 1], [5])], + - if [z] is [([1; 2; 3], [])], the result is [([1; 2; 3], [])]. + *) + +val right_while : ('a -> bool) -> 'a zipper -> 'a zipper +(** [right_while f z] moves the cursor in [z] to the right as long as + the predicate [f] is [true] when applied to the focus, or the right + end of the zipper is reached. *) + +val far_right : 'a zipper -> 'a zipper +(** Move the cursor to the right, as much as possible. *) + +val goto : int -> 'a zipper -> 'a zipper +(** Move the cursor to a specific (absolute) position in the zipper. + Depending on the current position, it either moves the cursor + forward or backwards, without crossing the zipper boundaries. *) + +(** {1 Changes at the cursor} *) + +(** Zippers provide [O(1)] operations performed at the cursor position. + This involve [push]ing and [pop]ping elements before and after the + cursor. *) + +val pop_after : 'a zipper -> 'a zipper +(** Remove the element at the cursor position, if any, and return the + modified zipper. Calling [pop_after z], + + - if [z] is [([3; 2; 1], [4; 5])], the result is [([3; 2; 1], [5])], + - if [z] is [([1; 2; 3], [])], the result is [([1; 2; 3], [])]. + *) + +val pop_before : 'a zipper -> 'a zipper +(** Remove the element before the cursor, if any, and return the + modified zipper. Calling [pop_before z], + + - if [z] is [([3; 2; 1], [4; 5])], the result is [([2; 1], [4, 5])], + - if [z] is [([], [1; 2; 3])], the result is [([], [1; 2; 3])]. + *) + +val pop : 'a zipper -> 'a zipper +(** [pop] is an alias for [pop_before]. *) + +val push_after : 'a -> 'a zipper -> 'a zipper +(** Insert an element after the cursor. + Calling [push_after 0 z], if [z] is [([3; 2; 1], [4; 5])], + the result is [([3; 2; 1], [0; 4, 5]))], *) + +val push_before : 'a -> 'a zipper -> 'a zipper +(** Insert an element before the cursor. Return the modified zipper. + Calling [push_before 0 z], if [z] is [([3; 2; 1], [4; 5])], + the result is [([0; 3; 2; 1], [4, 5]))]. *) + +val push : 'a -> 'a zipper -> 'a zipper +(** [push] is an alias for [push_before]. *) + +val split : 'a zipper -> 'a zipper * 'a zipper +(** [split z] splits the zipper in two. [([3; 2; 1], [4; 5])] becomes + [([3; 2; 1], []), ([], [4; 5])]. *) + +(** {1 Consuming zippers} *) + +(** Since zippers are based on sequences, iterating over zippers + terminates only when both sequences are finite. + Unless otherwise stated, these functions will iterate on the + elements before the cursor, first. *) + +val iter_before : ('a -> unit) -> 'a zipper -> unit +(** [iter_before f z] will call [f x] for all [x], elements before the + cursor in [z].*) + +val iter_after : ('a -> unit) -> 'a zipper -> unit +(** [iter_after f z] will call [f x] for all [x], elements after the + cursor in [z].*) + +val iter : ('a -> unit) -> 'a zipper -> unit +(** [iter f z] is equivalent to [iter_before f z; iter_after f z] *) + +val for_all : ('a -> bool) -> 'a zipper -> bool +(** [for_all p z] tests whether a predicate [p] is [true] for all + elements in a zipper. *) + +val exists : ('a -> bool) -> 'a zipper -> bool +(** [exists p z] tests whether at least one element in the zipper is + [true] according to the predicate [p]. *) + +val find_before : ('a -> bool) -> 'a zipper -> 'a option +(** [find_before p z] will return the first element before the cursor in + [z] satisfying the predicate [p], if any. *) + +val find_after : ('a -> bool) -> 'a zipper -> 'a option +(** [find_after p z] will return the first element after the cursor in + [z] satisfying the predicate [p], if any. *) + +(** {1 Transforming zippers} *) + +(** Since zippers are based on sequences, the functions in this section + are lazy; i.e., resulting elements of the zipper are computed only + when demanded. *) + +val map_before : ('a -> 'a) -> 'a zipper -> 'a zipper +(** Map a function over all elements before the cursor. *) + +val map_after : ('a -> 'a) -> 'a zipper -> 'a zipper +(** Map a function over all elements after the cursor. *) + +val map_focus : ('a -> 'a) -> 'a zipper -> 'a zipper +(** Map a function over the element focused by the cursor, if any. *) + +val map : ('a -> 'a) -> 'a zipper -> 'a zipper +(** Map a function over all elements of a zipper. *) + +val mapi_before : (int -> 'a -> 'a) -> 'a zipper -> 'a zipper +(** [mapi_before] is analogous to {!Zipper.map_before}, but the function + takes an index and an element. + The index indicates the distance of an element from the cursor. *) + +val mapi_after : (int -> 'a -> 'a) -> 'a zipper -> 'a zipper +(** [mapi_after] is analogous to {!Zipper.map_after}, but the function + takes an index and an element. + The index indicates the distance of an element from the cursor. *) + +val mapi : (int -> 'a -> 'a) -> 'a zipper -> 'a zipper +(** [mapi] is analogous to {!Zipper.map}, but the function takes an + index and an element. + The index indicates the distance of an element from the cursor. *) + +val filter_before : ('a -> bool) -> 'a zipper -> 'a zipper +(** [filter_before p z] filters the elements before the cursor in a + zipper [z] according to a predicate [p], i.e., keeping the elements + that satisfy the predicate. *) + +val filter_after : ('a -> bool) -> 'a zipper -> 'a zipper +(** [filter_after p z] filters the elements after the cursor in a + zipper [z] according to a predicate [p], i.e., keeping the elements + that satisfy the predicate. *) + +val filter : ('a -> bool) -> 'a zipper -> 'a zipper +(** [filter p z] filters the elements of the zipper [z] according to a + predicate [p], i.e., keeping the elements that satisfy the + predicate. *) + +val context_before : int -> 'a zipper -> 'a zipper +(** [context_before n z] will limit the zipper [z] to [n] elements before + the cursor. *) + +val context_after : int -> 'a zipper -> 'a zipper +(** [context_after n z] will limit the zipper [z] to [n] elements after + the cursor. *) + +val context : b:int -> ?a:int -> 'a zipper -> 'a zipper +(** [context ~b ~a z] will limit the zipper [z] to [b] elements before + the cursor and [a] elements after the cursor. When [a] is not + provided, it defaults to [b]. *) + +val clear_history : 'a zipper -> 'a zipper +(** Clear the history of the zipper. See {!Zipper.history}. *) + +(** {1 Zippers and sequences} *) + +val of_seq : 'a Sequence.t -> 'a zipper +(** Turn a sequence into a zipper with the cursor at the beginning. *) + +val to_seq : 'a zipper -> 'a Sequence.t +(** Return the zipper as a sequence. + Calling [to_seq z], with [z] being [([3; 2; 1], [4; 5])], results in + [[1; 2; 3; 4; 5]]. *) + +val window : from:int -> len:int -> 'a zipper -> 'a Sequence.t +(** [windows from len z] returns a sequence containing [len] elements + starting from [from]. *) -- cgit v1.2.3