summaryrefslogtreecommitdiff
path: root/elisp/geiser-connection.el
diff options
context:
space:
mode:
Diffstat (limited to 'elisp/geiser-connection.el')
-rw-r--r--elisp/geiser-connection.el274
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