functional text display
This commit is contained in:
cqc
341
oplevel.ml
341
oplevel.ml
@ -1,201 +1,178 @@
|
||||
open Lwt.Infix
|
||||
module F = Fmt
|
||||
open Tgles2
|
||||
module Gv = Graphv_gles2_native
|
||||
|
||||
let lang_mime_type = "text/x-ocaml"
|
||||
let lang_name = "ocaml"
|
||||
let use_mime_type = true
|
||||
let font_name = "Monospace 12"
|
||||
module GLFWExtras = struct
|
||||
open Ctypes
|
||||
open Foreign
|
||||
|
||||
let glfwSetErrorCallback :
|
||||
(int -> string -> unit) -> int -> string -> unit =
|
||||
let errorfun = int @-> string @-> returning void in
|
||||
foreign "glfwSetErrorCallback"
|
||||
(funptr errorfun @-> returning (funptr errorfun))
|
||||
end
|
||||
|
||||
let errorcb error desc =
|
||||
Printf.printf "GLFW error %d: %s\n%!" error desc
|
||||
|
||||
let load_data vg =
|
||||
let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in
|
||||
let _ =
|
||||
Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf"
|
||||
in
|
||||
let _ =
|
||||
Gv.Text.create vg ~name:"sans" ~file:"./assets/Roboto-Regular.ttf"
|
||||
in
|
||||
let _ =
|
||||
Gv.Text.create vg ~name:"sans-bold"
|
||||
~file:"./assets/Roboto-Bold.ttf"
|
||||
in
|
||||
let _ =
|
||||
Gv.Text.create vg ~name:"emoji"
|
||||
~file:"./assets/NotoEmoji-Regular.ttf"
|
||||
in
|
||||
Gv.Text.add_fallback vg ~name:"sans" ~fallback:"emoji";
|
||||
Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji";
|
||||
Gv.Text.set_font_face vg ~name:"mono"
|
||||
|
||||
let () =
|
||||
GLFW.init ();
|
||||
at_exit GLFW.terminate;
|
||||
let _res = GLFWExtras.glfwSetErrorCallback errorcb in
|
||||
GLFW.windowHint ~hint:GLFW.ClientApi ~value:GLFW.OpenGLESApi;
|
||||
GLFW.windowHint ~hint:GLFW.ContextVersionMajor ~value:2;
|
||||
GLFW.windowHint ~hint:GLFW.ContextVersionMinor ~value:0;
|
||||
|
||||
let window =
|
||||
GLFW.createWindow ~width:1000 ~height:600 ~title:"window" ()
|
||||
in
|
||||
(* Make the window's context current *)
|
||||
GLFW.makeContextCurrent ~window:(Some window);
|
||||
GLFW.swapInterval ~interval:0;
|
||||
|
||||
Gl.clear_color 0.3 0.3 0.32 1.;
|
||||
|
||||
Memtrace.trace_if_requested ();
|
||||
|
||||
let ctx =
|
||||
Gv.create ~flags:Gv.CreateFlags.(antialias lor stencil_strokes) ()
|
||||
in
|
||||
|
||||
let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in
|
||||
let _odata = load_data ctx in
|
||||
let continue = ref true in
|
||||
let min_fps = ref Float.max_float in
|
||||
let max_fps = ref Float.min_float in
|
||||
let blowup = ref false in
|
||||
|
||||
(* Thread which is woken up when the main window is closed. *)
|
||||
let _waiter, _wakener = Lwt.wait () in
|
||||
|
||||
Lwt_main.run
|
||||
((* Initializes GTK. *)
|
||||
ignore (GMain.init ());
|
||||
((fun () ->
|
||||
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 ->
|
||||
GLFW.setKeyCallback ~window
|
||||
~f:
|
||||
(Some
|
||||
(fun _ key _ state _ ->
|
||||
match (key, state) with
|
||||
| GLFW.Space, GLFW.Release -> blowup := not !blowup
|
||||
| _ -> ()))
|
||||
|> ignore;
|
||||
|
||||
(* Install Lwt<->Glib integration. *)
|
||||
Lwt_glib.install ();
|
||||
let t = GLFW.getTime () |> ref in
|
||||
while (not GLFW.(windowShouldClose ~window)) && !continue do
|
||||
let now = GLFW.getTime () in
|
||||
let dt = now -. !t in
|
||||
t := now;
|
||||
|
||||
(* Thread which is wakeup when the main window is closed. *)
|
||||
let waiter, wakener = Lwt.wait () in
|
||||
Perfgraph.update graph dt;
|
||||
|
||||
let language_manager =
|
||||
GSourceView3.source_language_manager ~default:true
|
||||
in
|
||||
if now > 2. then (
|
||||
let avg = 1. /. Perfgraph.average graph in
|
||||
min_fps := Float.min avg !min_fps;
|
||||
max_fps := Float.max avg !max_fps);
|
||||
|
||||
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 _mx, _my = GLFW.getCursorPos ~window in
|
||||
let win_w, win_h = GLFW.getWindowSize ~window 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 ();
|
||||
Gl.viewport 0 0 win_w win_h;
|
||||
Gl.clear
|
||||
(Gl.color_buffer_bit lor Gl.depth_buffer_bit
|
||||
lor Gl.stencil_buffer_bit);
|
||||
|
||||
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"));
|
||||
Gl.enable Gl.blend;
|
||||
Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
|
||||
Gl.enable Gl.cull_face_enum;
|
||||
Gl.disable Gl.depth_test;
|
||||
|
||||
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
|
||||
let win_w, win_h = (float win_w, float win_h) in
|
||||
Gv.begin_frame ctx ~width:win_w ~height:win_h
|
||||
~device_ratio:1.;
|
||||
|
||||
ignore (GtkMain.BindingSet.make "execute");
|
||||
Perfgraph.render graph ctx (win_w -. 205.) 5.;
|
||||
|
||||
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
|
||||
let ui =
|
||||
Ogui.Ui.window ctx Gg.(Box2.v P2.o (P2.v 500. 500.))
|
||||
in
|
||||
String.concat "" mods
|
||||
^ String.make 1 (Char.lowercase_ascii c)
|
||||
ignore Ogui.TextEdit.(show (multiline (String text)) ui);
|
||||
(* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
|
||||
Gv.end_frame ctx;
|
||||
|
||||
(* 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
|
||||
Gc.major_slice 0 |> ignore;
|
||||
|
||||
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
|
||||
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 ()))));
|
||||
GLFW.swapBuffers ~window;
|
||||
GLFW.pollEvents ()
|
||||
(*continue := false;*)
|
||||
done;
|
||||
|
||||
(* 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)
|
||||
Printf.printf "MIN %.2f\n" !min_fps;
|
||||
Printf.printf "MAX %.2f\n%!" !max_fps;
|
||||
|
||||
if Array.length Sys.argv = 1 then
|
||||
while not GLFW.(windowShouldClose ~window) do
|
||||
GLFW.pollEvents ();
|
||||
Unix.sleepf 0.25
|
||||
done;
|
||||
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
|
||||
(Toploop.use_input out_ppf
|
||||
(String "#use \"topfind\";;\n#list;;")); *)
|
||||
(* ignore (Toploop.use_input Format.std_formatter (String text)); *)
|
||||
(* Wait for it to be closed. *)
|
||||
Lwt.return ())
|
||||
())
|
||||
|
||||
Reference in New Issue
Block a user