From 8067e29ea8d24cccf565910d59675139141ee898 Mon Sep 17 00:00:00 2001 From: cqc Date: Sat, 19 Mar 2022 12:10:23 -0500 Subject: [PATCH] C-f and C-b --- human.ml | 268 ++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 175 insertions(+), 93 deletions(-) diff --git a/human.ml b/human.ml index 2e6a997..6d8f1e5 100644 --- a/human.ml +++ b/human.ml @@ -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 "@[%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 "@[ 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 "@[%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 "@[textedit_handler root:@ %a@]@." + pp_node n ; + F.epr "@[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