summaryrefslogtreecommitdiff
path: root/lib/editorBuffer.ml
diff options
context:
space:
mode:
Diffstat (limited to 'lib/editorBuffer.ml')
-rw-r--r--lib/editorBuffer.ml257
1 files changed, 195 insertions, 62 deletions
diff --git a/lib/editorBuffer.ml b/lib/editorBuffer.ml
index ea89fb9..e1706dd 100644
--- a/lib/editorBuffer.ml
+++ b/lib/editorBuffer.ml
@@ -5,104 +5,237 @@ open Util
5 5
6type kind = File of string | No_name | Scratch 6type kind = File of string | No_name | Scratch
7type error = No_such_file | Other 7type error = No_such_file | Other
8type buffer = { kind : kind; content : (char zipper zipper, error) Result.t } 8
9type buffer = {
10 kind : kind;
11 content : (char zipper zipper, error) Result.t;
12 rendered : char Sequence.t zipper;
13}
14
9type t = buffer 15type t = buffer
10 16
11let empty = 17let empty =
12 { kind = No_name; content = empty |> push_after empty |> Result.return } 18 {
19 kind = No_name;
20 content = empty |> push empty |> Result.return;
21 rendered = push Sequence.empty empty;
22 }
23
24let render =
25 let open Sequence in
26 let tabsize = 8 in
27 let f i = function
28 | '\t' ->
29 let width = tabsize - (i % tabsize) in
30 (i + width, take (repeat '.') width)
31 | c -> (i + 1, singleton c)
32 in
33 folding_map ~init:0 ~f &> join
34
35let cursor ?(rendered = true) b =
36 match b.content with
37 | Error _ -> (0, 0)
38 | Ok c ->
39 let hlen z =
40 if rendered then
41 Sequence.(length (before z |> to_list_rev |> of_list |> render))
42 else left_length z
43 in
44 (left_length c, apply_focus_or ~default:0 hlen c)
13 45
14module Action = struct 46module Action = struct
15 let on_content f b = { b with content = Result.map ~f b.content } 47 let on_content f b = { b with content = Result.map ~f b.content }
48 let on_rendered f b = { b with rendered = f b.rendered }
49
50 (* let on_content_stored ?(register = '"') ?(append = false) f b = ... *)
16 51
17 let move_up, move_down, move_left, move_right = 52 let update_render_at_cursor b =
18 let vertical f ?(n = 1) = 53 match b.content with
54 | Error _ -> b
55 | Ok c ->
56 let l = apply_focus_or ~default:Sequence.empty (to_seq &> render) c in
57 { b with rendered = swap_focus l b.rendered }
58
59 let move_up ?(n = 1) =
60 let change_content =
61 on_content (fun z ->
62 let col = apply_focus_or ~default:0 left_length z in
63 Fn.apply_n_times ~n left z |> map_focus (goto col))
64 and change_rendered = on_rendered (Fn.apply_n_times ~n left) in
65 change_content &> change_rendered
66
67 let move_down ?(n = 1) =
68 let change_content =
19 on_content (fun z -> 69 on_content (fun z ->
20 let col = focus_or ~default:Zipper.empty z |> left_length in 70 let col = apply_focus_or ~default:0 left_length z in
21 Fn.apply_n_times ~n f z |> map_focus (goto col)) 71 Fn.apply_n_times ~n right z |> map_focus (goto col))
22 and horizontal f ?(n = 1) = 72 and change_rendered = on_rendered (Fn.apply_n_times ~n right) in
23 Fn.apply_n_times ~n (map_focus f) |> on_content 73 change_content &> change_rendered
74
75 let move_left, move_right =
76 let horizontal f ?(n = 1) =
77 let change_content = map_focus (Fn.apply_n_times ~n f) |> on_content in
78 change_content &> update_render_at_cursor
24 in 79 in
25 (vertical left, vertical right, horizontal left, horizontal right) 80 (horizontal left, horizontal right)
26 81
27 let bol = map_focus far_left |> on_content 82 let bol = map_focus far_left |> on_content
28 let eol = map_focus far_right |> on_content 83 let eol = map_focus far_right |> on_content
29 let bof = far_left |> on_content 84
30 let eof = far_right |> on_content 85 let bof =
31 let insert k = map_focus (push k) |> on_content 86 let change_content = far_left |> on_content
87 and change_rendered = far_left |> on_rendered in
88 change_content &> change_rendered
89
90 let eof =
91 let change_content = far_right |> on_content
92 and change_rendered = far_right |> on_rendered in
93 change_content &> change_rendered
94
95 let insert k =
96 let change_content = map_focus (push_before k) |> on_content in
97 change_content &> update_render_at_cursor
98
32 (* let replace k = () *) 99 (* let replace k = () *)
33 100
34 let delete_after ?(cross_lines = false) ~n = 101 let join_lines ?(n = 2) =
35 let aux z = 102 let change_content =
36 let line = focus_or ~default:Zipper.empty z in 103 let join_2_lines z =
37 if cross_lines && is_far_right line && not (is_far_right z) then 104 if right_length z < 2 then z
38 pop_after z |> map_focus_or ~default:line (far_left &> join line) 105 else
39 else map_focus pop_after z 106 let to_join = right z |> focus_or ~default:Zipper.empty in
107 map_focus (join ~z2:to_join) z |> pop_after
108 in
109 Fn.apply_n_times ~n:(n - 1) join_2_lines |> on_content
110 and change_rendered = pop_after ~n:(n - 1) |> on_rendered in
111 change_content &> change_rendered &> update_render_at_cursor
112
113 let delete_after ?(cross_lines = false) ~n b =
114 let lines_to_delete =
115 match b.content with
116 | Error _ -> 0
117 | Ok z -> (
118 match Sequence.next (after z) with
119 | None -> 0
120 | Some (h, t) ->
121 let init = right_length h
122 and f acc z =
123 let acc' = acc + length z + 1 in
124 (acc', acc')
125 in
126 Sequence.shift_right (Sequence.folding_map t ~init ~f) init
127 |> Sequence.findi ~f:(fun _ a -> n <= a)
128 |> Option.map ~f:fst
129 |> Option.value ~default:(Sequence.length t))
40 in 130 in
41 Fn.apply_n_times ~n aux |> on_content 131 let change_content =
42 132 let delete_1_after z =
43 let delete_before ?(cross_lines = false) ~n = 133 let line = focus_or ~default:Zipper.empty z in
44 let aux z = 134 if cross_lines && is_far_right line && not (is_far_right z) then
45 let line = focus_or ~default:Zipper.empty z in 135 let to_join = right z |> focus_or ~default:Zipper.empty in
46 if cross_lines && is_far_left line && not (is_far_left z) then 136 map_focus (join ~z2:to_join) z |> pop_after
47 pop_after z |> left |> map_focus (far_right &> Fn.flip join line) 137 else map_focus pop z
48 else map_focus pop z 138 in
139 Fn.apply_n_times ~n delete_1_after |> on_content
140 and change_rendered =
141 if cross_lines then pop_after ~n:lines_to_delete |> on_rendered else Fn.id
49 in 142 in
50 Fn.apply_n_times ~n aux |> on_content 143 b |> change_content |> change_rendered |> update_render_at_cursor
144
145 let delete_before ?(cross_lines = false) ~n b =
146 let lines_to_delete =
147 match b.content with
148 | Error _ -> 0
149 | Ok z ->
150 let init = apply_focus_or ~default:0 left_length z
151 and f acc z =
152 let acc' = acc + length z + 1 in
153 (acc', acc')
154 in
155 Sequence.shift_right (Sequence.folding_map (before z) ~init ~f) init
156 |> Sequence.findi ~f:(fun _ a -> n <= a)
157 |> Option.map ~f:fst
158 |> Option.value ~default:(left_length z)
159 in
160 let change_content =
161 let delete_1_before z =
162 let line = focus_or ~default:Zipper.empty z in
163 if cross_lines && is_far_left line && not (is_far_left z) then
164 left z |> map_focus (join ~z2:line) |> pop_after
165 else map_focus pop_before z
166 in
167 Fn.apply_n_times ~n delete_1_before |> on_content
168 and change_rendered =
169 if cross_lines then pop_before ~n:lines_to_delete |> on_rendered
170 else Fn.id
171 in
172 b |> change_content |> change_rendered |> update_render_at_cursor
173
174 let delete_to_eol =
175 map_focus (split &> fst) |> on_content &> update_render_at_cursor
51 176
52 let delete_to_eol = map_focus (split &> fst) |> on_content 177 let delete_to_bol =
53 let delete_to_bol = map_focus (split &> snd) |> on_content 178 map_focus (split &> snd) |> on_content &> update_render_at_cursor
54 let delete_lines ~n = Fn.apply_n_times ~n pop_after |> on_content 179
55 let delete_lines_before ~n = Fn.apply_n_times ~n pop_before |> on_content 180 let delete_lines ~n =
181 let change_content = pop ~n |> on_content
182 and change_rendered = pop ~n |> on_rendered in
183 change_content &> change_rendered
184
185 let delete_lines_before ~n =
186 let change_content = pop_before ~n |> on_content
187 and change_rendered = pop_before ~n |> on_rendered in
188 change_content &> change_rendered
56 189
57 let newline = 190 let newline =
58 let aux z = 191 let change_content =
59 let l1, l2 = focus_or ~default:Zipper.empty z |> split in 192 let aux z =
60 push_before l1 z |> map_focus (Fn.const l2) 193 let default = (Zipper.empty, Zipper.empty) in
61 in 194 let l1, l2 = apply_focus_or ~default split z in
62 on_content aux 195 push_before l1 z |> swap_focus l2
63 196 in
64 let join_lines ~n = 197 on_content aux
65 let aux z = 198 and change_rendered b =
66 if is_far_right z || is_far_right (right z) then z 199 match b.content with
67 else 200 | Error _ -> b
68 let line = focus_or ~default:Zipper.empty z |> far_right in 201 | Ok c -> (
69 pop_after z |> map_focus (far_left &> join line) 202 match Sequence.next (before c) with
203 | None -> failwith "newline > change_rendered: unreachable"
204 | Some (h, _) ->
205 { b with rendered = push_before (to_seq h |> render) b.rendered })
70 in 206 in
71 Fn.apply_n_times ~n aux |> on_content 207 change_content &> change_rendered &> update_render_at_cursor
72 208
73 (* let save_history_to ?(clear = true) r = () *) 209 (* let save_history_to ?(clear = true) r = () *)
74end 210end
75 211
76let from_file f = 212let from_file f =
77 let lines = 213 let lines =
214 let line_to_seq l = String.to_list l |> Sequence.of_list in
78 try 215 try
79 let fd = Unix.(openfile f [ O_RDONLY ] 0o640) in 216 let fd = Unix.(openfile f [ O_RDONLY ] 0o640) in
80 let ic = Unix.in_channel_of_descr fd in 217 let ic = Unix.in_channel_of_descr fd in
81 let lines = In_channel.input_lines ic in 218 let lines = In_channel.input_lines ic in
82 In_channel.close ic; 219 In_channel.close ic;
83 lines 220 Sequence.(of_list lines |> map ~f:line_to_seq)
84 with Unix.Unix_error (ENOENT, _, _) -> [] 221 with Unix.Unix_error (ENOENT, _, _) -> Sequence.empty
85 in 222 in
86 let content = 223 let rendered = Sequence.map ~f:render lines |> of_seq in
87 let line_to_zipper l = String.to_list l |> Sequence.of_list |> of_seq in 224 let content = Sequence.map ~f:of_seq lines |> of_seq in
88 Sequence.(of_list lines |> map ~f:line_to_zipper) |> of_seq 225 { kind = File f; content = Ok content; rendered }
89 in
90 { kind = File f; content = Ok content }
91
92let cursor b =
93 let open Option in
94 let x = Result.(map ~f:left_length b.content |> ok |> value ~default:0)
95 and y =
96 Result.(map ~f:focus b.content |> ok)
97 |> join |> map ~f:left_length |> value ~default:0
98 in
99 (x, y)
100 226
101let view x y h w b = 227let unrendered_view x y h w b =
102 match b.content with 228 match b.content with
103 | Error _ -> Sequence.empty 229 | Error _ -> Sequence.empty
104 | Ok z -> 230 | Ok z ->
105 let cx, _ = cursor b in 231 let cx, _ = cursor b in
106 context ~b:(cx - x) ~a:(x + h - cx) z 232 context ~l:(cx - x) ~r:(x + h - cx) z
107 |> to_seq 233 |> to_seq
108 |> Sequence.map ~f:(window ~from:y ~len:w) 234 |> Sequence.map ~f:(window ~from:y ~len:w)
235
236let rendered_view x y h w b =
237 let window from len seq = Sequence.(take (drop_eagerly seq from) len) in
238 let cx, _ = cursor b in
239 context ~l:(cx - x) ~r:(x + h - cx) b.rendered
240 |> to_seq
241 |> Sequence.map ~f:(window y w)