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 [ `Style of style
| `Pad of Pad.t | `Pad of Pad.t
| `Shift of dim | `Shift of dim
| `Cursor
| `Handler of handler ] | `Handler of handler ]
and dir = [`X | `Y | `Z]
and dim = Size2.t and dim = Size2.t
and image = Wall.image * dim and image = Wall.image * dim
and style = Style.t and style = Style.t
and handler = node -> Event.t -> Event.t option Lwt.t and handler = node -> Event.t -> Event.t option Lwt.t
and dir = [`X | `Y | `Z]
let set_parent_on_children n : node = let set_parent_on_children n : node =
( match n.t with ( match n.t with
@ -1321,7 +1320,8 @@ module Panel = struct
| `Attr (a, _) -> `Attr (a, n') | `Attr (a, _) -> `Attr (a, n')
| `Join (d, a, b) when n == a -> `Join (d, n', b) | `Join (d, a, b) when n == a -> `Join (d, n', b)
| `Join (d, a, b) when n == b -> `Join (d, a, n') | `Join (d, a, b) when n == b -> `Join (d, a, n')
| _ -> assert false ) | _ -> assert false ) ;
ignore (set_parent_on_children p)
| None -> () ) ; | None -> () ) ;
n' n'
| _ -> assert false | _ -> assert false
@ -1335,15 +1335,22 @@ module Panel = struct
let join_ d (a : node) (b : node) = let join_ d (a : node) (b : node) =
set_parent_on_children {parent= a.parent; t= `Join (d, a, b)} 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_x = join_ `X
let join_y = join_ `Y let join_y = join_ `Y
let join_z = join_ `Z let join_z = join_ `Z
let pack_x : node Lwd_utils.monoid = (empty_join `X, join_x) let pack_x : node Lwd_utils.monoid = (empty_node, join_x)
let pack_y : node Lwd_utils.monoid = (empty_join `Y, join_y) let pack_y : node Lwd_utils.monoid = (empty_node, join_y)
let pack_z : node Lwd_utils.monoid = (empty_join `Z, join_z) let pack_z : node Lwd_utils.monoid = (empty_node, join_z)
let ( ^^ ) = join_x let ( ^^ ) = join_x
let ( ^/^ ) = join_y 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 = let pp_uchar ppf v =
if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char 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 | `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, (* 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) 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. 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`. 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. 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 module Text = struct
let rec _of_string (la : unit -> node) (str : string) : let rec of_string (str : string) : node =
unit -> node =
let uudec = Uutf.decoder (`String str) in 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 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 | (`Await | `Uchar _ | `End) as x -> (x, lx) in
let uuline = Uuseg.create `Line_break in let uuline = Uuseg.create `Line_break in
let rec new_line la' : unit -> node = let rec char (x, (l : node -> node)) =
let rec char (x, lx) (ly : unit -> node) = match Uuseg.add uuline x with
match Uuseg.add uuline x with | `End as x -> (l, x)
| `End as x -> (ly, x) | `Await -> char (dec l)
| `Boundary as x when Uuseg.mandatory uuline -> (ly, x) | `Boundary as x when Uuseg.mandatory uuline -> (l, x)
| `Await -> char (dec lx) ly | `Boundary ->
| `Boundary -> char (`Await, append_x l (node (`Atom (`Hint `Line))))
char | `Uchar c ->
(`Await, append `X lx (node (`Atom (`Hint `Line)))) char (`Await, append_x l (node (`Atom (`Uchar c))))
ly in
| `Uchar c -> let rec new_line la : node -> node =
char match char (`Await, la) with
(`Await, append `X lx (node (`Atom (`Uchar c))))
ly in
match char (`Await, la') la' with
| l, `Boundary -> | l, `Boundary ->
new_line new_line
(append `Y la' (append_y la (l (node (`Atom (`Boundary `Line)))))
((append `X l (node (`Atom (`Boundary `Line)))) ()) )
| l, `End -> l in | l, `End -> l in
new_line la (new_line (fun n -> n)) empty_node
let of_string str = _of_string new_append str ()
(* let segment ?(boundary = `Word) ?(label = `Word) (node : node) : (* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
node = node =
@ -1571,7 +1577,6 @@ module Panel = struct
| `Style s -> pane ~style:(Style.merge s style) node | `Style s -> pane ~style:(Style.merge s style) node
| `Pad p -> pad p (pane ~style node) | `Pad p -> pad p (pane ~style node)
| `Shift s -> shift s (pane ~style node) | `Shift s -> shift s (pane ~style node)
| `Cursor -> cursor (pane ~style node)
| _ -> pane ~style node | _ -> pane ~style node
and join ?(style = Style.empty) (d, a, b) : image = and join ?(style = Style.empty) (d, a, b) : image =
@ -1590,8 +1595,8 @@ module Panel = struct
type segment = type segment =
[ `Beginning of segment_type [ `Beginning of segment_type
| `Back of segment_type
| `Forward of segment_type | `Forward of segment_type
| `Backward of segment_type
| `End of segment_type ] | `End of segment_type ]
type t = type t =
@ -1615,43 +1620,95 @@ module Panel = struct
| `Out ] | `Out ]
end 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) : let rec search_forward (n : node) (f : node -> 'a option) :
'a option = 'a option =
F.epr "search_forward @." ;
match f n with match f n with
| None -> ( | None -> (
match n.t with match tree_next n with
| `Atom _ -> None | Some n' -> search_forward n' f
| `Attr (_, n) -> search_forward n f | None -> None )
| `Join (_, a, b) -> ( | x -> x
match search_forward a f with
| Some n' -> Some n'
| None -> search_forward b f ) )
| Some a -> Some a
let rec search_backward (n : node) (f : node -> 'a option) : let rec search_backward (n : node) (f : node -> 'a option) :
'a option = 'a option =
match f n with match tree_prev n with
| None -> ( | None -> None
match n.parent with | Some p -> (
| None -> None (* at root and didn't find anything *) match f p with
| Some n -> search_backward n f ) | None -> search_backward p f
| Some n' -> Some n' | Some x -> Some x )
let perform_action (a : Action.t) (c : node) : node = let perform_action (a : Action.t) (c : cursor) : node option =
match a with let r =
| `Move (`Beginning `Char) -> c match a with
| `Move (`Beginning `Word) -> | `Move (`Beginning `Char) -> None
Option.value ~default:c | `Move (`Beginning `Word) ->
(search_backward c (fun n -> search_backward c.sel (fun n ->
match n.t with match n.t with
| `Atom (`Boundary `Word) -> Some n | `Atom (`Boundary `Word) -> Some n
| _ -> None ) ) | _ -> None )
| `Move _ -> c | `Move (`Forward `Char) ->
| `Yank _s -> c F.epr "`Move (`Forward `Char)%a@." pp_node c.sel ;
| `Kill _s -> c search_forward c.sel (fun n ->
| `Descend -> sub c match n.t with
| `Ascend -> ( match c.parent with Some n -> n | None -> c ) | _ when n == c.sel -> None
| `Custom _s -> c (* 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] type event_status = [`Handled | `Event of Event.t]
@ -1659,32 +1716,46 @@ module Panel = struct
let open Key.Bind in let open Key.Bind in
empty empty
|> add [([Ctrl], C 'f')] [`Move (`Forward `Char)] |> add [([Ctrl], C 'f')] [`Move (`Forward `Char)]
|> add [([Ctrl], C 'b')] [`Move (`Back `Char)] |> add [([Ctrl], C 'b')] [`Move (`Backward `Char)]
|> add [([Ctrl], C 'f')] [`Move (`Forward `Word)] |> add [([Meta], C 'f')] [`Move (`Forward `Word)]
|> add [([Meta], C 'b')] [`Move (`Back `Word)] |> add [([Meta], C 'b')] [`Move (`Backward `Word)]
|> add |> add
[([Ctrl], C 'c'); ([Ctrl], C 'n')] [([Ctrl], C 'c'); ([Ctrl], C 'n')]
[`Move (`Forward `Phrase)] [`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 'n')] [`Move (`Forward `Line)]
|> add [([Ctrl], C 'p')] [`Move (`Back `Line)] |> add [([Ctrl], C 'p')] [`Move (`Backward `Line)]
|> add [([Meta], C 'v')] [`Move (`Forward `Page)] |> add [([Ctrl], C 'v')] [`Move (`Forward `Page)]
|> add [([Ctrl], C 'v')] [`Move (`Back `Page)] |> add [([Meta], C 'v')] [`Move (`Backward `Page)]
|> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)] |> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)]
|> add [([Ctrl], C 'e')] [`Move (`End `Line)] |> add [([Ctrl], C 'e')] [`Move (`End `Line)]
|> add [([Ctrl], C 'k')] [`Kill (`End `Line)] |> add [([Ctrl], C 'k')] [`Kill (`End `Line)]
|> add [([Ctrl], U `Backspace)] [`Kill (`Back `Word)] |> add [([Ctrl], U `Backspace)] [`Kill (`Backward `Word)]
|> add [([Meta], U `Backspace)] [`Kill (`Back `Word)] |> add [([Meta], U `Backspace)] [`Kill (`Backward `Word)]
|> add |> add
[([Ctrl], C 'x'); ([], U `Backspace)] [([Ctrl], C 'x'); ([], U `Backspace)]
[`Kill (`Back `Phrase)] [`Kill (`Backward `Phrase)]
|> add [([Ctrl], C 'q')] [`Ascend] |> add [([Ctrl], C 'q')] [`Ascend]
|> add [([Ctrl], C 'e')] [`Descend] |> 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 textedit_handler ?(bindings = textedit_bindings) (n : node) =
let bind = Key.Bind.init bindings in let bind = Key.Bind.init bindings in
let n' = insert_attr `Cursor n in let c =
let c = ref n in { 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.( Format.(
F.epr F.epr
"@[<hv> F.stderr margin: %d, max_indent: %d, max_boxes: %d \ "@[<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_margin F.stderr ())
(pp_get_max_indent F.stderr ()) (pp_get_max_indent F.stderr ())
(pp_get_max_boxes F.stderr ())) ; (pp_get_max_boxes F.stderr ())) ;
F.epr "@[<v>%a@]@." pp_node n' ; Format.pp_set_max_boxes F.stderr 32 ;
node node
(`Attr (`Attr
( `Handler ( `Handler
(fun (_ : node) (e : Event.t) : Event.t option Lwt.t -> (fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
match Key.Bind.resolve_events bind [e] with match Key.Bind.resolve_events bind [e] with
| x :: _ -> | x :: _ ->
c := F.epr "textedit_handler handling event@." ;
insert_attr `Cursor c.sel <- remove_attr c.sel ;
(perform_action x (remove_attr !c)) ; ( match perform_action x c with
F.epr "%a@." pp_node !c ; | 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_none
| [] -> Lwt.return_some e ) | [] -> Lwt.return_some e )
, n ) ) , n ) )
let handler_of_node (n : node) : handler option = let handler_of_node (n : node) : handler option =
F.epr "handler_of_node " ;
search_forward n (fun n -> search_forward n (fun n ->
match n.t with `Attr (`Handler f, _) -> Some f | _ -> None ) match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
@ -1745,14 +1828,13 @@ module Panel = struct
(Lwd.pure (Lwd.pure
(textedit_handler (textedit_handler
(style Style.dark (style Style.dark
(*(join_y (* (join_y
(join_y (join_y
(Text.insert_string empty_node (Text.of_string
"-- welcome to my land of idiocy ---" ) "-- welcome to my land of idiocy ---" )
(join_x (join_x
(Text.insert_string empty_node "hello bitch") (Text.of_string "hello bitch")
(Text.insert_string empty_node (Text.of_string "!\n sup daddy") ) )*)
"!\n sup daddy" ) ) )*)
(Text.of_string "test 1 2 3") ) ) ) (Text.of_string "test 1 2 3") ) ) )
(* ) *) (* ) *)
end end