6 Commits

Author SHA1 Message Date
cqc
50831dc73d most cursor movement functionality works, but there are lots of weird quirks to iron out 2022-03-20 16:01:41 -05:00
cqc
98e78d81ec ok it works now 2022-03-20 13:06:06 -05:00
cqc
fd7db32917 what have i done 2022-03-20 11:57:25 -05:00
cqc
c81dce7148 cursor movement by char works across lines (i.e. subnested joins) 2022-03-19 16:05:11 -05:00
cqc
205f650eac Action.pp_t and cleanup 2022-03-19 15:14:23 -05:00
cqc
8067e29ea8 C-f and C-b 2022-03-19 12:10:23 -05:00

654
human.ml
View File

@ -2,6 +2,8 @@
ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!!
Times I would have solved it faster if i broke it up instead of trying to understand it all at once: 2
a computation console
- irmin store provides a tree of data objects
@ -1242,6 +1244,8 @@ module Panel = struct
(* Tree-like structure of Ui elements, from the entire display down to individual glyphs. *)
(* i think this is gonna end up being a binary tree?? *)
(* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *)
open Gg
open Wall
@ -1250,13 +1254,13 @@ module Panel = struct
| `Attr of attr * node
| `Join of dir * node * node ]
and node = {mutable parent: node option; mutable t: t}
and node = {mutable parent: node option; mutable t: t; n: int}
and cursor = {root: node; mutable sel: node}
and atom =
[ `Image of image
| `Uchar of Uchar.t
| `Boundary of [`Word | `Line | `Sentance]
| `Boundary of boundary
| `Hint of [`Line | `Other]
| `Empty ]
@ -1264,14 +1268,14 @@ module Panel = struct
[ `Style of style
| `Pad of Pad.t
| `Shift of dim
| `Cursor
| `Handler of handler ]
and dir = [`X | `Y | `Z]
and dim = Size2.t
and image = Wall.image * dim
and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text]
and style = Style.t
and handler = node -> Event.t -> Event.t option Lwt.t
and dir = [`X | `Y | `Z]
let set_parent_on_children n : node =
( match n.t with
@ -1282,11 +1286,128 @@ module Panel = struct
b.parent <- Some n ) ;
n
let node (t : t) = set_parent_on_children {parent= None; t}
let node_count = ref 0
let node_n () =
node_count := !node_count + 1 ;
!node_count - 1
let node (t : t) =
set_parent_on_children {parent= None; t; n= node_n ()}
let atom (a : atom) = node (`Atom a)
let attr (a : attr) (child : node) = node (`Attr (a, child))
let join (d : dir) (a : node) (b : node) = node (`Join (d, a, b))
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))
module Pp = struct
let pp_uchar ppf v =
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
else Fmt.Dump.uchar ppf v
let pp_boundary ppf v =
F.any
( match v with
| `Char -> "`Char"
| `Word -> "`Word"
| `Phrase -> "`Phrase"
| `Line -> "`Line"
| `Page -> "`Page"
| `Text ->
"`Text"
(* text is like a file (unicode calls it End Of Text) *)
)
ppf ()
let pp_atom ppf v =
let open Fmt in
( match v with
| `Image _ -> any "`Image"
| `Uchar c -> any "`Uchar " ++ const pp_uchar c
| `Boundary b -> any "`Boundary " ++ const pp_boundary b
| `Hint h ->
any "`Hint "
++ any
(match h with `Line -> "`Line" | `Other -> "`Other")
| `Empty -> any "`Empty" )
ppf ()
let pp_attr ppf v =
let open Fmt in
(any
( match v with
| `Style _ -> "`Style ..."
| `Pad _ -> "`Pad ..."
| `Shift _ -> "`Shift ..."
| `Cursor -> "`Cursor"
| `Handler _ -> "`Handler ..." ) )
ppf ()
let pp_dir ppf v =
F.pf ppf "%s"
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
let pp_node_n ppf v = F.(pf ppf "%a" int v.n)
let rec _pp_t child ppf v =
let open Fmt in
match v with
| `Atom x -> pf ppf "`Atom %a" pp_atom x
| `Attr (a, n) ->
pf ppf "`Attr %a"
(parens (const pp_attr a ++ comma ++ const child n))
()
| `Join (d, a, b) ->
pf ppf "`Join %a"
(parens
( const pp_dir d ++ comma ++ const child a ++ comma
++ const child b ) )
()
and _pp_node child ppf v =
let open Fmt in
pf ppf "@[<hov>%a@]"
(braces
(record
[ field "n" (fun v -> v.n) int
; field "t" (fun v -> v.t) (_pp_t child)
; field "parent"
(fun v -> v.parent)
(option pp_node_n) ] ) )
v
and pp_node_n_record =
F.(
braces
(record ~sep:semi [field "n" Fun.id pp_node_n; any "..."]))
and pp_node ppf = _pp_node pp_node_n ppf
and pp_dump_node ppf = _pp_node pp_dump_node ppf
let pp_t ppf = F.pf ppf "@[<hov>%a@]" (_pp_t pp_node_n_record)
let pp_n ppf n =
F.pf ppf "@[<h>%a: %a@]" pp_node_n n (_pp_t pp_node_n) n.t
let rec pp_node_structure ppf v =
F.(
const int v.n
++ parens
(concat ~sep:comma
( match v.t with
| `Atom a -> [const pp_atom a]
| `Attr (a, n) ->
[const pp_attr a; const pp_node_structure n]
| `Join (d, l, r) ->
[ const pp_dir d; const pp_node_structure l
; const pp_node_structure r ] ) ))
ppf ()
end
open Pp
let rec traverse_nodes ~(f : node -> node option) (n : node) :
unit =
match f n with
@ -1321,7 +1442,8 @@ module Panel = struct
| `Attr (a, _) -> `Attr (a, n')
| `Join (d, a, b) when n == a -> `Join (d, n', b)
| `Join (d, a, b) when n == b -> `Join (d, a, n')
| _ -> assert false )
| _ -> assert false ) ;
ignore (set_parent_on_children p)
| None -> () ) ;
n'
| _ -> assert false
@ -1332,76 +1454,23 @@ module Panel = struct
| `Attr (_, n) -> n
| `Join (_, a, _) -> a
let join_ d (a : node) (b : node) =
set_parent_on_children {parent= a.parent; t= `Join (d, a, b)}
let empty_join d = node (`Join (d, empty_node, empty_node))
let join_x = join_ `X
let join_y = join_ `Y
let join_z = join_ `Z
let pack_x : node Lwd_utils.monoid = (empty_join `X, join_x)
let pack_y : node Lwd_utils.monoid = (empty_join `Y, join_y)
let pack_z : node Lwd_utils.monoid = (empty_join `Z, join_z)
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 ( ^^ ) = join_x
let ( ^/^ ) = join_y
let ( ^*^ ) = join_z
let pp_uchar ppf v =
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
else Fmt.Dump.uchar ppf v
let append_ d (l : node -> node) (a : node) : node -> node =
fun n -> l (join d a n)
let pp_atom ppf v =
let open Fmt in
( match v with
| `Image _ -> any "`Image"
| `Uchar c -> any "`Uchar " ++ const pp_uchar c
| `Boundary b -> (
any "`Boundary "
++
match b with
| `Word -> any "`Word"
| `Line -> any "`Line"
| `Sentance -> any "`Sentance" )
| `Hint h ->
any "`Hint "
++ any (match h with `Line -> "`Line" | `Other -> "`Other")
| `Empty -> any "`Empty" )
ppf ()
let tess v = F.epr "%a" pp_atom v
let pp_attr ppf v =
let open Fmt in
(any
( match v with
| `Style _ -> "`Style ..."
| `Pad _ -> "`Pad ..."
| `Shift _ -> "`Shift ..."
| `Cursor -> "`Cursor"
| `Handler _ -> "`Handler ..." ) )
ppf ()
let pp_dir ppf v =
F.pf ppf "%s"
(match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
let rec pp_node ppf v =
let open Fmt in
pf ppf "@[<hov>%a@]" pp_t v.t
and pp_t ppf v =
let open Fmt in
match v with
| `Join (d, a, b) ->
pf ppf "`Join %a"
(parens
( const pp_dir d ++ comma ++ const pp_node a ++ comma
++ const pp_node b ) )
()
| `Attr (a, n) ->
pf ppf "`Attr %a"
(parens (const pp_attr a ++ comma ++ const pp_node n))
()
| `Atom x -> pf ppf "`Atom %a" pp_atom x
let empty_append = Fun.id
let append_x = append_ `X
let append_y = append_ `Y
let append_z = append_ `Z
(* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
@ -1410,85 +1479,54 @@ module Panel = struct
So i think what is really happening is that i'm defining the `list` for this node type that allows `append`.
The main problem with this thought is that you can't do anything but append with the datastructure.
*)
let new_append () = empty_node
let append (d : dir) (l : unit -> node) (n : node) : unit -> node
=
fun () ->
set_parent_on_children {parent= None; t= `Join (d, l (), n)}
module Text = struct
let rec _of_string (la : unit -> node) (str : string) :
unit -> node =
let uudec = Uutf.decoder (`String str) in
let rec dec (lx : unit -> node) : 'a * (unit -> node) =
match Uutf.decode uudec with
| `Malformed b -> dec (_of_string lx (String.escaped b))
| (`Await | `Uchar _ | `End) as x -> (x, lx) in
let uuline = Uuseg.create `Line_break in
let rec new_line la' : unit -> node =
let rec char (x, lx) (ly : unit -> node) =
match Uuseg.add uuline x with
| `End as x -> (ly, x)
| `Boundary as x when Uuseg.mandatory uuline -> (ly, x)
| `Await -> char (dec lx) ly
let rec decode dec (l : 'a) :
'a * [< `Await | `End | `Uchar of Uchar.t] =
match Uutf.decode dec with
| `Malformed b ->
F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@."
(String.escaped b) ;
decode dec (append_x l (of_string (String.escaped b)))
| (`Await | `End | `Uchar _) as s -> (l, s)
and _of_string dec l =
match decode dec l with
| l, `End -> l (atom (`Boundary `Text))
| l, `Uchar c -> _of_string dec (append_x l (atom (`Uchar c)))
| l, _ -> _of_string dec l
and of_string str =
_of_string
(Uutf.decoder
~nln:(`Readline (Uchar.of_int 0x000A))
(`String str) )
empty_append
and _lines u d ly (lx, s) =
match Uuseg.add u s with
| `Boundary when Uuseg.mandatory u ->
_lines u d
(append_y ly (lx (atom (`Boundary `Line))))
(empty_append, `Await)
| `Boundary ->
char
(`Await, append `X lx (node (`Atom (`Hint `Line))))
ly
_lines u d ly (append_x lx (atom (`Hint `Line)), `Await)
| `End -> ly (lx (atom (`Boundary `Text)))
| `Await -> _lines u d ly (decode d lx)
| `Uchar c ->
char
(`Await, append `X lx (node (`Atom (`Uchar c))))
ly in
match char (`Await, la') la' with
| l, `Boundary ->
new_line
(append `Y la'
((append `X l (node (`Atom (`Boundary `Line)))) ()) )
| l, `End -> l in
new_line la
_lines u d ly (append_x lx (atom (`Uchar c)), `Await)
let of_string str = _of_string new_append str ()
(* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
node =
let uuseg = Uuseg.create boundary in
traverse_regions
~node:(fun node -> node)
~region:(fun ~parent (r, c) ~child ->
match child.child with
| `Atom (`Uchar uc) ->
let rec seg ((t : node Trope.t), (c : Region.cursor))
e' =
match Uuseg.add uuseg e' with
| `Boundary ->
seg
( Trope.put_right t c
{parent; child= `Atom (`Boundary label)}
, Trope.cursor_after c )
`Await
| `End | `Await -> (t, c)
| `Uchar ch ->
seg
( Trope.put_right t c
{parent; child= `Atom (`Uchar ch)}
, c )
`Await in
let r', c' = seg (r.t, c) (`Uchar uc) in
({r with t= r'}, c')
| _ -> (r, c) )
node
let words node : node =
segment ~boundary:`Word ~label:`Word node
let sentances node : node =
segment ~boundary:`Sentence ~label:`Sentance node
let text str : node = insert_string str |> sentances |> words *)
let lines str =
_lines
(Uuseg.create `Line_break)
(Uutf.decoder
~nln:(`Readline (Uchar.of_int 0x000A))
(`String str) )
empty_append
(empty_append, `Await)
end
let text = Text.of_string
let text = Text.lines
module Draw = struct
type d = [`X | `Y | `Z]
@ -1537,15 +1575,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) =
@ -1566,35 +1604,31 @@ module Panel = struct
| `Hint _ -> empty_image
| `Empty -> empty_image
and attr ?(style = Style.empty) (attr, node) : image =
match attr with
| `Style s -> pane ~style:(Style.merge s style) node
| `Pad p -> pad p (pane ~style node)
| `Shift s -> shift s (pane ~style node)
| `Cursor -> cursor (pane ~style node)
| _ -> pane ~style node
and attr ?(style = Style.empty) (a, n) : image =
match a with
| `Style s -> node ~style:(Style.merge s style) n
| `Pad p -> pad p (node ~style n)
| `Shift s -> shift s (node ~style n)
| _ -> node ~style n
and join ?(style = Style.empty) (d, a, b) : image =
cat d (pane ~style a) (pane ~style b)
cat d (node ~style a) (node ~style b)
and pane ?(style = Style.empty) (node : node) : image =
match node.t with
and node ?(style = Style.empty) (n : node) : image =
match n.t with
| `Atom a -> atom ~style a
| `Attr a -> attr ~style a
| `Join a -> join ~style a
end
module Action = struct
type segment_type =
[`Char | `Word | `Phrase | `Line | `Page | `Region]
type segment =
[ `Beginning of segment_type
| `Back of segment_type
| `Forward of segment_type
| `End of segment_type ]
[ `Beginning of boundary
| `Forward of boundary
| `Backward of boundary
| `End of boundary ]
type t =
and t =
[ `Move of segment
| `Yank of segment
| `Kill of segment
@ -1602,7 +1636,7 @@ module Panel = struct
| `Descend
| `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ]
type dir =
and dir =
[ `Next
| `Prev
| `Up
@ -1613,45 +1647,174 @@ module Panel = struct
| `Enter
| `In
| `Out ]
open Fmt
let pp_dir ppf v =
any
( match v with
| `Next -> "`Next"
| `Prev -> "`Prev"
| `Up -> "`Up"
| `Down -> "`Down"
| `Left -> "`Left"
| `Right -> "`Right"
| `Fwd -> "`Fwd"
| `Enter -> "`Enter"
| `In -> "`In"
| `Out -> "`Out" )
ppf ()
let pp_segment ppf v =
( match v with
| `Beginning s -> any "`Beginning " ++ const pp_boundary s
| `Forward s -> any "`Forward " ++ const pp_boundary s
| `Backward s -> any "`Backward " ++ const pp_boundary s
| `End s -> any "`End " ++ const pp_boundary s )
ppf ()
let pp_t ppf v =
( match v with
| `Move s -> any "`Move " ++ const pp_segment s
| `Yank s -> any "`Yank " ++ const pp_segment s
| `Kill s -> any "`Kill " ++ const pp_segment s
| `Ascend -> any "`Ascend"
| `Descend -> any "`Descend"
| `Custom (s, _) ->
fun ppf () -> pf ppf "`Custom \"%a\"" string s )
ppf ()
end
let rec search_forward (n : node) (f : node -> 'a option) :
'a option =
match f n with
| None -> (
let tree_next (n : node) =
let rec next_right n' =
match n'.parent with
| None -> None
| Some ({t= `Attr _; _} as p) -> next_right p
| Some {t= `Join (_, a, b); _} when n' == a -> Some b
| Some ({t= `Join (_, _, b); _} as p) when n' == b ->
next_right p
| Some {t= `Join _; _} -> assert false
| Some {t= `Atom _; _} -> assert false in
match n.t with
| `Atom _ -> None
| `Attr (_, n) -> search_forward n f
| `Join (_, a, b) -> (
match search_forward a f with
| Some n' -> Some n'
| None -> search_forward b f ) )
| Some a -> Some a
| `Atom _ -> next_right n
| `Attr (_, n') -> Some n'
| `Join (_, a, _) -> Some a
let rec search_backward (n : node) (f : node -> 'a option) :
'a option =
match f n with
| None -> (
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 (* at root and didn't find anything *)
| Some n -> search_backward n f )
| Some n' -> Some n'
| None -> None
| 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 perform_action (a : Action.t) (c : node) : node =
let rec tree_iter f n i =
if i <> 0 then tree_iter f (f n) (i - 1) else f n
let rec search_ next f n =
F.epr "search_ " ;
match next n with
| Some n' -> (
F.epr "%a@." pp_n n' ;
match f n' with
| Some a -> (n', Some a)
| None -> search_ next f n' )
| None -> F.epr "None@." ; (n, None)
let search_forward f (n : node) = snd (search_ tree_next f n)
let search_backward f (n : node) = snd (search_ tree_prev f n)
let is_atom_uchar = function
| {t= `Atom (`Uchar _); _} as n -> Some n
| _ -> None
let tree_uchar_fwd n =
match is_atom_uchar n with
| Some a -> a
| None ->
Option.value (search_forward is_atom_uchar n) ~default:n
let tree_uchar_back n =
match is_atom_uchar n with
| Some a -> a
| None ->
Option.value (search_backward is_atom_uchar n) ~default:n
let perform_action (a : Action.t) (c : cursor) : node option =
let mb ?(f = fun a -> a) b n =
match (b, n.t) with
| `Char, `Atom (`Uchar _)
|`Word, `Atom (`Boundary `Word)
|`Phrase, `Atom (`Boundary `Phrase)
|`Line, `Atom (`Boundary `Line)
|`Page, `Atom (`Boundary `Page) ->
Some (f n)
| _ -> None in
match a with
| `Move (`Beginning `Char) -> c
| `Move (`Beginning `Word) ->
Option.value ~default:c
(search_backward c (fun n ->
match n.t with
| `Atom (`Boundary `Word) -> Some n
| _ -> None ) )
| `Move _ -> c
| `Yank _s -> c
| `Kill _s -> c
| `Descend -> sub c
| `Ascend -> ( match c.parent with Some n -> n | None -> c )
| `Custom _s -> c
| `Move (`Forward `Line) -> (
let i = ref 0 in
ignore
(search_backward
(function
| {t= `Atom (`Boundary `Line); _} -> Some ()
| {t= `Atom (`Uchar _); _} -> incr i ; None
| _ -> None )
c.sel ) ;
match search_forward (mb `Line) c.sel with
| Some n' ->
Some
(tree_iter
(fun nn ->
Option.value
(search_forward (mb `Char) nn)
~default:nn )
n' !i )
| None -> None )
| `Move (`Backward `Line) -> (
let i = ref 0 in
match
search_backward
(function
| {t= `Atom (`Boundary `Line); _} as n' -> Some n'
| {t= `Atom (`Uchar _); _} -> incr i ; None
| _ -> None )
c.sel
with
| Some n' ->
Some
(tree_iter
(fun nn ->
Option.value
(search_forward (mb `Char) nn)
~default:nn )
(fst (search_ tree_prev (mb `Line) n'))
!i )
| None -> None )
| `Move (`Forward b) ->
search_forward (mb ~f:tree_uchar_back b) c.sel
| `Move (`Backward b) ->
search_backward (mb ~f:tree_uchar_fwd b) c.sel
| `Move (`Beginning b) ->
(* uses last searched node regardless of match *)
Some (tree_uchar_fwd (fst (search_ tree_prev (mb b) c.sel)))
| `Move (`End b) ->
(* uses last searched node regardless of match *)
Some
(tree_uchar_back (fst (search_ tree_next (mb b) c.sel)))
| `Yank _s -> None
| `Kill _s -> None
| `Descend -> Some (sub c.sel)
| `Ascend -> c.sel.parent
| `Custom _s -> None
type event_status = [`Handled | `Event of Event.t]
@ -1659,57 +1822,70 @@ module Panel = struct
let open Key.Bind in
empty
|> add [([Ctrl], C 'f')] [`Move (`Forward `Char)]
|> add [([Ctrl], C 'b')] [`Move (`Back `Char)]
|> add [([Ctrl], C 'f')] [`Move (`Forward `Word)]
|> add [([Meta], C 'b')] [`Move (`Back `Word)]
|> add [([Ctrl], C 'b')] [`Move (`Backward `Char)]
|> add [([Meta], C 'f')] [`Move (`Forward `Word)]
|> add [([Meta], C 'b')] [`Move (`Backward `Word)]
|> add
[([Ctrl], C 'c'); ([Ctrl], C 'n')]
[`Move (`Forward `Phrase)]
|> add [([Ctrl], C 'c'); ([Ctrl], C 'p')] [`Move (`Back `Phrase)]
|> add
[([Ctrl], C 'c'); ([Ctrl], C 'p')]
[`Move (`Backward `Phrase)]
|> add [([Ctrl], C 'n')] [`Move (`Forward `Line)]
|> add [([Ctrl], C 'p')] [`Move (`Back `Line)]
|> add [([Meta], C 'v')] [`Move (`Forward `Page)]
|> add [([Ctrl], C 'v')] [`Move (`Back `Page)]
|> add [([Ctrl], C 'p')] [`Move (`Backward `Line)]
|> add [([Ctrl], C 'v')] [`Move (`Forward `Page)]
|> add [([Meta], C 'v')] [`Move (`Backward `Page)]
|> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)]
|> add [([Ctrl], C 'e')] [`Move (`End `Line)]
|> add [([Ctrl], C 'k')] [`Kill (`End `Line)]
|> add [([Ctrl], U `Backspace)] [`Kill (`Back `Word)]
|> add [([Meta], U `Backspace)] [`Kill (`Back `Word)]
|> add [([Ctrl], U `Backspace)] [`Kill (`Backward `Word)]
|> add [([Meta], U `Backspace)] [`Kill (`Backward `Word)]
|> add
[([Ctrl], C 'x'); ([], U `Backspace)]
[`Kill (`Back `Phrase)]
[`Kill (`Backward `Phrase)]
|> add [([Ctrl], C 'q')] [`Ascend]
|> add [([Ctrl], C 'e')] [`Descend]
|> add [([Ctrl], C 'z')] [`Descend]
let cursor_attr = `Style Style.(bg Color.(v 1. 1. 0. 1.))
let textedit_handler ?(bindings = textedit_bindings) (n : node) =
Format.pp_set_max_boxes F.stderr 64 ;
(*full screen fynn *)
Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230 ;
let bind = Key.Bind.init bindings in
let n' = insert_attr `Cursor n in
let c = ref n in
Format.(
F.epr
"@[<hv> F.stderr margin: %d, max_indent: %d, max_boxes: %d \
@]@."
(pp_get_margin F.stderr ())
(pp_get_max_indent F.stderr ())
(pp_get_max_boxes F.stderr ())) ;
F.epr "@[<v>%a@]@." pp_node n' ;
node
(`Attr
let sel = insert_attr cursor_attr n in
let c =
{root= attr (`Handler (fun _ _ -> Lwt.return_none)) sel; sel}
in
c.root.t <-
`Attr
( `Handler
(fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
match Key.Bind.resolve_events bind [e] with
| x :: _ ->
c :=
insert_attr `Cursor
(perform_action x (remove_attr !c)) ;
F.epr "%a@." pp_node !c ;
c.sel <- remove_attr c.sel ;
(*F.epr
"textedit_handler c.sel.n=%d@ c.root=@ @[%a@]@."
pp_node_n c.sel pp_node_structure c.root ; *)
( match perform_action x c with
| Some n' ->
F.epr "textedit action @[%a@] Success@."
Action.pp_t x ;
c.sel <- n'
| None ->
F.epr "textedit action @[%a@] Failure@."
Action.pp_t x ) ;
c.sel <- insert_attr cursor_attr c.sel ;
Lwt.return_none
| [] -> Lwt.return_some e )
, n ) )
, n ) ;
set_parent_on_children c.root
let handler_of_node (n : node) : handler option =
search_forward n (fun n ->
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
let f n =
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None
in
match f n with Some a -> Some a | None -> search_forward f n
let handle_event (n : node) (ev : Event.t) : event_status Lwt.t =
match handler_of_node n with
@ -1738,23 +1914,23 @@ module Panel = struct
() ) ;
Lwt.return_unit )
ev
>|= fun () -> Draw.pane r )
>|= fun () -> Draw.node r )
let test =
panel
(Lwd.pure
(textedit_handler
(style Style.dark
(*(join_y
(join_y
(Text.insert_string empty_node
(join_y
(Text.of_string
"-- welcome to my land of idiocy ---" )
(join_x
(Text.insert_string empty_node "hello bitch")
(Text.insert_string empty_node
"!\n sup daddy" ) ) )*)
(Text.of_string "test 1 2 3") ) ) )
(* ) *)
( ( Text.of_string "hello bitch"
^^ Text.of_string "!\n sup daddy" )
^/^ (text "hello bitch" ^^ text "!\n sup daddy")
^/^ text "hello bitch" ^/^ text "!\n sup daddy"
) )
(Text.of_string "123") ) ) ) )
end
end