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

use our own glib loop which do not use busy waiting like lablgtk does 

Ignore-this: 12071140b9a724a83be67ae28af0d0ec

darcs-hash:20110920213743-c41ad-9d4d5be7abb46be0172b9f971a6e27745bf2e74c
This commit is contained in:
Jeremie Dimino 2011-09-20 23:37:43 +02:00
parent 7c4194a223
commit ddf0556887
3 changed files with 33 additions and 27 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 Path: src/gtk
CompiledObject: byte CompiledObject: byte
MainIs: uTop_gtk_top.ml MainIs: uTop_gtk_top.ml
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads, lablgtk2 BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads, lablgtk2, lwt.glib
# +-------------------------------------------------------------------+ # +-------------------------------------------------------------------+
# | Doc | # | Doc |

2
_tags
View File

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

32
src/gtk/uTop_gtk.ml
View File

@ -84,14 +84,24 @@ let init_history () =
return () return ()
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| GTK ui | | Glib main loop |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
(* Initializes GTK. *) (* Initializes GTK. *)
let _ = GMain.init () let _ = GMain.init ~setlocale:false ()
(* Start the gtk main loop in another thread. *) (* Glib main loop. *)
let _ = GtkThread.start () let main () =
while true do
Lwt_glib.iter ()
done
(* Start the glib main loop in another thread. *)
let _ = Thread.create main ()
(* +-----------------------------------------------------------------+
| GTK ui |
+-----------------------------------------------------------------+ *)
(* Create the main window. *) (* Create the main window. *)
let window = GWindow.window ~title:"utop" ~width:800 ~height:600 ~allow_shrink:true () let window = GWindow.window ~title:"utop" ~width:800 ~height:600 ~allow_shrink:true ()
@ -125,11 +135,9 @@ let computer_insertion = ref false
(* Exit when the window is closed. *) (* Exit when the window is closed. *)
let _ = let _ =
window#connect#destroy (fun () -> window#connect#destroy (fun () ->
(* Stop GTK. *) (* Destroy the main window immedlatly,
GMain.quit (); because the saving of history may take
(* Destroy the main window a while. *)
immedlatly, because the saving
of history may take a while. *)
window#destroy (); window#destroy ();
exit 0) exit 0)
@ -323,9 +331,9 @@ let rec read_input prompt buffer length =
(* Make the buffer editable. *) (* Make the buffer editable. *)
edit#set_editable true; edit#set_editable true;
let text = Lwt_main.run (
(* Wait for the user to press Return. *) (* Wait for the user to press Return. *)
lwt () = Lwt_condition.wait accept_cond in let () = Lwt_main.run (Lwt_condition.wait accept_cond) in
Mutex.lock edit_mutex; Mutex.lock edit_mutex;
(* Get the user input. *) (* Get the user input. *)
let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in
@ -337,8 +345,6 @@ let rec read_input prompt buffer length =
prompt_start := offset; prompt_start := offset;
prompt_stop := offset; prompt_stop := offset;
Mutex.unlock edit_mutex; Mutex.unlock edit_mutex;
return text
) in
(* Make the buffer uneditable while ocaml is executing things. *) (* Make the buffer uneditable while ocaml is executing things. *)
edit#set_editable false; edit#set_editable false;