diff --git a/boot_js.ml b/boot_js.ml index afbb306..efafb9c 100644 --- a/boot_js.ml +++ b/boot_js.ml @@ -3,10 +3,12 @@ open Lwt.Infix module NVG = Graphv_webgl let _ = - Logs.set_reporter (Human.Logs_browser.console_reporter ()); + Logs.set_reporter (Human.Logs_reporter.console_reporter ()); Logs.set_level (Some Debug); Logs.debug (fun m -> m "hello") +module Log = (val Logs.src_log Logs.default : Logs.LOG) + (* This scales the canvas to match the DPI of the window, it prevents blurriness when rendering to the canvas *) let scale_canvas (canvas : Dom_html.canvasElement Js.t) = @@ -95,7 +97,9 @@ let _ = Human.Panel.Ui.( render_lwt vg Gg.P2.o (Human.Event_js.evt_of_jskey `Press ev)) - >>= fun () -> + >>= fun p -> + Logs.debug (fun m -> + m "Drawing finished at point: %a" Gg.V2.pp p); NVG.end_frame vg; Lwt.return_unit)) diff --git a/dune b/dune index 4ca3ef9..1ddb754 100644 --- a/dune +++ b/dune @@ -16,16 +16,16 @@ graphv_webgl js_of_ocaml-lwt digestif.ocaml + checkseum.ocaml irmin.mem git irmin-git - httpaf - cohttp cohttp-lwt-jsoo mimic uri zed gg + wall )) diff --git a/human.ml b/human.ml index c47c022..6fa427a 100644 --- a/human.ml +++ b/human.ml @@ -1,5 +1,11 @@ (* +names?: + - universal tool, unitool [was thinking about how this is trying to unify a lot of my "tools for thought"] + * because it has always bothered me that it's easier to use google search as a calculator than the purpose built app!!!!!!!! + - universal console, unicon (UNICOrN) [unicon is nice ;3] + + describe exactly every case you can think of that you want this drawing and layout system to handle: * draw text on variously coloured backgrounds that can be defined locally or globally @@ -32,13 +38,11 @@ open Js_of_ocaml module F = Fmt module NVG = Graphv_webgl -module Logs_browser = struct +module Logs_reporter = struct (* Console reporter *) open Jsoo_runtime - let console_obj = Js.pure_js_expr "console" - let console : Logs.level -> string -> unit = fun level s -> let meth = @@ -49,7 +53,11 @@ module Logs_browser = struct | Logs.Debug -> "debug" | Logs.App -> "log" in - ignore (Js.meth_call console_obj meth [| Js.string s |]) + ignore + (Js.meth_call + (Js.pure_js_expr "console") + meth + [| Js.string s |]) let ppf, flush = let b = Buffer.create 255 in @@ -60,9 +68,13 @@ module Logs_browser = struct in (Format.formatter_of_buffer b, flush) + let log_buf = Buffer.create 4096 + let console_report _src level ~over k msgf = let k _ = - console level (flush ()); + let s = flush () in + console level s; + Buffer.add_string log_buf s; over (); k () in @@ -76,7 +88,7 @@ module Logs_browser = struct end let _ = - Logs.set_reporter (Logs_browser.console_reporter ()); + Logs.set_reporter (Logs_reporter.console_reporter ()); Logs.set_level (Some Debug); Logs.debug (fun m -> m "hello") @@ -421,6 +433,9 @@ module Nav = struct module Sync = Irmin.Sync.Make (S) type t = S.tree + type tree = t + type step = S.step + type path = step list let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree @@ -435,14 +450,13 @@ module Nav = struct Firebug.console##log (Js.string "Nav.test_pull()\n"); S.Repo.v (Config.init "") >>= fun repo -> Firebug.console##log (Js.string "Nav.test_pull(2)\n"); - S.of_branch repo "main" >>= fun t -> + S.of_branch repo "master" >>= fun t -> Firebug.console##log (Js.string "Nav.test_pull(3)\n"); Git_console_http.connect Mimic.empty >>= fun ctx -> Firebug.console##log (Js.string "Nav.test_pull(4)\n"); let upstream = - S.remote ~ctx "https://localhost:8080/mirage/irmin.git" + S.remote ~ctx "https://localhost:8080/ryugyong/pocketbrain" in - Firebug.console##log (Js.string "Nav.test_pull(5)\n"); Sync.fetch_exn t upstream >>= fun _ -> S.tree t (* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *) @@ -985,13 +999,14 @@ module Panel = struct | `Handler of handler | `Draw of draw ] + and p = P2.t and dir = [ `X | `Y | `Z ] and image = NVG.Image.image and boundary = [ `Char | `Word | `Phrase | `Line | `Page | `Text ] and style = Style.t and handler = node -> Event.t -> Event.t option and draw_context = { vg : NVG.t; style : Style.t } - and draw = draw_context -> P2.t -> P2.t + and draw = draw_context -> p -> p let node_count = ref 0 @@ -1726,22 +1741,40 @@ module Panel = struct F.epr "Unhandled event: %s@." (Event.to_string _e)); Draw.node { vg; style = Style.dark } p t - let storetree = ref (Nav.test_pull ()) - let storecursor = ref [] + (* I feel like the Wall module from github.com/let-def/wall includes another layer on top + of the drawing functions, missing from graphv, that + specificall allows the composability and cache-ability i want, so instead of writing in from + scratch i will try to steal it. + *) + + module View = struct + open Lwt.Infix + + let tree = ref (Nav.test_pull ()) + let cursor = ref [] + + let contents tree = + Nav.S.Tree.list tree !cursor >>= fun l -> + Lwt.return + (String.concat "\n" (List.map (fun (step, _t') -> step) l)) + + type t = { tree : Nav.tree; mutable cursor : Nav.step } + + let draw (vg, p) tree : p Lwt.t = + contents tree >>= fun contents -> + Lwt.return (Draw.node vg p (textedit (Text.lines contents))) + end open Lwt.Infix - let render_lwt (vg : NVG.t) (p : P2.t) (_ev : Event.t) : - unit Lwt.t = - !storetree >>= fun tree -> - Nav.S.Tree.list tree !storecursor >>= fun l -> - let contents = - String.concat "\n" (List.map (fun (step, _t') -> step) l) - in - - Draw.node { vg; style = Style.dark } p (Text.lines contents) - |> ignore; - Lwt.return_unit + let render_lwt (vg : NVG.t) (p : p) (_ev : Event.t) : p Lwt.t = + let t = { vg; style = Style.dark } in + !View.tree >>= fun tree -> + View.draw (t, p) tree >>= fun p -> + let module Buffer = Stdlib.Buffer in + Lwt.return + (Draw.node t p + (Text.lines (Buffer.contents Logs_reporter.log_buf))) end end