1 ;;; fuel-connection.el -- asynchronous comms with the fuel listener
3 ;; Copyright (C) 2018 Björn Lindqvist
4 ;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
5 ;; See http://factorcode.org/license.txt for BSD license.
7 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
8 ;; Keywords: languages, fuel, factor
9 ;; Start date: Thu Dec 11, 2008 03:10
13 ;; Handling communications via a comint buffer running a factor
25 ;;; Default connection:
27 (defvar-local fuel-con--connection nil)
29 (defun fuel-con--get-connection (buffer/proc)
30 (if (processp buffer/proc)
31 (fuel-con--get-connection (process-buffer buffer/proc))
32 (with-current-buffer buffer/proc fuel-con--connection)))
35 ;;; Request and connection datatypes:
37 ;;; TODO Replace with a defstruct
38 (defun fuel-con--connection-queue-request (c r)
39 (let ((reqs (assoc :requests c)))
40 (setcdr reqs (append (cdr reqs) (list r)))))
42 (defun fuel-con--make-request (str cont &optional sender-buffer)
43 (list :fuel-connection-request
44 (cons :id (+ 10000 (random 89999)))
46 (cons :continuation cont)
47 (cons :buffer (or sender-buffer (current-buffer)))))
49 (defsubst fuel-con--request-p (req)
50 (and (listp req) (eq (car req) :fuel-connection-request)))
52 (defsubst fuel-con--request-string (req)
53 (alist-get :string req))
55 (defsubst fuel-con--request-buffer (req)
56 (alist-get :buffer req))
58 (defsubst fuel-con--request-deactivate (req)
59 (setcdr (assoc :continuation req) nil))
61 (defsubst fuel-con--request-deactivated-p (req)
62 (null (alist-get :continuation req)))
64 ;;; TODO Replace with a defstruct
65 (defsubst fuel-con--make-connection (buffer)
66 (list :fuel-connection
67 (cons :requests (list))
69 (cons :completed (make-hash-table :weakness 'value))
73 (defsubst fuel-con--connection-p (c)
74 (and (listp c) (eq (car c) :fuel-connection)))
76 (defsubst fuel-con--connection-requests (c)
77 (alist-get :requests c))
79 (defsubst fuel-con--connection-current-request (c)
80 (alist-get :current c))
82 (defun fuel-con--connection-clean-current-request (c)
83 (let* ((cell (assoc :current c))
86 (puthash (alist-get :id req) req (alist-get :completed c))
89 (defsubst fuel-con--connection-completed-p (c id)
90 (gethash id (alist-get :completed c)))
92 (defsubst fuel-con--connection-buffer (c)
93 (alist-get :buffer c))
95 (defun fuel-con--connection-pop-request (c)
96 (let ((reqs (assoc :requests c))
97 (current (assoc :current c)))
98 (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
99 (if (and (cdr current)
100 (fuel-con--request-deactivated-p (cdr current)))
101 (fuel-con--connection-pop-request c)
104 (defun fuel-con--connection-start-timer (c)
105 (let ((cell (assoc :timer c)))
106 (when (cdr cell) (cancel-timer (cdr cell)))
107 (setcdr cell (run-at-time t 0.5 'fuel-con--process-next c))))
109 (defun fuel-con--connection-cancel-timer (c)
110 (let ((cell (assoc :timer c)))
111 (when (cdr cell) (cancel-timer (cdr cell)))))
114 ;;; Connection setup:
116 (defun fuel-con--cleanup-connection (c)
117 (fuel-con--connection-cancel-timer c))
119 (defun fuel-con--setup-connection (buffer)
121 (fuel-con--cleanup-connection fuel-con--connection)
122 (setq fuel-con--connection nil)
123 (let ((conn (fuel-con--make-connection buffer)))
124 (fuel-con--setup-comint)
125 (fuel-con--establish-connection conn buffer)))
127 (defconst fuel-con--prompt-regex "^IN: [^ ]+\\( auto-use\\)? ")
128 (defconst fuel-con--eot-marker "<~FUEL~>")
129 (defconst fuel-con--init-stanza "USE: fuel fuel-retort")
131 (defconst fuel-con--comint-finished-regex-connected
132 (format "^%s$" fuel-con--eot-marker))
134 (defvar fuel-con--comint-finished-regex fuel-con--prompt-regex)
136 (defun fuel-con--setup-comint ()
137 (setq-local comint-redirect-insert-matching-regexp t)
138 (add-hook 'comint-redirect-filter-functions
139 'fuel-con--comint-preoutput-filter nil t)
140 (add-hook 'comint-redirect-hook
141 'fuel-con--comint-redirect-hook nil t))
143 (defadvice comint-redirect-setup
144 (after fuel-con--advice (output-buffer comint-buffer finished-regexp &optional echo))
145 (with-current-buffer comint-buffer
146 (when fuel-con--connection
147 (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))))
148 (ad-activate 'comint-redirect-setup)
150 (defun fuel-con--comint-preoutput-filter (str)
151 (when (string-match fuel-con--comint-finished-regex str)
152 (setq comint-redirect-finished-regexp fuel-con--prompt-regex))
155 (defun fuel-con--establish-connection (conn buffer)
156 (with-current-buffer (fuel-con--comint-buffer) (erase-buffer))
157 (with-current-buffer buffer
158 (setq fuel-con--connection conn)
159 (setq fuel-con--comint-finished-regex fuel-con--prompt-regex)
160 (fuel-con--send-string/wait buffer
161 fuel-con--init-stanza
162 'fuel-con--establish-connection-cont
166 (defun fuel-con--establish-connection-cont (ignore)
167 (let ((str (with-current-buffer (fuel-con--comint-buffer) (buffer-string))))
168 (if (string-match fuel-con--eot-marker str)
170 (setq fuel-con--comint-finished-regex
171 fuel-con--comint-finished-regex-connected)
172 (fuel-con--connection-start-timer fuel-con--connection)
173 (message "FUEL listener up and running!"))
174 (fuel-con--connection-clean-current-request fuel-con--connection)
175 (setq fuel-con--connection nil)
176 (message "An error occurred initialising FUEL's Factor library!")
177 (pop-to-buffer (fuel-con--comint-buffer)))))
180 ;;; Requests handling:
182 (defsubst fuel-con--comint-buffer ()
183 (get-buffer-create " *fuel connection retort*"))
185 (defun fuel-con--comint-buffer-form ()
186 "Parse the text in the comint buffer into a
187 sexp. fuel-con-error is thrown if the sexp is malformed."
188 (with-current-buffer (fuel-con--comint-buffer)
189 (goto-char (point-min))
191 (let ((form (read (current-buffer))))
192 (if (listp form) form
193 (list 'fuel-con-error (buffer-string))))
194 (error (list 'fuel-con-error (format "%s" cerr))))))
196 (defun fuel-con--process-next (con)
197 (when (not (fuel-con--connection-current-request con))
198 (let* ((buffer (fuel-con--connection-buffer con))
199 (req (fuel-con--connection-pop-request con))
200 (str (and req (fuel-con--request-string req)))
201 (cbuf (with-current-buffer (fuel-con--comint-buffer)
204 (if (not (buffer-live-p buffer))
205 (fuel-con--connection-cancel-timer con)
206 (when (and buffer req str)
208 (fuel-log--info "<%s>: %s" (alist-get :id req) str)
209 (comint-redirect-send-command (format "%s" str) cbuf nil t))))))
211 (defun fuel-con--process-completed-request (req)
212 (let ((cont (alist-get :continuation req))
213 (id (alist-get :id req))
214 (rstr (fuel-con--request-string req))
215 (buffer (fuel-con--request-buffer req)))
217 (fuel-log--warn "<%s> Dropping result for request %S (%s)"
220 (with-current-buffer (or buffer (current-buffer))
221 (funcall cont (fuel-con--comint-buffer-form))
222 (fuel-log--info "<%s>: processed" id))
223 (error (fuel-log--error
224 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
226 (defun fuel-con--comint-redirect-hook ()
227 (if (not fuel-con--connection)
228 (fuel-log--error "No connection in buffer")
229 (let ((req (fuel-con--connection-current-request fuel-con--connection)))
230 (if (not req) (fuel-log--error "No current request")
231 (fuel-con--process-completed-request req)
232 (fuel-con--connection-clean-current-request fuel-con--connection)))))
235 ;;; Message sending interface:
237 (defconst fuel-con--error-message "FUEL connection not active")
239 (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
241 (let ((con (fuel-con--get-connection buffer/proc)))
242 (unless con (error fuel-con--error-message))
243 (let ((req (fuel-con--make-request str cont sender-buffer)))
244 (fuel-con--connection-queue-request con req)
245 (fuel-con--process-next con)
248 (defvar fuel-connection-timeout 30000
249 "Time limit, in msecs, blocking on synchronous evaluation requests")
251 (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
253 (let ((con (fuel-con--get-connection buffer/proc)))
254 (unless con (error fuel-con--error-message))
255 (let* ((req (fuel-con--send-string buffer/proc str cont sbuf))
256 (id (and req (alist-get :id req)))
257 (time (or timeout fuel-connection-timeout))
259 (waitsecs (/ step 1000.0)))
262 (while (and (> time 0)
263 (not (fuel-con--connection-completed-p con id)))
264 (accept-process-output nil waitsecs)
265 (setq time (- time step)))
266 (error (setq time 0)))
268 (fuel-con--request-deactivate req)
272 (provide 'fuel-connection)
274 ;;; fuel-connection.el ends here