completion in emacs mode

Ignore-this: f49eb1b85c5d37069e5de7694af241f7

darcs-hash:20110728193147-c41ad-1a95a93070db5c9b955f28a3b02020a4d6ea53e6

src/uTop_emacs.ml

@@ -76,11 +76,38 @@ let read_command () =
           | 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 buf = Buffer.create 1024 in
+  let rec loop first =
+    match read_command () with
+      | None ->
+          send "stderr" "'end' command missing!";
+          exit 1
+      | Some ("data", data) ->
+          if not first then Buffer.add_char buf '\n';
+          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;
+          exit 1
+  in
+  loop true
+
 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);
+
            send "prompt" ""
        | "* " | "  " ->
            (* Continuation of the current phrase. *)
@@ -88,11 +115,7 @@ let rec read_input prompt buffer length =
        | _ ->
            Printf.ksprintf (send "stderr") "unrecognized prompt %S!" prompt;
            exit 1);
-    match read_command () with
+    loop prompt buffer length
-      | None ->
-          (0, true)
-      | Some (command, argument) ->
-          process prompt buffer length command argument
   end else begin
     (* There is still some pending input. *)
     let i = ref 0 in
@@ -107,30 +130,26 @@ let rec read_input prompt buffer length =
 and process prompt buffer length command argument =
   match command with
     | "input" ->
-        let count =
+        input := read_data ();
-          try
-            int_of_string argument
-          with _ ->
-            send "stderr" "invalid number of line to read!";
-            exit 1
-        in
-        input := "";
         pos := 0;
-        for i = 1 to count do
-          match read_command () with
-            | None ->
-                send "stderr" "wrong number of lines!";
-                exit 1
-            | Some ("data", data) ->
-                input := !input ^ data ^ "\n"
-            | Some (command, argument) ->
-                Printf.ksprintf (send "stderr") "'data' command expected, got %S!" command;
-                exit 1
-        done;
         read_input prompt buffer length
+    | "complete" ->
+        let input = read_data ~final_newline:false () in
+        let start, words = UTop_complete.complete input in
+        send "completion-start" "";
+        List.iter (fun (word, suffix) -> send "completion" word) words;
+        send "completion-stop" "";
+        loop prompt buffer length
     | command ->
         Printf.ksprintf (send "stderr") "unrecognized command %S!" command;
         exit 1
 
+and loop prompt buffer length =
+  match read_command () with
+    | None ->
+        (0, true)
+    | Some (command, argument) ->
+        process prompt buffer length command argument
+
 let () =
   Toploop.read_interactive_input := read_input

src/utop.el

@@ -98,7 +98,10 @@ This hook is only run if exiting actually kills the buffer."
   "The history after the cursor.")
 
 (defvar utop-pending nil
-  "The text not yet added to the history")
+  "The text not yet added to the history.")
+
+(defvar utop-completion nil
+  "Current completion.")
 
 ;; +-----------------------------------------------------------------+
 ;; | Utils                                                           |
@@ -197,7 +200,7 @@ non-sticky mode."
 (defun utop-process-line (line)
   "Process one line from the utop sub-process."
   ;; Extract the command and its argument
-  (string-match "\\`\\([a-z]*\\):\\(.*\\)\\'" line)
+  (string-match "\\`\\([a-z-]*\\):\\(.*\\)\\'" line)
   (let ((command (match-string 1 line)) (argument (match-string 2 line)))
     (cond
      ;; Output on stdout
@@ -232,7 +235,18 @@ non-sticky mode."
       (setq utop-history-prev utop-history)
       (setq utop-history-next nil)
       ;; Insert the last prompt
-      (utop-insert-prompt utop-last-prompt)))))
+      (utop-insert-prompt utop-last-prompt))
+     ;; Start of completion
+     ((string= command "completion-start")
+      (setq utop-completion nil))
+     ;; A new possible completion
+     ((string= command "completion")
+      (setq utop-completion (cons argument utop-completion)))
+     ;; End of completion
+     ((string= command "completion-stop")
+      (with-output-to-temp-buffer "*Completions*"
+        (display-completion-list (nreverse utop-completion)))
+      (setq utop-completion nil)))))
 
 (defun utop-process-output (process output)
   "Process the output of utop"
@@ -283,18 +297,35 @@ sub-process."
         (setq utop-prompt-max stop)
         ;; Send all lines to utop
         (let ((lines (split-string input "\n")))
-          ;; Send the number of lines
+          (process-send-string utop-process "input:\n")
-          (process-send-string utop-process (concat "input:" (int-to-string (length lines)) "\n"))
           (while (consp lines)
             ;; Send the line
             (process-send-string utop-process (concat "data:" (car lines) "\n"))
             ;; Remove it and continue
-            (setq lines (cdr lines))))))))
+            (setq lines (cdr lines)))
+          (process-send-string utop-process "end:\n"))))))
 
 ;; +-----------------------------------------------------------------+
 ;; | Completion                                                      |
 ;; +-----------------------------------------------------------------+
 
+(defun utop-complete ()
+  "Complete current input."
+  (interactive)
+  ;; Complete only if the cursor is after the prompt
+  (if (>= (point) utop-prompt-max)
+      ;; Extract the input before the cursor
+      (let ((input (buffer-substring-no-properties utop-prompt-max (point))))
+        ;; Split it
+        (let ((lines (split-string input "\n")))
+          ;; Send all lines to utop
+          (process-send-string utop-process "complete:\n")
+          (while (consp 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")))))
 
 ;; +-----------------------------------------------------------------+
 ;; | Tuareg integration                                              |
@@ -407,6 +438,7 @@ sub-process."
   (define-key utop-mode-map [(control ?a)] 'utop-bol)
   (define-key utop-mode-map [(meta ?p)] 'utop-history-goto-prev)
   (define-key utop-mode-map [(meta ?n)] 'utop-history-goto-next)
+  (define-key utop-mode-map [tab] 'utop-complete)
 
   ;; Register the exit hook
   (add-hook 'kill-buffer-hook (lambda () (run-hooks 'utop-exit-hook)) t t)