console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

still works

Browse Source
This commit is contained in:
cqc
2023-01-23 11:54:46 -06:00
parent f0c5556450
commit d46c1de49d
3 changed files with 4911 additions and 4507 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9240
_build/default/boot_js.bc.js
View File

File diff suppressed because one or more lines are too long

2
boot_js.ml
View File

@ -91,7 +91,7 @@ let _ =
let body = Lwd.var (Lwd.pure Ui.empty) in let body = Lwd.var (Lwd.pure Ui.empty) in
let wm = Widgets.window_manager (Lwd.join (Lwd.get body)) in let wm = Widgets.window_manager (Lwd.join (Lwd.get body)) in
Nav.test_pull () >>= fun test_tree -> Nav.test_pull () >>= fun test_tree ->
Widgets.(tree_nav test_tree []) >>= fun ui -> Widgets.(tree_nav (test_tree, [])) >>= fun ui ->
let root = let root =
Lwd.set body Lwd.set body
(Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui); (Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui);

178
human.ml
View File

@ -2774,17 +2774,18 @@ module Widgets = struct
Ui.may_handle (Lwd.peek cursor) (fun row -> Ui.may_handle (Lwd.peek cursor) (fun row ->
Ui.may_handle (Lwd_table.get row) (fun line -> f row line)) Ui.may_handle (Lwd_table.get row) (fun line -> f row line))
let cursor_move cursor let cursor_move ?(update : 'a -> 'a -> unit = fun _ _ -> ())
(f : 'a Lwd_table.row -> 'a Lwd_table.row option) = (cursor : 'a Lwd_table.row option Lwd.var)
(new_row : 'a Lwd_table.row -> 'a Lwd_table.row option) =
match Lwd.peek cursor with match Lwd.peek cursor with
| Some cursor_row -> ( | Some cursor_row -> (
match f cursor_row with match new_row cursor_row with
| Some new_row -> | Some new_row ->
(match Lwd_table.get new_row with (match Lwd_table.get new_row with
| Some new_line -> | Some new_line ->
cursor_row |> Lwd_table.get cursor_row |> Lwd_table.get
|> Option.iter (fun cursor_line -> |> Option.iter (fun cursor_line ->
copy_line_cursor cursor_line new_line; update cursor_line new_line;
Focus.release cursor_line.focus); Focus.release cursor_line.focus);
Focus.request new_line.focus Focus.request new_line.focus
| None -> ()); | None -> ());
@ -2793,7 +2794,7 @@ module Widgets = struct
| None -> `Unhandled) | None -> `Unhandled)
| 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 = line Lwd_table.t =
(* Append lines from s to table *) (* Append lines from s to table *)
List.iter (line_append ~table) (String.split_on_char '\n' s); List.iter (line_append ~table) (String.split_on_char '\n' s);
@ -2839,6 +2840,9 @@ module Widgets = struct
((None, line_empty ()), focus_handle_compare) ((None, line_empty ()), focus_handle_compare)
table 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 ()) let edit_area ?(table = Lwd_table.make ()) ?(focus = Focus.make ())
() : Ui.t Lwd.t = () : Ui.t Lwd.t =
let cursor = Lwd.var @@ Lwd_table.first table in let cursor = Lwd.var @@ Lwd_table.first table in
@ -2859,19 +2863,20 @@ module Widgets = struct
Ui.keyboard_area ~focus (fun k -> Ui.keyboard_area ~focus (fun k ->
Log.debug (fun m -> Log.debug (fun m ->
m "edit_area handler %a" Ui.pp_key k); m "edit_area handler %a" Ui.pp_key k);
let cursor_move =
cursor_move ~update:copy_line_cursor cursor
in
match k with match k with
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' -> | `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
cursor_move cursor (fun c -> Lwd_table.next c) cursor_move Lwd_table.next
| `Arrow `Down, _ -> | `Arrow `Down, _ -> cursor_move Lwd_table.next
cursor_move cursor (fun c -> Lwd_table.next c)
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' -> | `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
cursor_move cursor (fun c -> Lwd_table.prev c) cursor_move Lwd_table.prev
| `Arrow `Up, _ -> | `Arrow `Up, _ -> cursor_move Lwd_table.prev
cursor_move cursor (fun c -> Lwd_table.prev c)
| `Uchar u, [ `Meta ] when eq_uc_c u '<' -> | `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 '>' -> | `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
cursor_move cursor (fun _ -> Lwd_table.last table) cursor_move (fun _ -> Lwd_table.last table)
| `Enter, [] -> | `Enter, [] ->
line_of_cursor cursor (fun old_row old_line -> line_of_cursor cursor (fun old_row old_line ->
let str, pos = Lwd.peek old_line.state in let str, pos = Lwd.peek old_line.state in
@ -2909,7 +2914,111 @@ module Widgets = struct
| _ -> `Unhandled)) | _ -> `Unhandled))
(Focus.status focus) (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 table = Lwd_table.make () in
let cursor_move cursor let cursor_move cursor
@ -2962,33 +3071,30 @@ module Widgets = struct
match Lwd_table.get cursor_row with match Lwd_table.get cursor_row with
| Some (_focus, (step, tree)) -> ( | Some (_focus, (step, tree)) -> (
Nav.S.Tree.kind tree [] >>= function Nav.S.Tree.kind tree [] >>= function
| Some `Node -> | Some `Node -> lwt_lwd_string "Sub-node??"
Lwt.return @@ Lwd.pure @@ string "Sub-node??"
| Some `Contents -> ( | Some `Contents -> (
Nav.S.Tree.find_all tree [] >>= function Nav.S.Tree.find_all tree [] >>= function
| Some (contents, _metadata) -> | Some (contents, _metadata) ->
Lwt.return Lwt.return
(edit_area (edit_area
~table:(edit_area_of_string contents) ~table:(line_table_of_string contents)
()) ())
| None -> | None ->
Lwt.return @@ Lwd.pure lwt_lwd_string
@@ string ("could not find path: " ^ step)) ("could not find path: " ^ step))
| None -> Lwt.return @@ Lwd.pure @@ string step)
| None -> | None ->
Lwt.return @@ Lwd.pure lwt_lwd_string
@@ string "cursor table row doesn't exist") ("Nav.S.Tree.kind " ^ step ^ " -> None?"))
| 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 in
Lwt.async (fun () -> Lwt.async (fun () ->
Lwt_stream.iter_s Lwt_stream.iter_s
(fun _ -> (fun _ ->
Lwd.quick_sample cvroot >>= fun cursorview'' -> Lwd.quick_sample cvroot >>= fun cursorview'' ->
Log.info (fun m -> Log.info (fun m ->
m m "tree_nav Lwt.async (Lwd.set cursorview)");
"tree_nav cursorviewroot on_invalidate Lwt.async \
(Lwd.set cursorview) triggered??");
Lwt.return (Lwd.set cursorview cursorview'')) Lwt.return (Lwd.set cursorview cursorview''))
cv); cv);
push_cv (Some ()); push_cv (Some ());
@ -3003,20 +3109,17 @@ module Widgets = struct
(Lwd_utils.lift_monoid Ui.pack_y) (Lwd_utils.lift_monoid Ui.pack_y)
table table
|> Lwd.join |> Lwd.join
|> Lwd.map2 |> Lwd.map2 (Focus.status focus) ~f:(fun focus ->
~f:(fun focus ->
Ui.keyboard_area ~focus (fun k -> Ui.keyboard_area ~focus (fun k ->
Log.debug (fun m -> Log.debug (fun m -> m "nav_handler %a" Ui.pp_key k);
m "edit_area handler %a" Ui.pp_key k);
match k with match k with
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' -> | `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, _ -> | `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' -> | `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
cursor_move cursor (fun c -> Lwd_table.prev c) cursor_move cursor Lwd_table.prev
| `Arrow `Up, _ -> | `Arrow `Up, _ -> cursor_move cursor Lwd_table.prev
cursor_move cursor (fun c -> Lwd_table.prev c)
| `Uchar u, [ `Meta ] when eq_uc_c u '<' -> | `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
cursor_move cursor (fun _ -> cursor_move cursor (fun _ ->
Lwd_table.first table) Lwd_table.first table)
@ -3027,11 +3130,10 @@ module Widgets = struct
| `Backspace, [] -> `Unhandled | `Backspace, [] -> `Unhandled
| `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' -> `Handled | `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' -> `Handled
| _ -> `Unhandled)) | _ -> `Unhandled))
(Focus.status focus)
|> Lwd.map2 |> Lwd.map2
(Lwd.join @@ Lwd.get cursorview)
~f:(fun cursorview' tree_view -> ~f:(fun cursorview' tree_view ->
Ui.join_x tree_view cursorview') Ui.join_x tree_view cursorview'))
(Lwd.join @@ Lwd.get cursorview))
(** Tab view, where exactly one element of [l] is shown at a time. *) (** 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 tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t