start of the GTK ui

Ignore-this: b51ff928e96baaa006c6ffc612196645

darcs-hash:20110920154735-c41ad-1bc3b29f91f26b1436235470bf4de5ef64de6146
This commit is contained in:
Jeremie Dimino 2011-09-20 17:47:35 +02:00
parent 5433a5cdd8
commit 2351c45995
10 changed files with 446 additions and 66 deletions

15
_oasis
View File

@ -15,6 +15,14 @@ Plugins: DevFiles (0.2), META (0.2)
Synopsis: utop
Description: Universal toplevel for OCaml
# +-------------------------------------------------------------------+
# | Flags |
# +-------------------------------------------------------------------+
Flag gtk
Description: Build the GTK interface
Default: false
# +-------------------------------------------------------------------+
# | The toplevel |
# +-------------------------------------------------------------------+
@ -49,6 +57,13 @@ Executable "utop-emacs"
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads
DataFiles: utop.el ($datadir/emacs/site-lisp)
Executable "utop-gtk"
Install: true
Path: src/gtk
CompiledObject: byte
MainIs: uTop_gtk_top.ml
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads, lablgtk2, lwt.glib
# +-------------------------------------------------------------------+
# | Doc |
# +-------------------------------------------------------------------+

1
_tags
View File

@ -10,6 +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
# OASIS_START
# OASIS_STOP

84
src/common/uTop_styles.ml Normal file
View File

@ -0,0 +1,84 @@
(*
* uTop_styles.ml
* --------------
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
* Licence : BSD3
*
* This file is a part of utop.
*)
open Lwt
type styles = {
mutable style_keyword : LTerm_style.t;
mutable style_symbol : LTerm_style.t;
mutable style_ident : LTerm_style.t;
mutable style_module : LTerm_style.t;
mutable style_constant : LTerm_style.t;
mutable style_char : LTerm_style.t;
mutable style_string : LTerm_style.t;
mutable style_quotation : LTerm_style.t;
mutable style_comment : LTerm_style.t;
mutable style_doc : LTerm_style.t;
mutable style_blanks : LTerm_style.t;
mutable style_error : LTerm_style.t;
mutable style_directive : LTerm_style.t;
mutable style_paren : LTerm_style.t;
mutable style_font : string option;
mutable style_foreground : LTerm_style.color option;
mutable style_background : LTerm_style.color option;
mutable style_cursor : LTerm_style.color option;
}
let styles = {
style_keyword = LTerm_style.none;
style_symbol = LTerm_style.none;
style_ident = LTerm_style.none;
style_module = LTerm_style.none;
style_constant = LTerm_style.none;
style_char = LTerm_style.none;
style_string = LTerm_style.none;
style_quotation = LTerm_style.none;
style_comment = LTerm_style.none;
style_doc = LTerm_style.none;
style_blanks = LTerm_style.none;
style_error = LTerm_style.none;
style_directive = LTerm_style.none;
style_paren = LTerm_style.none;
style_font = None;
style_foreground = None;
style_background = None;
style_cursor = None;
}
let load () =
try_lwt
lwt res = LTerm_resources.load (Filename.concat LTerm_resources.home ".utoprc") in
styles.style_keyword <- LTerm_resources.get_style "keyword" res;
styles.style_symbol <- LTerm_resources.get_style "symbol" res;
styles.style_ident <- LTerm_resources.get_style "identifier" res;
styles.style_module <- LTerm_resources.get_style "module" res;
styles.style_constant <- LTerm_resources.get_style "constant" res;
styles.style_char <- LTerm_resources.get_style "char" res;
styles.style_string <- LTerm_resources.get_style "string" res;
styles.style_quotation <- LTerm_resources.get_style "quotation" res;
styles.style_comment <- LTerm_resources.get_style "comment" res;
styles.style_doc <- LTerm_resources.get_style "doc" res;
styles.style_blanks <- LTerm_resources.get_style "blanks" res;
styles.style_error <- LTerm_resources.get_style "error" res;
styles.style_directive <- LTerm_resources.get_style "directive" res;
styles.style_paren <- LTerm_resources.get_style "parenthesis" res;
styles.style_font <- (match LTerm_resources.get "font" res with
| "" -> None
| str -> Some str);
styles.style_foreground <- LTerm_resources.get_color "foreground" res;
styles.style_background <- LTerm_resources.get_color "background" res;
styles.style_cursor <- LTerm_resources.get_color "cursor" res;
(match String.lowercase (LTerm_resources.get "profile" res) with
| "light" -> UTop.set_profile UTop.Light
| "dark" -> UTop.set_profile UTop.Dark
| "" -> ()
| str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str)));
return ()
with Unix.Unix_error(Unix.ENOENT, _, _) ->
return ()

