use the real history in emacs

Ignore-this: 2ec438176bdf1549eb2b7c6c8f3f5e50

darcs-hash:20120212204029-c41ad-c5e71ad6e8d290b0c7e19994e3ba46879b38089d

src/lib/uTop_main.ml

@@ -374,11 +374,14 @@ module Emacs(M : sig end) = struct
   (* Copy standard output, which will be used to send commands. *)
   let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout)
 
-  let split_lines str =
+  let split_at ?(trim=false) ch str =
     let rec aux i j =
       if j = String.length str then
-        []
+        if trim && i = j then
-      else if str.[j] = '\n' then
+          []
+        else
+          [String.sub str i (j - i)]
+      else if str.[j] = ch then
         String.sub str i (j - i) :: aux (j + 1) (j + 1)
       else
         aux i (j + 1)
@@ -455,7 +458,7 @@ module Emacs(M : sig end) = struct
             | Some idx ->
                 Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1)))
 
-  let read_data ?(final_newline = true) () =
+  let read_data () =
     let buf = Buffer.create 1024 in
     let rec loop first =
       match read_command () with
@@ -467,7 +470,6 @@ module Emacs(M : sig end) = struct
             Buffer.add_string buf data;
             loop false
         | Some ("end", _) ->
-            if final_newline then Buffer.add_char buf '\n';
             Buffer.contents buf
         | Some (command, argument) ->
             Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command;
@@ -475,17 +477,19 @@ module Emacs(M : sig end) = struct
     in
     loop true
 
-  let process_input eos_is_error =
+  let process_input add_to_history eos_is_error =
-    match parse_and_check (read_data ()) eos_is_error with
+    let input = read_data () in
+    match parse_and_check input eos_is_error with
       | UTop.Value phrase ->
           send "accept" "";
+          if add_to_history then LTerm_history.add UTop.history input;
           (* Add Lwt_main.run to toplevel evals. *)
           let phrase = if UTop.get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in
           (* No exception can be raised at this stage. *)
           ignore (Toploop.execute_phrase true Format.std_formatter phrase)
       | UTop.Error (locs, msg) ->
           send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs));
-          List.iter (send "stderr") (split_lines msg)
+          List.iter (send "stderr") (split_at ~trim:true '\n' msg)
 
   let rec loop () =
     (* Reset completion. *)
@@ -500,30 +504,30 @@ module Emacs(M : sig end) = struct
     (* Tell emacs we are ready. *)
     send "prompt" "";
 
-    loop_commands ()
+    loop_commands (LTerm_history.contents UTop.history) []
 
-  and loop_commands () =
+  and loop_commands history_prev history_next =
     match read_command () with
       | None ->
           ()
-      | Some ("input", "allow-incomplete") ->
+      | Some ("input", arg) ->
+          let args = split_at ',' arg in
+          let allow_incomplete = List.mem "allow-incomplete" args
+          and add_to_history = List.mem "add-to-history" args in
           let continue =
             try
-              process_input false;
+              process_input add_to_history (not allow_incomplete);
               false
             with UTop.Need_more ->
               send "continue" "";
               true
           in
           if continue then
-            loop_commands ()
+            loop_commands history_prev history_next
           else
             loop ()
-      | Some ("input", "") ->
-          process_input true;
-          loop ()
       | Some ("complete", _) ->
-          let input = read_data ~final_newline:false () in
+          let input = read_data () in
           let start, words = UTop_complete.complete input in
           let words = List.map fst words in
           let prefix = LTerm_read_line.common_prefix words in
@@ -536,11 +540,33 @@ module Emacs(M : sig end) = struct
           in
           if suffix = "" then begin
             send "completion-start" "";
-            List.iter (fun word -> send "completion" word) words;
+            List.iter (send "completion") words;
             send "completion-stop" "";
           end else
             send "completion-word" suffix;
