270 lines
9.0 KiB
EmacsLisp
270 lines
9.0 KiB
EmacsLisp
;;; geiser-connection.el -- talking to a scheme process
|
||
|
||
;; Copyright (C) 2009, 2010, 2011, 2013 Jose Antonio Ortega Ruiz
|
||
|
||
;; This program is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the Modified BSD License. You should
|
||
;; have received a copy of the license along with this program. If
|
||
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
|
||
|
||
;; Start date: Sat Feb 07, 2009 21:11
|
||
|
||
|
||
|
||
;; Connection datatype and functions for managing request queues
|
||
;; between emacs and inferior guile processes.
|
||
|
||
(require 'geiser-log)
|
||
(require 'geiser-syntax)
|
||
(require 'geiser-base)
|
||
(require 'geiser-impl)
|
||
|
||
(require 'tq)
|
||
|
||
|
||
;;; Buffer connections:
|
||
|
||
(make-variable-buffer-local
|
||
(defvar geiser-con--connection nil))
|
||
|
||
(defun geiser-con--get-connection (buffer/proc)
|
||
(if (processp buffer/proc)
|
||
(geiser-con--get-connection (process-buffer buffer/proc))
|
||
(with-current-buffer buffer/proc geiser-con--connection)))
|
||
|
||
|
||
;;; Request datatype:
|
||
|
||
(defun geiser-con--make-request (con str cont &optional sender-buffer)
|
||
(list (cons :id (geiser-con--connection-inc-count con))
|
||
(cons :string str)
|
||
(cons :continuation cont)
|
||
(cons :buffer (or sender-buffer (current-buffer)))
|
||
(cons :connection con)))
|
||
|
||
(defsubst geiser-con--request-id (req)
|
||
(cdr (assq :id req)))
|
||
|
||
(defsubst geiser-con--request-string (req)
|
||
(cdr (assq :string req)))
|
||
|
||
(defsubst geiser-con--request-continuation (req)
|
||
(cdr (assq :continuation req)))
|
||
|
||
(defsubst geiser-con--request-buffer (req)
|
||
(cdr (assq :buffer req)))
|
||
|
||
(defsubst geiser-con--request-connection (req)
|
||
(cdr (assq :connection req)))
|
||
|
||
(defsubst geiser-con--request-deactivate (req)
|
||
(setcdr (assq :continuation req) nil))
|
||
|
||
(defsubst geiser-con--request-deactivated-p (req)
|
||
(null (cdr (assq :continuation req))))
|
||
|
||
|
||
;;; Connection datatype:
|
||
|
||
(defun geiser-con--tq-create (process)
|
||
(let ((tq (tq-create process)))
|
||
(set-process-filter process
|
||
`(lambda (p s) (geiser-con--tq-filter ',tq s)))
|
||
tq))
|
||
|
||
(defun geiser-con--tq-filter (tq in)
|
||
(when (buffer-live-p (tq-buffer tq))
|
||
(with-current-buffer (tq-buffer tq)
|
||
(if (tq-queue-empty tq)
|
||
(progn (geiser-log--error "Unexpected queue input:\n %s" in)
|
||
(delete-region (point-min) (point-max)))
|
||
(goto-char (point-max))
|
||
(insert in)
|
||
(goto-char (point-min))
|
||
(when (re-search-forward (tq-queue-head-regexp tq) nil t)
|
||
(unwind-protect
|
||
(funcall (tq-queue-head-fn tq)
|
||
(tq-queue-head-closure tq)
|
||
(buffer-substring (point-min) (point)))
|
||
(delete-region (point-min) (point-max))
|
||
(tq-queue-pop tq)))))))
|
||
|
||
(defun geiser-con--combined-prompt (prompt debug)
|
||
(format "\\(%s%s\\)" prompt (if debug (format "\\|%s" debug) "")))
|
||
|
||
(defun geiser-con--connection-eot-re (prompt debug)
|
||
(geiser-con--combined-prompt (format "\n%s" prompt)
|
||
(and debug (format "\n%s" debug))))
|
||
|
||
(defun geiser-con--make-connection (proc prompt debug-prompt)
|
||
(list t
|
||
(cons :filter (process-filter proc))
|
||
(cons :tq (geiser-con--tq-create proc))
|
||
(cons :tq-filter (process-filter proc))
|
||
(cons :eot (geiser-con--connection-eot-re prompt debug-prompt))
|
||
(cons :prompt prompt)
|
||
(cons :debug-prompt debug-prompt)
|
||
(cons :is-debugging nil)
|
||
(cons :count 0)
|
||
(cons :completed (make-hash-table :weakness 'value))))
|
||
|
||
(defsubst geiser-con--connection-process (c)
|
||
(tq-process (cdr (assq :tq c))))
|
||
|
||
(defsubst geiser-con--connection-filter (c)
|
||
(cdr (assq :filter c)))
|
||
|
||
(defsubst geiser-con--connection-tq-filter (c)
|
||
(cdr (assq :tq-filter c)))
|
||
|
||
(defsubst geiser-con--connection-tq (c)
|
||
(cdr (assq :tq c)))
|
||
|
||
(defsubst geiser-con--connection-eot (c)
|
||
(cdr (assq :eot c)))
|
||
|
||
(defsubst geiser-con--connection-prompt (c)
|
||
(cdr (assq :prompt c)))
|
||
|
||
(defsubst geiser-con--connection-debug-prompt (c)
|
||
(cdr (assq :debug-prompt c)))
|
||
|
||
(defsubst geiser-con--connection-is-debugging (c)
|
||
(cdr (assq :is-debugging c)))
|
||
|
||
(defsubst geiser-con--connection-set-debugging (c d)
|
||
(setcdr (assq :is-debugging c) d))
|
||
|
||
(defun geiser-con--connection-update-debugging (c txt)
|
||
(let* ((dp (geiser-con--connection-debug-prompt c))
|
||
(is-d (and (stringp dp) (string-match dp txt))))
|
||
(geiser-con--connection-set-debugging c is-d)
|
||
is-d))
|
||
|
||
(defsubst geiser-con--connection-completed (c r)
|
||
(geiser-con--request-deactivate r)
|
||
(puthash (geiser-con--request-id r) r (cdr (assoc :completed c))))
|
||
|
||
(defsubst geiser-con--connection-completed-p (c id)
|
||
(gethash id (cdr (assoc :completed c))))
|
||
|
||
(defun geiser-con--connection-inc-count (c)
|
||
(let* ((cnt (assoc :count c))
|
||
(new (1+ (cdr cnt))))
|
||
(setcdr cnt new)
|
||
new))
|
||
|
||
(defun geiser-con--has-entered-debugger (con answer)
|
||
(and (not (geiser-con--connection-is-debugging con))
|
||
(let ((p (car (last (split-string answer "\n" t)))))
|
||
(and p (geiser-con--connection-update-debugging con p)))))
|
||
|
||
(defun geiser-con--connection-eot-p (con txt)
|
||
(and txt
|
||
(string-match-p (geiser-con--connection-eot con) txt)))
|
||
|
||
(defun geiser-con--connection-close (con)
|
||
(let ((tq (geiser-con--connection-tq con)))
|
||
(and tq (tq-close tq))))
|
||
|
||
(defvar geiser-con--startup-prompt nil)
|
||
(defun geiser-con--startup-prompt (p s)
|
||
(setq geiser-con--startup-prompt
|
||
(concat geiser-con--startup-prompt s))
|
||
nil)
|
||
|
||
(defun geiser-con--connection-deactivate (c &optional no-wait)
|
||
(when (car c)
|
||
(let* ((tq (geiser-con--connection-tq c))
|
||
(proc (geiser-con--connection-process c))
|
||
(proc-filter (geiser-con--connection-filter c)))
|
||
(unless no-wait
|
||
(while (and (not (tq-queue-empty tq))
|
||
(accept-process-output proc 0.1))))
|
||
(set-process-filter proc proc-filter)
|
||
(setcar c nil))))
|
||
|
||
(defun geiser-con--connection-activate (c)
|
||
(when (not (car c))
|
||
(let* ((tq (geiser-con--connection-tq c))
|
||
(proc (geiser-con--connection-process c))
|
||
(tq-filter (geiser-con--connection-tq-filter c)))
|
||
(while (accept-process-output proc 0.01))
|
||
(set-process-filter proc tq-filter)
|
||
(setcar c t))))
|
||
|
||
|
||
;;; Requests handling:
|
||
|
||
(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 . ,answer))
|
||
(condition-case err
|
||
(let ((start (string-match "((\\(?:result)?\\|error\\) " answer)))
|
||
(or (and start (car (read-from-string answer start)))
|
||
`((error (key . retort-syntax)) (output . ,answer))))
|
||
(error `((error (key . geiser-con-error))
|
||
(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 buffer
|
||
(funcall cont form)
|
||
(geiser-log--info "<%s>: processed" id))
|
||
(error (geiser-log--error
|
||
"<%s>: continuation failed %S \n\t%s" id rstr cerr))))
|
||
(geiser-con--connection-completed con req)))
|
||
|
||
(defun geiser-con--connection-add-request (c r)
|
||
(let ((rstr (geiser-con--request-string r)))
|
||
(geiser-log--info "REQUEST: <%s>: %s"
|
||
(geiser-con--request-id r)
|
||
rstr)
|
||
(geiser-con--connection-activate c)
|
||
(tq-enqueue (geiser-con--connection-tq c)
|
||
(concat rstr "\n")
|
||
(geiser-con--connection-eot c)
|
||
r
|
||
'geiser-con--process-completed-request
|
||
t)))
|
||
|
||
|
||
;;; Message sending interface:
|
||
|
||
(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 (con str cont &optional timeout sbuf)
|
||
(save-current-buffer
|
||
(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)))
|
||
(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)))
|
||
(accept-process-output proc (/ timeout 10)))
|
||
(error (geiser-con--request-deactivate req))))))))
|
||
|
||
|
||
(provide 'geiser-connection)
|