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

init.ml

Browse Source
This commit is contained in:
cqc
2024-02-19 16:41:11 -06:00
parent 2e6991f3dc
commit f46dc86c6a
6 changed files with 116 additions and 78 deletions
Download Patch File Download Diff File Expand all files Collapse all files

95
oplevel.ml
View File

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