still works
This commit is contained in:
cqc
File diff suppressed because one or more lines are too long
@ -91,7 +91,7 @@ let _ =
|
||||
let body = Lwd.var (Lwd.pure Ui.empty) in
|
||||
let wm = Widgets.window_manager (Lwd.join (Lwd.get body)) in
|
||||
Nav.test_pull () >>= fun test_tree ->
|
||||
Widgets.(tree_nav test_tree []) >>= fun ui ->
|
||||
Widgets.(tree_nav (test_tree, [])) >>= fun ui ->
|
||||
let root =
|
||||
Lwd.set body
|
||||
(Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui);
|
||||
|
||||
178
human.ml
178
human.ml
@ -2774,17 +2774,18 @@ module Widgets = struct
|
||||
Ui.may_handle (Lwd.peek cursor) (fun row ->
|
||||
Ui.may_handle (Lwd_table.get row) (fun line -> f row line))
|
||||
|
||||
let cursor_move cursor
|
||||
(f : 'a Lwd_table.row -> 'a Lwd_table.row option) =
|
||||
let cursor_move ?(update : 'a -> 'a -> unit = fun _ _ -> ())
|
||||
(cursor : 'a Lwd_table.row option Lwd.var)
|
||||
(new_row : 'a Lwd_table.row -> 'a Lwd_table.row option) =
|
||||
match Lwd.peek cursor with
|
||||
| Some cursor_row -> (
|
||||
match f cursor_row with
|
||||
match new_row cursor_row with
|
||||
| Some new_row ->
|
||||
(match Lwd_table.get new_row with
|
||||
| Some new_line ->
|
||||
cursor_row |> Lwd_table.get
|
||||
|> Option.iter (fun cursor_line ->
|
||||
copy_line_cursor cursor_line new_line;
|
||||
update cursor_line new_line;
|
||||
Focus.release cursor_line.focus);
|
||||
Focus.request new_line.focus
|
||||
| None -> ());
|
||||
@ -2793,7 +2794,7 @@ module Widgets = struct
|
||||
| None -> `Unhandled)
|
||||
| None -> `Unhandled
|
||||
|
||||
let edit_area_of_string ?(table = Lwd_table.make ()) (s : string) :
|
||||
let line_table_of_string ?(table = Lwd_table.make ()) (s : string) :
|
||||
line Lwd_table.t =
|
||||
(* Append lines from s to table *)
|
||||
List.iter (line_append ~table) (String.split_on_char '\n' s);
|
||||
@ -2839,6 +2840,9 @@ module Widgets = struct
|
||||
((None, line_empty ()), focus_handle_compare)
|
||||
table
|
||||
|
||||
let to_lwt_lwd e = Lwt.return @@ Lwd.pure e
|
||||
let lwt_lwd_string s = to_lwt_lwd @@ string s
|
||||
|
||||
let edit_area ?(table = Lwd_table.make ()) ?(focus = Focus.make ())
|
||||
() : Ui.t Lwd.t =
|
||||
let cursor = Lwd.var @@ Lwd_table.first table in
|
||||
@ -2859,19 +2863,20 @@ module Widgets = struct
|
||||
Ui.keyboard_area ~focus (fun k ->
|
||||
Log.debug (fun m ->
|
||||
m "edit_area handler %a" Ui.pp_key k);
|
||||
let cursor_move =
|
||||
cursor_move ~update:copy_line_cursor cursor
|
||||
in
|
||||
match k with
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
|
||||
cursor_move cursor (fun c -> Lwd_table.next c)
|
||||
| `Arrow `Down, _ ->
|
||||
cursor_move cursor (fun c -> Lwd_table.next c)
|
||||
cursor_move Lwd_table.next
|
||||
| `Arrow `Down, _ -> cursor_move Lwd_table.next
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
|
||||
cursor_move cursor (fun c -> Lwd_table.prev c)
|
||||
| `Arrow `Up, _ ->
|
||||
cursor_move cursor (fun c -> Lwd_table.prev c)
|
||||
cursor_move Lwd_table.prev
|
||||
| `Arrow `Up, _ -> cursor_move Lwd_table.prev
|
||||
| `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
|
||||
cursor_move cursor (fun _ -> Lwd_table.first table)
|
||||
cursor_move (fun _ -> Lwd_table.first table)
|
||||
| `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
|
||||
cursor_move cursor (fun _ -> Lwd_table.last table)
|
||||
cursor_move (fun _ -> Lwd_table.last table)
|
||||
| `Enter, [] ->
|
||||
line_of_cursor cursor (fun old_row old_line ->
|
||||
let str, pos = Lwd.peek old_line.state in
|
||||
@ -2909,7 +2914,111 @@ module Widgets = struct
|
||||
| _ -> `Unhandled))
|
||||
(Focus.status focus)
|
||||
|
||||
let tree_nav ?(focus = Focus.make ()) tree path : Ui.t Lwd.t Lwt.t =
|
||||
(* TODO: view_metadata *)
|
||||
|
||||
let rec node_edit_area ?(table = Lwd_table.make ())
|
||||
?(focus = Focus.make ()) ((tree, path) : Nav.tree * Nav.path) :
|
||||
Ui.t Lwd.t Lwt.t =
|
||||
let cursor = Lwd.var @@ Lwd_table.first table in
|
||||
let open Lwt.Infix in
|
||||
Nav.S.Tree.kind tree path >>= function
|
||||
| None ->
|
||||
lwt_lwd_string
|
||||
("Nav.S.Tree.kind " ^ String.concat "/" path
|
||||
^ " how'd you get here??")
|
||||
| Some `Node -> tree_nav (tree, path)
|
||||
| Some `Contents -> (
|
||||
Nav.S.Tree.find_all tree path >>= function
|
||||
| None ->
|
||||
lwt_lwd_string
|
||||
("Nav.S.Tree.find_all " ^ String.concat "/" path
|
||||
^ " -> None")
|
||||
| Some (contents, _metadata) ->
|
||||
line_table_of_string ~table contents |> ignore;
|
||||
Option.iter
|
||||
(fun cursor ->
|
||||
Option.iter (fun first -> Focus.request first.focus)
|
||||
@@ Lwd_table.get cursor)
|
||||
(Lwd.peek cursor);
|
||||
|
||||
(* Build view of table *)
|
||||
Lwt.return
|
||||
(Lwd_table.map_reduce
|
||||
(fun _ { ui; _ } -> ui)
|
||||
(Lwd_utils.lift_monoid Ui.pack_y)
|
||||
table
|
||||
|> Lwd.join
|
||||
|> Lwd.map2
|
||||
~f:(fun focus ->
|
||||
Ui.keyboard_area ~focus (fun k ->
|
||||
Log.debug (fun m ->
|
||||
m "edit_area handler %a" Ui.pp_key k);
|
||||
let cursor_move =
|
||||
cursor_move ~update:copy_line_cursor cursor
|
||||
in
|
||||
match k with
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
|
||||
cursor_move Lwd_table.next
|
||||
| `Arrow `Down, _ ->
|
||||
cursor_move Lwd_table.next
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
|
||||
cursor_move Lwd_table.prev
|
||||
| `Arrow `Up, _ -> cursor_move Lwd_table.prev
|
||||
| `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
|
||||
cursor_move (fun _ ->
|
||||
Lwd_table.first table)
|
||||
| `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
|
||||
cursor_move (fun _ ->
|
||||
Lwd_table.last table)
|
||||
| `Enter, [] ->
|
||||
line_of_cursor cursor
|
||||
(fun old_row old_line ->
|
||||
let str, pos =
|
||||
Lwd.peek old_line.state
|
||||
in
|
||||
let n_str =
|
||||
String.(
|
||||
sub str pos (length str - pos))
|
||||
in
|
||||
Lwd.set old_line.state
|
||||
(String.sub str 0 pos, pos);
|
||||
let new_line = line_make n_str in
|
||||
Focus.release old_line.focus;
|
||||
Focus.request new_line.focus;
|
||||
Lwd.set cursor
|
||||
(Some
|
||||
(Lwd_table.after old_row
|
||||
~set:new_line));
|
||||
`Handled)
|
||||
| `Backspace, [] ->
|
||||
line_of_cursor cursor (fun row line ->
|
||||
let str, pos = Lwd.peek line.state in
|
||||
Ui.may_handle (Lwd_table.prev row)
|
||||
(fun row_prev ->
|
||||
if pos = 0 then
|
||||
Ui.may_handle
|
||||
(Lwd_table.get row_prev)
|
||||
(fun line_prev ->
|
||||
let str_prev, _ =
|
||||
Lwd.peek line_prev.state
|
||||
in
|
||||
Focus.release line.focus;
|
||||
Focus.request
|
||||
line_prev.focus;
|
||||
Lwd.set line_prev.state
|
||||
( str_prev ^ str,
|
||||
String.length str_prev
|
||||
);
|
||||
Lwd_table.remove row;
|
||||
`Handled)
|
||||
else `Unhandled))
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' ->
|
||||
`Handled
|
||||
| _ -> `Unhandled))
|
||||
(Focus.status focus)))
|
||||
|
||||
and tree_nav ?(focus = Focus.make ())
|
||||
((tree, path) : Nav.tree * Nav.path) : Ui.t Lwd.t Lwt.t =
|
||||
let table = Lwd_table.make () in
|
||||
|
||||
let cursor_move cursor
|
||||
@ -2962,33 +3071,30 @@ module Widgets = struct
|
||||
match Lwd_table.get cursor_row with
|
||||
| Some (_focus, (step, tree)) -> (
|
||||
Nav.S.Tree.kind tree [] >>= function
|
||||
| Some `Node ->
|
||||
Lwt.return @@ Lwd.pure @@ string "Sub-node??"
|
||||
| Some `Node -> lwt_lwd_string "Sub-node??"
|
||||
| Some `Contents -> (
|
||||
Nav.S.Tree.find_all tree [] >>= function
|
||||
| Some (contents, _metadata) ->
|
||||
Lwt.return
|
||||
(edit_area
|
||||
~table:(edit_area_of_string contents)
|
||||
~table:(line_table_of_string contents)
|
||||
())
|
||||
| None ->
|
||||
Lwt.return @@ Lwd.pure
|
||||
@@ string ("could not find path: " ^ step))
|
||||
| None -> Lwt.return @@ Lwd.pure @@ string step)
|
||||
lwt_lwd_string
|
||||
("could not find path: " ^ step))
|
||||
| None ->
|
||||
Lwt.return @@ Lwd.pure
|
||||
@@ string "cursor table row doesn't exist")
|
||||
lwt_lwd_string
|
||||
("Nav.S.Tree.kind " ^ step ^ " -> None?"))
|
||||
| None ->
|
||||
Lwt.return @@ Lwd.pure @@ string "cursor doesn't exist")
|
||||
lwt_lwd_string "cursor table row doesn't exist")
|
||||
| None -> lwt_lwd_string "cursor doesn't exist")
|
||||
in
|
||||
Lwt.async (fun () ->
|
||||
Lwt_stream.iter_s
|
||||
(fun _ ->
|
||||
Lwd.quick_sample cvroot >>= fun cursorview'' ->
|
||||
Log.info (fun m ->
|
||||
m
|
||||
"tree_nav cursorviewroot on_invalidate Lwt.async \
|
||||
(Lwd.set cursorview) triggered??");
|
||||
m "tree_nav Lwt.async (Lwd.set cursorview)");
|
||||
Lwt.return (Lwd.set cursorview cursorview''))
|
||||
cv);
|
||||
push_cv (Some ());
|
||||
@ -3003,20 +3109,17 @@ module Widgets = struct
|
||||
(Lwd_utils.lift_monoid Ui.pack_y)
|
||||
table
|
||||
|> Lwd.join
|
||||
|> Lwd.map2
|
||||
~f:(fun focus ->
|
||||
|> Lwd.map2 (Focus.status focus) ~f:(fun focus ->
|
||||
Ui.keyboard_area ~focus (fun k ->
|
||||
Log.debug (fun m ->
|
||||
m "edit_area handler %a" Ui.pp_key k);
|
||||
Log.debug (fun m -> m "nav_handler %a" Ui.pp_key k);
|
||||
match k with
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
|
||||
cursor_move cursor (fun c -> Lwd_table.next c)
|
||||
cursor_move cursor Lwd_table.next
|
||||
| `Arrow `Down, _ ->
|
||||
cursor_move cursor (fun c -> Lwd_table.next c)
|
||||
cursor_move cursor Lwd_table.next
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
|
||||
cursor_move cursor (fun c -> Lwd_table.prev c)
|
||||
| `Arrow `Up, _ ->
|
||||
cursor_move cursor (fun c -> Lwd_table.prev c)
|
||||
cursor_move cursor Lwd_table.prev
|
||||
| `Arrow `Up, _ -> cursor_move cursor Lwd_table.prev
|
||||
| `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
|
||||
cursor_move cursor (fun _ ->
|
||||
Lwd_table.first table)
|
||||
@ -3027,11 +3130,10 @@ module Widgets = struct
|
||||
| `Backspace, [] -> `Unhandled
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' -> `Handled
|
||||
| _ -> `Unhandled))
|
||||
(Focus.status focus)
|
||||
|> Lwd.map2
|
||||
(Lwd.join @@ Lwd.get cursorview)
|
||||
~f:(fun cursorview' tree_view ->
|
||||
Ui.join_x tree_view cursorview')
|
||||
(Lwd.join @@ Lwd.get cursorview))
|
||||
Ui.join_x tree_view cursorview'))
|
||||
|
||||
(** Tab view, where exactly one element of [l] is shown at a time. *)
|
||||
let tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t
|
||||
|
||||
Reference in New Issue
Block a user