use the custom prompt

Ignore-this: 1912534fb4073b2f4774bb09fe977365

darcs-hash:20110921042650-c41ad-9a21b4232ac8e2d13af8b0fc588749de3e161212

src/common/uTop.ml

@@ -15,6 +15,14 @@ open LTerm_style
 
 module String_set = Set.Make(String)
 
+(* +-----------------------------------------------------------------+
+   | UI                                                              |
+   +-----------------------------------------------------------------+ *)
+
+type ui = UTop_private.ui = Console | GTK | Emacs
+
+let get_ui () = S.value UTop_private.ui
+
 (* +-----------------------------------------------------------------+
    | Keywords                                                        |
    +-----------------------------------------------------------------+ *)
@@ -61,73 +69,81 @@ let time = ref 0.
 
 let () = at_new_prompt (fun () -> time := Unix.time ())
 
-let make_prompt profile count size key_sequence (recording, macro_count, macro_counter) =
+let make_prompt ui profile count size key_sequence (recording, macro_count, macro_counter) =
   let tm = Unix.localtime !time in
   let color dark light =
     match profile with
       | Dark -> dark
       | Light -> light
   in
-  let bold = profile = Dark in
+  match ui with
-  let txta =
+    | Emacs ->
-    if key_sequence = [] then
+        [||]
-      eval [
+    | GTK ->
-        B_bold bold;
+        eval [B_fg (color lcyan blue);
-        B_fg (color lcyan blue);
+              S (Printf.sprintf "utop[%d]> " count)]
-        S "─( ";
+    | Console ->
-        B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg;
+        let bold = profile = Dark in
-        S " )─< ";
+        let txta =
-        B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg;
+          if key_sequence = [] then
-        S " >─";
+            eval [
-      ]
+              B_bold bold;
-    else
+              B_fg (color lcyan blue);
-      eval [
+              S "─( ";
-        B_bold bold;
+              B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg;
-        B_fg (color lcyan blue);
+              S " )─< ";
-        S "─( ";
+              B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg;
-        B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg;
+              S " >─";
-        S " )─< ";
+            ]
-        B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg;
+          else
-        S " >─[ ";
+            eval [
-        B_fg (color lgreen green); S (String.concat " " (List.map LTerm_key.to_string_compact key_sequence)); E_fg;
+              B_bold bold;
-        S " ]─";
+              B_fg (color lcyan blue);
-      ]
+              S "─( ";
-  in
+              B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg;
-  let txtb =
+              S " )─< ";
-    if recording then
+              B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg;
-      eval [
+              S " >─[ ";
-        B_bold bold;
+              B_fg (color lgreen green); S (String.concat " " (List.map LTerm_key.to_string_compact key_sequence)); E_fg;
-        B_fg (color lcyan blue);
+              S " ]─";
-        S "{ ";
+            ]
-        B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg;
+        in
-        S " }─[ ";
+        let txtb =
-        B_fg (color lwhite black); S (Printf.sprintf "macro: %d" macro_count); E_fg;
+          if recording then
-        S " ]─";
+            eval [
-      ]
+              B_bold bold;
-    else
+              B_fg (color lcyan blue);
-      eval [
+              S "{ ";
-        B_bold bold;
+              B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg;
-        B_fg (color lcyan blue);
+              S " }─[ ";
-        S "{ ";
+              B_fg (color lwhite black); S (Printf.sprintf "macro: %d" macro_count); E_fg;
-        B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg;
+              S " ]─";
-        S " }─";
+            ]
-      ]
+          else
-  in
+            eval [
-  Array.append (
+              B_bold bold;
-    if Array.length txta + Array.length txtb > size.cols then
+              B_fg (color lcyan blue);
-      Array.sub (Array.append txta txtb) 0 size.cols
+              S "{ ";
-    else
+              B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg;
-      Array.concat [
+              S " }─";
-        txta;
+            ]
-        Array.make
+        in
-          (size.cols - Array.length txta - Array.length txtb)
+        Array.append (
-          (UChar.of_int 0x2500, { none with foreground = Some (color lcyan blue); bold = Some bold });
+          if Array.length txta + Array.length txtb > size.cols then
-        txtb;
+            Array.sub (Array.append txta txtb) 0 size.cols
-      ]
+          else
-  ) [|(UChar.of_char '#', { none with foreground = Some (color lgreen green) }); (UChar.of_char ' ', none)|]
+            Array.concat [
+              txta;
+              Array.make
+                (size.cols - Array.length txta - Array.length txtb)
+                (UChar.of_int 0x2500, { none with foreground = Some (color lcyan blue); bold = Some bold });
+              txtb;
+            ]
+        ) [|(UChar.of_char '#', { none with foreground = Some (color lgreen green) }); (UChar.of_char ' ', none)|]
 
 let prompt = ref (
-  S.l5 make_prompt
+  S.l6 make_prompt
+    UTop_private.ui
     profile
     count
     size

src/common/uTop.mli

@@ -18,17 +18,23 @@ val keywords : Set.Make(String).t ref
 val add_keyword : string -> unit
   (** Add a new OCaml keyword. *)
 
-(** {6 Console specific configuration} *)
+type ui = Console | GTK | Emacs
+    (** The user interface in use. *)
+
+val get_ui : unit -> ui
+  (** Returns the user interface in use. *)
+
+(** {6 Console/GTK specific configuration} *)
 
 type profile = Dark | Light
-    (** Profile for terminal colors. *)
+    (** Profile for colors. *)
 
 val profile : profile React.signal
-  (** The profile of the terminal. It defaults to {!Dark}. This is
+  (** The color profile. It defaults to {!Dark}. This is used by the
-      used by the default prompt to choose colors. *)
+      default prompt to choose colors. *)
 
 val set_profile : profile -> unit
-  (** Sets the profile of the terminal. *)
+  (** Sets the color profile. *)
 
 val smart_accept : bool ref
   (** If [true], then only lines terminated with ";;" will be sent to
@@ -36,28 +42,33 @@ val smart_accept : bool ref
       user press Enter. It default to [true]. *)
 
 val size : LTerm_geom.size React.signal
-  (** The current size of the terminal.  *)
+  (** The current size of the terminal. This is used only in the
+      console UI. *)
 
 val key_sequence : LTerm_key.t list React.signal
-  (** The current key sequence entered by the user. *)
+  (** The current key sequence entered by the user. This is used only
+      in the console UI. *)
+
+val time : float ref
+  (** The time of the beginning of the current command. *)
 
 val prompt : LTerm_text.t React.signal ref
   (** The current prompt.
 
       For compatibility with ocaml error printing, it must ends with a
-      line of length 2. *)
+      line of length 2 in the console UI. *)
 
 val prompt_continue : LTerm_text.t React.signal ref
   (** The prompt used to continue unterminated phrase.
 
       For compatibility with ocaml error printing, it must ends with a
-      line of length 2. *)
+      line of length 2 in the console UI. *)
 
 val prompt_comment : LTerm_text.t React.signal ref
   (** The prompt used to continue unterminated comments.
 
       For compatibility with ocaml error printing, it must ends with a
-      line of length 2. *)
+      line of length 2 in the console UI. *)
 
 (** {6 Hooks} *)
 

