blob: af4c61139ace307ccd328f4b7aad0b02df4fe76c (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
|
;;; geiser-connection.el -- talking to a scheme process
;; Copyright (C) 2009 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 'comint)
(require 'advice)
;;; 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 (str cont &optional sender-buffer)
(list :geiser-connection-request
(cons :id (random))
(cons :string str)
(cons :continuation cont)
(cons :buffer (or sender-buffer (current-buffer)))))
(defsubst geiser-con--request-p (req)
(and (listp req) (eq (car req) :geiser-connection-request)))
(defsubst geiser-con--request-id (req)
(cdr (assoc :id req)))
(defsubst geiser-con--request-string (req)
(cdr (assoc :string req)))
(defsubst geiser-con--request-continuation (req)
(cdr (assoc :continuation req)))
(defsubst geiser-con--request-buffer (req)
(cdr (assoc :buffer req)))
(defsubst geiser-con--request-deactivate (req)
(setcdr (assoc :continuation req) nil))
(defsubst geiser-con--request-deactivated-p (req)
(null (cdr (assoc :continuation req))))
;;; Connection datatype:
(defsubst geiser-con--make-connection (buffer)
(list :geiser-connection
(cons :requests (list))
(cons :current nil)
(cons :completed (make-hash-table :weakness 'value))
(cons :buffer buffer)
(cons :timer nil)))
(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)))
(defsubst geiser-con--connection-requests (c)
(cdr (assoc :requests c)))
(defsubst geiser-con--connection-current-request (c)
(cdr (assoc :current c)))
(defun geiser-con--connection-clean-current-request (c)
(let* ((cell (assoc :current c))
(req (cdr cell)))
(when req
(puthash (geiser-con--request-id req) req (cdr (assoc :completed c)))
(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)))
(setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
(if (and (cdr current)
(geiser-con--request-deactivated-p (cdr current)))
(geiser-con--connection-pop-request c)
(cdr current))))
(defun geiser-con--connection-start-timer (c)
(let ((cell (assoc :timer c)))
(when (cdr cell) (cancel-timer (cdr cell)))
(setcdr cell (run-at-time t 0.5 'geiser-con--process-next c))))
(defun geiser-con--connection-cancel-timer (c)
(let ((cell (assoc :timer c)))
(when (cdr cell) (cancel-timer (cdr cell)))))
;;; Connection setup:
(defun geiser-con--cleanup-connection (c)
(geiser-con--connection-cancel-timer c))
(defun geiser-con--setup-connection (buffer prompt-regexp)
(with-current-buffer buffer
(when geiser-con--connection
(geiser-con--cleanup-connection geiser-con--connection))
(setq geiser-con--connection (geiser-con--make-connection buffer))
(geiser-con--setup-comint prompt-regexp)
(geiser-con--connection-start-timer geiser-con--connection)
(message "Geiser REPL up and running!")))
(defun geiser-con--setup-comint (prompt-regexp)
(set (make-local-variable 'comint-redirect-insert-matching-regexp) nil)
(set (make-local-variable 'comint-redirect-finished-regexp) prompt-regexp)
(add-hook 'comint-redirect-hook 'geiser-con--comint-redirect-hook nil t))
;;; Requests handling:
(defsubst geiser-con--comint-buffer ()
(get-buffer-create " *geiser connection retort*"))
(defun geiser-con--comint-buffer-form ()
(with-current-buffer (geiser-con--comint-buffer)
(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))))
(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)))
(cbuf (geiser-con--comint-buffer)))
(if (not (buffer-live-p buffer))
(geiser-con--connection-cancel-timer con)
(when (and buffer req str)
(with-current-buffer cbuf (delete-region (point-min) (point-max)))
(set-buffer buffer)
(geiser-log--info "<%s>: %s" (geiser-con--request-id req) str)
(comint-redirect-send-command (format "%s" str) cbuf 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)))
(if (not cont)
(geiser-log--warn "<%s> Droping result for request %S (%s)"
id rstr req)
(condition-case cerr
(with-current-buffer (or buffer (current-buffer))
(funcall cont (geiser-con--comint-buffer-form))
(geiser-log--info "<%s>: processed" id))
(error (geiser-log--error
"<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
(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)
(geiser-con--connection-clean-current-request geiser-con--connection)))))
(defadvice comint-redirect-setup
(after geiser-con--advice
(output-buffer comint-buffer finished-regexp &optional echo))
(with-current-buffer comint-buffer
(when geiser-con--connection (setq mode-line-process nil))))
(ad-activate 'comint-redirect-setup)
;;; Message sending interface:
(defconst geiser-con--error-message "Geiser connection not active")
(defun geiser-con--send-string (buffer/proc str cont &optional sender-buffer)
(save-current-buffer
(let ((con (geiser-con--get-connection buffer/proc)))
(unless con (error geiser-con--error-message))
(let ((req (geiser-con--make-request str cont sender-buffer)))
(geiser-con--connection-add-request con req)
(geiser-con--process-next con)
req))))
(defvar geiser-connection-timeout 30000
"Time limit, in msecs, blocking on synchronous evaluation requests")
(defun geiser-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
(save-current-buffer
(let ((con (geiser-con--get-connection buffer/proc)))
(unless (geiser-con--connection-process con)
(error geiser-con--error-message))
(let* ((req (geiser-con--send-string buffer/proc str cont sbuf))
(id (and req (geiser-con--request-id req)))
(time (or timeout geiser-connection-timeout))
(step 100)
(waitsecs (/ step 1000.0)))
(when id
(condition-case nil
(while (and (> time 0)
(geiser-con--connection-process con)
(not (geiser-con--connection-completed-p con id)))
(accept-process-output nil waitsecs)
(setq time (- time step)))
(error (setq time 0)))
(or (> time 0)
(geiser-con--request-deactivate req)
nil))))))
(provide 'geiser-connection)
;;; geiser-connection.el ends here
|
