From 2351c45995c36cc496fd382b3dfc3d8baec0d646 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 20 Sep 2011 17:47:35 +0200 Subject: [PATCH] start of the GTK ui Ignore-this: b51ff928e96baaa006c6ffc612196645 darcs-hash:20110920154735-c41ad-1bc3b29f91f26b1436235470bf4de5ef64de6146 --- _oasis | 15 ++ _tags | 1 + src/common/uTop_styles.ml | 84 +++++++++ src/common/uTop_styles.mli | 38 ++++ src/console/uTop_console.ml | 69 +------ src/console/uTop_console_top.mltop | 1 + src/gtk/uTop_gtk.ml | 283 +++++++++++++++++++++++++++++ src/gtk/uTop_gtk_top.mltop | 5 + utoprc-dark | 8 + utoprc-light | 8 + 10 files changed, 446 insertions(+), 66 deletions(-) create mode 100644 src/common/uTop_styles.ml create mode 100644 src/common/uTop_styles.mli create mode 100644 src/gtk/uTop_gtk.ml create mode 100644 src/gtk/uTop_gtk_top.mltop diff --git a/_oasis b/_oasis index 5f74712..9ca94b3 100644 --- a/_oasis +++ b/_oasis @@ -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 | # +-------------------------------------------------------------------+ diff --git a/_tags b/_tags index 818ebba..56a44ca 100644 --- a/_tags +++ b/_tags @@ -10,6 +10,7 @@ : use_compiler_libs, pkg_lambda-term, pkg_findlib <**/*.top>: use_utop : pkg_threads +: pkg_threads, pkg_lablgtk2, pkg_lwt.glib # OASIS_START # OASIS_STOP diff --git a/src/common/uTop_styles.ml b/src/common/uTop_styles.ml new file mode 100644 index 0000000..99a542a --- /dev/null +++ b/src/common/uTop_styles.ml @@ -0,0 +1,84 @@ +(* + * uTop_styles.ml + * -------------- + * Copyright : (c) 2011, Jeremie Dimino + * 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 () diff --git a/src/common/uTop_styles.mli b/src/common/uTop_styles.mli new file mode 100644 index 0000000..7bb31fc --- /dev/null +++ b/src/common/uTop_styles.mli @@ -0,0 +1,38 @@ +(* + * uTop_styles.mli + * --------------- + * Copyright : (c) 2011, Jeremie Dimino + * 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]. *) diff --git a/src/console/uTop_console.ml b/src/console/uTop_console.ml index ea90277..0bd4059 100644 --- a/src/console/uTop_console.ml +++ b/src/console/uTop_console.ml @@ -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 (); ] diff --git a/src/console/uTop_console_top.mltop b/src/console/uTop_console_top.mltop index 9567b66..cea99fe 100644 --- a/src/console/uTop_console_top.mltop +++ b/src/console/uTop_console_top.mltop @@ -2,3 +2,4 @@ UTop_console UTop_lexer UTop_token UTop_complete +UTop_styles diff --git a/src/gtk/uTop_gtk.ml b/src/gtk/uTop_gtk.ml new file mode 100644 index 0000000..8a69b50 --- /dev/null +++ b/src/gtk/uTop_gtk.ml @@ -0,0 +1,283 @@ +(* + * uTop_gtk.ml + * ----------- + * Copyright : (c) 2011, Jeremie Dimino + * 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 () diff --git a/src/gtk/uTop_gtk_top.mltop b/src/gtk/uTop_gtk_top.mltop new file mode 100644 index 0000000..160e569 --- /dev/null +++ b/src/gtk/uTop_gtk_top.mltop @@ -0,0 +1,5 @@ +UTop_gtk +UTop_lexer +UTop_token +UTop_complete +UTop_styles diff --git a/utoprc-dark b/utoprc-dark index c84e81d..c1a0d78 100644 --- a/utoprc-dark +++ b/utoprc-dark @@ -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 diff --git a/utoprc-light b/utoprc-light index a2c6706..d232007 100644 --- a/utoprc-light +++ b/utoprc-light @@ -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