3 Commits

Author SHA1 Message Date
cqc
60c83c608a looks like shit 2022-11-22 13:19:51 -06:00
cqc
58ec73972b lwd-ifying it 2022-11-22 02:21:45 -06:00
cqc
b705c598ff use main branch 2022-11-17 20:25:20 -06:00
5 changed files with 115 additions and 24 deletions

View File

@ -4,4 +4,4 @@ if [ ! -f /tmp/key.pem ]; then
openssl req -newkey rsa:2048 -new -nodes -x509 -days 3650 -keyout /tmp/key.pem -out /tmp/cert.pem -batch
fi
npx http-server --cors -S -P https://github.com --log-ip -c-1 -C /tmp/cert.pem -K /tmp/key.pem
npx http-server --cors -S -P https://gitea.departmentofinter.net --log-ip -c-1 -C /tmp/cert.pem -K /tmp/key.pem

3
dune
View File

@ -25,7 +25,6 @@
uri
zed
gg
wall
lwd
))

106
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
@ -92,6 +94,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 +287,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 +456,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 "master" >>= 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/ryugyong/pocketbrain"
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 +1753,94 @@ 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
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 []
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 contents tree =
Nav.S.Tree.list tree !cursor >>= fun l ->
module DText = struct
let lines = Lwd.map ~f:Text.lines
let of_string = Lwd.map ~f:Text.of_string
end
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 ->
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') -> DText.of_string (Lwd.pure step))
pack_y l;
}
type t = { tree : Nav.tree; mutable cursor : Nav.step }
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) tree : p Lwt.t =
contents tree >>= fun contents ->
Lwt.return (Draw.node vg p (textedit (Text.lines contents)))
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
in
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
Lwt.return
(Draw.node t p
(Text.lines (Buffer.contents Logs_reporter.log_buf)))
Nav.test_pull () >>= fun tree ->
View.of_tree tree >>= fun doc ->
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

View File

@ -1,4 +1,4 @@
<!DOCTYPE>
<!DOCTYPE html>
<html>
<head>
<style>

26
notes.org Normal file
View File

@ -0,0 +1,26 @@
* mvp todo
** toplevel repl in js_of_ocaml
** git pull from gitea.departmentofinter.net/console/boot
** git push to gitea.departmentofinter.net/console/boot
** execute a git file execution in top level
** display arbitrary git file from pulled repo
** edit arbitrary file with common emacs bindings
*** move left and right by character
*** move up and down by line
* other todo
*** yank (to clipboard) next char
*** move left and right by word and sentance
*** region select
* principles?
an "anywhere" programming environment