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

little re-arranging

Browse Source
This commit is contained in:
cqc
2022-11-17 20:16:15 -06:00
parent 3fc8125d42
commit 9d1ccb93b5
3 changed files with 64 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
boot_js.ml
View File

@ -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))

4
dune
View File

@ -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
))

79
human.ml
View File

@ -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