src/common/uTop_private.ml

@@ -18,3 +18,7 @@ let key_sequence, set_key_sequence =
   (S.switch (S.const ([] : LTerm_key.t list)) ev, set_key_sequence)
 
 let count, set_count = S.create(-1)
+
+type ui = Console | GTK | Emacs
+
+let ui, set_ui = S.create Console

src/console/uTop_console.ml

@@ -19,6 +19,8 @@ open UTop_styles
 
 module String_set = Set.Make(String)
 
+let () = UTop_private.set_ui UTop_private.Console
+
 (* +-----------------------------------------------------------------+
    | History                                                         |
    +-----------------------------------------------------------------+ *)

src/emacs/uTop_emacs.ml

@@ -11,6 +11,8 @@
 
 open Lwt
 
+let () = UTop_private.set_ui UTop_private.Emacs
+
 (* Copy standard output, which will be used to send commands. *)
 let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout)
 

src/gtk/uTop_gtk.ml

@@ -11,6 +11,8 @@ open Lwt
 open Lwt_react
 open UTop_styles
 
+let () = UTop_private.set_ui UTop_private.GTK
+
 (* Copy stderr for errors. *)
 let stderr_fd = Unix.dup Unix.stderr
 let stderr = Unix.out_channel_of_descr stderr_fd
@@ -216,6 +218,55 @@ let _ =
     ~callback:(Gobject.Closure.create changed)
     ~after:false
 
