path: root/lib/editorBuffer.ml

open Base
open Stdio
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;
  rendered : char Sequence.t zipper;
  last_modified : float;
}

type t = buffer

let empty () =
  {
    kind = No_name;
    content = empty |> push empty |> Result.return;
    rendered = push Sequence.empty empty;
    last_modified = Unix.gettimeofday ();
  }

let kind b = b.kind

let string_of_kind = function
  | No_name -> "[No Name]"
  | Scratch -> "[Scratch]"
  | File name -> name

let size e =
  match e.content with
  | Error _ -> (0, 0)
  | Ok z -> (length z, apply_focus_or ~default:0 length z)

let render =
  let open Sequence in
  let tabsize = 8 in
  let f i = function
    | '\t' ->
        let width = tabsize - (i % tabsize) in
        (i + width, take (repeat '.') width)
    | c -> (i + 1, singleton c)
  in
  folding_map ~init:0 ~f &> join

let cursor ?(rendered = true) b =
  match b.content with
  | Error _ -> (0, 0)
  | Ok c ->
      let hlen z =
        if rendered then
          Sequence.(length (before z |> to_list_rev |> of_list |> render))
        else left_length z
      in
      (left_length c, apply_focus_or ~default:0 hlen c)

type 'a action = t -> 'a * t

