1 ;;; fuel-connection.el -- asynchronous comms with the fuel listener -*- lexical-binding: t -*-
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-deactivate (req)
53 (setcdr (assoc :continuation req) nil))
55 (defsubst fuel-con--request-deactivated-p (req)
56 (null (alist-get :continuation req)))
58 ;;; TODO Replace with a defstruct
59 (defsubst fuel-con--make-connection (buffer)
60 (list :fuel-connection
61 (cons :requests (list))
63 (cons :completed (make-hash-table :weakness 'value))
67 (defsubst fuel-con--connection-p (c)
68 (and (listp c) (eq (car c) :fuel-connection)))
70 (defun fuel-con--connection-clean-current-request (c)
71 (let* ((cell (assoc :current c))
74 (puthash (alist-get :id req) req (alist-get :completed c))
77 (defsubst fuel-con--connection-completed-p (c id)
78 (gethash id (alist-get :completed c)))
80 (defun fuel-con--connection-pop-request (c)
81 (let ((reqs (assoc :requests c))
82 (current (assoc :current c)))
83 (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
84 (if (and (cdr current)
85 (fuel-con--request-deactivated-p (cdr current)))
86 (fuel-con--connection-pop-request c)
89 (defun fuel-con--connection-start-timer (c)
90 (let ((cell (assoc :timer c)))
91 (when (cdr cell) (cancel-timer (cdr cell)))
92 (setcdr cell (run-at-time t 0.5 'fuel-con--process-next c))))
94 (defun fuel-con--connection-cancel-timer (c)
95 (let ((cell (assoc :timer c)))
96 (when (cdr cell) (cancel-timer (cdr cell)))))
101 (defun fuel-con--cleanup-connection (c)
102 (fuel-con--connection-cancel-timer c))
104 (defun fuel-con--setup-connection (buffer)
106 (fuel-con--cleanup-connection fuel-con--connection)
107 (setq fuel-con--connection nil)
108 (let ((conn (fuel-con--make-connection buffer)))
109 (fuel-con--setup-comint)
110 (fuel-con--establish-connection conn buffer)))
112 (defconst fuel-con--prompt-regex "^IN: [^ ]+\\( auto-use\\)? ")
113 (defconst fuel-con--eot-marker "<~FUEL~>")
114 (defconst fuel-con--init-stanza "USE: fuel fuel-retort")
116 (defconst fuel-con--comint-finished-regex-connected
117 (format "^%s$" fuel-con--eot-marker))
119 (defvar fuel-con--comint-finished-regex fuel-con--prompt-regex)
121 (defun fuel-con--setup-comint ()
122 (setq-local comint-redirect-insert-matching-regexp t)
123 (add-hook 'comint-redirect-filter-functions
124 'fuel-con--comint-preoutput-filter nil t)
125 (add-hook 'comint-redirect-hook
126 'fuel-con--comint-redirect-hook nil t))
128 (defadvice comint-redirect-setup
129 (after fuel-con--advice (output-buffer comint-buffer finished-regexp &optional echo))
130 (with-current-buffer comint-buffer
131 (when fuel-con--connection
132 (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))))
133 (ad-activate 'comint-redirect-setup)
135 (defun fuel-con--comint-preoutput-filter (str)
136 (when (string-match fuel-con--comint-finished-regex str)
137 (setq comint-redirect-finished-regexp fuel-con--prompt-regex))
140 (defun fuel-con--establish-connection (conn buffer)
141 (with-current-buffer (fuel-con--comint-buffer) (erase-buffer))
142 (with-current-buffer buffer
143 (setq fuel-con--connection conn)
144 (setq fuel-con--comint-finished-regex fuel-con--prompt-regex)
145 (fuel-con--send-string/wait buffer
146 fuel-con--init-stanza
147 'fuel-con--establish-connection-cont
151 (defun fuel-con--establish-connection-cont (ignore)
152 (let ((str (with-current-buffer (fuel-con--comint-buffer) (buffer-string))))
153 (if (string-match fuel-con--eot-marker str)
155 (setq fuel-con--comint-finished-regex
156 fuel-con--comint-finished-regex-connected)
157 (fuel-con--connection-start-timer fuel-con--connection)
158 (message "FUEL listener up and running!"))
159 (fuel-con--connection-clean-current-request fuel-con--connection)
160 (setq fuel-con--connection nil)
161 (message "An error occurred initialising FUEL's Factor library!")
162 (pop-to-buffer (fuel-con--comint-buffer)))))
165 ;;; Requests handling:
167 (defsubst fuel-con--comint-buffer ()
168 (get-buffer-create " *fuel connection retort*"))
170 (defun fuel-con--comint-buffer-form ()
171 "Parse the text in the comint buffer into a
172 sexp. fuel-con-error is thrown if the sexp is malformed."
173 (with-current-buffer (fuel-con--comint-buffer)
174 (goto-char (point-min))
176 (let ((form (read (current-buffer))))
177 (if (listp form) form
178 (list 'fuel-con-error (buffer-string))))
179 (error (list 'fuel-con-error (format "%s" cerr))))))
181 (defun fuel-con--process-next (con)
182 (when (not (alist-get :current con))
183 (let* ((buffer (alist-get :buffer con))
184 (req (fuel-con--connection-pop-request con))
185 (str (and req (alist-get :string req)))
186 (cbuf (with-current-buffer (fuel-con--comint-buffer)
189 (if (not (buffer-live-p buffer))
190 (fuel-con--connection-cancel-timer con)
191 (when (and buffer req str)
193 (fuel-log--info "<%s>: %s" (alist-get :id req) str)
194 (comint-redirect-send-command (format "%s" str) cbuf nil t))))))
196 (defun fuel-con--process-completed-request (req)
197 (let ((cont (alist-get :continuation req))
198 (id (alist-get :id req))
199 (rstr (alist-get :string req))
200 (buffer (alist-get :buffer req)))
202 (fuel-log--warn "<%s> Dropping result for request %S (%s)"
205 (with-current-buffer (or buffer (current-buffer))
206 (funcall cont (fuel-con--comint-buffer-form))
207 (fuel-log--info "<%s>: processed" id))
208 (error (fuel-log--error
209 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
211 (defun fuel-con--comint-redirect-hook ()
212 (if (not fuel-con--connection)
213 (fuel-log--error "No connection in buffer")
214 (let ((req (alist-get :current fuel-con--connection)))
215 (if (not req) (fuel-log--error "No current request")
216 (fuel-con--process-completed-request req)
217 (fuel-con--connection-clean-current-request fuel-con--connection)))))
220 ;;; Message sending interface:
222 (defconst fuel-con--error-message "FUEL connection not active")
224 (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
226 (let ((con (fuel-con--get-connection buffer/proc)))
227 (unless con (error fuel-con--error-message))
228 (let ((req (fuel-con--make-request str cont sender-buffer)))
229 (fuel-con--connection-queue-request con req)
230 (fuel-con--process-next con)
233 (defvar fuel-connection-timeout 30000
234 "Time limit, in msecs, blocking on synchronous evaluation requests")
236 (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
238 (let ((con (fuel-con--get-connection buffer/proc)))
239 (unless con (error fuel-con--error-message))
240 (let* ((req (fuel-con--send-string buffer/proc str cont sbuf))
241 (id (and req (alist-get :id req)))
242 (time (or timeout fuel-connection-timeout))
244 (waitsecs (/ step 1000.0)))
247 (while (and (> time 0)
248 (not (fuel-con--connection-completed-p con id)))
249 (accept-process-output nil waitsecs)
250 (setq time (- time step)))
251 (error (setq time 0)))
253 (fuel-con--request-deactivate req)
257 (provide 'fuel-connection)
259 ;;; fuel-connection.el ends here