Fix for the fix
[geiser.git] / elisp / geiser-connection.el
blobcce2c5ba97a6548835a61520dde6e89e24cf64cd
1 ;;; geiser-connection.el -- talking to a scheme process
3 ;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the Modified BSD License. You should
7 ;; have received a copy of the license along with this program. If
8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
10 ;; Start date: Sat Feb 07, 2009 21:11
14 ;; Connection datatype and functions for managing request queues
15 ;; between emacs and inferior guile processes.
17 (require 'geiser-log)
18 (require 'geiser-syntax)
19 (require 'geiser-base)
20 (require 'geiser-impl)
22 (require 'tq)
25 ;;; Buffer connections:
27 (make-variable-buffer-local
28 (defvar geiser-con--connection nil))
30 (defun geiser-con--get-connection (buffer/proc)
31 (if (processp buffer/proc)
32 (geiser-con--get-connection (process-buffer buffer/proc))
33 (with-current-buffer buffer/proc geiser-con--connection)))
36 ;;; Request datatype:
38 (defun geiser-con--make-request (con str cont &optional sender-buffer)
39 (list (cons :id (geiser-con--connection-inc-count con))
40 (cons :string str)
41 (cons :continuation cont)
42 (cons :buffer (or sender-buffer (current-buffer)))
43 (cons :connection con)))
45 (defsubst geiser-con--request-id (req)
46 (cdr (assoc :id req)))
48 (defsubst geiser-con--request-string (req)
49 (cdr (assoc :string req)))
51 (defsubst geiser-con--request-continuation (req)
52 (cdr (assoc :continuation req)))
54 (defsubst geiser-con--request-buffer (req)
55 (cdr (assoc :buffer req)))
57 (defsubst geiser-con--request-connection (req)
58 (cdr (assoc :connection req)))
60 (defsubst geiser-con--request-deactivate (req)
61 (setcdr (assoc :continuation req) nil))
63 (defsubst geiser-con--request-deactivated-p (req)
64 (null (cdr (assoc :continuation req))))
67 ;;; Connection datatype:
69 (defun geiser-con--tq-create (process)
70 (let ((tq (tq-create process)))
71 (set-process-filter process
72 `(lambda (p s) (geiser-con--tq-filter ',tq s)))
73 tq))
75 (defun geiser-con--tq-filter (tq in)
76 (when (buffer-live-p (tq-buffer tq))
77 (with-current-buffer (tq-buffer tq)
78 (if (tq-queue-empty tq)
79 (progn (geiser-log--error "Unexpected queue input:\n %s" in)
80 (delete-region (point-min) (point-max)))
81 (goto-char (point-max))
82 (insert in)
83 (goto-char (point-min))
84 (when (re-search-forward (tq-queue-head-regexp tq) nil t)
85 (unwind-protect
86 (funcall (tq-queue-head-fn tq)
87 (tq-queue-head-closure tq)
88 (buffer-substring (point-min) (point)))
89 (delete-region (point-min) (point-max))
90 (tq-queue-pop tq)))))))
92 (defun geiser-con--combined-prompt (prompt debug)
93 (format "\\(%s%s\\)" prompt (if debug (format "\\|%s" debug) "")))
95 (defun geiser-con--connection-eot-re (prompt debug)
96 (geiser-con--combined-prompt (format "\n%s" prompt)
97 (and debug (format "\n%s" debug))))
99 (defun geiser-con--make-connection (proc prompt debug-prompt)
100 (list t
101 (cons :filter (process-filter proc))
102 (cons :tq (geiser-con--tq-create proc))
103 (cons :tq-filter (process-filter proc))
104 (cons :eot (geiser-con--connection-eot-re prompt debug-prompt))
105 (cons :prompt prompt)
106 (cons :debug-prompt debug-prompt)
107 (cons :is-debugging nil)
108 (cons :count 0)
109 (cons :completed (make-hash-table :weakness 'value))))
111 (defsubst geiser-con--connection-process (c)
112 (tq-process (cdr (assoc :tq c))))
114 (defsubst geiser-con--connection-filter (c)
115 (cdr (assoc :filter c)))
117 (defsubst geiser-con--connection-tq-filter (c)
118 (cdr (assoc :tq-filter c)))
120 (defsubst geiser-con--connection-tq (c)
121 (cdr (assoc :tq c)))
123 (defsubst geiser-con--connection-eot (c)
124 (cdr (assoc :eot c)))
126 (defsubst geiser-con--connection-prompt (c)
127 (cdr (assoc :prompt c)))
129 (defsubst geiser-con--connection-debug-prompt (c)
130 (cdr (assoc :debug-prompt c)))
132 (defsubst geiser-con--connection-is-debugging (c)
133 (cdr (assoc :is-debugging c)))
135 (defsubst geiser-con--connection-set-debugging (c d)
136 (setcdr (assoc :is-debugging c) d))
138 (defun geiser-con--connection-update-debugging (c txt)
139 (let* ((dp (geiser-con--connection-debug-prompt c))
140 (is-d (and (stringp dp) (string-match dp txt))))
141 (geiser-con--connection-set-debugging c is-d)
142 is-d))
144 (defsubst geiser-con--connection-completed (c r)
145 (geiser-con--request-deactivate r)
146 (puthash (geiser-con--request-id r) r (cdr (assoc :completed c))))
148 (defsubst geiser-con--connection-completed-p (c id)
149 (gethash id (cdr (assoc :completed c))))
151 (defun geiser-con--connection-inc-count (c)
152 (let* ((cnt (assoc :count c))
153 (new (1+ (cdr cnt))))
154 (setcdr cnt new)
155 new))
157 (defun geiser-con--has-entered-debugger (con answer)
158 (and (not (geiser-con--connection-is-debugging con))
159 (geiser-con--connection-update-debugging con answer)))
161 (defun geiser-con--connection-close (con)
162 (let ((tq (geiser-con--connection-tq con)))
163 (and tq (tq-close tq))))
165 (defvar geiser-con--startup-prompt nil)
166 (defun geiser-con--startup-prompt (p s)
167 (setq geiser-con--startup-prompt
168 (concat geiser-con--startup-prompt s))
169 nil)
171 (defun geiser-con--connection-deactivate (c &optional no-wait)
172 (when (car c)
173 (let* ((tq (geiser-con--connection-tq c))
174 (proc (geiser-con--connection-process c))
175 (proc-filter (geiser-con--connection-filter c)))
176 (unless no-wait
177 (while (and (not (tq-queue-empty tq))
178 (accept-process-output proc 0.1))))
179 (set-process-filter proc proc-filter)
180 (setcar c nil))))
182 (defun geiser-con--connection-activate (c)
183 (when (not (car c))
184 (let* ((tq (geiser-con--connection-tq c))
185 (proc (geiser-con--connection-process c))
186 (tq-filter (geiser-con--connection-tq-filter c)))
187 (while (accept-process-output proc 0.01))
188 (set-process-filter proc tq-filter)
189 (setcar c t))))
192 ;;; Requests handling:
194 (defun geiser-con--req-form (req answer)
195 (let ((con (geiser-con--request-connection req)))
196 (if (geiser-con--has-entered-debugger con answer)
197 `((error (key . geiser-debugger))
198 (output . ,answer))
199 (condition-case err
200 (let* ((start (string-match "((\\(?:result\\|error\\) " answer))
201 (form (or (and start (car (read-from-string answer start)))
202 `((error (key . retort-syntax)
203 (output . ,answer))))))
204 form)
205 (error `((error (key . geiser-con-error))
206 (output . ,(format "%s\n(%s)"
207 answer
208 (error-message-string err)))))))))
210 (defun geiser-con--process-completed-request (req answer)
211 (let ((cont (geiser-con--request-continuation req))
212 (id (geiser-con--request-id req))
213 (rstr (geiser-con--request-string req))
214 (form (geiser-con--req-form req answer))
215 (buffer (or (geiser-con--request-buffer req) (current-buffer)))
216 (con (geiser-con--request-connection req)))
217 (if (not cont)
218 (geiser-log--warn "<%s> Droping result for request %S: %s"
219 id rstr form)
220 (condition-case cerr
221 (with-current-buffer buffer
222 (funcall cont form)
223 (geiser-log--info "<%s>: processed" id))
224 (error (geiser-log--error
225 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))
226 (geiser-con--connection-completed con req)))
228 (defun geiser-con--connection-add-request (c r)
229 (geiser-log--info "REQUEST: <%s>: %s"
230 (geiser-con--request-id r)
231 (geiser-con--request-string r))
232 (geiser-con--connection-activate c)
233 (tq-enqueue (geiser-con--connection-tq c)
234 (concat (geiser-con--request-string r) "\n")
235 (geiser-con--connection-eot c)
237 'geiser-con--process-completed-request
241 ;;; Message sending interface:
243 (defun geiser-con--send-string (con str cont &optional sbuf)
244 (let ((req (geiser-con--make-request con str cont sbuf)))
245 (geiser-con--connection-add-request con req)
246 req))
248 (defvar geiser-connection-timeout 30000
249 "Time limit, in msecs, blocking on synchronous evaluation requests")
251 (defun geiser-con--send-string/wait (con str cont &optional timeout sbuf)
252 (save-current-buffer
253 (let ((proc (and con (geiser-con--connection-process con))))
254 (unless proc (error "Geiser connection not active"))
255 (let* ((req (geiser-con--send-string con str cont sbuf))
256 (id (geiser-con--request-id req))
257 (timeout (/ (or timeout geiser-connection-timeout) 1000.0)))
258 (with-timeout (timeout (geiser-con--request-deactivate req))
259 (condition-case nil
260 (while (and (geiser-con--connection-process con)
261 (not (geiser-con--connection-completed-p con id)))
262 (accept-process-output proc (/ timeout 10)))
263 (error (geiser-con--request-deactivate req))))))))
266 (provide 'geiser-connection)