it worked but we couldn't figure out how to do the fucking keyboard shortcuts without patching lablgtk3 and understanding a whole bunch of c interface stuff
This commit is contained in:
cqc
320
oplevel.ml
320
oplevel.ml
@ -1,133 +1,201 @@
|
||||
open Js_of_ocaml
|
||||
open Js_of_ocaml_tyxml
|
||||
open Lwt
|
||||
open Store
|
||||
open Lwt.Infix
|
||||
module F = Fmt
|
||||
|
||||
let by_id s = Dom_html.getElementById s
|
||||
let lang_mime_type = "text/x-ocaml"
|
||||
let lang_name = "ocaml"
|
||||
let use_mime_type = true
|
||||
let font_name = "Monospace 12"
|
||||
|
||||
let by_id_coerce s f =
|
||||
Js.Opt.get
|
||||
(f (Dom_html.getElementById s))
|
||||
(fun () -> raise Not_found)
|
||||
let () =
|
||||
Lwt_main.run
|
||||
((* Initializes GTK. *)
|
||||
ignore (GMain.init ());
|
||||
|
||||
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 ()
|
||||
(* Install Lwt<->Glib integration. *)
|
||||
Lwt_glib.install ();
|
||||
|
||||
let appendchild ~container html =
|
||||
Dom.appendChild container (Tyxml_js.To_dom.of_a html)
|
||||
(* Thread which is wakeup when the main window is closed. *)
|
||||
let waiter, wakener = Lwt.wait () in
|
||||
|
||||
let _ =
|
||||
Dom_html.window##.onload
|
||||
:= Dom_html.handler (fun _ ->
|
||||
Lwt.async (fun () ->
|
||||
let output = by_id "output" in
|
||||
let container = by_id "toplevel-container" in
|
||||
appendchild ~container
|
||||
Tyxml_js.Html.(
|
||||
a
|
||||
~a:[ a_class [ "window" ] ]
|
||||
[
|
||||
div
|
||||
~a:[ a_class [ "status" ] ]
|
||||
[ txt "starting..." ];
|
||||
]);
|
||||
let textbox : 'a Js.t =
|
||||
by_id_coerce "userinput" Dom_html.CoerceTo.textarea
|
||||
let language_manager =
|
||||
GSourceView3.source_language_manager ~default:true
|
||||
in
|
||||
|
||||
let lang =
|
||||
if use_mime_type then
|
||||
match
|
||||
language_manager#guess_language
|
||||
~content_type:lang_mime_type ()
|
||||
with
|
||||
| Some x -> x
|
||||
| None ->
|
||||
failwith (F.str "no language for %s" lang_mime_type)
|
||||
else
|
||||
match language_manager#language lang_name with
|
||||
| Some x -> x
|
||||
| None -> failwith (F.str "can't load %s" lang_name)
|
||||
in
|
||||
Store.init_default
|
||||
(F.str "%s/console/rootstore.git" Secrets.giturl)
|
||||
>>= fun 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 found\";;"
|
||||
| exc ->
|
||||
Lwt.return
|
||||
(F.str ".config/init.ml load exception: %s"
|
||||
(Printexc.to_string exc)))
|
||||
>>= fun text ->
|
||||
let source_buffer =
|
||||
GSourceView3.source_buffer ~language:lang ~text
|
||||
?style_scheme:
|
||||
((GSourceView3.source_style_scheme_manager ~default:true)
|
||||
#style_scheme "solarized-dark")
|
||||
~highlight_matching_brackets:true ~highlight_syntax:true ()
|
||||
in
|
||||
|
||||
let win = GWindow.window ~title:"oplevel main" () in
|
||||
(* Quit when the window is closed. *)
|
||||
ignore (win#connect#destroy ~callback:(Lwt.wakeup wakener));
|
||||
(* Show the window. *)
|
||||
win#show ();
|
||||
|
||||
let vbox =
|
||||
GPack.vbox ~spacing:10 ~border_width:15 ~packing:win#add ()
|
||||
in
|
||||
let scroll_edit =
|
||||
GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
|
||||
~packing:vbox#add ()
|
||||
in
|
||||
let edit =
|
||||
GSourceView3.source_view ~source_buffer ~auto_indent:true
|
||||
~insert_spaces_instead_of_tabs:true ~tab_width:2
|
||||
~show_line_numbers:true ~right_margin_position:80
|
||||
~show_right_margin:true (* ~smart_home_end:true *)
|
||||
~packing:scroll_edit#add ~height:500 ~width:650 ()
|
||||
in
|
||||
edit#misc#modify_font_by_name font_name;
|
||||
edit#set_smart_home_end `AFTER;
|
||||
if edit#smart_home_end <> `AFTER then failwith "regret";
|
||||
ignore
|
||||
(edit#connect#undo ~callback:(fun _ -> prerr_endline "undo"));
|
||||
|
||||
let scroll_output =
|
||||
GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
|
||||
~packing:vbox#add ()
|
||||
in
|
||||
let output_buffer = GText.buffer ~text:"loading..." () in
|
||||
let _output_win =
|
||||
GText.view ~buffer:output_buffer ~editable:false
|
||||
~cursor_visible:true ~packing:scroll_output#add ()
|
||||
in
|
||||
F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
|
||||
Toploop.initialize_toplevel_env ();
|
||||
let out_ppf =
|
||||
Format.formatter_of_out_functions
|
||||
Format.
|
||||
{
|
||||
out_string = (fun s _ _ -> output_buffer#insert s);
|
||||
out_flush = (fun () -> ());
|
||||
out_indent =
|
||||
(fun n ->
|
||||
for _ = 0 to n do
|
||||
output_buffer#insert " "
|
||||
done);
|
||||
out_newline = (fun () -> output_buffer#insert "\n");
|
||||
out_spaces =
|
||||
(fun n -> output_buffer#insert (String.make n ' '));
|
||||
}
|
||||
in
|
||||
|
||||
ignore (GtkMain.BindingSet.make "execute");
|
||||
|
||||
let module GToolbox = struct
|
||||
include GToolbox
|
||||
|
||||
(* mk_keys turns keys from a key_combination into a format which can be used in
|
||||
* a GTK+ RC file. *)
|
||||
let mk_keys (mods, c) =
|
||||
let mods =
|
||||
List.map
|
||||
(function
|
||||
| `A -> "<alt>" | `C -> "<control>" | `S -> "<shift>")
|
||||
mods
|
||||
in
|
||||
String.concat "" mods
|
||||
^ String.make 1 (Char.lowercase_ascii c)
|
||||
|
||||
(* Signal creation for shortcuts unfortunately requires us to create an
|
||||
* in-memory gtkrc file which this function do. *)
|
||||
let make_gtkrc_string g_type shortcuts =
|
||||
let sp = Printf.sprintf in
|
||||
let b = Buffer.create 4000 in
|
||||
Buffer.add_string b "binding \"Shortcuts\" {";
|
||||
StdLabels.List.iter shortcuts ~f:(fun t ->
|
||||
ListLabels.iter t.keys ~f:(fun keys ->
|
||||
let keys = mk_keys keys in
|
||||
Buffer.add_string b
|
||||
(sp " bind \"%s\" { \"%s\" () }" keys t.name)));
|
||||
Buffer.add_string b "}";
|
||||
let classname = Gobject.Type.name g_type in
|
||||
Buffer.add_string b
|
||||
(sp "\nclass \"%s\" binding \"Shortcuts\"" classname);
|
||||
Buffer.contents b
|
||||
|
||||
let create_shortcuts ~window:(win : #GWindow.window_skel)
|
||||
~shortcuts ~callback =
|
||||
let win = win#as_window in
|
||||
let g_type = Gobject.get_type win in
|
||||
F.pr "gtkrc_string: %s@.@."
|
||||
(make_gtkrc_string g_type shortcuts);
|
||||
GtkMain.Rc.parse_string (make_gtkrc_string g_type shortcuts);
|
||||
ListLabels.iter shortcuts ~f:(fun t ->
|
||||
let sgn =
|
||||
{
|
||||
GtkSignal.name = t.name;
|
||||
classe = `window;
|
||||
marshaller = GtkSignal.marshal_unit;
|
||||
}
|
||||
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 \
|
||||
found\";;"
|
||||
| exc ->
|
||||
Firebug.console##log_3
|
||||
(Js.string ".config/init.ml load exception")
|
||||
(Js.string (Printexc.to_string exc))
|
||||
exc;
|
||||
Lwt.return ";;")
|
||||
>>= fun init ->
|
||||
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
|
||||
"re-pulling rootstore for init.ml\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);
|
||||
GtkSignal.signal_new t.name g_type
|
||||
[ `ACTION; `RUN_FIRST ];
|
||||
ignore
|
||||
(GtkSignal.connect ~sgn
|
||||
~callback:(fun () -> callback t.message)
|
||||
win))
|
||||
end in
|
||||
GToolbox.create_shortcuts ~window:win
|
||||
~shortcuts:
|
||||
[
|
||||
{
|
||||
name = "Quit";
|
||||
keys = [ ([ `C ], 'q') ];
|
||||
message = `Quit;
|
||||
};
|
||||
{
|
||||
name = "Execute";
|
||||
keys = [ ([ `C ], 'e') ];
|
||||
message = `Execute;
|
||||
};
|
||||
]
|
||||
~callback:(function
|
||||
| `Quit ->
|
||||
F.pr "`Quit@.";
|
||||
F.pf out_ppf "`Quit@.";
|
||||
Lwt.wakeup wakener ()
|
||||
| `Execute ->
|
||||
F.pr "`Execute@.";
|
||||
F.pf out_ppf "`Execute@.";
|
||||
ignore
|
||||
(Toploop.use_input out_ppf
|
||||
(String (source_buffer#get_text ()))));
|
||||
|
||||
Js._false)
|
||||
(* ignore
|
||||
(Toploop.use_input out_ppf
|
||||
(String "#use \"topfind\";;\n#list;;")); *)
|
||||
output_buffer#set_text "";
|
||||
ignore (Toploop.use_input out_ppf (String text));
|
||||
(* Wait for it to be closed. *)
|
||||
waiter)
|
||||
|
||||
Reference in New Issue
Block a user