refactor: turn editor buffer into a state monad

1 files changed, 189 insertions, 82 deletions

diff --git a/lib/editorBuffer.ml b/lib/editorBuffer.ml
index 295e6e7..52b1115 100644
--- a/lib/editorBuffer.ml
+++ b/lib/editorBuffer.ml
@@ -55,15 +55,54 @@ let cursor ?(rendered = true) b =
       in
       (left_length c, apply_focus_or ~default:0 hlen c)
 
+type 'a action = t -> 'a * t
+
 module Action = struct
-  let on_content f b = { b with content = Result.map ~f b.content }
-  let on_rendered f b = { b with rendered = f b.rendered }
+  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 >>= (put &> f)
+  let on_content f b = ((), { b with content = Result.map ~f b.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_content_stored ?(register = '"') ?(append = false) f b = ... *)
+  let on_rendered f b = ((), { b with rendered = f b.rendered })
 
   let update_render ?(before = false) ~n b =
     match b.content with
-    | Error _ -> b
+    | Error _ -> ((), b)
     | Ok c ->
         let step = if before then left else right in
         let rec aux i r c =
@@ -74,51 +113,66 @@ module Action = struct
             let c' = step c and r' = swap_focus l r |> step in
             aux (i - 1) r' c'
         in
-        { b with rendered = aux n b.rendered c |> goto (left_length c) }
+        ((), { b with rendered = aux n b.rendered c |> goto (left_length c) })
 
-  let update_render_at_cursor = update_render ~n:1
+  let update_render_at_cursor = update_render ~before:false ~n:1
 
   let move_up ?(n = 1) =
     let change_content =
-      on_content (fun z ->
-          let col = apply_focus_or ~default:0 left_length z in
-          Fn.apply_n_times ~n left z |> map_focus (goto col))
+      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
+    change_content *> change_rendered
 
   let move_down ?(n = 1) =
     let change_content =
-      on_content (fun z ->
-          let col = apply_focus_or ~default:0 left_length z in
-          Fn.apply_n_times ~n right z |> map_focus (goto col))
+      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
+    change_content *> change_rendered
 
   let move_left, move_right =
     let horizontal f ?(n = 1) =
-      let change_content = map_focus (Fn.apply_n_times ~n f) |> on_content in
-      change_content &> update_render_at_cursor
+      map_focus (Fn.apply_n_times ~n f) |> on_content
     in
     (horizontal left, horizontal right)
 
-  let bol = map_focus far_left |> on_content
-  let eol = map_focus far_right |> on_content
+  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
+    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
+    change_content *> change_rendered
 
   let insert k =
     let change_content = map_focus (push_before k) |> on_content in
-    change_content &> update_render_at_cursor
+    change_content *> update_render_at_cursor
 
-  (* let replace k = () *)
+  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 =
@@ -126,14 +180,14 @@ module Action = struct
         if right_length z < 2 then z
         else
           let to_join = right z |> focus_or ~default:Zipper.empty in
-          map_focus (join ~z2:to_join) z |> pop_after
+          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) |> on_rendered in
-    change_content &> change_rendered &> update_render_at_cursor
+    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 b =
-    let lines_to_delete =
+  let delete_after ?(cross_lines = false) ~n =
+    let lines_to_delete b =
       match b.content with
       | Error _ -> 0
       | Ok z -> (
@@ -149,23 +203,38 @@ module Action = struct
               |> 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 change_content =
-      let delete_1_after z =
-        let line = focus_or ~default:Zipper.empty z in
-        if cross_lines && is_far_right line && not (is_far_right z) then
-          let to_join = right z |> focus_or ~default:Zipper.empty in
-          map_focus (join ~z2:to_join) z |> pop_after
-        else map_focus pop z
-      in
-      Fn.apply_n_times ~n delete_1_after |> on_content
-    and change_rendered =
-      if cross_lines then pop_after ~n:lines_to_delete |> on_rendered else Fn.id
-    in
-    b |> change_content |> change_rendered |> update_render_at_cursor
-
-  let delete_before ?(cross_lines = false) ~n b =
-    let lines_to_delete =
+    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 ->
@@ -178,55 +247,87 @@ module Action = struct
           |> 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 change_content =
-      let delete_1_before z =
-        let line = focus_or ~default:Zipper.empty z in
-        if cross_lines && is_far_left line && not (is_far_left z) then
-          left z |> map_focus (join ~z2:line) |> pop_after
-        else map_focus pop_before z
-      in
-      Fn.apply_n_times ~n delete_1_before |> on_content
-    and change_rendered =
-      if cross_lines then pop_before ~n:lines_to_delete |> on_rendered
-      else Fn.id
-    in
-    b |> change_content |> change_rendered |> update_render_at_cursor
-
-  let delete_to_eol =
-    map_focus (split &> fst) |> on_content &> update_render_at_cursor
-
-  let delete_to_bol =
-    map_focus (split &> snd) |> on_content &> update_render_at_cursor
+    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 change_content = pop ~n |> on_content
-    and change_rendered = pop ~n |> on_rendered in
-    change_content &> change_rendered
+    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_lines_before ~n =
-    let change_content = pop_before ~n |> on_content
-    and change_rendered = pop_before ~n |> on_rendered in
-    change_content &> change_rendered
+  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 l1, l2 = apply_focus_or ~default split z in
-        push_before l1 z |> swap_focus l2
+        let z1, z2 = apply_focus_or ~default split z in
+        push_before z1 z |> swap_focus z2
       in
       on_content aux
-    and change_rendered b =
-      match b.content with
-      | Error _ -> b
-      | Ok c -> (
-          match Sequence.next (before c) with
-          | None -> failwith "newline > change_rendered: unreachable"
-          | Some (h, _) ->
-              { b with rendered = push_before (to_seq h |> render) b.rendered })
+    and change_rendered =
+      (push_before Sequence.empty |> on_rendered)
+      *> update_render ~before:true ~n:2
     in
-    change_content &> change_rendered &> update_render_at_cursor
+    change_content *> change_rendered
 
   let paste ?(before = false) ?(linewise = false) ?(n = 1) s =
     let change_content =
@@ -263,9 +364,15 @@ module Action = struct
         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
+        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
-    Fn.apply_n_times ~n (change_content &> change_rendered)
+    bind_n_times ~n (change_content *> change_rendered)
 
   (* let save_history_to ?(clear = true) r = () *)
 end