selectable node/contents, needs correcting focus control
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_store ->
|
||||
Widgets.(tree_nav (test_store, [])) >>= fun ui ->
|
||||
let ui = Widgets.(h_node_area (test_store, [ [] ])) in
|
||||
let root =
|
||||
Lwd.set body
|
||||
(Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui);
|
||||
|
||||
486
human.ml
486
human.ml
@ -2483,15 +2483,6 @@ module Widgets = struct
|
||||
Lwd.set offset (s_x, s_y);
|
||||
`Handled
|
||||
in
|
||||
let focus_handler = function
|
||||
| `Arrow `Left, [] -> scroll (-.scroll_step) 0.
|
||||
| `Arrow `Right, [] -> scroll (+.scroll_step) 0.
|
||||
| `Arrow `Up, [] -> scroll 0. (-.scroll_step)
|
||||
| `Arrow `Down, [] -> scroll 0. (+.scroll_step)
|
||||
| `Page `Up, [] -> scroll 0. (-.scroll_step *. 8.)
|
||||
| `Page `Down, [] -> scroll 0. (+.scroll_step *. 8.)
|
||||
| _ -> `Unhandled
|
||||
in
|
||||
(* let scroll_handler ~x:_ ~y:_ = function
|
||||
| `Scroll `Up -> scroll 0. (-.scroll_step)
|
||||
| `Scroll `Down -> scroll 0. (+.scroll_step)
|
||||
@ -2500,7 +2491,17 @@ module Widgets = struct
|
||||
Lwd.map2 t (Lwd.get offset) ~f:(fun t (s_x, s_y) ->
|
||||
t |> Ui.shift_area s_x s_y
|
||||
(*|> Ui.mouse_area scroll_handler*)
|
||||
|> Ui.keyboard_area focus_handler)
|
||||
|> Ui.keyboard_area (fun e ->
|
||||
Log.debug (fun m ->
|
||||
m "keyboard_area: scroll_area focus_handler");
|
||||
match e with
|
||||
| `Arrow `Left, [] -> scroll (-.scroll_step) 0.
|
||||
| `Arrow `Right, [] -> scroll (+.scroll_step) 0.
|
||||
| `Arrow `Up, [] -> scroll 0. (-.scroll_step)
|
||||
| `Arrow `Down, [] -> scroll 0. (+.scroll_step)
|
||||
| `Page `Up, [] -> scroll 0. (-.scroll_step *. 8.)
|
||||
| `Page `Down, [] -> scroll 0. (+.scroll_step *. 8.)
|
||||
| _ -> `Unhandled))
|
||||
|
||||
let main_menu_item wm text f =
|
||||
let text = string ~attr:A.menu_main (" " ^ text ^ " ") in
|
||||
@ -2737,8 +2738,6 @@ module Widgets = struct
|
||||
Lwd.map2 state node ~f:(fun state content ->
|
||||
Ui.mouse_area (mouse_grab state) content *)
|
||||
|
||||
open Lwd.Infix
|
||||
|
||||
type line = {
|
||||
focus : Focus.handle;
|
||||
state : (string * int) Lwd.var;
|
||||
@ -2788,7 +2787,7 @@ module Widgets = struct
|
||||
| Some new_row ->
|
||||
(match Lwd_table.get new_row with
|
||||
| Some new_line ->
|
||||
cursor_row |> Lwd_table.get
|
||||
Lwd_table.get cursor_row
|
||||
|> Option.iter (fun cursor_line ->
|
||||
update cursor_line new_line;
|
||||
Focus.release cursor_line.focus);
|
||||
@ -2851,11 +2850,10 @@ module Widgets = struct
|
||||
let edit_area ?(table = Lwd_table.make ()) ?(focus = Focus.make ())
|
||||
() : Ui.t Lwd.t =
|
||||
let cursor = Lwd.var @@ Lwd_table.first table in
|
||||
Option.iter
|
||||
(fun cursor ->
|
||||
Option.iter (fun first -> Focus.request first.focus)
|
||||
@@ Lwd_table.get cursor)
|
||||
(Lwd.peek cursor);
|
||||
Lwd.peek cursor
|
||||
|> Option.iter (fun cursor ->
|
||||
Lwd_table.get cursor
|
||||
|> Option.iter (fun first -> Focus.request first.focus));
|
||||
|
||||
(* Build view of table *)
|
||||
Lwd_table.map_reduce
|
||||
@ -2867,7 +2865,7 @@ module Widgets = struct
|
||||
~f:(fun focus ->
|
||||
Ui.keyboard_area ~focus (fun k ->
|
||||
Log.debug (fun m ->
|
||||
m "edit_area handler %a" Ui.pp_key k);
|
||||
m "keyboard_area: edit_area handler %a" Ui.pp_key k);
|
||||
let cursor_move =
|
||||
cursor_move ~update:copy_line_cursor cursor
|
||||
in
|
||||
@ -2921,220 +2919,167 @@ module Widgets = struct
|
||||
|
||||
(* TODO: view_metadata *)
|
||||
|
||||
let rec node_edit_area ?(table = Lwd_table.make ())
|
||||
let node_edit_area ?(table = Lwd_table.make ())
|
||||
?(focus = Focus.make ()) ((store, path) : Nav.S.t * 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 store >>= fun tree ->
|
||||
Nav.S.Tree.kind tree path >>= function
|
||||
let save_stream, save_push = Lwt_stream.create () in
|
||||
Lwt.async (fun () ->
|
||||
Lwt_stream.iter_s
|
||||
(fun contents ->
|
||||
Nav.S.Tree.add tree path contents >>= fun tree' ->
|
||||
Nav.S.set_tree
|
||||
~info:(fun () ->
|
||||
Nav.S.Info.v
|
||||
~message:
|
||||
("node_edit_area " ^ String.concat "/" path
|
||||
^ " 'save'")
|
||||
(Int64.of_float
|
||||
((new%js Js.date_now)##getTime /. 1000.)))
|
||||
store path tree'
|
||||
>>= fun _ -> Lwt.return_unit)
|
||||
save_stream);
|
||||
|
||||
Nav.S.Tree.find_all tree path >>= function
|
||||
| None ->
|
||||
lwt_lwd_string
|
||||
("Nav.S.Tree.kind " ^ String.concat "/" path
|
||||
^ " how'd you get here??")
|
||||
| Some `Node -> tree_nav (store, path)
|
||||
| Some `Contents -> (
|
||||
let save_stream, save_push = Lwt_stream.create () in
|
||||
Lwt.async (fun () ->
|
||||
Lwt_stream.iter_s
|
||||
(fun contents ->
|
||||
Nav.S.Tree.add tree path contents >>= fun tree' ->
|
||||
Nav.S.set_tree
|
||||
~info:(fun () ->
|
||||
Nav.S.Info.v ~message:"node_edit_area 'save'"
|
||||
(Int64.of_float
|
||||
((new%js Js.date_now)##getTime /. 1000.)))
|
||||
store path tree'
|
||||
>>= fun _ -> Lwt.return_unit)
|
||||
save_stream);
|
||||
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);
|
||||
("Nav.S.Tree.find_all " ^ String.concat "/" path
|
||||
^ " -> None")
|
||||
| Some (contents, _metadata) ->
|
||||
line_table_of_string ~table contents |> ignore;
|
||||
|
||||
(* 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
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'x' ->
|
||||
let b = Buffer.create 1024 in
|
||||
Lwd_table.iter
|
||||
(fun line ->
|
||||
Buffer.add_string b
|
||||
@@ string_of_line line)
|
||||
table;
|
||||
save_push (Some (Buffer.contents b));
|
||||
Lwd.peek cursor
|
||||
|> Option.iter (fun cursor ->
|
||||
Lwd_table.get cursor
|
||||
|> Option.iter (fun first -> Focus.request first.focus));
|
||||
|
||||
`Handled
|
||||
| _ -> `Unhandled))
|
||||
(Focus.status focus)))
|
||||
(* 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 (Focus.status focus) ~f:(fun focus' ->
|
||||
Ui.keyboard_area ~focus:focus' (fun k ->
|
||||
Log.debug (fun m ->
|
||||
m "node_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
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'x' ->
|
||||
let b = Buffer.create 1024 in
|
||||
Lwd_table.iter
|
||||
(fun line ->
|
||||
Buffer.add_string b
|
||||
@@ string_of_line line)
|
||||
table;
|
||||
save_push (Some (Buffer.contents b));
|
||||
`Handled
|
||||
| _ -> `Unhandled)))
|
||||
|
||||
and tree_nav ?(focus = Focus.make ())
|
||||
module Cursor = struct
|
||||
type 'a t = 'a Lwd_table.row option Lwd.var
|
||||
|
||||
let get t ~f =
|
||||
Lwd.peek t
|
||||
|> Option.iter (fun t_row ->
|
||||
Option.iter (f t_row) (Lwd_table.get t_row))
|
||||
end
|
||||
|
||||
let tree_nav ?(focus = Focus.make ()) ?(selection = Lwd.var @@ None)
|
||||
((store, path) : Nav.S.t * Nav.path) : Ui.t Lwd.t Lwt.t =
|
||||
let table = Lwd_table.make () in
|
||||
|
||||
let cursor_move cursor
|
||||
(f : 'a Lwd_table.row -> 'a Lwd_table.row option) =
|
||||
match Lwd.peek cursor with
|
||||
| Some cursor_row -> (
|
||||
match f cursor_row with
|
||||
| Some new_row ->
|
||||
(match Lwd_table.get new_row with
|
||||
| Some (new_line_focus, _) ->
|
||||
cursor_row |> Lwd_table.get
|
||||
|> Option.iter (fun (cursor_line_focus, _) ->
|
||||
Focus.release cursor_line_focus);
|
||||
Focus.request new_line_focus
|
||||
| None -> ());
|
||||
let cursor_move cursor f =
|
||||
Ui.may_handle (Lwd.peek cursor) (fun cursor_row ->
|
||||
Ui.may_handle (f cursor_row) (fun new_row ->
|
||||
Lwd_table.get new_row
|
||||
|> Option.iter (fun (new_line_focus, new_line_sel) ->
|
||||
Lwd.set selection (Some new_line_sel);
|
||||
Lwd_table.get cursor_row
|
||||
|> Option.iter (fun (cursor_line_focus, _) ->
|
||||
Focus.release cursor_line_focus);
|
||||
Focus.request new_line_focus);
|
||||
Lwd.set cursor (Some new_row);
|
||||
`Handled
|
||||
| None -> `Unhandled)
|
||||
| None -> `Unhandled
|
||||
`Handled))
|
||||
in
|
||||
|
||||
(* Build view of tree *)
|
||||
let open Lwt.Infix in
|
||||
Nav.S.tree store >>= fun tree ->
|
||||
Nav.S.Tree.list tree path >>= fun treelist ->
|
||||
Nav.S.list store path >>= fun treelist ->
|
||||
List.iter
|
||||
(fun (step, _tree) ->
|
||||
Lwd_table.append' table (Focus.make (), step))
|
||||
treelist;
|
||||
let cursor = Lwd.var @@ Lwd_table.first table in
|
||||
Option.iter
|
||||
(fun cursor ->
|
||||
Option.iter (fun (f, _) -> Focus.request f)
|
||||
@@ Lwd_table.get cursor)
|
||||
(Lwd.peek cursor);
|
||||
|
||||
(* Lwd.observe ~on_invalidate:(fun _ ->
|
||||
Lwd.set cursorview (Lwd.quick_sample (root ()))); *)
|
||||
let cursorview =
|
||||
Lwd.var @@ Lwd.pure @@ string "initializing..."
|
||||
in
|
||||
let cv, push_cv = Lwt_stream.create () in
|
||||
let cvroot =
|
||||
Lwd.observe ~on_invalidate:(fun _ ->
|
||||
Log.info (fun m ->
|
||||
m
|
||||
"tree_nav cursorviewroot on_invalidate push_cv \
|
||||
triggered??");
|
||||
push_cv (Some ()))
|
||||
@@ Lwd.map (Lwd.get cursor) ~f:(function
|
||||
| Some cursor_row -> (
|
||||
match Lwd_table.get cursor_row with
|
||||
| Some (_focus, step) -> (
|
||||
Nav.S.Tree.kind tree (path @ [ step ]) >>= function
|
||||
| Some `Node -> lwt_lwd_string "Sub-node??"
|
||||
| Some `Contents ->
|
||||
node_edit_area (store, path @ [ step ])
|
||||
| None ->
|
||||
lwt_lwd_string
|
||||
("Nav.S.Tree.kind " ^ step ^ " -> None?"))
|
||||
| None ->
|
||||
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 Lwt.async (Lwd.set cursorview)");
|
||||
Lwt.return (Lwd.set cursorview cursorview''))
|
||||
cv);
|
||||
push_cv (Some ());
|
||||
Lwd.peek cursor
|
||||
|> Option.iter (fun cursor ->
|
||||
Lwd_table.get cursor
|
||||
|> Option.iter (fun (f, _) -> Focus.request f));
|
||||
Lwt.return
|
||||
(Lwd_table.map_reduce
|
||||
(fun _ (f, s) ->
|
||||
Lwd.map
|
||||
~f:(fun focus_h ->
|
||||
Lwd.map (Focus.status f) ~f:(fun focus_h ->
|
||||
if Focus.has_focus focus_h then string ~attr:A.cursor s
|
||||
else string s)
|
||||
(Focus.status f))
|
||||
else string s))
|
||||
(Lwd_utils.lift_monoid Ui.pack_y)
|
||||
table
|
||||
|> Lwd.join
|
||||
|> Lwd.map2 (Focus.status focus) ~f:(fun focus ->
|
||||
Ui.keyboard_area ~focus (fun k ->
|
||||
Log.debug (fun m -> m "nav_handler %a" Ui.pp_key k);
|
||||
|> Lwd.map2 (Focus.status focus) ~f:(fun focus' ->
|
||||
Ui.keyboard_area ~focus:focus' (fun k ->
|
||||
Log.debug (fun m ->
|
||||
m "keyboard_area: tree_nav %a" Ui.pp_key k);
|
||||
match k with
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
|
||||
cursor_move cursor Lwd_table.next
|
||||
@ -3149,18 +3094,135 @@ module Widgets = struct
|
||||
| `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
|
||||
cursor_move cursor (fun _ ->
|
||||
Lwd_table.last table)
|
||||
| `Enter, [] -> `Handled
|
||||
| `Backspace, [] -> `Unhandled
|
||||
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' -> `Handled
|
||||
| _ -> `Unhandled))
|
||||
|> Lwd.map2
|
||||
(Lwd.join @@ Lwd.get cursorview)
|
||||
~f:(fun cursorview' tree_view ->
|
||||
Ui.join_x tree_view cursorview'))
|
||||
| `Enter, [] ->
|
||||
Lwd.peek cursor
|
||||
|> Option.iter (fun c ->
|
||||
Lwd_table.get c
|
||||
|> Option.iter (fun (f, _step) ->
|
||||
Focus.release focus;
|
||||
Focus.request f));
|
||||
`Unhandled
|
||||
| `Backspace, [] -> `Unhandled
|
||||
| _ -> `Unhandled)))
|
||||
|
||||
(* let cursorview =
|
||||
Lwd.var @@ Lwd.pure @@ string "initializing..."
|
||||
in
|
||||
let cv, push_cv = Lwt_stream.create () in
|
||||
let cvroot =
|
||||
Lwd.observe ~on_invalidate:(fun _ ->
|
||||
Log.info (fun m ->
|
||||
m
|
||||
"tree_nav cursorviewroot on_invalidate push_cv \
|
||||
triggered??");
|
||||
push_cv (Some ()))
|
||||
@@ Lwd.map (Lwd.get cursor) ~f:(function
|
||||
| Some cursor_row -> (
|
||||
match Lwd_table.get cursor_row with
|
||||
| Some (focus, step) -> (
|
||||
let path' = path @ [ step ] in
|
||||
Nav.S.kind store path' >>= function
|
||||
| Some `Node -> lwt_lwd_string "Sub-node??"
|
||||
| Some `Contents -> node_edit_area (store, path')
|
||||
| None ->
|
||||
lwt_lwd_string
|
||||
("Nav.S.kind " ^ String.concat "/" path'
|
||||
^ " -> None?"))
|
||||
| None ->
|
||||
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 Lwt.async (Lwd.set cursorview)");
|
||||
Lwt.return (Lwd.set cursorview cursorview''))
|
||||
cv);
|
||||
push_cv (Some ()); *)
|
||||
(*|> Lwd.map2
|
||||
(Lwd.join @@ Lwd.get cursorview)
|
||||
~f:(fun cursorview' tree_view ->
|
||||
Ui.join_x tree_view cursorview') *)
|
||||
|
||||
open Lwt.Infix
|
||||
|
||||
let rec node_ui ?(focus = Focus.make ()) store path
|
||||
(f : Focus.handle * ui Lwd.t -> unit) : unit =
|
||||
Lwt.async (fun () ->
|
||||
Nav.S.tree store >>= fun tree ->
|
||||
Nav.S.Tree.kind tree path >>= function
|
||||
| None ->
|
||||
f
|
||||
( focus,
|
||||
Lwd.pure
|
||||
@@ string
|
||||
("Nav.S.Tree.kind " ^ String.concat "/" path
|
||||
^ " how'd you get here??") );
|
||||
Lwt.return_unit
|
||||
| Some `Node ->
|
||||
let selection = Lwd.var None in
|
||||
tree_nav ~selection ~focus (store, path) >>= fun ui ->
|
||||
f
|
||||
( focus,
|
||||
Lwd.map2
|
||||
(Lwd.pair (Focus.status focus) (Lwd.get selection))
|
||||
ui
|
||||
~f:(fun (focus, selection) ui ->
|
||||
Ui.keyboard_area ~focus
|
||||
(fun k ->
|
||||
Log.debug (fun m ->
|
||||
m "keyboard_area: node_ui %a" Ui.pp_key k);
|
||||
|
||||
match k with
|
||||
| `Enter, [] -> (
|
||||
match selection with
|
||||
| Some sel ->
|
||||
Log.debug (fun m ->
|
||||
m "node_ui selecting '%s'" sel);
|
||||
node_ui store (path @ [ sel ]) f;
|
||||
Log.debug (fun m ->
|
||||
m "node_ui done selecting '%s'"
|
||||
sel);
|
||||
|
||||
`Handled
|
||||
| None -> `Unhandled)
|
||||
| _ -> `Unhandled)
|
||||
ui) );
|
||||
Lwt.return_unit
|
||||
| Some `Contents ->
|
||||
node_edit_area ~focus (store, path) >>= fun ui ->
|
||||
f (focus, ui);
|
||||
Lwt.return_unit)
|
||||
|
||||
let h_node_area ?(table = Lwd_table.make ())
|
||||
?(focus = Focus.make ())
|
||||
((store, paths) : Nav.S.t * Nav.path list) : Ui.t Lwd.t =
|
||||
List.iter
|
||||
(fun path ->
|
||||
node_ui store path (fun v -> Lwd_table.append' table v))
|
||||
paths;
|
||||
let _cursor = Lwd.var @@ Lwd_table.first table in
|
||||
Lwd_table.map_reduce
|
||||
(fun _row (_focus, ui) -> ui)
|
||||
(Lwd_utils.lift_monoid Ui.pack_x)
|
||||
table
|
||||
|> Lwd.join
|
||||
|> Lwd.map2 (Focus.status focus) ~f:(fun focus' ->
|
||||
Ui.keyboard_area ~focus:focus' (fun k ->
|
||||
Log.debug (fun m ->
|
||||
m "keyboard_area: h_node_area_handler %a" Ui.pp_key
|
||||
k);
|
||||
match k with
|
||||
| `Enter, [] -> `Unhandled
|
||||
| _ -> `Unhandled))
|
||||
|
||||
(** 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
|
||||
=
|
||||
let open Lwd.Infix in
|
||||
match tabs with
|
||||
| [] -> Lwd.return Ui.empty
|
||||
| _ ->
|
||||
|
||||
Reference in New Issue
Block a user