-          loop_commands ()
+          loop_commands history_prev history_next
+      | Some ("history-prev", _) -> begin
+          let input = read_data () in
+          match history_prev with
+            | [] ->
+                send "history-bound" "";
+                loop_commands history_prev history_next
+            | entry :: history_prev ->
+                List.iter (send "history-data") (split_at '\n' entry);
+                send "history-end" "";
+                loop_commands history_prev (input :: history_next)
+        end
+      | Some ("history-next", _) -> begin
+          let input = read_data () in
+          match history_next with
+            | [] ->
+                send "history-bound" "";
+                loop_commands history_prev history_next
+            | entry :: history_next ->
+                List.iter (send "history-data") (split_at '\n' entry);
+                send "history-end" "";
+                loop_commands (input :: history_prev) history_next
+        end
       | Some (command, _) ->
           Printf.ksprintf (send "stderr") "unrecognized command %S!" command;
           exit 1
@@ -641,19 +667,22 @@ let common_init () =
   (* Make sure SIGINT is catched while executing OCaml code. *)
   Sys.catch_break true;
   (* Load user's .ocamlinit file. *)
-  match !Clflags.init_file with
+  (match !Clflags.init_file with
-    | Some fn ->
+     | Some fn ->
-        if Sys.file_exists fn then
+         if Sys.file_exists fn then
-          ignore (Toploop.use_silently Format.err_formatter fn)
+           ignore (Toploop.use_silently Format.err_formatter fn)
-        else
+         else
-          Printf.eprintf "Init file not found: \"%s\".\n" fn
+           Printf.eprintf "Init file not found: \"%s\".\n" fn
-    | None ->
+     | None ->
-        if Sys.file_exists ".ocamlinit" then
+         if Sys.file_exists ".ocamlinit" then
-          ignore (Toploop.use_silently Format.err_formatter ".ocamlinit")
+           ignore (Toploop.use_silently Format.err_formatter ".ocamlinit")
-        else
+         else
-          let fn = Filename.concat LTerm_resources.home ".ocamlinit" in
+           let fn = Filename.concat LTerm_resources.home ".ocamlinit" in
-          if Sys.file_exists fn then
+           if Sys.file_exists fn then
-            ignore (Toploop.use_silently Format.err_formatter fn)
+             ignore (Toploop.use_silently Format.err_formatter fn));
+  (* Load history after the initialization file so the user can change
+     the history file name. *)
+  Lwt_main.run (init_history ())
 
 let load_inputrc () =
   try_lwt
@@ -684,9 +713,6 @@ let main_aux () =
       Lwt_main.run (welcome term);
       (* Common initialization. *)
       common_init ();
-      (* Load history after the initialization file so the user can
-         change the history file name. *)
-      Lwt_main.run (init_history ());
       (* Print help message. *)
       print_string "\nType #utop_help for help about using utop.\n\n";
       flush stdout;

src/top/utop.el

@@ -146,15 +146,6 @@ This hook is only run if exiting actually kills the buffer."
 (defvar utop-command-number 0
   "The number of the current command.")
 
-(defvar utop-history nil
-  "The history of typed command.")
-
-(defvar utop-history-prev nil
-  "The history before the cursor.")
-
-(defvar utop-history-next nil
-  "The history after the cursor.")
-
 (defvar utop-completion nil
   "Current completion.")
 
@@ -167,6 +158,7 @@ before the end of prompt.")
 
 - edit: the user is typing a command
 - comp: waiting for completion
+- hist: waiting for history
 - wait: ocaml is evaluating a phrase
 - done: ocaml has died.")
 
@@ -176,8 +168,8 @@ before the end of prompt.")
 (defvar utop-phrase-terminator ";;"
   "The OCaml phrase terminator.")
 
-(defvar utop-pending-input nil
+(defvar utop-pending-entry nil
-  "The phrase to add to history if it is accepted by OCaml.")
+  "History entry")
 
 (defvar utop-pending-position nil
   "The position of the cursor in the phrase sent to OCaml (where
@@ -204,7 +196,7 @@ to add the newline character if it is not accepted).")
          (select-window window)
          (goto-char (point-max)))))))
 