module Action = struct
  include Applicative.Make (struct
    type 'a t = 'a action

    let return a b = (a, b)

    let apply f a b =
      let g, b = f b in
      let x, b = a b in
      (g x, b)

    let map = `Define_using_apply
  end)

  include Monad.Make (struct
    type 'a t = 'a action

    let return x b = (x, b)

    let bind a ~f x =
      let y, a' = a x in
      f y a'

    let map = `Define_using_bind
  end)

  let ( let* ) b f = bind b ~f
  let ( and* ) = both
  let ( let+ ) b f = map b ~f
  let get b = (b, b)
  let put b _ = ((), b)
  let modify ~f = get >>| f >>= put
  let get_content b = (b.content, b)
  let set_content c b = ((), { b with content = c })
  let on_content f = get_content >>| Result.map ~f >>= set_content

  let on_content_with_output ~default f b =
    match b.content with
    | Error _ -> (default, b)
    | Ok z ->
        let a, z = f z in
        (a, { b with content = Ok z })

  let on_rendered f b = ((), { b with rendered = f b.rendered })

  let update_render ?(before = false) ~n b =
    match b.content with
    | Error _ -> ((), b)
    | Ok c ->
        let rstep = if before then left else right ~by_one:false in
        let cstep = if before then left else right ~by_one:false in
        let rec aux i r c =
          if i = 0 then r
          else
            let default = Sequence.empty in
            let l = apply_focus_or ~default (to_seq &> render) c in
            let c' = cstep c and r' = swap_focus l r |> rstep in
            aux (i - 1) r' c'
        in
        ((), { b with rendered = aux n b.rendered c |> goto (left_length c) })

  let update_render_at_cursor = update_render ~before:false ~n:1

  let move_up ?(n = 1) =
    let change_content =
      let act z =
        let col = apply_focus_or ~default:0 left_length z in
        Fn.apply_n_times ~n left z |> map_focus (goto col)
      in
      on_content act
    and change_rendered = on_rendered (Fn.apply_n_times ~n left) in
    change_content *> change_rendered

  let move_down ?(n = 1) =
    let change_content =
      let act z =
        let col = apply_focus_or ~default:0 left_length z in
        Fn.apply_n_times ~n right z |> map_focus (goto col)
      in
      on_content act
    and change_rendered = on_rendered (Fn.apply_n_times ~n right) in
    change_content *> change_rendered

  let move_left, move_right =
    let horizontal f ?(n = 1) =
      map_focus (Fn.apply_n_times ~n f) |> on_content
    in
    (horizontal left, horizontal right)

  let goto ~r ?(c = 0) =
    let change_content = Zipper.(goto r &> map_focus (goto c)) |> on_content
    and change_rendered = Zipper.goto r |> on_rendered in
    change_content *> change_rendered

  let bol ?(n = 0) = move_down ~n *> (map_focus far_left |> on_content)
  let eol ?(n = 0) = move_down ~n *> (map_focus far_right |> on_content)

  let bof =
    let change_content = far_left |> on_content
    and change_rendered = far_left |> on_rendered in
    change_content *> change_rendered

  let eof =
    let change_content = far_right |> on_content
    and change_rendered = far_right |> on_rendered in
    change_content *> change_rendered

  let insert k =
    let change_content = map_focus (push_before k) |> on_content in
    change_content *> update_render_at_cursor

  let replace k =
    let change_content = map_focus (swap_focus k) |> on_content in
    change_content *> update_render_at_cursor

  let insert_line ?(before = false) =
    let change_content =
      let push = if before then push_before else push_after in
      push Zipper.empty |> on_content
    and change_rendered =
      let push = if before then push_before else push_after in
      push Sequence.empty |> on_rendered
    in
    change_content *> change_rendered

  let join_lines ?(n = 2) =
    let change_content =
      let join_2_lines z =
        if right_length z < 2 then z
        else
          let to_join = right z |> focus_or ~default:Zipper.empty in
          map_focus (Zipper.join ~z2:to_join) z |> pop_after |> snd
      in
      Fn.apply_n_times ~n:(n - 1) join_2_lines |> on_content
    and change_rendered = pop_after ~n:(n - 1) &> snd |> on_rendered in
    change_content *> change_rendered *> update_render_at_cursor

  let delete_after ?(cross_lines = false) ~n =
    let lines_to_delete b =
      match b.content with
      | Error _ -> 0
      | Ok z -> (
          match Sequence.next (after z) with
          | None -> 0
          | Some (h, t) ->
              let init = right_length h
              and f acc z =
                let acc' = acc + length z + 1 in
                (acc', acc')
              in
              Sequence.shift_right (Sequence.folding_map t ~init ~f) init
              |> Sequence.findi ~f:(fun _ a -> n <= a)
              |> Option.map ~f:fst
              |> Option.value ~default:(Sequence.length t))
    and change_content =
      let default = Sequence.empty in
      on_content_with_output ~default (fun z ->
          let rec aux i acc z =
            let line = focus_or ~default:Zipper.empty z in
            if right_length line >= i || (not cross_lines) || right_length z < 2
            then
              let s, z1 = pop ~n:i line in
              (s :: acc, swap_focus z1 z)
            else
              let rlen = right_length line in
              let s, z1 = pop ~n:rlen line in
              let z = swap_focus z1 z in
              let to_join = right z |> focus_or ~default:Zipper.empty in
              let z =
                map_focus (Zipper.join ~z2:to_join) z |> pop_after |> snd
              in
              aux (i - rlen - 1) (s :: acc) z
          in
          let acc, z = aux n [] z in
          (List.rev acc |> Sequence.of_list, z))
    and change_rendered n =
      if cross_lines then pop_after ~n &> snd |> on_rendered else return ()
    in
    let* n = get >>| lines_to_delete in
    let* out = change_content
    and* () = change_rendered n
    and* () = update_render_at_cursor in
    return out

  let delete_before ?(cross_lines = false) ~n =
    let lines_to_delete b =
      match b.content with
      | Error _ -> 0
      | Ok z ->
          let init = apply_focus_or ~default:0 left_length z
          and f acc z =
            let acc' = acc + length z + 1 in
            (acc', acc')
          in
          Sequence.shift_right (Sequence.folding_map (before z) ~init ~f) init
          |> Sequence.findi ~f:(fun _ a -> n <= a)
          |> Option.map ~f:fst
          |> Option.value ~default:(left_length z)
    and change_content =
      let default = Sequence.empty in
      on_content_with_output ~default (fun z ->
          let rec aux i acc z =
            let line = focus_or ~default:Zipper.empty z in
            if left_length line >= i || (not cross_lines) || is_far_left z then
              let s, z1 = pop_before ~n:i line in
              let z' = swap_focus z1 z in
              (s :: acc, z')
            else
              let llen = left_length line in
              let s, z1 = pop_before ~n:llen line in
              let z' = swap_focus z1 z in
              let to_join = focus_or ~default:Zipper.empty z' in
              let z'' =
                left z'
                |> map_focus (Zipper.join ~z2:to_join)
                |> pop_after |> snd
              in
              aux (i - llen - 1) (s :: acc) z''
          in
          let acc, z' = aux n [] z in
          (List.rev acc |> Sequence.of_list, z'))
    and change_rendered n =
      if cross_lines then pop_before ~n &> snd |> on_rendered else return ()
    in
    let* n = get >>| lines_to_delete in
    let* out = change_content
    and* () = change_rendered n
    and* () = update_render_at_cursor in
    return out

  let delete_lines ~n =
    let default = Sequence.empty in
    let* out = pop ~n |> on_content_with_output ~default
    and* () = pop ~n &> snd |> on_rendered in
    return (Sequence.map ~f:to_seq out)

  (* TODO: maybe not needed *)
  (* let delete_lines_before ~n b = *)
  (*   let default = Sequence.empty in *)
  (*   let out, b = on_content_with_output ~default (pop_before ~n) b in *)
  (*   (Sequence.map ~f:to_seq out, on_rendered (pop_before ~n &> snd) b) *)

  let delete_to_eol ?(n = 0) =
    let act z =
      let default = (Zipper.empty, Zipper.empty) in
      let z1, z2 = apply_focus_or ~default split z in
      (to_seq z2, swap_focus z1 z)
    in
    let default = Sequence.empty in
    let* h = act |> on_content_with_output ~default
    and* t = move_down *> delete_lines ~n
    and* () = move_up *> eol
    and* () = update_render_at_cursor in
    return (Sequence.shift_right t h)

  let delete_to_bol =
    let act z =
      let default = (Zipper.empty, Zipper.empty) in
      let z1, z2 = apply_focus_or ~default split z in
      (Sequence.singleton (to_seq z1), swap_focus z2 z)
    in
    let default = Sequence.empty in
    let* out = act |> on_content_with_output ~default
    and* () = update_render_at_cursor in
    return out

  let newline =
    let change_content =
      let aux z =
        let default = (Zipper.empty, Zipper.empty) in
        let z1, z2 = apply_focus_or ~default split z in
        push_before z1 z |> swap_focus z2
      in
      on_content aux
    and change_rendered =
      (push_before Sequence.empty |> on_rendered)
      *> update_render ~before:true ~n:2
    in
    change_content *> change_rendered

  let paste ?(before = false) ?(linewise = false) ?(n = 1) s =
    let change_content =
      if linewise then
        let push = if before then push_before_seq else push_after_seq in
        push (Sequence.map ~f:of_seq s) |> on_content
      else
        let aux z =
          match Sequence.next s with
          | None -> z
          | Some (h, t) ->
              let init =
                let default = Zipper.(of_seq h |> far_right) in
                map_focus_or ~default (push_before_seq h) z
              and f z l =
                let default = (Zipper.empty, Zipper.empty) in
                let z1, z2 = apply_focus_or ~default split z in
                z |> push_before z1 |> swap_focus z2
                |> map_focus (push_before_seq l)
              in
              let folded = Sequence.fold ~init ~f t in
              if before then folded
              else
                folded
                |> Fn.apply_n_times ~n:(Sequence.length t) left
                |> map_focus (Fn.apply_n_times ~n:(Sequence.length h) left)
        in
        on_content aux
    and change_rendered =
      if linewise then
        let push = if before then push_before_seq else push_after_seq in
        push (Sequence.map ~f:render s) |> on_rendered
      else
        let len = Sequence.length s in
        let push = if before then push_before else push in
        let aux z = Fn.apply_n_times ~n:(len - 1) (push Sequence.empty) z in
        on_rendered aux *> update_render ~before ~n:len
    in
    let rec bind_n_times ~n act =
      match n with
      | _ when n <= 0 -> return ()
      | 1 -> act
      | _ -> act *> bind_n_times ~n:(n - 1) act
    in
    bind_n_times ~n (change_content *> change_rendered)

  let search forward word =
    let rec tails s =
      match Sequence.next s with
      | None -> Sequence.empty
      | Some (_, t) -> Sequence.shift_right (tails t) s
    and prefix p l =
      match Sequence.(next p, next l) with
      | Some (ph, pt), Some (lh, lt) when Char.(ph = lh) -> prefix pt lt
      | None, _ -> true
      | _ -> false
    in
    let search_line w l =
      Sequence.findi ~f:(fun _ -> prefix w) (tails l) |> Option.map ~f:fst
    in
    let* b = get in
    let cr, cc = cursor ~rendered:false b in
    let* c = get_content in
    match c with
    | Error _ -> return None
    | Ok c -> (
        if forward then
          match Sequence.next (Zipper.after c) with
          | None -> return None
          | Some (h, t) -> (
              match Zipper.(h |> right |> after) |> search_line word with
              | Some i -> return (Some (cr, cc + i + 1))
              | None ->
                  let f r z =
                    z |> to_seq |> search_line word
                    |> Option.map ~f:(fun c -> (cr + r + 1, c))
                  in
                  return (Sequence.find_mapi t ~f))
        else
          let word = Sequence.(word |> to_list_rev |> of_list) in
          let wlen = Sequence.length word in
          match Zipper.(c |> right |> before) |> Sequence.next with
          | None -> return None
          | Some (h, t) -> (
              match h |> Zipper.before |> search_line word with
              | Some i -> return (Some (cr, cc - wlen - i))
              | None ->
                  let f r z =
                    let z = z |> far_right in
                    let len = left_length z in
                    z |> before |> search_line word
                    |> Option.map ~f:(fun c -> (cr - r - 1, len - wlen - c))
                  in
                  return (Sequence.find_mapi t ~f)))

  (* let save_history_to ?(clear = true) r = () *)
end

let from_file f =
  let lines =
    let line_to_seq l = String.to_list l |> Sequence.of_list in
    try
      let fd = Unix.(openfile f [ O_RDONLY ] 0o640) in
      let ic = Unix.in_channel_of_descr fd in
      let lines = In_channel.input_lines ic in
      In_channel.close ic;
      Sequence.(of_list lines |> map ~f:line_to_seq)
    with Unix.Unix_error (ENOENT, _, _) -> Sequence.empty
  in
  let kind = File f
  and content = Sequence.map ~f:of_seq lines |> of_seq |> Result.return
  and rendered = Sequence.map ~f:render lines |> of_seq
  and last_modified = Unix.gettimeofday () in
  { kind; content; rendered; last_modified }

let unrendered_view x y h w b =
  match b.content with
  | Error _ -> Sequence.empty
  | Ok z ->
      let cx, _ = cursor b in
      context ~l:(cx - x) ~r:(x + h - cx) z
      |> to_seq
      |> Sequence.map ~f:(window ~from:y ~len:w)

let rendered_view x y h w b =
  let window from len seq = Sequence.(take (drop_eagerly seq from) len) in
  let cx, _ = cursor ~rendered:false b in
  context ~l:(cx - x) ~r:(x + h - cx) b.rendered
  |> to_seq
  |> Sequence.map ~f:(window y w)