misc/fuel/fuel-connection.el

   1 ;;; fuel-connection.el -- asynchronous comms with the fuel listener
   2
   3 ;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
   4 ;; See http://factorcode.org/license.txt for BSD license.
   5
   6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
   7 ;; Keywords: languages, fuel, factor
   8 ;; Start date: Thu Dec 11, 2008 03:10
   9
  10 ;;; Comentary:
  11
  12 ;; Handling communications via a comint buffer running a factor
  13 ;; listener.
  14
  15 ;;; Code:
  16
  17 (require 'fuel-log)
  18 (require 'fuel-base)
  19
  20 (require 'comint)
  21 (require 'advice)
  22
  23 \f
  24 ;;; Default connection:
  25
  26 (defvar-local fuel-con--connection nil)
  27
  28 (defun fuel-con--get-connection (buffer/proc)
  29   (if (processp buffer/proc)
  30       (fuel-con--get-connection (process-buffer buffer/proc))
  31     (with-current-buffer buffer/proc fuel-con--connection)))
  32
  33 \f
  34 ;;; Request and connection datatypes:
  35
  36 ;;; TODO Replace with a defstruct
  37 (defun fuel-con--connection-queue-request (c r)
  38   (let ((reqs (assoc :requests c)))
  39     (setcdr reqs (append (cdr reqs) (list r)))))
  40
  41 (defun fuel-con--make-request (str cont &optional sender-buffer)
  42   (list :fuel-connection-request
  43         (cons :id (+ 10000 (random 89999)))
  44         (cons :string str)
  45         (cons :continuation cont)
  46         (cons :buffer (or sender-buffer (current-buffer)))))
  47
  48 (defsubst fuel-con--request-p (req)
  49   (and (listp req) (eq (car req) :fuel-connection-request)))
  50
  51 (defsubst fuel-con--request-id (req)
  52   (cdr (assoc :id req)))
  53
  54 (defsubst fuel-con--request-string (req)
  55   (cdr (assoc :string req)))
  56
  57 (defsubst fuel-con--request-continuation (req)
  58   (cdr (assoc :continuation req)))
  59
  60 (defsubst fuel-con--request-buffer (req)
  61   (cdr (assoc :buffer req)))
  62
  63 (defsubst fuel-con--request-deactivate (req)
  64   (setcdr (assoc :continuation req) nil))
  65
  66 (defsubst fuel-con--request-deactivated-p (req)
  67   (null (cdr (assoc :continuation req))))
  68
  69 ;;; TODO Replace with a defstruct
  70 (defsubst fuel-con--make-connection (buffer)
  71   (list :fuel-connection
  72         (cons :requests (list))
  73         (cons :current nil)
  74         (cons :completed (make-hash-table :weakness 'value))
  75         (cons :buffer buffer)
  76         (cons :timer nil)))
  77
  78 (defsubst fuel-con--connection-p (c)
  79   (and (listp c) (eq (car c) :fuel-connection)))
  80
  81 (defsubst fuel-con--connection-requests (c)
  82   (cdr (assoc :requests c)))
  83
  84 (defsubst fuel-con--connection-current-request (c)
  85   (cdr (assoc :current c)))
  86
  87 (defun fuel-con--connection-clean-current-request (c)
  88   (let* ((cell (assoc :current c))
  89          (req (cdr cell)))
  90     (when req
  91       (puthash (fuel-con--request-id req) req (cdr (assoc :completed c)))
  92       (setcdr cell nil))))
  93
  94 (defsubst fuel-con--connection-completed-p (c id)
  95   (gethash id (cdr (assoc :completed c))))
  96
  97 (defsubst fuel-con--connection-buffer (c)
  98   (cdr (assoc :buffer c)))
  99
 100 (defun fuel-con--connection-pop-request (c)
 101   (let ((reqs (assoc :requests c))
 102         (current (assoc :current c)))
 103     (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
 104     (if (and (cdr current)
 105              (fuel-con--request-deactivated-p (cdr current)))
 106         (fuel-con--connection-pop-request c)
 107       (cdr current))))
 108
 109 (defun fuel-con--connection-start-timer (c)
 110   (let ((cell (assoc :timer c)))
 111     (when (cdr cell) (cancel-timer (cdr cell)))
 112     (setcdr cell (run-at-time t 0.5 'fuel-con--process-next c))))
 113
 114 (defun fuel-con--connection-cancel-timer (c)
 115   (let ((cell (assoc :timer c)))
 116     (when (cdr cell) (cancel-timer (cdr cell)))))
 117
 118 \f
 119 ;;; Connection setup:
 120
 121 (defun fuel-con--cleanup-connection (c)
 122   (fuel-con--connection-cancel-timer c))
 123
 124 (defun fuel-con--setup-connection (buffer)
 125   (set-buffer buffer)
 126   (fuel-con--cleanup-connection fuel-con--connection)
 127   (setq fuel-con--connection nil)
 128   (let ((conn (fuel-con--make-connection buffer)))
 129     (fuel-con--setup-comint)
 130     (fuel-con--establish-connection conn buffer)))
 131
 132 (defconst fuel-con--prompt-regex "^IN: [^ ]+\\( auto-use\\)? ")
 133 (defconst fuel-con--eot-marker "<~FUEL~>")
 134 (defconst fuel-con--init-stanza "USE: fuel fuel-retort")
 135
 136 (defconst fuel-con--comint-finished-regex-connected
 137   (format "^%s$" fuel-con--eot-marker))
 138
 139 (defvar fuel-con--comint-finished-regex fuel-con--prompt-regex)
 140
 141 (defun fuel-con--setup-comint ()
 142   (setq-local comint-redirect-insert-matching-regexp t)
 143   (add-hook 'comint-redirect-filter-functions
 144             'fuel-con--comint-preoutput-filter nil t)
 145   (add-hook 'comint-redirect-hook
 146             'fuel-con--comint-redirect-hook nil t))
 147
 148 (defadvice comint-redirect-setup
 149   (after fuel-con--advice (output-buffer comint-buffer finished-regexp &optional echo))
 150   (with-current-buffer comint-buffer
 151     (when fuel-con--connection
 152       (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))))
 153 (ad-activate 'comint-redirect-setup)
 154
 155 (defun fuel-con--comint-preoutput-filter (str)
 156   (when (string-match fuel-con--comint-finished-regex str)
 157     (setq comint-redirect-finished-regexp fuel-con--prompt-regex))
 158   str)
 159
 160 (defun fuel-con--establish-connection (conn buffer)
 161   (with-current-buffer (fuel-con--comint-buffer) (erase-buffer))
 162   (with-current-buffer buffer
 163     (setq fuel-con--connection conn)
 164     (setq fuel-con--comint-finished-regex fuel-con--prompt-regex)
 165     (fuel-con--send-string/wait buffer
 166                                 fuel-con--init-stanza
 167                                 'fuel-con--establish-connection-cont
 168                                 3000000)
 169     conn))
 170
 171 (defun fuel-con--establish-connection-cont (ignore)
 172   (let ((str (with-current-buffer (fuel-con--comint-buffer) (buffer-string))))
 173     (if (string-match fuel-con--eot-marker str)
 174         (progn
 175           (setq fuel-con--comint-finished-regex
 176                 fuel-con--comint-finished-regex-connected)
 177           (fuel-con--connection-start-timer fuel-con--connection)
 178           (message "FUEL listener up and running!"))
 179       (fuel-con--connection-clean-current-request fuel-con--connection)
 180       (setq fuel-con--connection nil)
 181       (message "An error occurred initialising FUEL's Factor library!")
 182       (pop-to-buffer (fuel-con--comint-buffer)))))
 183
 184 \f
 185 ;;; Requests handling:
 186
 187 (defsubst fuel-con--comint-buffer ()
 188   (get-buffer-create " *fuel connection retort*"))
 189
 190 (defun fuel-con--comint-buffer-form ()
 191   "Parse the text in the comint buffer into a
 192 sexp. fuel-con-error is thrown if the sexp is malformed."
 193   (with-current-buffer (fuel-con--comint-buffer)
 194     (goto-char (point-min))
 195     (condition-case cerr
 196         (let ((form (read (current-buffer))))
 197           (if (listp form) form
 198             (list 'fuel-con-error (buffer-string))))
 199       (error (list 'fuel-con-error (format "%s" cerr))))))
 200
 201 (defun fuel-con--process-next (con)
 202   (when (not (fuel-con--connection-current-request con))
 203     (let* ((buffer (fuel-con--connection-buffer con))
 204            (req (fuel-con--connection-pop-request con))
 205            (str (and req (fuel-con--request-string req)))
 206            (cbuf (with-current-buffer (fuel-con--comint-buffer)
 207                    (erase-buffer)
 208                    (current-buffer))))
 209       (if (not (buffer-live-p buffer))
 210           (fuel-con--connection-cancel-timer con)
 211         (when (and buffer req str)
 212           (set-buffer buffer)
 213           (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
 214           (comint-redirect-send-command (format "%s" str) cbuf nil t))))))
 215
 216 (defun fuel-con--process-completed-request (req)
 217   (let ((cont (fuel-con--request-continuation req))
 218         (id (fuel-con--request-id req))
 219         (rstr (fuel-con--request-string req))
 220         (buffer (fuel-con--request-buffer req)))
 221     (if (not cont)
 222         (fuel-log--warn "<%s> Droping result for request %S (%s)"
 223                             id rstr req)
 224       (condition-case cerr
 225           (with-current-buffer (or buffer (current-buffer))
 226             (funcall cont (fuel-con--comint-buffer-form))
 227             (fuel-log--info "<%s>: processed" id))
 228         (error (fuel-log--error
 229                 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
 230
 231 (defun fuel-con--comint-redirect-hook ()
 232   (if (not fuel-con--connection)
 233       (fuel-log--error "No connection in buffer")
 234     (let ((req (fuel-con--connection-current-request fuel-con--connection)))
 235       (if (not req) (fuel-log--error "No current request")
 236         (fuel-con--process-completed-request req)
 237         (fuel-con--connection-clean-current-request fuel-con--connection)))))
 238
 239 \f
 240 ;;; Message sending interface:
 241
 242 (defconst fuel-con--error-message "FUEL connection not active")
 243
 244 (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
 245   (save-current-buffer
 246     (let ((con (fuel-con--get-connection buffer/proc)))
 247       (unless con (error fuel-con--error-message))
 248       (let ((req (fuel-con--make-request str cont sender-buffer)))
 249         (fuel-con--connection-queue-request con req)
 250         (fuel-con--process-next con)
 251         req))))
 252
 253 (defvar fuel-connection-timeout 30000
 254   "Time limit, in msecs, blocking on synchronous evaluation requests")
 255
 256 (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
 257   (save-current-buffer
 258     (let ((con (fuel-con--get-connection buffer/proc)))
 259       (unless con (error fuel-con--error-message))
 260       (let* ((req (fuel-con--send-string buffer/proc str cont sbuf))
 261              (id (and req (fuel-con--request-id req)))
 262              (time (or timeout fuel-connection-timeout))
 263              (step 100)
 264              (waitsecs (/ step 1000.0)))
 265         (when id
 266           (condition-case nil
 267               (while (and (> time 0)
 268                           (not (fuel-con--connection-completed-p con id)))
 269                 (accept-process-output nil waitsecs)
 270                 (setq time (- time step)))
 271             (error (setq time 0)))
 272           (or (> time 0)
 273               (fuel-con--request-deactivate req)
 274               nil))))))
 275
 276 \f
 277 (provide 'fuel-connection)
 278
 279 ;;; fuel-connection.el ends here