-(defun set-utop-state (state)
+(defun utop-set-state (state)
   "Change the utop state and mode-line-process."
   (setq utop-state state)
   (setq mode-line-process
@@ -213,6 +205,8 @@ to add the newline character if it is not accepted).")
           ": idle")
          ((eq state 'comp)
           ": completion")
+         ((eq state 'hist)
+          ": history")
          ((eq state 'wait)
           ": running")
          ((eq state 'done)
@@ -233,6 +227,18 @@ to add the newline character if it is not accepted).")
          (t
           ": unknown"))))
 
+(defun utop-send-data (cmd)
+  "Send current input to utop"
+  (let ((lines (split-string (buffer-substring-no-properties utop-prompt-max (point-max)) "\n")))
+    ;; Send all lines to utop
+    (process-send-string utop-process cmd)
+    (while lines
+      ;; Send the line
+      (process-send-string utop-process (concat "data:" (car lines) "\n"))
+      ;; Remove it and continue
+      (setq lines (cdr lines)))
+    (process-send-string utop-process "end:\n")))
+
 ;; +-----------------------------------------------------------------+
 ;; | Edition control                                                 |
 ;; +-----------------------------------------------------------------+
@@ -244,7 +250,9 @@ to add the newline character if it is not accepted).")
    ((eq utop-state 'done)
     (signal 'text-read-only '("You cannot edit the buffer when ocaml is not running")))
    ((eq utop-state 'comp)
-    (signal 'text-read-only '("You cannot edit the buffer while waiting for completion")))))
+    (signal 'text-read-only '("You cannot edit the buffer while waiting for completion")))
+   ((eq utop-state 'comp)
+    (signal 'text-read-only '("You cannot edit the buffer while waiting for history")))))
 
 (defun utop-before-change (start stop)
   (unless utop-inhibit-check
@@ -278,25 +286,19 @@ to add the newline character if it is not accepted).")
   "Go to the previous entry of the history."
   (interactive)
   (with-current-buffer utop-buffer-name
-    (when (and (eq utop-state 'edit) utop-history-prev)
+    (when (eq utop-state 'edit)
-      ;; Push current input after the history cursor
+      (utop-set-state 'hist)
-      (push (delete-and-extract-region utop-prompt-max (point-max)) utop-history-next)
+      (setq utop-pending-entry nil)
-      ;; Go to after the prompt to insert the previous input
+      (utop-send-data "history-prev:\n"))))
-      (goto-char utop-prompt-max)
-      ;; Pop one element from history before the cursor and insert it
-      (insert (pop utop-history-prev)))))
 
 (defun utop-history-goto-next ()
   "Go to the next entry of the history."
   (interactive)
   (with-current-buffer utop-buffer-name
-    (when (and (eq utop-state 'edit) utop-history-next)
+    (when (eq utop-state 'edit)
-      ;; Push current input before the history cursor
+      (utop-set-state 'hist)
-      (push (delete-and-extract-region utop-prompt-max (point-max)) utop-history-prev)
+      (setq utop-pending-entry nil)
-      ;; Go to after the prompt to insert the next input
+      (utop-send-data "history-next:\n"))))
-      (goto-char utop-prompt-max)
-      ;; Pop one element from history after the cursor and insert it
-      (insert (pop utop-history-next)))))
 
 ;; +-----------------------------------------------------------------+
 ;; | Receiving input from the utop sub-process                     |
@@ -331,7 +333,7 @@ to add the newline character if it is not accepted).")
   ;; Make everything before the end prompt read-only
   (add-text-properties (point-min) utop-prompt-max utop-non-editable-properties)
   ;; We are now editing
-  (set-utop-state 'edit)
+  (utop-set-state 'edit)
   ;; Move the point to the end of buffer in all utop windows
   (utop-goto-point-max-all-windows))
 
@@ -363,9 +365,6 @@ to add the newline character if it is not accepted).")
      ;; A new prompt
      ((string= command "prompt")
       (let ((prompt (apply utop-prompt ())))
-        ;; Reset history
-        (setq utop-history-prev utop-history)
-        (setq utop-history-next nil)
         ;; Insert the new prompt
         (utop-insert-prompt prompt)
         ;; Increment the command number
@@ -374,15 +373,10 @@ to add the newline character if it is not accepted).")
         (when utop-initial-command
           (goto-char (point-max))
           (insert utop-initial-command)
-          (utop-insert-phrase-terminator)
           (setq utop-initial-command nil)
-          (utop-eval-input))))
+          (utop-eval-input nil t nil))))
      ;; Input has been accepted
      ((string= command "accept")
-      ;; Push input to the history if it is different from the top
-      ;; of the history
-      (when (or (null utop-history) (not (string= utop-pending-input (car utop-history))))
-        (push utop-pending-input utop-history))
       ;; Add a newline character at the end of the buffer
       (goto-char (point-max))
       (insert "\n")
@@ -408,10 +402,30 @@ to add the newline character if it is not accepted).")
         (goto-char (+ utop-prompt-max utop-pending-position))
         (insert "\n"))
       ;; Reset the state
