add styles to the GTk ui

Ignore-this: 79cd2a422f1c45ce08644396abf4c443

darcs-hash:20110920182657-c41ad-1cfb44fa2ff4ff5e01ec4547c480bde62bb639af

_oasis

@@ -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                                                               |

_tags

@@ -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

src/common/uTop_styles.ml

@@ -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

src/common/uTop_styles.mli

@@ -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. *)

src/console/uTop_console.ml

@@ -88,212 +88,7 @@ object(self)
         styled.(i) <- (ch, LTerm_style.merge token_style style)
       done
     in
-    let rec loop tokens =
+    UTop_styles.stylise stylise (UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled));
-      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;
 
     (* Parenthesis matching. *)
     if not last then LTerm_text.stylise_parenthesis styled position styles.style_paren;

src/gtk/uTop_gtk.ml

@@ -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. *)
+(* Initializes GTK. *)
-let () =
+let _ = GMain.init ()
-  (* Initializes GTK. *)
-  ignore (GMain.init ());
 
-  (* Integrate GLib and Lwt. *)
+(* Start the gtk main loop in another thread. *)
-  Lwt_glib.install ()
+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;
+      return text
-      pos := 0;
+    ) in
-      lwt () = Lwt_log.notice_f "text: %S" text in
+
-      return ()
+    (* 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