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
(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 k _ =
let s = flush () in
console level s;
Buffer.add_string log_buf s;
!hook level s;
over ();
k ()
in
@ -1759,8 +1761,6 @@ module Panel = struct
*)
module View = struct
open Lwd
type path = Nav.path
type t = {
@ -1772,14 +1772,27 @@ module Panel = struct
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 of_string = Lwd.map ~f:Text.of_string
end
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)
let of_path path =
Lwd.map2 ~f:join_x
(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 =
Nav.S.Tree.list tree path >>= fun l ->
@ -1790,18 +1803,28 @@ module Panel = struct
cursor = Lwd.var path;
doc =
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;
}
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 =
Lwd.observe
~on_invalidate:(fun _ ->
Log.warn (fun m -> m "View.draw doc_root on_invalidate"))
t.doc
t
in
Lwt.return (Draw.node vg p (Lwd.quick_sample root))
end
@ -1811,10 +1834,13 @@ module Panel = struct
let t = { vg; style = Style.dark } in
Nav.test_pull () >>= fun tree ->
View.of_tree tree >>= fun doc ->
View.draw (t, p) doc >>= fun p ->
Lwt.return
(Draw.node t p
(Text.lines (Stdlib.Buffer.contents Logs_reporter.log_buf)))
View.draw (t, p)
(Lwd_utils.reduce View.pack_y
[
doc.doc;
View.of_path (Lwd.peek doc.cursor);
View.list_logs Logs_reporter.hook;
])
end
end