+(* Insert the prompt. *)
+let insert_prompt ?(locked = true) prompt =
+  if locked then Mutex.lock edit_mutex;
+  computer_insertion := true;
+  let iter = edit_buffer#get_iter (`OFFSET !prompt_start) in
+  (* Remove the previous prompt. *)
+  if !prompt_start < !prompt_stop then begin
+    edit_buffer#delete ~start:iter ~stop:(edit_buffer#get_iter (`OFFSET !prompt_stop))
+  end;
+  (* Insert the text of the new one. *)
+  edit_buffer#insert ~iter ~tags:[frozen] (LTerm_text.to_string prompt);
+  (* Update the end of prompt. *)
+  prompt_stop := iter#offset;
+  (* Stylise it. *)
+  let stylise start stop style =
+    if start < stop then begin
+      let start = edit_buffer#get_iter (`OFFSET (start + !prompt_start)) and stop = edit_buffer#get_iter (`OFFSET (stop + !prompt_start)) in
+      edit_buffer#apply_tag ~start ~stop (tag_of_term_style style)
+    end
+  in
+  let rec loop i j style =
+    if j = Array.length prompt then
+      stylise i j style
+    else begin
+      let _, style' = prompt.(j) in
+      if LTerm_style.equal style style' then
+        loop i (j + 1) style
+      else begin
+        stylise i j style;
+        loop j (j + 1) style'
+      end
+    end
+  in
+  loop 0 0 LTerm_style.none;
+  computer_insertion := false;
+  if locked then Mutex.unlock edit_mutex
+
+(* The current prompt. *)
+let current_prompt, set_current_prompt = S.create ~eq:(==) (S.const [||])
+
+(* Update the prompt when it change. *)
+let () =
+  E.keep
+    (E.map
+       (fun prompt ->
+          (* Update it only if we are editing. *)
+          if edit#editable then insert_prompt ~locked:true prompt)
+       (S.changes (S.switch (S.value current_prompt) (S.changes current_prompt))))
+
 (* +-----------------------------------------------------------------+
    | Standard outputs redirections                                   |
    +-----------------------------------------------------------------+ *)
@@ -283,15 +334,16 @@ let rec read_input prompt buffer length =
            end;
 
            (* Insert the prompt. *)
-           prompt_start := edit#buffer#end_iter#offset;
+           let offset = edit_buffer#end_iter#offset in
-           computer_insertion := true;
+           prompt_start := offset;
-           edit_buffer#insert ~iter:edit_buffer#end_iter ~tags:[frozen] prompt;
+           prompt_stop := offset;
-           computer_insertion := false;
+           insert_prompt ~locked:false (S.value !UTop.prompt);
-           prompt_stop := edit_buffer#end_iter#offset;
 
            Mutex.unlock edit_mutex;
 
-       | "* " | "  " ->
+           set_current_prompt !UTop.prompt
+
+       | "  " ->
            (* Continuation of the current phrase. *)
 
            (* Call hooks. *)
@@ -299,12 +351,29 @@ let rec read_input prompt buffer length =
 
            (* Insert the prompt. *)
            Mutex.lock edit_mutex;
-           prompt_start := edit#buffer#end_iter#offset;
+           let offset = edit_buffer#end_iter#offset in
-           computer_insertion := true;
+           prompt_start := offset;
-           edit_buffer#insert ~iter:edit_buffer#end_iter ~tags:[frozen] prompt;
+           prompt_stop := offset;
-           computer_insertion := false;
+           insert_prompt ~locked:false (S.value !UTop.prompt_continue);
-           prompt_stop := edit_buffer#end_iter#offset;
+           Mutex.unlock edit_mutex;
-           Mutex.unlock edit_mutex
+
+           set_current_prompt !UTop.prompt_continue
+
+       | "* " ->
+           (* Continuation of the current phrase (in a comment). *)
+
+           (* Call hooks. *)
+           Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
+
+           (* Insert the prompt. *)
+           Mutex.lock edit_mutex;
+           let offset = edit_buffer#end_iter#offset in
+           prompt_start := offset;
+           prompt_stop := offset;
+           insert_prompt ~locked:false (S.value !UTop.prompt_comment);
+           Mutex.unlock edit_mutex;
+
+           set_current_prompt !UTop.prompt_comment
 
        | _ ->
            (* Unknown prompt: error. *)
@@ -321,6 +390,9 @@ let rec read_input prompt buffer length =
     (* Wait for the user to press Return. *)
     let () = Lwt_main.run (Lwt_condition.wait accept_cond) in
 
+    (* Make the buffer uneditable while ocaml is executing things. *)
+    edit#set_editable false;
+
     Mutex.lock edit_mutex;
     (* Get the user input. *)
     let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in
@@ -333,9 +405,6 @@ let rec read_input prompt buffer length =
     prompt_stop := offset;
     Mutex.unlock edit_mutex;
 
-    (* Make the buffer uneditable while ocaml is executing things. *)
-    edit#set_editable false;
-
     input := text;
     pos := 0;