From e0c1b131a377a483c83be3450a60d626fa46c614 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 28 Jul 2011 17:40:23 +0200 Subject: [PATCH] better handling of multiple line inputs in emacs mode Ignore-this: 917d53810e44b96c6cfa59801634b05 darcs-hash:20110728154023-c41ad-ab46224a3144db4192420db8e0298e51f32411fe --- src/uTop_emacs.ml | 96 +++++++++++++++++++++++++++++++++++------------ src/utop.el | 49 +++++++++++++----------- 2 files changed, 99 insertions(+), 46 deletions(-) diff --git a/src/uTop_emacs.ml b/src/uTop_emacs.ml index 644d3b3..2f832f0 100644 --- a/src/uTop_emacs.ml +++ b/src/uTop_emacs.ml @@ -58,32 +58,78 @@ let _ = redirect "stderr" Unix.stderr | Input | +-----------------------------------------------------------------+ *) -let rec copy_input buffer offset length = - if offset = length then - return (offset, false) - else - Lwt_io.read_char_opt Lwt_io.stdin >>= function - | Some '\n' -> - buffer.[offset] <- '\n'; - return (offset + 1, false) - | Some ch -> - buffer.[offset] <- ch; - copy_input buffer (offset + 1) length - | None -> - return (offset, true) +(* The text typed by the user. *) +let input = ref "" -let read_input prompt buffer length = - match prompt with - | "# " -> - (* New phrase. *) - send "prompt" ""; - Lwt_main.run (copy_input buffer 0 length) - | "* " | " " -> - (* Continuation of the current phrase. *) - send "continue" ""; - Lwt_main.run (copy_input buffer 0 length) - | _ -> - send "stderr" "unrecognized prompt"; +(* The position of the text already sent to ocaml in {!input}. *) +let pos = ref 0 + +let read_command () = + match Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) with + | None -> + None + | Some line -> + match try Some (String.index line ':') with Not_found -> None with + | None -> + send "stderr" "':' missing!"; + exit 1 + | Some idx -> + Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1))) + +let rec read_input prompt buffer length = + if !pos = String.length !input then begin + (match prompt with + | "# " -> + (* New phrase. *) + send "prompt" "" + | "* " | " " -> + (* Continuation of the current phrase. *) + send "continue" "" + | _ -> + 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 + end else begin + (* There is still some pending input. *) + let i = ref 0 in + while !i < length && !pos < String.length !input do + buffer.[!i] <- (!input).[!pos]; + incr i; + incr pos + done; + (!i, false) + end + +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 := ""; + 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 + | command -> + Printf.ksprintf (send "stderr") "unrecognized command %S!" command; exit 1 let () = diff --git a/src/utop.el b/src/utop.el index d90b6d0..29e7054 100644 --- a/src/utop.el +++ b/src/utop.el @@ -264,27 +264,34 @@ sub-process." (let ((input (buffer-substring-no-properties utop-prompt-max (point-max)))) (if (stringp utop-pending) (setq utop-pending (concat utop-pending "\n" input)) - (setq utop-pending input))) - ;; Goto the end of the buffer - (goto-char (point-max)) - ;; Terminate input by a newline - (insert "\n") - (let ((start utop-prompt-max) (stop (point-max))) - ;; Make the text read-only - (add-text-properties start stop '(read-only t)) - ;; Make the old prompt sticky so we cannot edit after it - (let ((inhibit-read-only t)) - (remove-text-properties utop-prompt-min utop-prompt-max '(rear-nonsticky nil))) - ;; Makes the text sent read only and add it the frozen face. - (let ((inhibit-read-only t)) - (utop-add-text-properties-rear-nonsticky start stop - '(read-only t face utop-frozen) - '(face read-only))) - ;; Move the prompt to the end of the buffer - (setq utop-prompt-min stop) - (setq utop-prompt-max stop) - ;; Send everything after the prompt to utop - (process-send-region utop-process start stop)))) + (setq utop-pending input)) + ;; Goto the end of the buffer + (goto-char (point-max)) + ;; Terminate input by a newline + (insert "\n") + (let ((start utop-prompt-max) (stop (point-max))) + ;; Make the text read-only + (add-text-properties start stop '(read-only t)) + ;; Make the old prompt sticky so we cannot edit after it + (let ((inhibit-read-only t)) + (remove-text-properties utop-prompt-min utop-prompt-max '(rear-nonsticky nil))) + ;; Makes the text sent read only and add it the frozen face. + (let ((inhibit-read-only t)) + (utop-add-text-properties-rear-nonsticky start stop + '(read-only t face utop-frozen) + '(face read-only))) + ;; Move the prompt to the end of the buffer + (setq utop-prompt-min stop) + (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")) + (while (consp lines) + ;; Send the line + (process-send-string utop-process (concat "data:" (car lines) "\n")) + ;; Remove it and continue + (setq lines (cdr lines)))))))) ;; +-----------------------------------------------------------------+ ;; | Completion |