From 50831dc73dea8c751b52468ce99c19e853d2d92b Mon Sep 17 00:00:00 2001 From: cqc Date: Sun, 20 Mar 2022 16:01:41 -0500 Subject: [PATCH] most cursor movement functionality works, but there are lots of weird quirks to iron out --- human.ml | 205 ++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 126 insertions(+), 79 deletions(-) diff --git a/human.ml b/human.ml index a386137..257d41c 100644 --- a/human.ml +++ b/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 "@[%a@]" (_pp_t pp_node_n_record) + + let pp_n ppf n = + F.pf ppf "@[%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