misc/fuel/fuel-connection.el

   1 ;;; fuel-connection.el -- asynchronous comms with the fuel listener -*- lexical-binding: t -*-
   2
   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.
   6
   7 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
   8 ;; Keywords: languages, fuel, factor
   9 ;; Start date: Thu Dec 11, 2008 03:10
  10
  11 ;;; Comentary:
  12
  13 ;; Handling communications via a comint buffer running a factor
  14 ;; listener.
  15
  16 ;;; Code:
  17
  18 (require 'fuel-log)
  19 (require 'fuel-base)
  20
  21 (require 'comint)
  22 (require 'advice)
  23
  24 \f
  25 ;;; Default connection:
  26
  27 (defvar-local fuel-con--connection nil)
  28
  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)))
  33
  34 \f
  35 ;;; Request and connection datatypes:
  36
  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)))))
  41
  42 (defun fuel-con--make-request (str cont &optional sender-buffer)
  43   (list :fuel-connection-request
  44         (cons :id (+ 10000 (random 89999)))
  45         (cons :string str)
  46         (cons :continuation cont)
  47         (cons :buffer (or sender-buffer (current-buffer)))))
  48
  49 (defsubst fuel-con--request-p (req)
  50   (and (listp req) (eq (car req) :fuel-connection-request)))
  51
  52 (defsubst fuel-con--request-deactivate (req)
  53   (setcdr (assoc :continuation req) nil))
  54
  55 (defsubst fuel-con--request-deactivated-p (req)
  56   (null (alist-get :continuation req)))
  57
  58 ;;; TODO Replace with a defstruct
  59 (defsubst fuel-con--make-connection (buffer)
  60   (list :fuel-connection
  61         (cons :requests (list))
  62         (cons :current nil)
  63         (cons :completed (make-hash-table :weakness 'value))
  64         (cons :buffer buffer)
  65         (cons :timer nil)))
  66
  67 (defsubst fuel-con--connection-p (c)
  68   (and (listp c) (eq (car c) :fuel-connection)))
  69
  70 (defun fuel-con--connection-clean-current-request (c)
  71   (let* ((cell (assoc :current c))
  72          (req (cdr cell)))
  73     (when req
  74       (puthash (alist-get :id req) req (alist-get :completed c))
  75       (setcdr cell nil))))
  76
  77 (defsubst fuel-con--connection-completed-p (c id)
  78   (gethash id (alist-get :completed c)))
  79
  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)
  87       (cdr current))))
  88
  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))))
  93
  94 (defun fuel-con--connection-cancel-timer (c)
  95   (let ((cell (assoc :timer c)))
  96     (when (cdr cell) (cancel-timer (cdr cell)))))
  97
  98 \f
  99 ;;; Connection setup:
 100
 101 (defun fuel-con--cleanup-connection (c)
 102   (fuel-con--connection-cancel-timer c))
 103
 104 (defun fuel-con--setup-connection (buffer)
 105   (set-buffer 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)))
 111
 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")
 115
 116 (defconst fuel-con--comint-finished-regex-connected
 117   (format "^%s$" fuel-con--eot-marker))
 118
 119 (defvar fuel-con--comint-finished-regex fuel-con--prompt-regex)
 120
 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))
 127
 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)
 134
 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))
 138   str)
 139
 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
 148                                 3000000)
 149     conn))
 150
 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)
 154         (progn
 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)))))
 163
 164 \f
 165 ;;; Requests handling:
 166
 167 (defsubst fuel-con--comint-buffer ()
 168   (get-buffer-create " *fuel connection retort*"))
 169
 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))
 175     (condition-case cerr
 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))))))
 180
 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)
 187                    (erase-buffer)
 188                    (current-buffer))))
 189       (if (not (buffer-live-p buffer))
 190           (fuel-con--connection-cancel-timer con)
 191         (when (and buffer req str)
 192           (set-buffer buffer)
 193           (fuel-log--info "<%s>: %s" (alist-get :id req) str)
 194           (comint-redirect-send-command (format "%s" str) cbuf nil t))))))
 195
 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)))
 201     (if (not cont)
 202         (fuel-log--warn "<%s> Dropping result for request %S (%s)"
 203                             id rstr req)
 204       (condition-case cerr
 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))))))
 210
 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)))))
 218
 219 \f
 220 ;;; Message sending interface:
 221
 222 (defconst fuel-con--error-message "FUEL connection not active")
 223
 224 (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
 225   (save-current-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)
 231         req))))
 232
 233 (defvar fuel-connection-timeout 30000
 234   "Time limit, in msecs, blocking on synchronous evaluation requests")
 235
 236 (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
 237   (save-current-buffer
 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))
 243              (step 100)
 244              (waitsecs (/ step 1000.0)))
 245         (when id
 246           (condition-case nil
 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)))
 252           (or (> time 0)
 253               (fuel-con--request-deactivate req)
 254               nil))))))
 255
 256 \f
 257 (provide 'fuel-connection)
 258
 259 ;;; fuel-connection.el ends here