path: root/lib/editor.ml

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