diff options
Diffstat (limited to 'elisp/geiser-connection.el')
| -rw-r--r-- | elisp/geiser-connection.el | 274 |
1 files changed, 97 insertions, 177 deletions
diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el index dc669aa..d1e7d59 100644 --- a/elisp/geiser-connection.el +++ b/elisp/geiser-connection.el @@ -19,8 +19,7 @@ (require 'geiser-base) (require 'geiser-impl) -(require 'comint) -(require 'advice) +(require 'tq) ;;; Buffer connections: @@ -71,234 +70,155 @@ ;;; Connection datatype: -(defsubst geiser-con--make-connection (buffer) +(defun geiser-con--make-connection (proc prompt debug-prompt) (list :geiser-connection - (cons :requests (list)) - (cons :current nil) + (cons :tq (tq-create proc)) + (cons :eot (format "\\(%s%s\\)" + prompt + (if debug-prompt + (format "\\|%s" debug-prompt) + ""))) + (cons :prompt prompt) + (cons :debug-prompt debug-prompt) (cons :count 0) - (cons :completed (make-hash-table :weakness 'value)) - (cons :buffer buffer) - (cons :reply (geiser-con--make-reply-buffer buffer)))) - -(defvar geiser-con--eot-regexp nil) -(geiser-impl--register-local-variable - 'geiser-con--eot-regexp 'eot-regexp nil - "A regular expression used to detect end of transmissions. -By default, Geiser uses the prompt regexp.") - -(defun geiser-con--make-reply-buffer (buffer) - (let ((name (concat " geiser-con-reply: " (buffer-name buffer))) - (eot (with-current-buffer buffer geiser-con--eot-regexp))) - (with-current-buffer (get-buffer-create name) - (setq geiser-con--eot-regexp eot) - (current-buffer)))) + (cons :completed (make-hash-table :weakness 'value)))) + +(defun geiser-con--connection-swap-proc (con proc) + (let* ((this-proc (geiser-con--connection-process con)) + (this-filter (process-filter this-proc)) + (this-buffer (process-buffer this-proc)) + (filter (process-filter proc)) + (buffer (process-buffer proc)) + (tq (geiser-con--connection-tq con))) + (set-process-filter this-proc filter) + (set-process-buffer this-proc buffer) + (set-process-filter proc this-filter) + (set-process-buffer proc this-buffer) + (setcdr tq (cons proc (tq-buffer tq))) + this-proc)) (defsubst geiser-con--connection-p (c) (and (listp c) (eq (car c) :geiser-connection))) -(defsubst geiser-con--connection-buffer (c) - (cdr (assoc :buffer c))) - (defsubst geiser-con--connection-process (c) - (get-buffer-process (geiser-con--connection-buffer c))) + (tq-process (cdr (assoc :tq c)))) + +(defsubst geiser-con--connection-tq (c) + (cdr (assoc :tq c))) -(defsubst geiser-con--connection-requests (c) - (cdr (assoc :requests c))) +(defsubst geiser-con--connection-eot (c) + (cdr (assoc :eot c))) -(defsubst geiser-con--connection-current-request (c) - (cdr (assoc :current c))) +(defsubst geiser-con--connection-prompt (c) + (cdr (assoc :prompt c))) -(defsubst geiser-con--connection-reply-buffer (c) - (cdr (assoc :reply c))) +(defsubst geiser-con--connection-debug-prompt (c) + (cdr (assoc :debug-prompt c))) (defsubst geiser-con--connection-completed (c r) (geiser-con--request-deactivate r) (puthash (geiser-con--request-id r) r (cdr (assoc :completed c)))) -(defun geiser-con--connection-clean-current-request (c) - (let* ((cell (assoc :current c)) - (req (cdr cell))) - (when req - (geiser-con--connection-completed c req) - (setcdr cell nil)))) - -(defun geiser-con--connection-add-request (c r) - (let ((reqs (assoc :requests c))) - (setcdr reqs (append (cdr reqs) (list r))))) - (defsubst geiser-con--connection-completed-p (c id) (gethash id (cdr (assoc :completed c)))) -(defun geiser-con--connection-pop-request (c) - (let* ((reqs (assoc :requests c)) - (current (assoc :current c)) - (old-current (cdr current)) - (new-current (cadr reqs)) - (new-reqs (cddr reqs))) - (when old-current (geiser-con--connection-completed c old-current)) - (setcdr reqs new-reqs) - (if (and new-current - (geiser-con--request-deactivated-p new-current)) - (geiser-con--connection-pop-request c) - (setcdr current new-current)))) - (defun geiser-con--connection-inc-count (c) (let* ((cnt (assoc :count c)) (new (1+ (cdr cnt)))) (setcdr cnt new) new)) - -;;; Connection setup: -(make-variable-buffer-local - (defvar geiser-con--debugging-prompt-regexp nil)) - -(make-variable-buffer-local - (defvar geiser-con--debugging-inhibits-eval t)) - -(make-variable-buffer-local - (defvar geiser-con--debugging-preamble-regexp nil)) - -(defun geiser-con--is-debugging (&optional con) - (with-current-buffer (or (and con (geiser-con--connection-buffer con)) - (current-buffer)) - (and geiser-con--debugging-prompt-regexp - geiser-con--debugging-inhibits-eval - comint-last-prompt-overlay - (string-match-p geiser-con--debugging-prompt-regexp - (buffer-substring (overlay-start - comint-last-prompt-overlay) - (overlay-end - comint-last-prompt-overlay)))))) - -(defsubst geiser-con--has-entered-debugger (con) - (with-current-buffer (geiser-con--connection-buffer con) - (and geiser-con--debugging-prompt-regexp - (re-search-backward geiser-con--debugging-prompt-regexp nil t) - (or (null geiser-con--debugging-preamble-regexp) - (save-excursion - (re-search-backward geiser-con--debugging-preamble-regexp - nil t)))))) - -(defun geiser-con--connection-teardown () - (when geiser-con--connection - (kill-buffer - (geiser-con--connection-reply-buffer geiser-con--connection)))) - -(defun geiser-con--setup-connection (buffer - prompt-regexp - &optional debug-prompt-regexp - debug-preamble-regexp) - (with-current-buffer buffer - (geiser-con--connection-teardown) - (setq geiser-con--debugging-prompt-regexp debug-prompt-regexp) - (setq geiser-con--debugging-preamble-regexp debug-preamble-regexp) - (setq geiser-con--connection (geiser-con--make-connection buffer)) - (set (make-local-variable 'comint-redirect-insert-matching-regexp) t) - (setq comint-prompt-regexp - (if debug-prompt-regexp - (format "\\(%s\\)\\|\\(%s\\)" prompt-regexp debug-prompt-regexp) - prompt-regexp)) - (add-hook 'comint-redirect-hook 'geiser-con--comint-redirect-hook nil t))) +(defun geiser-con--has-entered-debugger (con answer) + (let ((dp (geiser-con--connection-debug-prompt con))) + (and (stringp dp) (string-match dp answer)))) + +(defun geiser-con--connection-close (con) + (let ((tq (geiser-con--connection-tq con))) + (and tq (tq-close tq)))) + +(defvar geiser-con--connection-sentinel nil) +(defun geiser-con--connection-sentinel (p s) + (setq geiser-con--connection-sentinel + (concat geiser-con--connection-sentinel s))) + +(defun geiser-con--open-connection (host port prompt debug-prompt) + (setq geiser-con--connection-sentinel "") + (let ((proc (make-network-process :name "geiser-con" + :host host + :service port + :filter 'geiser-con--connection-sentinel + :noquery t))) + (with-timeout (10 + (error (format "Timeout connecting to %s:%s" host port))) + (while (not (string-match prompt geiser-con--connection-sentinel)) + (accept-process-output proc 1))) + (geiser-con--make-connection proc prompt debug-prompt))) ;;; Requests handling: -(defun geiser-con--comint-buffer-form (con) - (with-current-buffer (geiser-con--connection-reply-buffer con) - (goto-char (point-max)) - (if (geiser-con--has-entered-debugger con) +(defun geiser-con--req-form (req answer) + (let ((con (geiser-con--request-connection req))) + (if (geiser-con--has-entered-debugger con answer) `((error (key . geiser-debugger)) - (output . ,(buffer-substring (point-min) (point)))) - (condition-case nil - (progn - (goto-char (point-min)) - (re-search-forward "((\\(result\\|error\\)\\>") - (goto-char (match-beginning 0)) - (let ((form (read (current-buffer)))) - (if (listp form) form (error "")))) + (output . ,answer)) + (condition-case err + (car (read-from-string answer)) (error `((error (key . geiser-con-error)) - (output . ,(buffer-string)))))))) - -(defun geiser-con--process-next (con) - (when (not (geiser-con--connection-current-request con)) - (let* ((buffer (geiser-con--connection-buffer con)) - (req (geiser-con--connection-pop-request con)) - (str (and req (geiser-con--request-string req))) - (rbuffer (geiser-con--connection-reply-buffer con))) - (when (and buffer (buffer-live-p buffer) req str) - (with-current-buffer rbuffer - (delete-region (point-min) (point-max))) - (set-buffer buffer) - (if (geiser-con--is-debugging) - (geiser-con--connection-completed con req) - (geiser-log--info "<%s>: %s" (geiser-con--request-id req) str) - (comint-redirect-send-command (format "%s" str) rbuffer nil t)))))) - -(defun geiser-con--process-completed-request (req) - (let* ((cont (geiser-con--request-continuation req)) - (id (geiser-con--request-id req)) - (rstr (geiser-con--request-string req)) - (buffer (geiser-con--request-buffer req)) - (con (geiser-con--request-connection req)) - (form (geiser-con--comint-buffer-form con))) + (output . ,(format "%s\n(%s)" + answer + (error-message-string err))))))))) + +(defun geiser-con--process-completed-request (req answer) + (let ((cont (geiser-con--request-continuation req)) + (id (geiser-con--request-id req)) + (rstr (geiser-con--request-string req)) + (form (geiser-con--req-form req answer)) + (buffer (or (geiser-con--request-buffer req) (current-buffer))) + (con (geiser-con--request-connection req))) (if (not cont) (geiser-log--warn "<%s> Droping result for request %S: %s" id rstr form) (condition-case cerr - (with-current-buffer (or buffer (current-buffer)) + (with-current-buffer buffer (funcall cont form) - (geiser-con--request-deactivate req) (geiser-log--info "<%s>: processed" id)) (error (geiser-log--error "<%s>: continuation failed %S \n\t%s" id rstr cerr)))) - (geiser-con--connection-clean-current-request con))) - -(defun geiser-con--comint-redirect-hook () - (if (not geiser-con--connection) - (geiser-log--error "No connection in buffer") - (let ((req (geiser-con--connection-current-request - geiser-con--connection))) - (if (not req) - (geiser-log--error "No current request") - (geiser-con--process-completed-request req))))) - -(defadvice comint-redirect-setup - (after geiser-con--advice - (output-buffer comint-buffer finished-regexp &optional echo)) - (with-current-buffer comint-buffer - (when geiser-con--eot-regexp - (setq comint-redirect-finished-regexp geiser-con--eot-regexp)) - (when geiser-con--connection (setq mode-line-process nil)))) -(ad-activate 'comint-redirect-setup) + (geiser-con--connection-completed con req))) + +(defun geiser-con--connection-add-request (c r) + (tq-enqueue (geiser-con--connection-tq c) + (geiser-con--request-string r) + (geiser-con--connection-eot c) + r + 'geiser-con--process-completed-request + t)) ;;; Message sending interface: -(defconst geiser-con--error-message "Geiser connection not active") +(defun geiser-con--send-string (con str cont &optional sbuf) + (let ((req (geiser-con--make-request con str cont sbuf))) + (geiser-con--connection-add-request con req) + req)) (defvar geiser-connection-timeout 30000 "Time limit, in msecs, blocking on synchronous evaluation requests") -(defun geiser-con--send-string/wait (b/p str cont &optional timeout sbuf) +(defun geiser-con--send-string/wait (con str cont &optional timeout sbuf) (save-current-buffer - (let* ((con (geiser-con--get-connection b/p)) - (proc (and con (geiser-con--connection-process con)))) - (unless proc (error geiser-con--error-message)) - (when (geiser-con--is-debugging con) (error "REPL is in debug mode")) - (let* ((req (geiser-con--make-request con str cont sbuf)) + (let ((proc (and con (geiser-con--connection-process con)))) + (unless proc (error "Geiser connection not active")) + (let* ((req (geiser-con--send-string con str cont sbuf)) (id (geiser-con--request-id req)) - (timeout (/ (or timeout geiser-connection-timeout) 1000.0)) - (waitsecs 0.1)) - (geiser-con--connection-add-request con req) + (timeout (/ (or timeout geiser-connection-timeout) 1000.0))) (with-timeout (timeout (geiser-con--request-deactivate req)) (condition-case nil (while (and (geiser-con--connection-process con) (not (geiser-con--connection-completed-p con id))) - (geiser-con--process-next con) - (accept-process-output proc waitsecs nil t)) + (accept-process-output proc (/ timeout 10))) (error (geiser-con--request-deactivate req)))))))) (provide 'geiser-connection) -;;; geiser-connection.el ends here |