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

switched to using local test repo because there was no internet on Le Canadien, fixed tree_nav focus handle embedding, added Moar to may_handle

Browse Source
This commit is contained in:
cqc
2023-02-16 13:35:34 -06:00
parent 53982ab0c6
commit 480e77bbb9
2 changed files with 55 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
boot_js.ml
View File

@ -90,7 +90,7 @@ let _ =
let gravity_crop = Gravity.make ~h:`Positive ~v:`Negative in let gravity_crop = Gravity.make ~h:`Positive ~v:`Negative in
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_store -> Nav.test_populate () >>= fun test_store ->
let ui = Widgets.(h_node_area (test_store, [ [] ])) in let ui = Widgets.(h_node_area (test_store, [ [] ])) in
let root = let root =
Lwd.set body Lwd.set body

86
human.ml
View File

@ -441,6 +441,8 @@ module Nav = struct
end end
module Sync = Irmin.Sync.Make (S) module Sync = Irmin.Sync.Make (S)
(* owo *)
(* owo *)
type t = S.tree type t = S.tree
type store = S.t type store = S.t
@ -448,13 +450,24 @@ module Nav = struct
type step = S.step type step = S.step
type path = step list type path = step list
let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree let empty_repo_main () = S.Repo.v (Irmin_mem.config ()) >>= S.main
let test_populate () : t Lwt.t = let time_now () =
Int64.of_float ((new%js Js.date_now)##getTime /. 1000.)
let info_msg ?(time = time_now ()) message = S.Info.v ~message time
let test_populate () : store Lwt.t =
let add p s t = S.Tree.add t p s in let add p s t = S.Tree.add t p s in
let r' = empty_repo_main () in
add [ "hello" ] "world" (S.Tree.empty ()) add [ "hello" ] "world" (S.Tree.empty ())
>>= add [ "hello"; "daddy" ] "ily" >>= add [ "daddy" ] "ily"
>>= add [ "beep"; "beep" ] "motherfucker" >>= add [ "beep"; "beep" ] "motherfucker"
>>= fun t ->
r' >>= fun r ->
S.set_tree ~info:(fun () -> info_msg "test_populate ()") r [] t
|> ignore;
r'
let test_pull () : store Lwt.t = let test_pull () : store Lwt.t =
(* test_populate ()*) (* test_populate ()*)
@ -573,8 +586,6 @@ module NVG = struct
include Graphv_webgl.Color include Graphv_webgl.Color
let none = Color.transparent let none = Color.transparent
(* let transparent = rgbaf ~r:0. ~g:0. ~b:0. ~a:0.000001 *)
let gray a = rgbf ~r:a ~g:a ~b:a let gray a = rgbf ~r:a ~g:a ~b:a
let light = gray 0.8 let light = gray 0.8
let dark = gray 0.2 let dark = gray 0.2
@ -1360,7 +1371,7 @@ module Nottui = struct
end end
module Ui = struct module Ui = struct
type may_handle = [ `Unhandled | `Handled ] type may_handle = [ `Unhandled | `Handled | `Moar ]
let may_handle (type a) (v : a option) (f : a -> may_handle) : let may_handle (type a) (v : a option) (f : a -> may_handle) :
may_handle = may_handle =
@ -1369,6 +1380,7 @@ module Nottui = struct
let pp_may_handle ppf = function let pp_may_handle ppf = function
| `Unhandled -> F.pf ppf "`Unhandled" | `Unhandled -> F.pf ppf "`Unhandled"
| `Handled -> F.pf ppf "`Handled" | `Handled -> F.pf ppf "`Handled"
| `Moar -> F.pf ppf "`Moar"
type mouse_handler = type mouse_handler =
x:float -> x:float ->
@ -1966,7 +1978,7 @@ module Nottui = struct
| Event_filter (n, f) -> ( | Event_filter (n, f) -> (
match f (`Mouse (`Press btn, (x, y), [])) with match f (`Mouse (`Press btn, (x, y), [])) with
| `Handled -> true | `Handled -> true
| `Unhandled -> aux ox oy sw sh n) | `Unhandled | `Moar -> aux ox oy sw sh n)
in in
aux 0. 0. w h t aux 0. 0. w h t
@ -2036,7 +2048,9 @@ module Nottui = struct
| Atom image -> | Atom image ->
let image = let image =
if Focus.has_focus t.focus then ( if Focus.has_focus t.focus then (
Log.debug (fun m -> m "render_node Atom has_focus"); Log.debug (fun m ->
m "render_node Atom has_focus status=%a"
Focus.pp_status t.focus);
I.attr A.clickable image) I.attr A.clickable image)
else image else image
in in
@ -2170,7 +2184,11 @@ module Nottui = struct
else else
{ {
cache with cache with
image = I.attr A.(bg Color.transparent) cache.image; image =
I.attr
A.(bg Color.(rgbaf ~r:0. ~g:0. ~b:0. ~a:0.000001))
(* TODO: HACK *)
cache.image;
} }
in in
t.cache <- cache; t.cache <- cache;
@ -2182,7 +2200,7 @@ module Nottui = struct
(render_node vg 0. 0. w h w h view).image (render_node vg 0. 0. w h w h view).image
let dispatch_raw_key st keys = let dispatch_raw_key st keys =
let rec iter (st : ui list) : [> `Unhandled ] = let rec iter (st : ui list) : [> `Unhandled | `Moar ] =
match st with match st with
| [] -> `Unhandled | [] -> `Unhandled
| ui :: tl -> ( | ui :: tl -> (
@ -2198,10 +2216,10 @@ module Nottui = struct
| Focus_area (t, f) -> ( | Focus_area (t, f) -> (
match iter [ t ] with match iter [ t ] with
| `Handled -> `Handled | `Handled -> `Handled
| `Unhandled -> ( | `Unhandled | `Moar -> (
match f keys with match f keys with
| `Handled -> `Handled | `Handled -> `Handled
| `Unhandled -> iter tl)) | `Unhandled | `Moar -> iter tl))
| Attr (t, _) | Attr (t, _)
| Mouse_handler (t, _) | Mouse_handler (t, _)
| Size_sensor (t, _) | Size_sensor (t, _)
@ -2214,7 +2232,7 @@ module Nottui = struct
| Event_filter (t, f) -> ( | Event_filter (t, f) -> (
match f (`Keys keys) with match f (`Keys keys) with
| `Unhandled -> iter (t :: tl) | `Unhandled -> iter (t :: tl)
| `Handled -> `Handled)) | a -> a))
in in
iter [ st.view ] iter [ st.view ]
@ -2305,25 +2323,24 @@ module Nottui = struct
let rec dispatch_key st (keys : Ui.keys) = let rec dispatch_key st (keys : Ui.keys) =
match (dispatch_raw_key st keys, keys) with match (dispatch_raw_key st keys, keys) with
| `Handled, _ -> `Handled | `Handled, _ -> `Handled
| `Unhandled, [ (`Arrow dir, []) ] -> | _, [ (`Arrow dir, []) ] ->
let dir : [ `Down | `Left | `Right | `Up ] :> let dir : [ `Down | `Left | `Right | `Up ] :>
[ `Down | `Left | `Right | `Up | `Next | `Prev ] = [ `Down | `Left | `Right | `Up | `Next | `Prev ] =
dir dir
in in
dispatch_key st [ (`Focus dir, [ `Meta ]) ] dispatch_key st [ (`Focus dir, [ `Meta ]) ]
| `Unhandled, [ (`Tab, mods) ] | _, [ (`Tab, mods) ] when mods == [] || mods = [ `Shift ] ->
when mods == [] || mods = [ `Shift ] ->
dispatch_key st dispatch_key st
[ [
( `Focus (if List.mem `Shift mods then `Prev else `Next), ( `Focus (if List.mem `Shift mods then `Prev else `Next),
mods ); mods );
] ]
| `Unhandled, [ (`Focus dir, _) ] -> | _, [ (`Focus dir, _) ] ->
let r = dispatch_focus st.view dir in let r = dispatch_focus st.view dir in
(if r then Log.debug else Log.warn) (fun m -> (if r then Log.debug else Log.warn) (fun m ->
m "Renderer.dispatch_focus key:%a -> %b" pp_keys keys r); m "Renderer.dispatch_focus key:%a -> %b" pp_keys keys r);
if r then `Handled else `Unhandled if r then `Handled else `Unhandled
| `Unhandled, _ -> `Unhandled | a, _ -> a
let dispatch_event t = function let dispatch_event t = function
| `Keys keys -> dispatch_key t keys | `Keys keys -> dispatch_key t keys
@ -2399,12 +2416,12 @@ module Nottui_lwt = struct
match match
Renderer.dispatch_event renderer (`Keys !key_list) Renderer.dispatch_event renderer (`Keys !key_list)
with with
| `Handled -> key_list := [] | `Handled | `Unhandled -> key_list := []
| `Unhandled -> ()) | `Moar -> ())
| #Ui.event as event -> ( | #Ui.event as event -> (
match Renderer.dispatch_event renderer event with match Renderer.dispatch_event renderer event with
| `Handled -> () | `Handled -> ()
| `Unhandled -> | `Moar | `Unhandled ->
Log.warn (fun m -> Log.warn (fun m ->
m m
"Nottui_lwt.render process_event #Ui.event -> \ "Nottui_lwt.render process_event #Ui.event -> \
@ -2482,6 +2499,10 @@ module Widgets = struct
List.mem List.mem
(`Uchar (Uchar.of_char 'g'), [ `Ctrl ]) (`Uchar (Uchar.of_char 'g'), [ `Ctrl ])
k' k'
||
match k' with
| [ (`Escape, []) ] -> true
| _ -> false
then `Handled then `Handled
else `Unhandled else `Unhandled
| _ -> `Unhandled) | _ -> `Unhandled)
@ -3186,6 +3207,7 @@ module Widgets = struct
Lwd_table.append' table (Focus.make (), step)) Lwd_table.append' table (Focus.make (), step))
treelist; treelist;
let cursor = Lwd.var @@ Lwd_table.first table in let cursor = Lwd.var @@ Lwd_table.first table in
Log.debug (fun m -> m "tree_nav cursor focus.request");
Lwd.peek cursor Lwd.peek cursor
|> Option.iter (fun cursor -> |> Option.iter (fun cursor ->
Lwd_table.get cursor Lwd_table.get cursor
@ -3194,8 +3216,17 @@ module Widgets = struct
(Lwd_table.map_reduce (Lwd_table.map_reduce
(fun _ (f, s) -> (fun _ (f, s) ->
Lwd.map (Focus.status f) ~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 Ui.keyboard_area ~focus:focus_h
else string s)) (fun k ->
Log.debug (fun m ->
m
"keyboard_area: tree_nav map_reduce \
%a->`Unhandled"
Ui.pp_keys k);
`Unhandled)
(if Focus.has_focus focus_h then
string ~attr:A.cursor s
else string s)))
(Lwd_utils.lift_monoid Ui.pack_y) (Lwd_utils.lift_monoid Ui.pack_y)
table table
|> Lwd.join |> Lwd.join
@ -3321,7 +3352,6 @@ module Widgets = struct
Lwt.return_unit) Lwt.return_unit)
let h_node_area ?(table = Lwd_table.make ()) let h_node_area ?(table = Lwd_table.make ())
?(focus = Focus.make ())
((store, paths) : Nav.S.t * Nav.path list) : Ui.t Lwd.t = ((store, paths) : Nav.S.t * Nav.path list) : Ui.t Lwd.t =
List.iter List.iter
(fun path -> (fun path ->
@ -3334,14 +3364,6 @@ module Widgets = struct
(Lwd_utils.lift_monoid Ui.pack_x) (Lwd_utils.lift_monoid Ui.pack_x)
table table
|> Lwd.join |> 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_keys k);
match k with
| [ (`Enter, []) ] -> `Unhandled
| _ -> `Unhandled))
(** 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