open Base module Buffer = EditorBuffer open Util type selection = | Empty | Glyphwise of char Sequence.t Sequence.t | Linewise of char Sequence.t Sequence.t type cursor = int * int type editor = { term : Terminal.state; mode : Mode.t; offset : int * int; cursor : cursor; buffer : Buffer.t Tipper.t; rendered : bool; istream : Command.t Sequence.t; nstream : Command.t Sequence.t; status_size : int; message : string option; message_timestamp : float; message_duration : float; pending_command : string; registers : selection Array.t; control : Control.t; search_history : (bool * char Sequence.t) Zipper.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 |> Option.value_or_thunk ~default:Buffer.empty |> Tipper.create; rendered = true; istream = Command.i_stream; nstream = Command.n_stream; status_size = 2; message = Some "Welcome to the sandy editor!"; message_timestamp = Unix.time (); message_duration = 5.; pending_command = ""; registers = Array.create ~len:128 Empty; control = Control.create Key.Nul; search_history = Zipper.empty; } let statusbar e = let open Text in (* let open Sequence.Infix in *) let w = e.term.size |> snd in let status = let mode = e.mode |> Mode.to_string |> sequence_of_string in let lsize = Sequence.length mode in let buf = Tipper.focus e.buffer in let c = buf.kind |> Buffer.string_of_kind |> sequence_of_string and br, bc = Buffer.size buf and cr, cc = Buffer.cursor ~rendered:false buf in let perc = match cr with | 0 -> "Top" | n when n = br -> "Bot" | n -> Printf.sprintf "%2d%%" (100 * n / br) in let nav = Printf.sprintf "%d/%d %2d/%2d [%s] " cr br cc bc perc |> sequence_of_string in let rsize = Sequence.length nav in spread ~l:(bold mode) ~lsize ~c ~r:(bold nav) ~rsize ~fill:' ' w |> invert and control = match e.mode with | Control -> Control.render e.control | _ -> let msg = Option.value ~default:"" e.message |> sequence_of_string and cmd = e.pending_command |> sequence_of_string in spread ~l:msg ~r:cmd ~fill:' ' w in Sequence.(take (of_list [ status; control ]) e.status_size) 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 e = (a, e) let apply f a e = let g, e = f e in let x, e = a e in (g x, e) let map = `Define_using_apply end) include Monad.Make (struct type 'a t = 'a action let return x e = (x, e) let bind a ~f x = let y, a' = a x in f y a' let map = `Define_using_bind end) let ( let+ ) e f = map e ~f let ( let* ) e f = bind e ~f let ( and* ) = both let rec repeat ?(n = 1) a = match n with | _ when n <= 0 -> return () | 1 -> a | _ -> a *> repeat ~n:(n - 1) a 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 (* Limit cursor to buffer view *) let rs = rs - e.status_size in let cx, cy = e.buffer |> Tipper.focus |> Buffer.cursor in let dx' = Int.clamp_exn ~min:(cx - rs + 1) ~max:cx dx and dy' = Int.clamp_exn ~min:(cy - cs + 1) ~max:cy dy in { e with cursor = (cx - dx' + 1, cy - dy' + 1); offset = (dx', dy') } in modify ~f:aux let get_focused_buffer_history e = (e.buffer, e) let set_focused_buffer_history h = (fun e -> ((), { e with buffer = h })) *> update_cursor let on_focused_buffer_history f = get_focused_buffer_history >>| f >>= set_focused_buffer_history let get_focused_buffer e = (Tipper.focus e.buffer, e) let set_focused_buffer b e = ((), { e with buffer = Tipper.set_focus b e.buffer }) let on_focused_buffer f = let* b = get_focused_buffer in let out, b = f b in let* () = set_focused_buffer b in let* () = update_cursor in return out let simulate f = let* b = get_focused_buffer in return (f b |> fst) let get_control_buffer e = (e.control, e) let set_control_buffer c e = ((), { e with control = c }) let on_control_buffer f = let* c = get_control_buffer in set_control_buffer (f c) let get_mode e = (e.mode, e) let set_mode m e = ((), { e with mode = m }) let get_search_history e = (e.search_history, e) let set_search_history h e = ((), { e with search_history = h }) let on_search_history f = get_search_history >>| f >>= set_search_history let set_last_search dir word = Zipper.(far_left &> swap_focus (dir, word)) |> on_search_history let get_terminal_size e = (e.term.size, e) let get_register ?(r = '"') e = assert (Char.('!' <= r && r <= '~')); (e.registers.(Char.to_int r), e) let set_register ?(r = '"') s e = assert (Char.('!' <= r && r <= '~')); e.registers.(Char.to_int r) <- s; ((), e) let render = let aux e = let x, y = e.offset and r, c = e.term.size and fill = Sequence.singleton '~' and status = statusbar e and limit = (* debug *) Buffer.(if e.rendered then rendered_view else unrendered_view) in let ssize = e.status_size in let bufview = e.buffer |> Tipper.focus |> limit x y (r - ssize) c |> Text.extend ~fill r |> Fn.flip Sequence.take (r - ssize) in let screen = Sequence.append bufview status and cursor = let open Mode in match e.mode with | Control -> (r, Control.cursor e.control) | _ -> e.cursor in Terminal.redraw screen cursor in get >>| aux (* TODO: save logic *) let quit n = Stdlib.exit n (* Statusbar *) let set_message m e = ((), { e with message = Some m; message_timestamp = Unix.time () }) let get_pending_command e = (e.pending_command, e) let set_pending_command p e = ((), { e with pending_command = p }) let append_pending_command k = let aux p = p ^ Key.to_string k in get_pending_command >>| aux >>= set_pending_command let clear_pending_command = set_pending_command "" let tick = let check_message_timestamp e = let now = Unix.time () in let expired = Float.(e.message_timestamp < now - e.message_duration) in if Option.is_some e.message && expired then { e with message = None } else e in get >>| check_message_timestamp >>= put (* Control line *) let search dir word = let* coords = Buffer.Action.(search dir word |> on_focused_buffer) in match coords with | None -> let word = word |> Sequence.to_list |> String.of_list in set_message (Printf.sprintf "Pattern not found: %s" word) | Some (r, c) -> Buffer.Action.goto ~r ~c |> on_focused_buffer (* History *) let take_buffer_snapshot = let* h = get_focused_buffer_history in let buf = { (Tipper.focus h) with last_modified = Unix.gettimeofday () } in let h = Tipper.(h |> push (create buf) |> down) in set_focused_buffer_history h let undo = let* h = get_focused_buffer_history in if Tipper.is_root h then set_message "Already at the oldest change" else set_focused_buffer_history (Tipper.up h) let redo = let* h = get_focused_buffer_history in if Tipper.is_leaf h then set_message "Already at the newest change" else set_focused_buffer_history (Tipper.down h) let timetravel ?(later = false) ?(_secs = 0.) = let last_modified (n : Buffer.t Tipper.t) = (Tipper.focus n).last_modified in let find ts h = let f a t = let tmax = if later then Option.(map ~f:last_modified a |> value ~default:Float.max_value) else ts in let tmin = if later then ts else Option.(map ~f:last_modified a |> value ~default:0.) and cur = last_modified t in if Float.(tmin < cur && cur < tmax) then Some t else a in Tipper.fold ~a:None ~f h in let* h = get_focused_buffer_history in let ts = last_modified h in match find ts (Tipper.root h) with | None -> set_message "Already at the oldest change" | Some h -> set_focused_buffer_history h (* Debug *) let get_rendered e = (e.rendered, e) let set_rendered r e = ((), { e with rendered = r }) let toggle_rendered = get_rendered >>| not >>= set_rendered 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 handle_insert_command = let open Command in let open Action in function | Simple Arrow_down -> Buffer.Action.move_down |> on_focused_buffer | Simple Arrow_left -> Buffer.Action.move_left |> on_focused_buffer | Simple Arrow_right -> Buffer.Action.move_right |> on_focused_buffer | Simple Arrow_up -> Buffer.Action.move_up |> on_focused_buffer | Simple Backspace -> Buffer.Action.delete_before ~cross_lines:true ~n:1 |> on_focused_buffer |> ignore_m | Simple (Ctrl 'Q') -> quit 0 | Simple Delete -> Buffer.Action.delete_after ~cross_lines:true ~n:1 |> on_focused_buffer |> ignore_m | Simple Enter -> Buffer.Action.newline |> on_focused_buffer | Simple Esc -> let* () = Buffer.Action.move_left |> on_focused_buffer in set_mode Normal | Simple Page_down | Simple (Ctrl 'F') -> (* TODO consider using the buffer window size (i.e., subtract status_size) *) let* n, _ = get_terminal_size in Buffer.Action.move_down ~n |> on_focused_buffer | Simple Page_up | Simple (Ctrl 'B') -> let* n, _ = get_terminal_size in Buffer.Action.move_up ~n |> on_focused_buffer | Simple (Ctrl 'D') -> let* r, _ = get_terminal_size in Buffer.Action.move_down ~n:(r / 2) |> on_focused_buffer | Simple (Ctrl 'U') -> let* r, _ = get_terminal_size in Buffer.Action.move_up ~n:(r / 2) |> on_focused_buffer | Simple Home -> Buffer.Action.bol |> on_focused_buffer | Simple End -> Buffer.Action.eol |> on_focused_buffer | Simple Tab -> Buffer.Action.insert '\t' |> on_focused_buffer | Type k -> Buffer.Action.insert k |> on_focused_buffer | _ -> noop let handle_normal_command c = let open Command in let open Action in let update_command_cue = match c with | Partial k -> append_pending_command k | _ -> clear_pending_command and compute_action = match c with (* Movements *) | Chord (_, n, Noop, _, Down) -> Buffer.Action.move_down ?n |> on_focused_buffer | Chord (_, n, Noop, _, Left) -> Buffer.Action.move_left ?n |> on_focused_buffer | Chord (_, n, Noop, _, Right) -> Buffer.Action.move_right ?n |> on_focused_buffer | Chord (_, n, Noop, _, Up) -> Buffer.Action.move_up ?n |> on_focused_buffer | Chord (_, n, Noop, _, To_bol) -> let n = Option.value ~default:1 n - 1 in Buffer.Action.bol ~n |> on_focused_buffer | Chord (_, n, Noop, _, To_eol) -> let n = Option.value ~default:1 n - 1 in Buffer.Action.eol ~n |> on_focused_buffer | Simple Page_down | Simple (Ctrl 'F') -> let* n, _ = get_terminal_size in Buffer.Action.move_down ~n |> on_focused_buffer | Simple Page_up | Simple (Ctrl 'B') -> let* n, _ = get_terminal_size in Buffer.Action.move_up ~n |> on_focused_buffer | Simple (Ctrl 'D') -> let* r, _ = get_terminal_size in Buffer.Action.move_down ~n:(r / 2) |> on_focused_buffer | Simple (Ctrl 'U') -> let* r, _ = get_terminal_size in Buffer.Action.move_up ~n:(r / 2) |> on_focused_buffer | Shortcut (_, n, Goto) -> ( match n with | None -> Buffer.Action.eof |> on_focused_buffer | Some n -> Buffer.Action.goto ~r:n |> on_focused_buffer) (* Yank *) | Shortcut (r, n, Yank) -> let n = Option.value ~default:1 n - 1 in let* out = Buffer.Action.delete_to_eol ~n |> simulate in set_register ?r (Glyphwise out) | Chord (r, n1, Yank, n2, Line) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* out = Buffer.Action.delete_lines ~n |> simulate in set_register ?r (Linewise out) | Chord (r, n1, Yank, n2, Down) -> let n = Option.((value ~default:1 n1 * value ~default:1 n2) + 1) in let* out = Buffer.Action.delete_lines ~n |> simulate in set_register ?r (Linewise out) | Chord (r, n1, Yank, n2, Left) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* out = Buffer.Action.delete_before ~n |> simulate in set_register ?r (Glyphwise out) | Chord (r, n1, Yank, n2, Right) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* out = Buffer.Action.delete_after ~n |> simulate in set_register ?r (Glyphwise out) | Chord (r, n1, Yank, n2, Up) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* out = Buffer.Action.(move_up ~n *> delete_lines ~n:(n + 1)) |> simulate in set_register ?r (Linewise out) | Chord (r, _, Yank, _, To_bol) -> let* out = Buffer.Action.delete_to_bol |> simulate in set_register ?r (Glyphwise out) | Chord (r, n1, Yank, n2, To_eol) -> let n = Option.((value ~default:1 n1 * value ~default:1 n2) - 1) in let* out = Buffer.Action.delete_to_eol ~n |> simulate in set_register ?r (Glyphwise out) (* Change *) | Shortcut (r, n, Change) -> let n = Option.value ~default:1 n - 1 in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_to_eol ~n |> on_focused_buffer in let* () = set_register ?r (Glyphwise out) in set_mode Insert | Chord (r, n1, Change, n2, Line) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let act = let open Buffer.Action in let* out = delete_lines ~n and* () = insert_line ~before:true *> move_up in return out in let* () = take_buffer_snapshot in let* out = act |> on_focused_buffer in let* () = set_register ?r (Linewise out) in set_mode Insert | Chord (r, n1, Change, n2, Down) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) + 1 in let act = let open Buffer.Action in let* out = delete_lines ~n and* () = insert_line ~before:true *> move_up in return out in let* () = take_buffer_snapshot in let* out = act |> on_focused_buffer in let* () = set_register ?r (Linewise out) in set_mode Insert | Chord (r, n1, Change, n2, Left) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_before ~n |> on_focused_buffer in let* () = set_register ?r (Glyphwise out) in set_mode Insert | Chord (r, n1, Change, n2, Right) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_after ~n |> on_focused_buffer in let* () = set_register ?r (Glyphwise out) in set_mode Insert | Chord (r, n1, Change, n2, Up) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let act = let open Buffer.Action in let* out = move_up ~n *> delete_lines ~n:(n + 1) and* () = insert_line ~before:true *> move_up in return out in let* () = take_buffer_snapshot in let* out = act |> on_focused_buffer in let* () = set_register ?r (Linewise out) in set_mode Insert | Chord (r, _, Change, _, To_bol) -> let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_to_bol |> on_focused_buffer in let* () = set_register ?r (Glyphwise out) in set_mode Insert | Chord (r, n1, Change, n2, To_eol) -> let n = Option.((value ~default:1 n1 * value ~default:1 n2) - 1) in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_to_eol ~n |> on_focused_buffer in let* () = set_register ?r (Glyphwise out) in set_mode Insert (* Delete *) | Shortcut (r, n, Delete) -> let n = Option.value ~default:1 n - 1 in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_to_eol ~n |> on_focused_buffer in set_register ?r (Glyphwise out) | Chord (r, n1, Delete, n2, Line) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_lines ~n |> on_focused_buffer in set_register ?r (Linewise out) | Chord (r, n1, Delete, n2, Down) -> let n = Option.((value ~default:1 n1 * value ~default:1 n2) + 1) in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_lines ~n |> on_focused_buffer in set_register ?r (Linewise out) | Chord (r, n1, Delete, n2, Left) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_before ~n |> on_focused_buffer in set_register ?r (Glyphwise out) | Chord (r, n1, Delete, n2, Right) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_after ~n |> on_focused_buffer in set_register ?r (Glyphwise out) | Chord (r, n1, Delete, n2, Up) -> let n = Option.(value ~default:1 n1 * value ~default:1 n2) in let* () = take_buffer_snapshot in let* out = Buffer.Action.(move_up ~n *> delete_lines ~n:(n + 1)) |> on_focused_buffer in set_register ?r (Linewise out) | Shortcut (r, n, Erase_before) -> let n = Option.value ~default:1 n in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_before ~n |> on_focused_buffer in set_register ?r (Glyphwise out) | Shortcut (r, n, Erase_after) -> let n = Option.value ~default:1 n in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_after ~n |> on_focused_buffer in set_register ?r (Glyphwise out) | Chord (r, _, Delete, _, To_bol) -> let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_to_bol |> on_focused_buffer in set_register ?r (Glyphwise out) | Chord (r, n1, Delete, n2, To_eol) -> let n = Option.((value ~default:1 n1 * value ~default:1 n2) - 1) in let* () = take_buffer_snapshot in let* out = Buffer.Action.delete_to_eol ~n |> on_focused_buffer in set_register ?r (Glyphwise out) (* Paste *) | Shortcut (r, n, Paste_after) -> ( get_register ?r >>= function | Empty -> noop | Glyphwise z -> let* () = take_buffer_snapshot in Buffer.Action.paste ?n z |> on_focused_buffer | Linewise z -> let* () = take_buffer_snapshot in Buffer.Action.paste ~linewise:true ?n z |> on_focused_buffer) | Shortcut (r, n, Paste_before) -> ( get_register ?r >>= function | Empty -> noop | Glyphwise z -> let* () = take_buffer_snapshot in Buffer.Action.paste ~before:true ?n z |> on_focused_buffer | Linewise z -> let* () = take_buffer_snapshot in Buffer.Action.paste ~before:true ~linewise:true ?n z |> on_focused_buffer) (* Join *) | Shortcut (_, n, Join) -> let n = Option.(value ~default:2 n) in let* () = take_buffer_snapshot in Buffer.Action.join_lines ~n |> on_focused_buffer (* Control *) | Simple (Key ':' as k) -> let c = Control.create k in set_control_buffer c *> set_mode Control | Simple (Key '/' as k) -> let c = Control.create k in (Zipper.(far_left &> push (true, Sequence.empty)) |> on_search_history) *> set_control_buffer c *> set_mode Control | Simple (Key '?' as k) -> let c = Control.create k in (Zipper.(far_left &> push (false, Sequence.empty)) |> on_search_history) *> set_control_buffer c *> set_mode Control | Shortcut (_, n, Search) -> ( let* h = get_search_history in match Zipper.focus h with | None -> set_message "No search history" | Some (dir, word) -> search dir word |> repeat ?n) | Shortcut (_, n, Search_rev) -> ( let* h = get_search_history in match Zipper.focus h with | None -> set_message "No search history" | Some (dir, word) -> search (not dir) word |> repeat ?n) | Simple (Ctrl 'Q') -> quit 0 (* History *) | Shortcut (_, n, Undo) -> repeat ?n undo | Shortcut (_, n, Redo) -> repeat ?n redo | Shortcut (_, n, Earlier) -> repeat ?n timetravel | Shortcut (_, n, Later) -> repeat ?n (timetravel ~later:true) (* | Shortcut (_, n, Redo) -> repeat ?n redo *) (* Misc *) | Simple (Key 'A') -> (Buffer.Action.eol |> on_focused_buffer) *> set_mode Insert | Simple (Key 'a') -> (Buffer.Action.move_right |> on_focused_buffer) *> set_mode Insert (* | Key 'G' -> Buffer.Action.eof |> on_focused_buffer_or_new *) (* | Key 'I' -> noop *) | Simple (Key 'i') -> set_mode Insert (* | Key 's' -> *) (* (Buffer.Action.delete_after |> on_focused_buffer_or_new) *) (* *> set_mode Insert *) (* Debug *) | Simple (Ctrl 'R') -> toggle_rendered | _ -> noop in compute_action *> update_command_cue let handle_control_command = let open Command in let open Action in function | Simple Arrow_down -> let* c = get_control_buffer in if Control.is_search c then let* () = Zipper.left |> on_search_history and* h = get_search_history in match Zipper.focus h with | None -> noop | Some (_, word) -> Control.set_content word |> on_control_buffer else failwith "Control line command history unimplemented!" | Simple Arrow_left -> Control.move_left |> on_control_buffer | Simple Arrow_right -> Control.move_right |> on_control_buffer | Simple Arrow_up -> let* c = get_control_buffer in if Control.is_search c then let* () = Zipper.right |> on_search_history and* h = get_search_history in match Zipper.focus h with | None -> noop | Some (_, word) -> Control.set_content word |> on_control_buffer else failwith "Control line command history unimplemented!" | Simple Backspace -> Control.delete_before |> on_control_buffer | Simple Delete -> Control.delete_after |> on_control_buffer | Simple Enter -> ( let* () = set_mode Normal and* c = get_control_buffer in match Control.get_result c with | Search (dir, word) -> search dir word *> set_last_search dir word | No_result -> noop) | Simple Esc -> ( let* () = set_mode Normal and* c = get_control_buffer in match Control.get_result c with | Search _ -> Zipper.(far_left &> pop &> snd) |> on_search_history | No_result -> noop) | Simple Home -> Control.bol |> on_control_buffer | Simple End -> Control.eol |> on_control_buffer | Type k -> Control.insert k |> on_control_buffer | _ -> noop let handle_next_command m e = let open Mode in match m with | Insert -> ( match Sequence.next e.istream with | None -> ((), e) | Some (h, t) -> handle_insert_command h { e with istream = t }) | Normal -> ( match Sequence.next e.nstream with | None -> ((), e) | Some (h, t) -> handle_normal_command h { e with nstream = t }) | Control -> ( match Sequence.next e.istream with | None -> ((), e) | Some (h, t) -> handle_control_command h { e with istream = t }) let handle_next_command = let open Action in get_mode >>= handle_next_command