console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

cursor movement by char works across lines (i.e. subnested joins)

Browse Source
This commit is contained in:
cqc
2022-03-19 16:05:11 -05:00
parent 205f650eac
commit c81dce7148
1 changed files with 38 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
human.ml
View File

@ -1295,7 +1295,7 @@ module Panel = struct
set_parent_on_children {parent= None; t; n= node_n ()}
let empty_image = (Image.empty, V2.zero)
let empty_node = node (`Atom `Empty)
let empty_node () = node (`Atom `Empty)
let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
let rec traverse_nodes ~(f : node -> node option) (n : node) :
@ -1351,9 +1351,9 @@ module Panel = struct
let join_x = join_ `X
let join_y = join_ `Y
let join_z = join_ `Z
let pack_x : node Lwd_utils.monoid = (empty_node, join_x)
let pack_y : node Lwd_utils.monoid = (empty_node, join_y)
let pack_z : node Lwd_utils.monoid = (empty_node, join_z)
let pack_x : node Lwd_utils.monoid = (empty_node (), join_x)
let pack_y : node Lwd_utils.monoid = (empty_node (), join_y)
let pack_z : node Lwd_utils.monoid = (empty_node (), join_z)
let ( ^^ ) = join_x
let ( ^/^ ) = join_y
let ( ^*^ ) = join_z
@ -1473,7 +1473,7 @@ module Panel = struct
new_line
(append_y la (l (node (`Atom (`Boundary `Line)))))
| l, `End -> l in
(new_line (fun n -> n)) empty_node
(new_line (fun n -> n)) (empty_node ())
(* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
node =
@ -1562,15 +1562,15 @@ module Panel = struct
let m = Wall_text.Font.text_measure f str in
let v = Gg.Size2.v m.width (f.size +. f.line_height) in
( I.stack
(I.paint
(Wall.Paint.color style.fg)
(simple_text f ~valign:`TOP ~halign:`LEFT ~x:0. ~y:0.
str ) )
(I.paint
(Wall.Paint.color style.bg)
( I.fill_path
@@ fun t ->
P.rect t ~x:0. ~y:0. ~w:(Size2.w v) ~h:(Size2.h v) ) )
(I.paint
(Wall.Paint.color style.fg)
(simple_text f ~valign:`TOP ~halign:`LEFT ~x:0. ~y:0.
str ) )
, v )
let cat d (ai, av) (bi, bv) =
@ -1702,15 +1702,21 @@ module Panel = struct
| `Join (_, a, _) -> Some a
let tree_prev (n : node) =
let rec prev_right n' =
match n'.t with
| `Attr (_, nn) -> prev_right nn
| `Join (_, _, b) -> prev_right b
| `Atom _ -> Some n' in
match n.parent with
| None -> None
| Some ({t; _} as p) -> (
match t with
| `Atom _ -> assert false (* shouldn't happen *)
| `Attr _ -> Some p
| `Join (_, a, _) when a == n -> Some p
| `Join (_, a, b) when b == n -> Some a
| `Join _ -> assert false (* shouldn't happen *) )
| Some {t= `Atom _; _} ->
assert false
(* shouldn't happen TODO is there no way to type constrain these? *)
| Some {t= `Attr _; _} -> n.parent
| Some {t= `Join (_, a, b); _} when b == n -> prev_right a
| Some {t= `Join (_, a, _); _} when a == n -> n.parent
| Some {t= `Join _; _} -> assert false
(* shouldn't happen *)
let rec search_forward (n : node) (f : node -> 'a option) :
'a option =
@ -1798,19 +1804,19 @@ module Panel = struct
search_forward n (fun v ->
match v.t with `Join _ -> Some v | _ -> None )
let cursor_attr = `Style Style.(bg Color.(blend red green))
let cursor_attr = `Style Style.(bg Color.(v 1. 1. 0. 1.))
let textedit_handler ?(bindings = textedit_bindings) (n : node) =
let bind = Key.Bind.init bindings in
let c =
{ root= n
; sel=
insert_attr
(`Style Style.(bg Color.(blend red green)))
insert_attr cursor_attr
( match join_search_forward n with
| Some n -> n
| None -> n ) } in
Format.pp_set_max_boxes F.stderr 99999 ;
Format.pp_set_max_boxes F.stderr 64 ;
Format.pp_set_margin F.stderr 120 ;
Format.(
F.epr
"@[<hv>F.stderr margin: %d, max_indent: %d, max_boxes: %d \
@ -1825,6 +1831,9 @@ module Panel = struct
match Key.Bind.resolve_events bind [e] with
| x :: _ ->
c.sel <- remove_attr c.sel ;
F.epr
"textedit_handler c.root=@.@[%a@]@.c.sel=%a@."
pp_dump_node c.root pp_node c.sel ;
( match perform_action x c with
| Some _ ->
F.epr
@ -1879,15 +1888,15 @@ module Panel = struct
(Lwd.pure
(textedit_handler
(style Style.dark
(* (join_y
(join_y
(* (join_y
(Text.of_string
"-- welcome to my land of idiocy ---" )
(join_x
(join_x *)
(Text.of_string "hello bitch")
(*
(Text.of_string "!\n sup daddy") ) ) *)
(Text.of_string "123") ) ) )
(* ) *)
(Text.of_string "123") ) ) ) )
end
end