-      (set-utop-state 'edit))
+      (utop-set-state 'edit))
+     ;; Part of a history entry
+     ((string= command "history-data")
+      (cond
+       (utop-pending-entry
+        (setq utop-pending-entry (concat utop-pending-entry "\n" argument)))
+       (t
+        (setq utop-pending-entry argument))))
+     ;; End of history data
+     ((string= command "history-end")
+      (goto-char utop-prompt-max)
+      ;; Delete current input
+      (delete-region utop-prompt-max (point-max))
+      ;; Insert entry
+      (insert utop-pending-entry)
+      ;; Resume edition
+      (utop-set-state 'edit))
+     ;; We are at a bound of history
+     ((string= command "history-bound")
+      ;; Just resume edition
+      (utop-set-state 'edit))
      ;; Complete with a word
      ((string= command "completion-word")
-      (set-utop-state 'edit)
+      (utop-set-state 'edit)
       (insert argument)
       ;; Hide completion
       (minibuffer-hide-completions))
@@ -423,7 +437,7 @@ to add the newline character if it is not accepted).")
       (push argument utop-completion))
      ;; End of completion
      ((string= command "completion-stop")
-      (set-utop-state 'edit)
+      (utop-set-state 'edit)
       (with-output-to-temp-buffer "*Completions*"
         (display-completion-list (nreverse utop-completion)))
       (setq utop-completion nil)))))
@@ -450,7 +464,7 @@ to add the newline character if it is not accepted).")
 ;; | Sending data to the utop sub-process                            |
 ;; +-----------------------------------------------------------------+
 
-(defun utop-eval-input (&optional allow-incomplete auto-end)
+(defun utop-eval-input (&optional allow-incomplete auto-end add-to-history)
   "Send the current input to the utop process and let ocaml
 evaluate it.
 
@@ -460,7 +474,9 @@ continue.
 
 If AUTO-END is non-nill then ALLOW-INCOMPLETE is ignored and a
 phrase terminator (;; or ; if using revised syntax) will be
-automatically inserted by utop."
+automatically inserted by utop.
+
+If ADD-TO-HISTORY is t then the input will be added to history."
   (interactive)
   (with-current-buffer utop-buffer-name
     (when (eq utop-state 'edit)
@@ -477,30 +493,26 @@ automatically inserted by utop."
         ;; character at the end
         (when (< utop-pending-position 0)
           (setq utop-pending-position (- (point) utop-prompt-max)))))
-      (let* ((input (buffer-substring-no-properties utop-prompt-max (point-max)))
+      ;; We are now waiting for ocaml
-             (lines (split-string input "\n")))
+      (utop-set-state 'wait)
-        ;; Save for history
+      (utop-send-data
-        (setq utop-pending-input input)
+       (cond
-        ;; We are now waiting for ocaml
+        ((and allow-incomplete (not auto-end) add-to-history)
-        (set-utop-state 'wait)
+         "input:allow-incomplete,add-to-history\n")
-        ;; Send all lines to utop
+        (add-to-history
-        (process-send-string utop-process (if (and allow-incomplete (not auto-end)) "input:allow-incomplete\n" "input:\n"))
+         "input:add-to-history\n")
-        (while lines
+        (t
-          ;; Send the line
+         "input:\n"))))))
-          (process-send-string utop-process (concat "data:" (car lines) "\n"))
-          ;; Remove it and continue
-          (setq lines (cdr lines)))
-        (process-send-string utop-process "end:\n")))))
 
 (defun utop-eval-input-or-newline ()
-  "Same as (`utop-eval-input' t nil)."
+  "Same as (`utop-eval-input' t nil t)."
   (interactive)
-  (utop-eval-input t nil))
+  (utop-eval-input t nil t))
 
 (defun utop-eval-input-auto-end ()
-  "Same as (`utop-eval-input' nil t)."
+  "Same as (`utop-eval-input' nil t t)."
   (interactive)
-  (utop-eval-input nil t))
+  (utop-eval-input nil t t))
 
 ;; +-----------------------------------------------------------------+
 ;; | Completion                                                      |
@@ -516,7 +528,7 @@ automatically inserted by utop."
       ;; Split it
       (let ((lines (split-string input "\n")))
         ;; We are now waiting for completion
-        (set-utop-state 'comp)
+        (utop-set-state 'comp)
         ;; Send all lines to utop
         (process-send-string utop-process "complete:\n")
         (while lines
@@ -580,7 +592,7 @@ automatically inserted by utop."
         (insert text)
         ;; Send input to utop now, telling it to automatically add the
         ;; phrase terminator
-        (utop-eval-input nil t))
+        (utop-eval-input nil t nil))
        ((eq utop-state 'wait)
         ;; utop is starting, save the initial command to send
         (setq utop-initial-command text))))))
