From babeb42c12a3f1bffaefd87d9f2b18e8ae2e8939 Mon Sep 17 00:00:00 2001 From: Federico Igne Date: Fri, 26 Jan 2024 20:38:37 +0100 Subject: refactor: turn editor buffer into a state monad --- lib/editorBuffer.ml | 271 ++++++++++++++++++++++++++++++++++++---------------- 1 file 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 -- cgit v1.2.3