From f46dc86c6a2540100e9d131f0f653ae87278d327 Mon Sep 17 00:00:00 2001 From: cqc Date: Mon, 19 Feb 2024 16:41:11 -0600 Subject: [PATCH] init.ml --- dune | 2 +- notes.org | 4 +++ oplevel.ml | 95 ++++++++++++++++++++++++++++++++++++++++++++++++---- store.ml | 4 +-- toplevel.ml | 78 ++++++------------------------------------ toplevel.mli | 11 +++++- 6 files changed, 116 insertions(+), 78 deletions(-) diff --git a/dune b/dune index c1c9d2a..9705757 100644 --- a/dune +++ b/dune @@ -37,7 +37,7 @@ js_of_ocaml-lwt.graphics js_of_ocaml-ppx uucp - httpaf) + httpaf) (flags (:standard -rectypes -warn-error -A)) (link_flags diff --git a/notes.org b/notes.org index ae9dfef..bbf4640 100644 --- a/notes.org +++ b/notes.org @@ -1,3 +1,7 @@ +* run with +dune build ./oplevel.bc.js; dune exec ./cors_proxy.exe + + * Test run with git where it was authorizied Listening on localhost:8080 and proxying requests via https://gitea.departmentofinter.net. diff --git a/oplevel.ml b/oplevel.ml index 0b79529..804f34d 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -10,17 +10,30 @@ let by_id_coerce s f = (f (Dom_html.getElementById s)) (fun () -> raise Not_found) -let do_by_id s f = - try f (Dom_html.getElementById s) with Not_found -> () +let resize ~container ~textbox () = + Lwt.pause () >>= fun () -> + textbox##.style##.height := Js.string "auto"; + textbox##.style##.height + := Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight)); + container##.scrollTop := container##.scrollHeight; + Lwt.return () let _ = Dom_html.window##.onload := Dom_html.handler (fun _ -> Lwt.async (fun () -> let output = by_id "output" in - let rootstore = Store.test_pull () in - rootstore >>= fun rs -> - (try Store.S.Tree.get rs [ ".config"; "init.ml" ] with + let container = by_id "toplevel-container" in + + let textbox : 'a Js.t = + by_id_coerce "userinput" Dom_html.CoerceTo.textarea + in + let rootrepo = Store.test_pull () in + rootrepo >>= fun (upstream, t) -> + Store.S.tree t >>= fun rootstore -> + (try + Store.S.Tree.get rootstore [ ".config"; "init.ml" ] + with | Not_found | Invalid_argument _ -> Lwt.return "print_newline \"rootstore://.config/init.ml not \ @@ -32,7 +45,77 @@ let _ = exc; Lwt.return ";;") >>= fun init -> - Toplevel.run ~init ~output (); + let execute = ref (Toplevel.run ~init ~output ()) in + let meta e = + let b = Js.to_bool in + b e##.ctrlKey || b e##.altKey || b e##.metaKey + in + let shift e = Js.to_bool e##.shiftKey in + (* setup handlers *) + textbox##.onkeyup := + Dom_html.handler (fun _ -> + Lwt.async (resize ~container ~textbox); + Js._true); + textbox##.onchange := + Dom_html.handler (fun _ -> + Lwt.async (resize ~container ~textbox); + Js._true); + textbox##.onkeydown := + Dom_html.handler + Dom_html.Keyboard_code.( + fun e -> + match of_key_code e##.keyCode with + | Enter when not (meta e || shift e) -> + Lwt.async (fun () -> + !execute + (Js.to_string textbox##.value##trim) + ()); + Js._false + | Enter -> + Lwt.async (resize ~container ~textbox); + Js._true + | Tab -> + Indent.textarea textbox; + Js._false + | KeyL when meta e -> + output##.innerHTML := Js.string ""; + Js._true + | KeyK when meta e -> + Lwt.async + Store.S.( + fun () -> + rootrepo >>= fun (upstream, t) -> + Sync.pull_exn t upstream `Set + >>= fun _ -> + Firebug.console##log + (Js.string "Nav.test_pull(6)\n"); + tree t >>= fun rs -> + (try + Store.S.Tree.get rs + [ ".config"; "init.ml" ] + with + | Not_found | Invalid_argument _ -> + Lwt.return + "print_newline \ + \"rootstore://.config/init.ml \ + not found\";;" + | exc -> + Firebug.console##log_3 + (Js.string + ".config/init.ml load \ + exception") + (Js.string + (Printexc.to_string exc)) + exc; + Lwt.return ";;") + >>= fun init -> + Lwt.return + (execute := + Toplevel.run ~init ~output ())); + Js._false + (* | ArrowUp -> history_up e + | ArrowDown -> history_down e *) + | _ -> Js._true); Lwt.return_unit); Js._false) diff --git a/store.ml b/store.ml index 8d4f8e1..a20b0b9 100644 --- a/store.ml +++ b/store.ml @@ -355,7 +355,7 @@ let test_populate () : t Lwt.t = >>= add [ "hello"; "daddy" ] "ily" >>= add [ "beep"; "beep" ] "motherfucker" -let test_pull () : t Lwt.t = +let test_pull () : (Irmin.remote * Sync.db) Lwt.t = (* test_populate ()*) Firebug.console##log (Js.string "Nav.test_pull()\n"); S.Repo.v (Config.init "") >>= fun repo -> @@ -378,5 +378,5 @@ let test_pull () : t Lwt.t = Firebug.console##log (Js.string "Nav.test_pull(5)\n"); Sync.pull_exn t upstream `Set >>= fun _ -> Firebug.console##log (Js.string "Nav.test_pull(6)\n"); - S.tree t + Lwt.return (upstream, t) (* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *) diff --git a/toplevel.ml b/toplevel.ml index c998433..5bf36fd 100644 --- a/toplevel.ml +++ b/toplevel.ml @@ -377,7 +377,8 @@ module History = struct textbox##.value := Js.string !data.(!idx)) end -let run ~init ~output () = +let run ~init ~output () : + ?pp_code:Format.formatter -> string -> unit -> unit Lwt.t = Firebug.console##log "run"; let container = by_id "toplevel-container" in @@ -410,66 +411,6 @@ let run ~init ~output () = textbox##focus; Lwt.return_unit in - let history_down _e = - let txt = Js.to_string textbox##.value in - let pos = textbox##.selectionStart in - try - if String.length txt = pos then raise Not_found; - let _ = String.index_from txt pos '\n' in - Js._true - with Not_found -> - History.current txt; - History.next textbox; - Js._false - in - let history_up _e = - let txt = Js.to_string textbox##.value in - let pos = textbox##.selectionStart - 1 in - try - if pos < 0 then raise Not_found; - let _ = String.rindex_from txt pos '\n' in - Js._true - with Not_found -> - History.current txt; - History.previous textbox; - Js._false - in - let meta e = - let b = Js.to_bool in - b e##.ctrlKey || b e##.altKey || b e##.metaKey - in - let shift e = Js.to_bool e##.shiftKey in - (* setup handlers *) - textbox##.onkeyup := - Dom_html.handler (fun _ -> - Lwt.async (resize ~container ~textbox); - Js._true); - textbox##.onchange := - Dom_html.handler (fun _ -> - Lwt.async (resize ~container ~textbox); - Js._true); - textbox##.onkeydown := - Dom_html.handler (fun e -> - match e##.keyCode with - | 13 when not (meta e || shift e) -> - Lwt.async (fun () -> - execute (Js.to_string textbox##.value##trim) ()); - Js._false - | 13 -> - Lwt.async (resize ~container ~textbox); - Js._true - | 09 -> - Indent.textarea textbox; - Js._false - | 76 when meta e -> - output##.innerHTML := Js.string ""; - Js._true - | 75 when meta e -> - setup_toplevel (); - Js._false - | 38 -> history_up e - | 40 -> history_down e - | _ -> Js._true); (Lwt.async_exception_hook := fun exc -> Format.eprintf "exc during Lwt.async: %s@." @@ -522,14 +463,15 @@ let run ~init ~output () = (Js.string ".config/init.ml exception") (Js.string (Printexc.to_string exc)) exc); - try - let code = List.assoc "code" (parse_hash ()) in - textbox##.value := Js.string (B64.decode code); - Lwt.async (fun () -> - execute (Js.to_string textbox##.value##trim) ()) - with + (try + let code = List.assoc "code" (parse_hash ()) in + textbox##.value := Js.string (B64.decode code); + Lwt.async (fun () -> + execute (Js.to_string textbox##.value##trim) ()) + with | Not_found -> () | exc -> Firebug.console##log_3 (Js.string "exception") (Js.string (Printexc.to_string exc)) - exc + exc); + execute diff --git a/toplevel.mli b/toplevel.mli index 26bf137..1cda7ed 100644 --- a/toplevel.mli +++ b/toplevel.mli @@ -1,4 +1,13 @@ open Js_of_ocaml open Store -val run : init:string -> output:Dom_html.element Js.t -> unit -> unit +val run : + init:string -> + output:Dom_html.element Js.t -> + unit -> + ?pp_code:Format.formatter -> + string -> + unit -> + unit Lwt.t + +val setup_toplevel : unit -> unit