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

C-f and C-b

Browse Source
This commit is contained in:
cqc
2022-03-19 12:10:23 -05:00
parent 0d831aa9cf
commit 8067e29ea8
1 changed files with 175 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files

268
human.ml
View File

@ -1264,14 +1264,13 @@ 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 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
@ -1321,7 +1320,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
@ -1335,15 +1335,22 @@ module Panel = struct
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 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 append_ d (l : node -> node) (a : node) : node -> node =
fun n -> l (join_ d a n)
let append_x = append_ `X
let append_y = append_ `Y
let append_z = append_ `Z
let pp_uchar ppf v =
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
@ -1403,6 +1410,17 @@ module Panel = struct
()
| `Atom x -> pf ppf "`Atom %a" pp_atom x
let rec pp_dump_node ppf v =
let open Fmt in
pf ppf "@[<hov>%a@]"
(braces
(record
[ field "t" (fun v -> v.t) pp_t
; field "parent"
(fun v -> v.parent)
(option pp_dump_node) ] ) )
v
(* 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)
ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
@ -1410,45 +1428,33 @@ 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 rec of_string (str : string) : node =
let uudec = Uutf.decoder (`String str) in
let rec dec (lx : unit -> node) : 'a * (unit -> node) =
let rec dec (lx : node -> node) : 'a * (node -> node) =
match Uutf.decode uudec with
| `Malformed b -> dec (_of_string lx (String.escaped b))
| `Malformed b ->
dec (append_x lx (of_string (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
| `Boundary ->
char
(`Await, append `X lx (node (`Atom (`Hint `Line))))
ly
| `Uchar c ->
char
(`Await, append `X lx (node (`Atom (`Uchar c))))
ly in
match char (`Await, la') la' with
let rec char (x, (l : node -> node)) =
match Uuseg.add uuline x with
| `End as x -> (l, x)
| `Await -> char (dec l)
| `Boundary as x when Uuseg.mandatory uuline -> (l, x)
| `Boundary ->
char (`Await, append_x l (node (`Atom (`Hint `Line))))
| `Uchar c ->
char (`Await, append_x l (node (`Atom (`Uchar c))))
in
let rec new_line la : node -> node =
match char (`Await, la) with
| l, `Boundary ->
new_line
(append `Y la'
((append `X l (node (`Atom (`Boundary `Line)))) ()) )
(append_y la (l (node (`Atom (`Boundary `Line)))))
| l, `End -> l in
new_line la
let of_string str = _of_string new_append str ()
(new_line (fun n -> n)) empty_node
(* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
node =
@ -1571,7 +1577,6 @@ module Panel = struct
| `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 join ?(style = Style.empty) (d, a, b) : image =
@ -1590,8 +1595,8 @@ module Panel = struct
type segment =
[ `Beginning of segment_type
| `Back of segment_type
| `Forward of segment_type
| `Backward of segment_type
| `End of segment_type ]
type t =
@ -1615,43 +1620,95 @@ module Panel = struct
| `Out ]
end
let tree_next (n : node) =
F.epr "tree_next @." ;
let rec next_right n' =
F.epr "next_right n=%a@." pp_dump_node n' ;
match n.parent with
| None ->
F.epr "tree_next None@." ;
None
| Some ({t= `Attr _; _} as p) -> next_right p
| Some {t= `Join (_, a, b); _} when n' == a ->
F.epr "next_right `Join _,n,_@." ;
Some b
| Some ({t= `Join (_, _, b); _} as p) when n' == b ->
F.epr "next_right `Join _,_,n@." ;
next_right p
| Some {t= `Join (_, a, b); _} ->
F.epr "next_right `Join (_,%a,%a)@." pp_node a pp_node b ;
assert false
| Some {t= `Atom _; _} -> assert false in
match n.t with
| `Atom _ -> next_right n
| `Attr (_, n') -> Some n'
| `Join (_, {t= `Atom `Empty; _}, b) -> Some b
| `Join (_, a, _) -> Some a
let tree_prev (n : node) =
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 *) )
let rec search_forward (n : node) (f : node -> 'a option) :
'a option =
F.epr "search_forward @." ;
match f n with
| None -> (
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
match tree_next n with
| Some n' -> search_forward n' f
| None -> None )
| x -> x
let rec search_backward (n : node) (f : node -> 'a option) :
'a option =
match f n with
| None -> (
match n.parent with
| None -> None (* at root and didn't find anything *)
| Some n -> search_backward n f )
| Some n' -> Some n'
match tree_prev n with
| None -> None
| Some p -> (
match f p with
| None -> search_backward p f
| Some x -> Some x )
let perform_action (a : Action.t) (c : node) : node =
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
let perform_action (a : Action.t) (c : cursor) : node option =
let r =
match a with
| `Move (`Beginning `Char) -> None
| `Move (`Beginning `Word) ->
search_backward c.sel (fun n ->
match n.t with
| `Atom (`Boundary `Word) -> Some n
| _ -> None )
| `Move (`Forward `Char) ->
F.epr "`Move (`Forward `Char)%a@." pp_node c.sel ;
search_forward c.sel (fun n ->
match n.t with
| _ when n == c.sel -> None
(* TODO proper detection of root | _ when n == c.root -> Some n *)
| `Atom (`Uchar _) -> Some n
| _ -> None )
| `Move (`Backward `Char) ->
search_backward c.sel (fun n ->
match n.t with
(* TODO proper detection of root | _ when n == c.root -> Some np *)
| `Atom (`Uchar _) -> Some n
| _ -> None )
| `Move _ -> None
| `Yank _s -> None
| `Kill _s -> None
| `Descend -> Some (sub c.sel)
| `Ascend -> c.sel.parent
| `Custom _s -> None in
match r with
| Some n ->
c.sel <- n ;
Some n
| None -> None
type event_status = [`Handled | `Event of Event.t]
@ -1659,32 +1716,46 @@ 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]
let join_search_forward n =
search_forward n (fun v ->
match v.t with `Join _ -> Some v | _ -> None )
let cursor_attr = `Style Style.(bg Color.(blend red green))
let textedit_handler ?(bindings = textedit_bindings) (n : node) =
let bind = Key.Bind.init bindings in
let n' = insert_attr `Cursor n in
let c = ref n in
let c =
{ root= n
; sel=
insert_attr
(`Style Style.(bg Color.(blend red green)))
( match join_search_forward n with
| Some n -> n
| None -> n ) } in
Format.(
F.epr
"@[<hv> F.stderr margin: %d, max_indent: %d, max_boxes: %d \
@ -1692,22 +1763,34 @@ module Panel = struct
(pp_get_margin F.stderr ())
(pp_get_max_indent F.stderr ())
(pp_get_max_boxes F.stderr ())) ;
F.epr "@[<v>%a@]@." pp_node n' ;
Format.pp_set_max_boxes F.stderr 32 ;
node
(`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 ;
F.epr "textedit_handler handling event@." ;
c.sel <- remove_attr c.sel ;
( match perform_action x c with
| Some _ ->
F.epr
"textedit_handler perform_action success@."
| None ->
F.epr
"textedit_handler perform_action FAILURE@."
) ;
c.sel <- insert_attr cursor_attr c.sel ;
F.epr "@[<v>textedit_handler root:@ %a@]@."
pp_node n ;
F.epr "@[<v>textedit_handler cursor:@ %a@]@."
pp_node c.sel ;
Lwt.return_none
| [] -> Lwt.return_some e )
, n ) )
let handler_of_node (n : node) : handler option =
F.epr "handler_of_node " ;
search_forward n (fun n ->
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
@ -1745,14 +1828,13 @@ module Panel = struct
(Lwd.pure
(textedit_handler
(style Style.dark
(*(join_y
(join_y
(Text.insert_string empty_node
"-- welcome to my land of idiocy ---" )
(join_x
(Text.insert_string empty_node "hello bitch")
(Text.insert_string empty_node
"!\n sup daddy" ) ) )*)
(* (join_y
(join_y
(Text.of_string
"-- welcome to my land of idiocy ---" )
(join_x
(Text.of_string "hello bitch")
(Text.of_string "!\n sup daddy") ) )*)
(Text.of_string "test 1 2 3") ) ) )
(* ) *)
end