@@ -669,7 +681,7 @@ To automatically do that just add these lines to your .emacs:
         (let ((status (process-status utop-process)))
           (when (or (eq status 'exit) (eq status 'signal))
             ;; The process is terminated
-            (set-utop-state 'done)
+            (utop-set-state 'done)
             (let ((exit-code (process-exit-status utop-process)))
               (utop-perform
                ;; Insert a message at the end
@@ -786,7 +798,6 @@ To automatically do that just add these lines to your .emacs:
   (setq utop-prompt-max (point-max))
   (setq utop-output "")
   (setq utop-command-number 0)
-  (setq utop-pending nil)
   (setq utop-completion nil)
 
   ;; Set the state to done to allow utop to be restarted if
@@ -798,7 +809,7 @@ To automatically do that just add these lines to your .emacs:
 
   ;; Set the initial state: we are waiting for ocaml to send the
   ;; initial prompt
-  (set-utop-state 'wait)
+  (utop-set-state 'wait)
 
   ;; Filter the output of the sub-process with our filter function
   (set-process-filter utop-process 'utop-process-output)
@@ -823,16 +834,12 @@ To automatically do that just add these lines to your .emacs:
   (make-local-variable 'utop-last-prompt)
   (make-local-variable 'utop-output)
   (make-local-variable 'utop-command-number)
-  (make-local-variable 'utop-history)
-  (make-local-variable 'utop-history-prev)
-  (make-local-variable 'utop-history-next)
-  (make-local-variable 'utop-pending)
   (make-local-variable 'utop-inhibit-check)
   (make-local-variable 'utop-state)
   (make-local-variable 'utop-initial-command)
   (make-local-variable 'utop-phrase-terminator)
-  (make-local-variable 'utop-pending-input)
   (make-local-variable 'utop-pending-position)
+  (make-local-variable 'utop-pending-entry)
 
   ;; Set the major mode
   (setq major-mode 'utop-mode)