haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add styles to the GTk ui 

Ignore-this: 79cd2a422f1c45ce08644396abf4c443

darcs-hash:20110920182657-c41ad-1cfb44fa2ff4ff5e01ec4547c480bde62bb639af
This commit is contained in:
Jeremie Dimino 2011-09-20 20:26:57 +02:00
parent 2351c45995
commit 7c4194a223
6 changed files with 369 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
_oasis
View File

@ -62,7 +62,7 @@ Executable "utop-gtk"
Path: src/gtk
CompiledObject: byte
MainIs: uTop_gtk_top.ml
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads, lablgtk2, lwt.glib
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads, lablgtk2
# +-------------------------------------------------------------------+
# | Doc |

2
_tags
View File

@ -10,7 +10,7 @@
<src/**>: use_compiler_libs, pkg_lambda-term, pkg_findlib
<**/*.top>: use_utop
<src/emacs/uTop_emacs_top.top>: pkg_threads
<src/gtk/uTop_gtk_top.top>: pkg_threads, pkg_lablgtk2, pkg_lwt.glib
<src/gtk/uTop_gtk_top.top>: pkg_threads, pkg_lablgtk2
# OASIS_START
# OASIS_STOP

210
src/common/uTop_styles.ml
View File

@ -8,6 +8,9 @@
*)
open Lwt
open UTop_token
module String_set = Set.Make (String)
type styles = {
mutable style_keyword : LTerm_style.t;
@ -82,3 +85,210 @@ let load () =
return ()
with Unix.Unix_error(Unix.ENOENT, _, _) ->
return ()
let stylise stylise tokens =
let rec loop tokens =
match tokens with
| [] ->
()
| (token, start, stop, src) :: rest ->
match token with
| Symbol ->
stylise start stop styles.style_symbol;
loop rest
| Lident ->
stylise start stop
(if String_set.mem src !UTop.keywords then
styles.style_keyword
else
styles.style_ident);
loop rest
| Uident ->
if String_set.mem src !UTop.keywords then begin
stylise start stop styles.style_keyword;
loop rest
end else
loop_after_uident start stop rest
| Constant ->
stylise start stop styles.style_constant;
loop rest
| Char ->
stylise start stop styles.style_char;
loop rest
| String _ ->
stylise start stop styles.style_string;
loop rest
| Quotation _ ->
stylise start stop styles.style_quotation;
loop rest
| Comment _ ->
stylise start stop styles.style_comment;
loop rest
| Doc _ ->
stylise start stop styles.style_doc;
loop rest
| Blanks ->
stylise start stop styles.style_blanks;
loop rest
| Error ->
stylise start stop styles.style_error;
loop rest
and loop_after_uident uid_start uid_stop tokens =
match tokens with
| [] ->
()
| (token, start, stop, src) :: rest ->
match token with
| Symbol ->
if src = "." then
stylise uid_start uid_stop styles.style_module
else
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_symbol;
loop rest
| Lident ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop
(if String_set.mem src !UTop.keywords then
styles.style_keyword
else
styles.style_ident);
loop rest
| Uident ->
stylise uid_start uid_stop styles.style_ident;
if String_set.mem src !UTop.keywords then begin
stylise start stop styles.style_keyword;
loop rest
end else
loop_after_uident start stop rest
| Constant ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_constant;
loop rest
| Char ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_char;
loop rest
| String _ ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_string;
loop rest
| Quotation _ ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_quotation;
loop rest
| Comment _ ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_comment;
loop_after_uident uid_start uid_stop rest
| Doc _ ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_doc;
loop_after_uident uid_start uid_stop rest
| Blanks ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_blanks;
loop_after_uident uid_start uid_stop rest
| Error ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_error;
loop rest
and loop_sharp tokens =
match tokens with
| [] ->
()
| (token, start, stop, src) :: rest ->
match token with
| Symbol ->
if src = "#" then begin
stylise start stop styles.style_directive;
loop_directive rest
end else begin
stylise start stop styles.style_symbol;
loop rest
end
| Lident ->
stylise start stop
(if String_set.mem src !UTop.keywords then
styles.style_keyword
else
styles.style_ident);
loop rest
| Uident ->
if String_set.mem src !UTop.keywords then begin
stylise start stop styles.style_keyword;
loop rest
end else
loop_after_uident start stop rest
| Constant ->
stylise start stop styles.style_constant;
loop rest
| Char ->
stylise start stop styles.style_char;
loop rest
| String _ ->
stylise start stop styles.style_string;
loop rest
| Quotation _ ->
stylise start stop styles.style_quotation;
loop rest
| Comment _ ->
stylise start stop styles.style_comment;
loop_sharp rest
| Doc _ ->
stylise start stop styles.style_doc;
loop_sharp rest
| Blanks ->
stylise start stop styles.style_blanks;
loop_sharp rest
| Error ->
stylise start stop styles.style_error;
loop rest
and loop_directive tokens =
match tokens with
| [] ->
()
| (token, start, stop, src) :: rest ->
match token with
| Symbol ->
stylise start stop styles.style_symbol;
loop rest
| Lident ->
stylise start stop
(if String_set.mem src !UTop.keywords then
styles.style_keyword
else
styles.style_directive);
loop rest
| Uident ->
if String_set.mem src !UTop.keywords then begin
stylise start stop styles.style_keyword;
loop rest
end else
loop_after_uident start stop rest
| Constant ->
stylise start stop styles.style_constant;
loop rest
| Char ->
stylise start stop styles.style_char;
loop rest
| String _ ->
stylise start stop styles.style_string;
loop rest
| Quotation _ ->
stylise start stop styles.style_quotation;
loop rest
| Comment _ ->
stylise start stop styles.style_comment;
loop_directive rest
| Doc _ ->
stylise start stop styles.style_doc;
loop_directive rest
| Blanks ->
stylise start stop styles.style_blanks;
loop_directive rest
| Error ->
stylise start stop styles.style_error;
loop rest
in
loop_sharp tokens

4
src/common/uTop_styles.mli
View File

@ -36,3 +36,7 @@ val styles : styles
val load : unit -> unit Lwt.t
(** Load resources into [styles]. *)
val stylise : (int -> int -> LTerm_style.t -> unit) -> (UTop_token.t * int * int * string) list -> unit
(** [stylise apply tokens] calls [apply] on all tokens boundary with
the associated style. *)

207
src/console/uTop_console.ml
View File

@ -88,212 +88,7 @@ object(self)
styled.(i) <- (ch, LTerm_style.merge token_style style)
done
in
let rec loop tokens =
match tokens with
| [] ->
()
| (token, start, stop, src) :: rest ->
match token with
| Symbol ->
stylise start stop styles.style_symbol;
loop rest
| Lident ->
stylise start stop
(if String_set.mem src !UTop.keywords then
styles.style_keyword
else
styles.style_ident);
loop rest
| Uident ->
if String_set.mem src !UTop.keywords then begin
stylise start stop styles.style_keyword;
loop rest
end else
loop_after_uident start stop rest
| Constant ->
stylise start stop styles.style_constant;
loop rest
| Char ->
stylise start stop styles.style_char;
loop rest
| String _ ->
stylise start stop styles.style_string;
loop rest
| Quotation _ ->
stylise start stop styles.style_quotation;
loop rest
| Comment _ ->
stylise start stop styles.style_comment;
loop rest
| Doc _ ->
stylise start stop styles.style_doc;
loop rest
| Blanks ->
stylise start stop styles.style_blanks;
loop rest
| Error ->
stylise start stop styles.style_error;
loop rest
and loop_after_uident uid_start uid_stop tokens =
match tokens with
| [] ->
()
| (token, start, stop, src) :: rest ->
match token with
| Symbol ->
if src = "." then
stylise uid_start uid_stop styles.style_module
else
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_symbol;
loop rest
| Lident ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop
(if String_set.mem src !UTop.keywords then
styles.style_keyword
else
styles.style_ident);
loop rest
| Uident ->
stylise uid_start uid_stop styles.style_ident;
if String_set.mem src !UTop.keywords then begin
stylise start stop styles.style_keyword;
loop rest
end else
loop_after_uident start stop rest
| Constant ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_constant;
loop rest
| Char ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_char;
loop rest
| String _ ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_string;
loop rest
| Quotation _ ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_quotation;
loop rest
| Comment _ ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_comment;
loop_after_uident uid_start uid_stop rest
| Doc _ ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_doc;
loop_after_uident uid_start uid_stop rest
| Blanks ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_blanks;
loop_after_uident uid_start uid_stop rest
| Error ->
stylise uid_start uid_stop styles.style_ident;
stylise start stop styles.style_error;
loop rest
and loop_sharp tokens =
match tokens with
| [] ->
()
| (token, start, stop, src) :: rest ->
match token with
| Symbol ->
if src = "#" then begin
stylise start stop styles.style_directive;
loop_directive rest
end else begin
stylise start stop styles.style_symbol;
loop rest
end
| Lident ->
stylise start stop
(if String_set.mem src !UTop.keywords then
styles.style_keyword
else
styles.style_ident);
loop rest
| Uident ->
if String_set.mem src !UTop.keywords then begin
stylise start stop styles.style_keyword;
loop rest
end else
loop_after_uident start stop rest
| Constant ->
stylise start stop styles.style_constant;
loop rest
| Char ->
stylise start stop styles.style_char;
loop rest
| String _ ->
stylise start stop styles.style_string;
loop rest
| Quotation _ ->
stylise start stop styles.style_quotation;
loop rest
| Comment _ ->
stylise start stop styles.style_comment;
loop_sharp rest
| Doc _ ->
stylise start stop styles.style_doc;
loop_sharp rest
| Blanks ->
stylise start stop styles.style_blanks;
loop_sharp rest
| Error ->
stylise start stop styles.style_error;
loop rest
and loop_directive tokens =
match tokens with
| [] ->
()
| (token, start, stop, src) :: rest ->
match token with
| Symbol ->
stylise start stop styles.style_symbol;
loop rest
| Lident ->
stylise start stop
(if String_set.mem src !UTop.keywords then
styles.style_keyword
else
styles.style_directive);
loop rest
| Uident ->
if String_set.mem src !UTop.keywords then begin
stylise start stop styles.style_keyword;
loop rest
end else
loop_after_uident start stop rest
| Constant ->
stylise start stop styles.style_constant;
loop rest
| Char ->
stylise start stop styles.style_char;
loop rest
| String _ ->
stylise start stop styles.style_string;
loop rest
| Quotation _ ->
stylise start stop styles.style_quotation;
loop rest
| Comment _ ->
stylise start stop styles.style_comment;
loop_directive rest
| Doc _ ->
stylise start stop styles.style_doc;
loop_directive rest
| Blanks ->
stylise start stop styles.style_blanks;
loop_directive rest
| Error ->
stylise start stop styles.style_error;
loop rest
in
let tokens = UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled) in
loop_sharp tokens;
UTop_styles.stylise stylise (UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled));
(* Parenthesis matching. *)
if not last then LTerm_text.stylise_parenthesis styled position styles.style_paren;