View File

@ -0,0 +1,38 @@
(*
* uTop_styles.mli
* ---------------
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
* Licence : BSD3
*
* This file is a part of utop.
*)
(** Styled loaded from ~/.utoprc *)
(** Type of utop styles. *)
type styles = {
mutable style_keyword : LTerm_style.t;
mutable style_symbol : LTerm_style.t;
mutable style_ident : LTerm_style.t;
mutable style_module : LTerm_style.t;
mutable style_constant : LTerm_style.t;
mutable style_char : LTerm_style.t;
mutable style_string : LTerm_style.t;
mutable style_quotation : LTerm_style.t;
mutable style_comment : LTerm_style.t;
mutable style_doc : LTerm_style.t;
mutable style_blanks : LTerm_style.t;
mutable style_error : LTerm_style.t;
mutable style_directive : LTerm_style.t;
mutable style_paren : LTerm_style.t;
mutable style_font : string option;
mutable style_foreground : LTerm_style.color option;
mutable style_background : LTerm_style.color option;
mutable style_cursor : LTerm_style.color option;
}
val styles : styles
(** The styles in use. *)
val load : unit -> unit Lwt.t
(** Load resources into [styles]. *)

View File

@ -15,73 +15,10 @@ open Lwt_react
open LTerm_text
open LTerm_geom
open UTop_token
open UTop_styles
module String_set = Set.Make(String)
(* +-----------------------------------------------------------------+
| Resources |
+-----------------------------------------------------------------+ *)
type styles = {
mutable style_keyword : LTerm_style.t;
mutable style_symbol : LTerm_style.t;
mutable style_ident : LTerm_style.t;
mutable style_module : LTerm_style.t;
mutable style_constant : LTerm_style.t;
mutable style_char : LTerm_style.t;
mutable style_string : LTerm_style.t;
mutable style_quotation : LTerm_style.t;
mutable style_comment : LTerm_style.t;
mutable style_doc : LTerm_style.t;
mutable style_blanks : LTerm_style.t;
mutable style_error : LTerm_style.t;
mutable style_directive : LTerm_style.t;
mutable style_paren : LTerm_style.t;
}
let styles = {
style_keyword = LTerm_style.none;
style_symbol = LTerm_style.none;
style_ident = LTerm_style.none;
style_module = LTerm_style.none;
style_constant = LTerm_style.none;
style_char = LTerm_style.none;
style_string = LTerm_style.none;
style_quotation = LTerm_style.none;
style_comment = LTerm_style.none;
style_doc = LTerm_style.none;
style_blanks = LTerm_style.none;
style_error = LTerm_style.none;
style_directive = LTerm_style.none;
style_paren = LTerm_style.none;
}
let init_resources () =
try_lwt
lwt res = LTerm_resources.load (Filename.concat (try Sys.getenv "HOME" with Not_found -> "") ".utoprc") in
styles.style_keyword <- LTerm_resources.get_style "keyword" res;
styles.style_symbol <- LTerm_resources.get_style "symbol" res;
styles.style_ident <- LTerm_resources.get_style "identifier" res;
styles.style_module <- LTerm_resources.get_style "module" res;
styles.style_constant <- LTerm_resources.get_style "constant" res;
styles.style_char <- LTerm_resources.get_style "char" res;
styles.style_string <- LTerm_resources.get_style "string" res;
styles.style_quotation <- LTerm_resources.get_style "quotation" res;
styles.style_comment <- LTerm_resources.get_style "comment" res;
styles.style_doc <- LTerm_resources.get_style "doc" res;
styles.style_blanks <- LTerm_resources.get_style "blanks" res;
styles.style_error <- LTerm_resources.get_style "error" res;
styles.style_directive <- LTerm_resources.get_style "directive" res;
styles.style_paren <- LTerm_resources.get_style "parenthesis" res;
(match String.lowercase (LTerm_resources.get "profile" res) with
| "light" -> UTop.set_profile UTop.Light
| "dark" -> UTop.set_profile UTop.Dark
| "" -> ()
| str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str)));
return ()
with Unix.Unix_error(Unix.ENOENT, _, _) ->
return ()
(* +-----------------------------------------------------------------+
| History |
+-----------------------------------------------------------------+ *)
@ -89,7 +26,7 @@ let init_resources () =
let history = ref []
let init_history () =
let hist_name = Filename.concat (try Sys.getenv "HOME" with Not_found -> "") ".utop-history" in
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. *)
@ -537,7 +474,7 @@ let init_read_interactive_input () =
lwt () = join [
init_history ();
init_resources ();
UTop_styles.load ();
init_read_interactive_input ();
LTerm_inputrc.load ();
]

