little re-arranging
This commit is contained in:
@ -3,10 +3,12 @@ open Lwt.Infix
|
|||||||
module NVG = Graphv_webgl
|
module NVG = Graphv_webgl
|
||||||
|
|
||||||
let _ =
|
let _ =
|
||||||
Logs.set_reporter (Human.Logs_browser.console_reporter ());
|
Logs.set_reporter (Human.Logs_reporter.console_reporter ());
|
||||||
Logs.set_level (Some Debug);
|
Logs.set_level (Some Debug);
|
||||||
Logs.debug (fun m -> m "hello")
|
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,
|
(* This scales the canvas to match the DPI of the window,
|
||||||
it prevents blurriness when rendering to the canvas *)
|
it prevents blurriness when rendering to the canvas *)
|
||||||
let scale_canvas (canvas : Dom_html.canvasElement Js.t) =
|
let scale_canvas (canvas : Dom_html.canvasElement Js.t) =
|
||||||
@ -95,7 +97,9 @@ let _ =
|
|||||||
Human.Panel.Ui.(
|
Human.Panel.Ui.(
|
||||||
render_lwt vg Gg.P2.o
|
render_lwt vg Gg.P2.o
|
||||||
(Human.Event_js.evt_of_jskey `Press ev))
|
(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;
|
NVG.end_frame vg;
|
||||||
Lwt.return_unit))
|
Lwt.return_unit))
|
||||||
|
|
||||||
|
|||||||
4
dune
4
dune
@ -16,16 +16,16 @@
|
|||||||
graphv_webgl
|
graphv_webgl
|
||||||
js_of_ocaml-lwt
|
js_of_ocaml-lwt
|
||||||
digestif.ocaml
|
digestif.ocaml
|
||||||
|
checkseum.ocaml
|
||||||
irmin.mem
|
irmin.mem
|
||||||
git
|
git
|
||||||
irmin-git
|
irmin-git
|
||||||
httpaf
|
|
||||||
cohttp
|
|
||||||
cohttp-lwt-jsoo
|
cohttp-lwt-jsoo
|
||||||
mimic
|
mimic
|
||||||
uri
|
uri
|
||||||
zed
|
zed
|
||||||
gg
|
gg
|
||||||
|
wall
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
||||||
|
|||||||
79
human.ml
79
human.ml
@ -1,4 +1,10 @@
|
|||||||
(*
|
(*
|
||||||
|
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:
|
describe exactly every case you can think of that you want this drawing and layout system to handle:
|
||||||
|
|
||||||
@ -32,13 +38,11 @@ open Js_of_ocaml
|
|||||||
module F = Fmt
|
module F = Fmt
|
||||||
module NVG = Graphv_webgl
|
module NVG = Graphv_webgl
|
||||||
|
|
||||||
module Logs_browser = struct
|
module Logs_reporter = struct
|
||||||
(* Console reporter *)
|
(* Console reporter *)
|
||||||
|
|
||||||
open Jsoo_runtime
|
open Jsoo_runtime
|
||||||
|
|
||||||
let console_obj = Js.pure_js_expr "console"
|
|
||||||
|
|
||||||
let console : Logs.level -> string -> unit =
|
let console : Logs.level -> string -> unit =
|
||||||
fun level s ->
|
fun level s ->
|
||||||
let meth =
|
let meth =
|
||||||
@ -49,7 +53,11 @@ module Logs_browser = struct
|
|||||||
| Logs.Debug -> "debug"
|
| Logs.Debug -> "debug"
|
||||||
| Logs.App -> "log"
|
| Logs.App -> "log"
|
||||||
in
|
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 ppf, flush =
|
||||||
let b = Buffer.create 255 in
|
let b = Buffer.create 255 in
|
||||||
@ -60,9 +68,13 @@ module Logs_browser = struct
|
|||||||
in
|
in
|
||||||
(Format.formatter_of_buffer b, flush)
|
(Format.formatter_of_buffer b, flush)
|
||||||
|
|
||||||
|
let log_buf = Buffer.create 4096
|
||||||
|
|
||||||
let console_report _src level ~over k msgf =
|
let console_report _src level ~over k msgf =
|
||||||
let k _ =
|
let k _ =
|
||||||
console level (flush ());
|
let s = flush () in
|
||||||
|
console level s;
|
||||||
|
Buffer.add_string log_buf s;
|
||||||
over ();
|
over ();
|
||||||
k ()
|
k ()
|
||||||
in
|
in
|
||||||
@ -76,7 +88,7 @@ module Logs_browser = struct
|
|||||||
end
|
end
|
||||||
|
|
||||||
let _ =
|
let _ =
|
||||||
Logs.set_reporter (Logs_browser.console_reporter ());
|
Logs.set_reporter (Logs_reporter.console_reporter ());
|
||||||
Logs.set_level (Some Debug);
|
Logs.set_level (Some Debug);
|
||||||
Logs.debug (fun m -> m "hello")
|
Logs.debug (fun m -> m "hello")
|
||||||
|
|
||||||
@ -421,6 +433,9 @@ module Nav = struct
|
|||||||
module Sync = Irmin.Sync.Make (S)
|
module Sync = Irmin.Sync.Make (S)
|
||||||
|
|
||||||
type t = S.tree
|
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
|
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");
|
Firebug.console##log (Js.string "Nav.test_pull()\n");
|
||||||
S.Repo.v (Config.init "") >>= fun repo ->
|
S.Repo.v (Config.init "") >>= fun repo ->
|
||||||
Firebug.console##log (Js.string "Nav.test_pull(2)\n");
|
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");
|
Firebug.console##log (Js.string "Nav.test_pull(3)\n");
|
||||||
Git_console_http.connect Mimic.empty >>= fun ctx ->
|
Git_console_http.connect Mimic.empty >>= fun ctx ->
|
||||||
Firebug.console##log (Js.string "Nav.test_pull(4)\n");
|
Firebug.console##log (Js.string "Nav.test_pull(4)\n");
|
||||||
let upstream =
|
let upstream =
|
||||||
S.remote ~ctx "https://localhost:8080/mirage/irmin.git"
|
S.remote ~ctx "https://localhost:8080/ryugyong/pocketbrain"
|
||||||
in
|
in
|
||||||
|
|
||||||
Firebug.console##log (Js.string "Nav.test_pull(5)\n");
|
Firebug.console##log (Js.string "Nav.test_pull(5)\n");
|
||||||
Sync.fetch_exn t upstream >>= fun _ -> S.tree t
|
Sync.fetch_exn t upstream >>= fun _ -> S.tree t
|
||||||
(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)
|
(* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)
|
||||||
@ -985,13 +999,14 @@ module Panel = struct
|
|||||||
| `Handler of handler
|
| `Handler of handler
|
||||||
| `Draw of draw ]
|
| `Draw of draw ]
|
||||||
|
|
||||||
|
and p = P2.t
|
||||||
and dir = [ `X | `Y | `Z ]
|
and dir = [ `X | `Y | `Z ]
|
||||||
and image = NVG.Image.image
|
and image = NVG.Image.image
|
||||||
and boundary = [ `Char | `Word | `Phrase | `Line | `Page | `Text ]
|
and boundary = [ `Char | `Word | `Phrase | `Line | `Page | `Text ]
|
||||||
and style = Style.t
|
and style = Style.t
|
||||||
and handler = node -> Event.t -> Event.t option
|
and handler = node -> Event.t -> Event.t option
|
||||||
and draw_context = { vg : NVG.t; style : Style.t }
|
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
|
let node_count = ref 0
|
||||||
|
|
||||||
@ -1726,22 +1741,40 @@ module Panel = struct
|
|||||||
F.epr "Unhandled event: %s@." (Event.to_string _e));
|
F.epr "Unhandled event: %s@." (Event.to_string _e));
|
||||||
Draw.node { vg; style = Style.dark } p t
|
Draw.node { vg; style = Style.dark } p t
|
||||||
|
|
||||||
let storetree = ref (Nav.test_pull ())
|
(* I feel like the Wall module from github.com/let-def/wall includes another layer on top
|
||||||
let storecursor = ref []
|
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
|
open Lwt.Infix
|
||||||
|
|
||||||
let render_lwt (vg : NVG.t) (p : P2.t) (_ev : Event.t) :
|
let render_lwt (vg : NVG.t) (p : p) (_ev : Event.t) : p Lwt.t =
|
||||||
unit Lwt.t =
|
let t = { vg; style = Style.dark } in
|
||||||
!storetree >>= fun tree ->
|
!View.tree >>= fun tree ->
|
||||||
Nav.S.Tree.list tree !storecursor >>= fun l ->
|
View.draw (t, p) tree >>= fun p ->
|
||||||
let contents =
|
let module Buffer = Stdlib.Buffer in
|
||||||
String.concat "\n" (List.map (fun (step, _t') -> step) l)
|
Lwt.return
|
||||||
in
|
(Draw.node t p
|
||||||
|
(Text.lines (Buffer.contents Logs_reporter.log_buf)))
|
||||||
Draw.node { vg; style = Style.dark } p (Text.lines contents)
|
|
||||||
|> ignore;
|
|
||||||
Lwt.return_unit
|
|
||||||
end
|
end
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user