most cursor movement functionality works, but there are lots of weird quirks to iron out
This commit is contained in:
cqc
205
human.ml
205
human.ml
@ -1383,10 +1383,13 @@ module Panel = struct
|
||||
braces
|
||||
(record ~sep:semi [field "n" Fun.id pp_node_n; any "..."]))
|
||||
|
||||
and pp_node ppf = _pp_node pp_node_n_record ppf
|
||||
and pp_node ppf = _pp_node pp_node_n ppf
|
||||
and pp_dump_node ppf = _pp_node pp_dump_node ppf
|
||||
|
||||
let pp_t = _pp_t pp_node_n_record
|
||||
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.(
|
||||
@ -1601,18 +1604,18 @@ 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)
|
||||
| _ -> 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
|
||||
@ -1714,57 +1717,104 @@ module Panel = struct
|
||||
| Some {t= `Join _; _} -> assert false
|
||||
(* shouldn't happen *)
|
||||
|
||||
let rec search_forward (n : node) (f : node -> 'a option) :
|
||||
'a option =
|
||||
match f n with
|
||||
| None -> (
|
||||
match tree_next n with
|
||||
| Some n' -> search_forward n' f
|
||||
| None -> None )
|
||||
| x -> x
|
||||
let rec tree_iter f n i =
|
||||
if i <> 0 then tree_iter f (f n) (i - 1) else f n
|
||||
|
||||
let rec search_backward (n : node) (f : node -> 'a option) :
|
||||
'a option =
|
||||
match tree_prev n with
|
||||
| None -> None
|
||||
| Some p -> (
|
||||
match f p with
|
||||
| None -> search_backward p f
|
||||
| Some x -> Some x )
|
||||
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 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
|
||||
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 (`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 )
|
||||
| `Move (`Forward `Char) ->
|
||||
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
|
||||
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]
|
||||
|
||||
@ -1794,28 +1844,21 @@ module Panel = struct
|
||||
[([Ctrl], C 'x'); ([], U `Backspace)]
|
||||
[`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 )
|
||||
|> 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) =
|
||||
let bind = Key.Bind.init bindings in
|
||||
let c =
|
||||
{ root= n
|
||||
; sel=
|
||||
insert_attr cursor_attr
|
||||
( match join_search_forward n with
|
||||
| Some n -> n
|
||||
| None -> n ) } in
|
||||
Format.pp_set_max_boxes F.stderr 64 ;
|
||||
(*full screen fynn *)
|
||||
Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230 ;
|
||||
node
|
||||
(`Attr
|
||||
let bind = Key.Bind.init bindings in
|
||||
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
|
||||
@ -1825,20 +1868,24 @@ module Panel = struct
|
||||
"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 _ ->
|
||||
| Some n' ->
|
||||
F.epr "textedit action @[%a@] Success@."
|
||||
Action.pp_t x
|
||||
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
|
||||
@ -1867,7 +1914,7 @@ module Panel = struct
|
||||
() ) ;
|
||||
Lwt.return_unit )
|
||||
ev
|
||||
>|= fun () -> Draw.pane r )
|
||||
>|= fun () -> Draw.node r )
|
||||
|
||||
let test =
|
||||
panel
|
||||
|
||||
Reference in New Issue
Block a user