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

looks like shit

Browse Source
This commit is contained in:
cqc
2022-11-22 13:19:51 -06:00
parent 58ec73972b
commit 60c83c608a
1 changed files with 42 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
human.ml
View File

@ -68,13 +68,15 @@ module Logs_reporter = struct
in in
(Format.formatter_of_buffer b, flush) (Format.formatter_of_buffer b, flush)
let log_buf = Buffer.create 4096 let hook =
ref (fun level s ->
ignore (Logs.level_to_string (Some level) ^ ": " ^ s))
let console_report _src level ~over k msgf = let console_report _src level ~over k msgf =
let k _ = let k _ =
let s = flush () in let s = flush () in
console level s; console level s;
Buffer.add_string log_buf s; !hook level s;
over (); over ();
k () k ()
in in
@ -1759,8 +1761,6 @@ module Panel = struct
*) *)
module View = struct module View = struct
open Lwd
type path = Nav.path type path = Nav.path
type t = { type t = {
@ -1772,14 +1772,27 @@ module Panel = struct
open Lwt.Infix open Lwt.Infix
module Text = struct let pack_x = Lwd_utils.lift_monoid (empty_node (), join_x)
let pack_y = Lwd_utils.lift_monoid (empty_node (), join_y)
let pack_z = Lwd_utils.lift_monoid (empty_node (), join_z)
module DText = struct
let lines = Lwd.map ~f:Text.lines let lines = Lwd.map ~f:Text.lines
let of_string = Lwd.map ~f:Text.of_string let of_string = Lwd.map ~f:Text.of_string
end end
let pack_x = Lwd_utils.lift_monoid (empty_node (), join_x) let of_path path =
let pack_y = Lwd_utils.lift_monoid (empty_node (), join_y) Lwd.map2 ~f:join_x
let pack_z = Lwd_utils.lift_monoid (empty_node (), join_z) (DText.of_string (Lwd.pure "/"))
(Lwd_utils.map_reduce
(fun step ->
Lwd_utils.pack
(empty_node (), join_x)
[
DText.of_string (Lwd.pure "/");
DText.of_string (Lwd.pure step);
])
pack_x path)
let of_tree ?(path = []) tree = let of_tree ?(path = []) tree =
Nav.S.Tree.list tree path >>= fun l -> Nav.S.Tree.list tree path >>= fun l ->
@ -1790,18 +1803,28 @@ module Panel = struct
cursor = Lwd.var path; cursor = Lwd.var path;
doc = doc =
Lwd_utils.map_reduce Lwd_utils.map_reduce
(fun (step, _t') -> Text.of_string (Lwd.pure step)) (fun (step, _t') -> DText.of_string (Lwd.pure step))
pack_y l; pack_y l;
} }
let draw (vg, p) (t : t) : p Lwt.t = let list_logs hook =
let var = Lwd.var (empty_node ()) in
(hook :=
fun level s ->
Lwd.set var
(join_y
(Text.of_string
(Logs.level_to_string (Some level) ^ ": " ^ s))
(Lwd.peek var)));
Lwd.get var
let draw (vg, p) (t : node Lwd.t) : p Lwt.t =
let root = let root =
Lwd.observe Lwd.observe
~on_invalidate:(fun _ -> ~on_invalidate:(fun _ ->
Log.warn (fun m -> m "View.draw doc_root on_invalidate")) Log.warn (fun m -> m "View.draw doc_root on_invalidate"))
t.doc t
in in
Lwt.return (Draw.node vg p (Lwd.quick_sample root)) Lwt.return (Draw.node vg p (Lwd.quick_sample root))
end end
@ -1811,10 +1834,13 @@ module Panel = struct
let t = { vg; style = Style.dark } in let t = { vg; style = Style.dark } in
Nav.test_pull () >>= fun tree -> Nav.test_pull () >>= fun tree ->
View.of_tree tree >>= fun doc -> View.of_tree tree >>= fun doc ->
View.draw (t, p) doc >>= fun p -> View.draw (t, p)
Lwt.return (Lwd_utils.reduce View.pack_y
(Draw.node t p [
(Text.lines (Stdlib.Buffer.contents Logs_reporter.log_buf))) doc.doc;
View.of_path (Lwd.peek doc.cursor);
View.list_logs Logs_reporter.hook;
])
end end
end end