haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

completion in emacs mode 

Ignore-this: f49eb1b85c5d37069e5de7694af241f7

darcs-hash:20110728193147-c41ad-1a95a93070db5c9b955f28a3b02020a4d6ea53e6
This commit is contained in:
Jeremie Dimino 2011-07-28 21:31:47 +02:00
parent 5426f83657
commit 60a3e780da
2 changed files with 81 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
src/uTop_emacs.ml
View File

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

44
src/utop.el
View File

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