486 lines
16 KiB
OCaml
486 lines
16 KiB
OCaml
(*
|
|
* uTop_gtk.ml
|
|
* -----------
|
|
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
|
* Licence : BSD3
|
|
*
|
|
* This file is a part of utop.
|
|
*)
|
|
|
|
open Lwt
|
|
open Lwt_react
|
|
open UTop_styles
|
|
|
|
let () = UTop_private.set_ui UTop_private.GTK
|
|
|
|
(* Copy stderr for errors. *)
|
|
let stderr_fd = Unix.dup Unix.stderr
|
|
let stderr = Unix.out_channel_of_descr stderr_fd
|
|
|
|
(* Logs to the original stderr: *)
|
|
let () =
|
|
Lwt_log.default := Lwt_log.channel ~close_mode:`Close ~channel:(Lwt_io.of_fd ~mode:Lwt_io.output (Lwt_unix.of_unix_file_descr ~blocking:true ~set_flags:false stderr_fd)) ()
|
|
|
|
(* Just to prevent ocaml from doing stuppid things with the
|
|
terminal. *)
|
|
let () = Unix.putenv "TERM" "dumb"
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Utils |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
let colors_16 = [|
|
|
(0x00, 0x00, 0x00);
|
|
(0xcd, 0x00, 0x00);
|
|
(0x00, 0xcd, 0x00);
|
|
(0xcd, 0xcd, 0x00);
|
|
(0x00, 0x00, 0xee);
|
|
(0xcd, 0x00, 0xcd);
|
|
(0x00, 0xcd, 0xcd);
|
|
(0xe5, 0xe5, 0xe5);
|
|
(0x7f, 0x7f, 0x7f);
|
|
(0xff, 0x00, 0x00);
|
|
(0x00, 0xff, 0x00);
|
|
(0xff, 0xff, 0x00);
|
|
(0x5c, 0x5c, 0xff);
|
|
(0xff, 0x00, 0xff);
|
|
(0x00, 0xff, 0xff);
|
|
(0xff, 0xff, 0xff);
|
|
|]
|
|
|
|
let color_of_term_color default = function
|
|
| LTerm_style.Default ->
|
|
default ()
|
|
| LTerm_style.Index n ->
|
|
if n >= 0 && n <= 15 then
|
|
let r, g, b = colors_16.(n) in
|
|
`RGB (r * 65535 / 255, g * 65535 / 255, b * 65535 / 255)
|
|
else
|
|
default ()
|
|
| LTerm_style.RGB (r, g, b) ->
|
|
`RGB (r * 65535 / 255, g * 65535 / 255, b * 65535 / 255)
|
|
|
|
let default_foreground () =
|
|
match S.value UTop.profile with
|
|
| UTop.Dark -> `WHITE
|
|
| UTop.Light -> `BLACK
|
|
|
|
let default_background () =
|
|
match S.value UTop.profile with
|
|
| UTop.Dark -> `BLACK
|
|
| UTop.Light -> `WHITE
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| History |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
let history = ref []
|
|
|
|
let init_history () =
|
|
let hist_name = Filename.concat LTerm_resources.home ".utop-history" in
|
|
(* Save history on exit. *)
|
|
Lwt_main.at_exit (fun () -> LTerm_read_line.save_history hist_name !history);
|
|
(* Load history. *)
|
|
lwt h = LTerm_read_line.load_history hist_name in
|
|
history := h;
|
|
return ()
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Glib main loop |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* Initializes GTK. *)
|
|
let _ = GMain.init ~setlocale:false ()
|
|
|
|
let () =
|
|
UTop_private.exec_in_gui :=
|
|
(fun job ->
|
|
ignore (Glib.Timeout.add ~ms:0 ~callback:(fun () -> job (); false)))
|
|
|
|
(* The glib main loop. *)
|
|
let main () =
|
|
while true do
|
|
Lwt_glib.iter true
|
|
done
|
|
|
|
(* Start the glib main loop in another thread. *)
|
|
let _ = Thread.create main ()
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| GTK ui |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* Create the main window. *)
|
|
let window = GWindow.window ~title:"utop" ~width:800 ~height:600 ~allow_shrink:true ()
|
|
|
|
(* The scrolled window which contains the edition widget. *)
|
|
let scrolled_window = GBin.scrolled_window ~packing:window#add ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
|
|
|
|
(* Create the edition widget which will contains ocaml output. *)
|
|
let edit = GText.view ~packing:scrolled_window#add ~editable:false ()
|
|
|
|
(* The edition buffer. *)
|
|
let edit_buffer = edit#buffer
|
|
|
|
(* Uneditable text tag. *)
|
|
let frozen = edit#buffer#create_tag [`EDITABLE false]
|
|
|
|
(* Start of prompt. *)
|
|
let prompt_start = ref 0
|
|
|
|
(* End of prompt. *)
|
|
let prompt_stop = ref 0
|
|
|
|
(* Mutex used to protect access to [edit#buffer], [prompt_start] and
|
|
[prompt_stop]. *)
|
|
let edit_mutex = Mutex.create ()
|
|
|
|
(* [true] iff the current insertion is done by the computer and not by
|
|
the user. *)
|
|
let computer_insertion = ref false
|
|
|
|
(* Exit when the window is closed. *)
|
|
let _ =
|
|
window#connect#destroy (fun () ->
|
|
(* Destroy the main window immedlatly,
|
|
because the saving of history may take
|
|
a while. *)
|
|
window#destroy ();
|
|
exit 0)
|
|
|
|
(* Condition which is signaled when the user press Return. *)
|
|
let accept_cond = Lwt_condition.create ()
|
|
|
|
(* Notification used to notify the main thread that input is
|
|
available. *)
|
|
let notification = Lwt_unix.make_notification (Lwt_condition.signal accept_cond)
|
|
|
|
(* Accept current input when the user press Return. *)
|
|
let _ =
|
|
edit#event#connect#key_press
|
|
(fun ev ->
|
|
if GdkEvent.Key.keyval ev = GdkKeysyms._Return then
|
|
Lwt_unix.send_notification notification;
|
|
false)
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Styling |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* Is there pending data ? *)
|
|
let pending = ref false
|
|
|
|
(* Input sent to ocaml but not yet finished. *)
|
|
let pending_string = ref ""
|
|
|
|
(* Length of pending input, in unicode characters. *)
|
|
let pending_length = ref 0
|
|
|
|
let gdk_color spec = Gdk.Color.alloc ~colormap:edit#misc#colormap spec
|
|
|
|
let tag_of_term_style style =
|
|
let props = [] in
|
|
let props = if LTerm_style.bold style = Some true then `WEIGHT `BOLD :: props else props in
|
|
let props = if LTerm_style.underline style = Some true then `UNDERLINE `SINGLE :: props else props in
|
|
let props =
|
|
if LTerm_style.reverse style = Some true then
|
|
let props =
|
|
match LTerm_style.foreground style with
|
|
| Some color -> `BACKGROUND_GDK (gdk_color (color_of_term_color default_foreground color)) :: props
|
|
| None -> `BACKGROUND_GDK (gdk_color (default_foreground ())) :: props
|
|
in
|
|
let props =
|
|
match LTerm_style.background style with
|
|
| Some color -> `FOREGROUND_GDK (gdk_color (color_of_term_color default_background color)) :: props
|
|
| None -> `FOREGROUND_GDK (gdk_color (default_background ())) :: props
|
|
in
|
|
props
|
|
else
|
|
let props =
|
|
match LTerm_style.foreground style with
|
|
| Some color -> `FOREGROUND_GDK (gdk_color (color_of_term_color default_foreground color)) :: props
|
|
| None -> props
|
|
in
|
|
let props =
|
|
match LTerm_style.background style with
|
|
| Some color -> `BACKGROUND_GDK (gdk_color (color_of_term_color default_background color)) :: props
|
|
| None -> props
|
|
in
|
|
props
|
|
in
|
|
edit_buffer#create_tag props
|
|
|
|
(* Handle buffer modifications. *)
|
|
let changed argv =
|
|
if not !computer_insertion then begin
|
|
Mutex.lock edit_mutex;
|
|
let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in
|
|
(* First remove all tags from the input. *)
|
|
edit_buffer#remove_all_tags ~start ~stop;
|
|
(* Syntax highlighting. *)
|
|
let stylise start stop style =
|
|
let start = !prompt_stop + max 0 (start - !pending_length) and stop = !prompt_stop + stop - !pending_length in
|
|
if start < stop then begin
|
|
let start = edit_buffer#get_iter (`OFFSET start) and stop = edit_buffer#get_iter (`OFFSET stop) in
|
|
edit_buffer#apply_tag ~start ~stop (tag_of_term_style style)
|
|
end
|
|
in
|
|
UTop_styles.stylise stylise (UTop_lexer.lex_string (!pending_string ^ edit_buffer#get_text ~start ~stop ()));
|
|
Mutex.unlock edit_mutex
|
|
end
|
|
|
|
let _ =
|
|
GtkSignal.connect_by_name
|
|
edit_buffer#as_buffer
|
|
~name:"changed"
|
|
~callback:(Gobject.Closure.create changed)
|
|
~after:false
|
|
|
|
(* Insert the prompt. *)
|
|
let insert_prompt ?(locked = true) prompt =
|
|
if locked then Mutex.lock edit_mutex;
|
|
computer_insertion := true;
|
|
let iter = edit_buffer#get_iter (`OFFSET !prompt_start) in
|
|
(* Remove the previous prompt. *)
|
|
if !prompt_start < !prompt_stop then begin
|
|
edit_buffer#delete ~start:iter ~stop:(edit_buffer#get_iter (`OFFSET !prompt_stop))
|
|
end;
|
|
(* Insert the text of the new one. *)
|
|
edit_buffer#insert ~iter ~tags:[frozen] (LTerm_text.to_string prompt);
|
|
(* Update the end of prompt. *)
|
|
prompt_stop := iter#offset;
|
|
(* Stylise it. *)
|
|
let stylise start stop style =
|
|
if start < stop then begin
|
|
let start = edit_buffer#get_iter (`OFFSET (start + !prompt_start)) and stop = edit_buffer#get_iter (`OFFSET (stop + !prompt_start)) in
|
|
edit_buffer#apply_tag ~start ~stop (tag_of_term_style style)
|
|
end
|
|
in
|
|
let rec loop i j style =
|
|
if j = Array.length prompt then
|
|
stylise i j style
|
|
else begin
|
|
let _, style' = prompt.(j) in
|
|
if LTerm_style.equal style style' then
|
|
loop i (j + 1) style
|
|
else begin
|
|
stylise i j style;
|
|
loop j (j + 1) style'
|
|
end
|
|
end
|
|
in
|
|
loop 0 0 LTerm_style.none;
|
|
computer_insertion := false;
|
|
if locked then Mutex.unlock edit_mutex
|
|
|
|
(* The current prompt. *)
|
|
let current_prompt, set_current_prompt = S.create ~eq:(==) (S.const [||])
|
|
|
|
(* Update the prompt when it change. *)
|
|
let () =
|
|
E.keep
|
|
(E.map
|
|
(fun prompt ->
|
|
(* Update it only if we are editing. *)
|
|
if edit#editable then insert_prompt ~locked:true prompt)
|
|
(S.changes (S.switch (S.value current_prompt) (S.changes current_prompt))))
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Standard outputs redirections |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
let copy ic =
|
|
while true do
|
|
let line = input_line ic in
|
|
Mutex.lock edit_mutex;
|
|
(* Insert the line before the prompt. *)
|
|
let iter = edit_buffer#get_iter (`OFFSET !prompt_start) in
|
|
computer_insertion := true;
|
|
edit_buffer#insert ~iter ~tags:[frozen] line;
|
|
edit_buffer#insert ~iter ~tags:[frozen] "\n";
|
|
computer_insertion := false;
|
|
(* Advance the prompt. *)
|
|
let delta = iter#offset - !prompt_start in
|
|
prompt_start := !prompt_start + delta;
|
|
prompt_stop := !prompt_stop + delta;
|
|
Mutex.unlock edit_mutex
|
|
done
|
|
|
|
let redirect fd =
|
|
let fdr, fdw = Unix.pipe () in
|
|
Unix.dup2 fdw fd;
|
|
Unix.close fdw;
|
|
Thread.create copy (Unix.in_channel_of_descr fdr)
|
|
|
|
let _ = redirect Unix.stdout
|
|
let _ = redirect Unix.stderr
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| OCaml integration |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* The text typed by the user. *)
|
|
let input = ref ""
|
|
|
|
(* The position of the text already sent to ocaml in {!input}. *)
|
|
let pos = ref 0
|
|
|
|
let rec read_input prompt buffer length =
|
|
if !pos = String.length !input then begin
|
|
(match prompt with
|
|
| "# " ->
|
|
(* New phrase. *)
|
|
|
|
(* Reset completion. *)
|
|
UTop_complete.reset ();
|
|
|
|
(* Increment the command counter. *)
|
|
UTop_private.set_count (React.S.value UTop_private.count + 1);
|
|
|
|
(* Call hooks. *)
|
|
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
|
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
|
|
|
|
Mutex.lock edit_mutex;
|
|
|
|
(* Add the previous line to the history. *)
|
|
if !pending then begin
|
|
history := LTerm_read_line.add_entry !pending_string !history;
|
|
pending := false;
|
|
pending_string := "";
|
|
pending_length := 0
|
|
end;
|
|
|
|
(* Insert the prompt. *)
|
|
let offset = edit_buffer#end_iter#offset in
|
|
prompt_start := offset;
|
|
prompt_stop := offset;
|
|
insert_prompt ~locked:false (S.value !UTop.prompt);
|
|
|
|
Mutex.unlock edit_mutex;
|
|
|
|
set_current_prompt !UTop.prompt
|
|
|
|
| " " ->
|
|
(* Continuation of the current phrase. *)
|
|
|
|
(* Call hooks. *)
|
|
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
|
|
|
|
(* Insert the prompt. *)
|
|
Mutex.lock edit_mutex;
|
|
let offset = edit_buffer#end_iter#offset in
|
|
prompt_start := offset;
|
|
prompt_stop := offset;
|
|
insert_prompt ~locked:false (S.value !UTop.prompt_continue);
|
|
Mutex.unlock edit_mutex;
|
|
|
|
set_current_prompt !UTop.prompt_continue
|
|
|
|
| "* " ->
|
|
(* Continuation of the current phrase (in a comment). *)
|
|
|
|
(* Call hooks. *)
|
|
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
|
|
|
|
(* Insert the prompt. *)
|
|
Mutex.lock edit_mutex;
|
|
let offset = edit_buffer#end_iter#offset in
|
|
prompt_start := offset;
|
|
prompt_stop := offset;
|
|
insert_prompt ~locked:false (S.value !UTop.prompt_comment);
|
|
Mutex.unlock edit_mutex;
|
|
|
|
set_current_prompt !UTop.prompt_comment
|
|
|
|
| _ ->
|
|
(* Unknown prompt: error. *)
|
|
|
|
let dialog = GWindow.dialog ~title:"error" () in
|
|
ignore (GMisc.label ~text:(Printf.sprintf "unrecognized prompt %S!" prompt) ~packing:dialog#vbox#add ());
|
|
dialog#add_button_stock `OK `OK;
|
|
ignore (dialog#run ());
|
|
exit 1);
|
|
|
|
(* Make the buffer editable. *)
|
|
edit#set_editable true;
|
|
|
|
(* Wait for the user to press Return. *)
|
|
let () = Lwt_main.run (Lwt_condition.wait accept_cond) in
|
|
|
|
(* Make the buffer uneditable while ocaml is executing things. *)
|
|
edit#set_editable false;
|
|
|
|
Mutex.lock edit_mutex;
|
|
(* Get the user input. *)
|
|
let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in
|
|
let text = edit_buffer#get_text ~start ~stop () in
|
|
(* Froze the input. *)
|
|
edit_buffer#apply_tag ~start ~stop frozen;
|
|
(* Advance the prompt. *)
|
|
let offset = stop#offset in
|
|
prompt_start := offset;
|
|
prompt_stop := offset;
|
|
Mutex.unlock edit_mutex;
|
|
|
|
input := text;
|
|
pos := 0;
|
|
|
|
(* Add current input to pending input. *)
|
|
if !pending then begin
|
|
pending_string := !pending_string ^ "\n" ^ text;
|
|
pending_length := !pending_length + 1 + Zed_utf8.length text
|
|
end else begin
|
|
pending := true;
|
|
pending_string := text;
|
|
pending_length := Zed_utf8.length text
|
|
end;
|
|
|
|
read_input prompt buffer length
|
|
end else begin
|
|
(* There is still some pending input. *)
|
|
let i = ref 0 in
|
|
while !i < length && !pos < String.length !input do
|
|
buffer.[!i] <- (!input).[!pos];
|
|
incr i;
|
|
incr pos
|
|
done;
|
|
(!i, false)
|
|
end
|
|
|
|
let () = Toploop.read_interactive_input := read_input
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Initialization |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
lwt () = join [
|
|
init_history ();
|
|
UTop_styles.load ();
|
|
]
|
|
|
|
(* Set the font of the edition buffer. *)
|
|
let () =
|
|
match styles.style_font with
|
|
| Some font -> edit#misc#modify_font_by_name font
|
|
| None -> ()
|
|
|
|
(* Set foreground color. *)
|
|
let () =
|
|
match styles.style_foreground with
|
|
| Some color ->
|
|
edit#misc#modify_text [(`NORMAL, color_of_term_color default_foreground color)]
|
|
| None ->
|
|
edit#misc#modify_text [(`NORMAL, default_foreground ())]
|
|
|
|
(* Set background color. *)
|
|
let () =
|
|
match styles.style_background with
|
|
| Some color ->
|
|
edit#misc#modify_base [(`NORMAL, color_of_term_color default_background color)]
|
|
| None ->
|
|
edit#misc#modify_base [(`NORMAL, default_background ())]
|
|
|
|
(* Show the window in the GUI thread, this is needed for windows. *)
|
|
let () = UTop.exec_in_gui window#show
|