lwd-ifying it

human.ml

@@ -92,6 +92,7 @@ let _ =
   Logs.set_level (Some Debug);
   Logs.debug (fun m -> m "hello")
 
+module Log = Logs
 module Cohttp_backend = Cohttp_lwt_jsoo
 
 module Git_af = struct
@@ -284,7 +285,10 @@ module Git_console_http = struct
       match git_scheme with
       | `Git | `SSH | `Scheme _ -> Lwt.return_none
       | `HTTP | `HTTPS ->
-          let headers = git_http_headers in
+          let headers =
+            ("content-type", "application/x-git-upload-pack-request")
+            :: git_http_headers
+          in
           let handshake ~uri0 ~uri1 = function
             | T.T flow -> (
                 Firebug.console##log
@@ -450,12 +454,12 @@ 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 "current" >>= 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/console/boot"
+      S.remote ~ctx "https://localhost:8080/console/rootstore.git"
     in
     Firebug.console##log (Js.string "Nav.test_pull(5)\n");
     Sync.fetch_exn t upstream >>= fun _ -> S.tree t
@@ -1747,34 +1751,70 @@ module Panel = struct
        scratch i will try to steal it.
     *)
 
+    (* we need to determine how "document types" should be implemented:
+       * as a module that implements a common interface which allows
+       production of a Ui.t which is then rendered.
+         * this will require exposing the Ui and all drawing related functions.
+         *
+    *)
+
     module View = struct
+      open Lwd
+
+      type path = Nav.path
+
+      type t = {
+        tree : Nav.tree;
+        view : path list Lwd.var;
+        cursor : Nav.path Lwd.var;
+        doc : node Lwd.t;
+      }
+
       open Lwt.Infix
 
-      let tree = ref (Nav.test_pull ())
-      let cursor = ref []
+      module Text = struct
+        let lines = Lwd.map ~f:Text.lines
+        let of_string = Lwd.map ~f:Text.of_string
+      end
 
-      let contents tree =
-        Nav.S.Tree.list tree !cursor >>= fun l ->
+      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_tree ?(path = []) tree =
+        Nav.S.Tree.list tree path >>= fun l ->
         Lwt.return
-          (String.concat "\n" (List.map (fun (step, _t') -> step) l))
+          {
+            tree;
+            view = Lwd.var [ path ];
+            cursor = Lwd.var path;
+            doc =
+              Lwd_utils.map_reduce
+                (fun (step, _t') -> Text.of_string (Lwd.pure step))
+                pack_y l;
+          }
 
-      type t = { tree : Nav.tree; mutable cursor : Nav.step }
+      let draw (vg, p) (t : t) : p Lwt.t =
+        let root =
+          Lwd.observe
+            ~on_invalidate:(fun _ ->
+              Log.warn (fun m -> m "View.draw doc_root on_invalidate"))
+            t.doc
+        in
 
-      let draw (vg, p) tree : p Lwt.t =
-        contents tree >>= fun contents ->
-        Lwt.return (Draw.node vg p (textedit (Text.lines contents)))
+        Lwt.return (Draw.node vg p (Lwd.quick_sample root))
     end
 
     open Lwt.Infix
 
     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
+      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 (Buffer.contents Logs_reporter.log_buf)))
+           (Text.lines (Stdlib.Buffer.contents Logs_reporter.log_buf)))
   end
 end