View File

@ -2,3 +2,4 @@ UTop_console
UTop_lexer
UTop_token
UTop_complete
UTop_styles

283
src/gtk/uTop_gtk.ml Normal file
View File

@ -0,0 +1,283 @@
(*
* 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
(* Logs to the real 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)) ()
(* 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)
(* +-----------------------------------------------------------------+
| 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 ()
(* +-----------------------------------------------------------------+
| GTK ui |
+-----------------------------------------------------------------+ *)
(* Initialization. *)
let () =
(* Initializes GTK. *)
ignore (GMain.init ());
(* Integrate GLib and Lwt. *)
Lwt_glib.install ()
(* Create the main window. *)
let window = GWindow.window ~title:"utop" ~width:800 ~height:600 ~allow_shrink:true ()
(* Create the edition widget which will contains ocaml output. *)
let edit = GText.view ~packing:window#add ()
(* 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 ()
(* 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
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 ()
(* 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 ();
false)
(* +-----------------------------------------------------------------+
| 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
edit_buffer#insert ~iter ~tags:[frozen] line;
edit_buffer#insert ~iter ~tags:[frozen] "\n";
(* 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;
prompt_start := edit#buffer#end_iter#offset;
edit_buffer#insert ~iter:edit_buffer#end_iter ~tags:[frozen] prompt;
prompt_stop := edit_buffer#end_iter#offset;
Mutex.unlock edit_mutex;
| "* " | " " ->
(* Continuation of the current phrase. *)
(* Call hooks. *)
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
Mutex.lock edit_mutex;
prompt_start := edit#buffer#end_iter#offset;
edit_buffer#insert ~iter:edit_buffer#end_iter ~tags:[frozen] prompt;
prompt_stop := edit_buffer#end_iter#offset;
Mutex.unlock edit_mutex
| _ ->
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 (
(* 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;
Mutex.unlock edit_mutex;
input := text;
pos := 0;
lwt () = Lwt_log.notice_f "text: %S" text in
return ()
);
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 -> ()
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
| 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 ())]
let () = window#show ()

View File

@ -0,0 +1,5 @@
UTop_gtk
UTop_lexer
UTop_token
UTop_complete
UTop_styles

View File

@ -2,6 +2,8 @@
! Copy this file to ~/.utoprc
! Common resources
profile: dark
identifier.foreground: none
module.foreground: x-palegreen
@ -16,3 +18,9 @@ quotation.foreground: x-purple
error.foreground: x-red
directive.foreground: x-lightsteelblue
parenthesis.background: blue
! GTK resources
font: Monospace
foreground: #5fbf77
background: black

View File

@ -2,6 +2,8 @@
! Copy this file to ~/.utoprc
! Common resources
profile: light
identifier.foreground: none
module.foreground: x-forestgreen
@ -16,3 +18,9 @@ quotation.foreground: x-purple
error.foreground: x-red
directive.foreground: x-mediumorchid4
parenthesis.background: light-blue
! GTK resources
font: Monospace
foreground: black
background: white