183
src/gtk/uTop_gtk.ml
View File

@ -11,9 +11,13 @@ open Lwt
open Lwt_react
open UTop_styles
(* Logs to the real stderr: *)
(* 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.dup Lwt_unix.stderr)) ()
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. *)
@ -54,6 +58,16 @@ let color_of_term_color default = function
| 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 |
+-----------------------------------------------------------------+ *)
@ -73,19 +87,20 @@ let init_history () =
| GTK ui |
+-----------------------------------------------------------------+ *)
(* Initialization. *)
let () =
(* Initializes GTK. *)
ignore (GMain.init ());
(* Initializes GTK. *)
let _ = GMain.init ()
(* Integrate GLib and Lwt. *)
Lwt_glib.install ()
(* Start the gtk main loop in another thread. *)
let _ = GtkThread.start ()
(* 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:window#add ()
let edit = GText.view ~packing:scrolled_window#add ~editable:false ()
(* The edition buffer. *)
let edit_buffer = edit#buffer
@ -103,12 +118,13 @@ let prompt_stop = ref 0
[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 () ->
(* Prevent lwt from running glib
stuff again. *)
Lwt_glib.remove ();
(* Stop GTK. *)
GMain.quit ();
(* Destroy the main window
@ -120,14 +136,91 @@ let _ =
(* 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_condition.signal accept_cond ();
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
(* +-----------------------------------------------------------------+
| Standard outputs redirections |
+-----------------------------------------------------------------+ *)
@ -138,8 +231,10 @@ let copy ic =
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;
@ -183,9 +278,22 @@ let rec read_input prompt buffer length =
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. *)
prompt_start := edit#buffer#end_iter#offset;
computer_insertion := true;
edit_buffer#insert ~iter:edit_buffer#end_iter ~tags:[frozen] prompt;
computer_insertion := false;
prompt_stop := edit_buffer#end_iter#offset;
Mutex.unlock edit_mutex;
| "* " | " " ->
@ -194,36 +302,59 @@ let rec read_input prompt buffer length =
(* Call hooks. *)
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
(* Insert the prompt. *)
Mutex.lock edit_mutex;
prompt_start := edit#buffer#end_iter#offset;
computer_insertion := true;
edit_buffer#insert ~iter:edit_buffer#end_iter ~tags:[frozen] prompt;
computer_insertion := false;
prompt_stop := edit_buffer#end_iter#offset;
Mutex.unlock edit_mutex
| _ ->
(* 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);
Lwt_main.run (
(* Make the buffer editable. *)
edit#set_editable true;
let text = Lwt_main.run (
(* Wait for the user to press Return. *)
lwt () = Lwt_condition.wait accept_cond in
(* Wait for GTK to add the newline character. *)
lwt () = Lwt_main.yield () in
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;
lwt () = Lwt_log.notice_f "text: %S" text in
return ()
);
return text
) in
(* Make the buffer uneditable while ocaml is executing things. *)
edit#set_editable false;
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
@ -254,16 +385,6 @@ let () =
| Some font -> edit#misc#modify_font_by_name font
| None -> ()
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
(* Set foreground color. *)
let () =
match styles.style_foreground with