diff --git a/src/uTop_emacs.ml b/src/uTop_emacs.ml index 2f832f0..0ae21bb 100644 --- a/src/uTop_emacs.ml +++ b/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 - | None -> - (0, true) - | Some (command, argument) -> - process prompt buffer length command argument + loop prompt buffer length 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 = - try - int_of_string argument - with _ -> - send "stderr" "invalid number of line to read!"; - exit 1 - in - input := ""; + input := read_data (); 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 diff --git a/src/utop.el b/src/utop.el index e8d1466..7a8ad04 100644 --- a/src/utop.el +++ b/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 (concat "input:" (int-to-string (length lines)) "\n")) + (process-send-string utop-process "input:\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)