elisp/geiser-connection.el

   1 ;;; geiser-connection.el -- talking to a scheme process
   2
   3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Sat Feb 07, 2009 21:11
  11
  12 \f
  13
  14 ;; Connection datatype and functions for managing request queues
  15 ;; between emacs and inferior guile processes.
  16
  17 (require 'geiser-log)
  18 (require 'geiser-syntax)
  19 (require 'geiser-base)
  20 (require 'geiser-impl)
  21
  22 (require 'comint)
  23 (require 'advice)
  24
  25 \f
  26 ;;; Buffer connections:
  27
  28 (make-variable-buffer-local
  29  (defvar geiser-con--connection nil))
  30
  31 (defun geiser-con--get-connection (buffer/proc)
  32   (if (processp buffer/proc)
  33       (geiser-con--get-connection (process-buffer buffer/proc))
  34     (with-current-buffer buffer/proc geiser-con--connection)))
  35
  36 \f
  37 ;;; Request datatype:
  38
  39 (defun geiser-con--make-request (con str cont &optional sender-buffer)
  40   (list :geiser-connection-request
  41         (cons :id (geiser-con--connection-inc-count con))
  42         (cons :string str)
  43         (cons :continuation cont)
  44         (cons :buffer (or sender-buffer (current-buffer)))
  45         (cons :connection con)))
  46
  47 (defsubst geiser-con--request-p (req)
  48   (and (listp req) (eq (car req) :geiser-connection-request)))
  49
  50 (defsubst geiser-con--request-id (req)
  51   (cdr (assoc :id req)))
  52
  53 (defsubst geiser-con--request-string (req)
  54   (cdr (assoc :string req)))
  55
  56 (defsubst geiser-con--request-continuation (req)
  57   (cdr (assoc :continuation req)))
  58
  59 (defsubst geiser-con--request-buffer (req)
  60   (cdr (assoc :buffer req)))
  61
  62 (defsubst geiser-con--request-connection (req)
  63   (cdr (assoc :connection req)))
  64
  65 (defsubst geiser-con--request-deactivate (req)
  66   (setcdr (assoc :continuation req) nil))
  67
  68 (defsubst geiser-con--request-deactivated-p (req)
  69   (null (cdr (assoc :continuation req))))
  70
  71 \f
  72 ;;; Connection datatype:
  73
  74 (defsubst geiser-con--make-connection (buffer)
  75   (list :geiser-connection
  76         (cons :requests (list))
  77         (cons :current nil)
  78         (cons :count 0)
  79         (cons :completed (make-hash-table :weakness 'value))
  80         (cons :buffer buffer)
  81         (cons :reply (geiser-con--make-reply-buffer buffer))))
  82
  83 (defvar geiser-con--eot-regexp nil)
  84 (geiser-impl--register-local-variable
  85  'geiser-con--eot-regexp 'eot-regexp nil
  86  "A regular expression used to detect end of transmissions.
  87 By default, Geiser uses the prompt regexp.")
  88
  89 (defun geiser-con--make-reply-buffer (buffer)
  90   (let ((name (concat " geiser-con-reply: " (buffer-name buffer)))
  91         (eot (with-current-buffer buffer geiser-con--eot-regexp)))
  92     (with-current-buffer (get-buffer-create name)
  93       (setq geiser-con--eot-regexp eot)
  94       (current-buffer))))
  95
  96 (defsubst geiser-con--connection-p (c)
  97   (and (listp c) (eq (car c) :geiser-connection)))
  98
  99 (defsubst geiser-con--connection-buffer (c)
 100   (cdr (assoc :buffer c)))
 101
 102 (defsubst geiser-con--connection-process (c)
 103   (get-buffer-process (geiser-con--connection-buffer c)))
 104
 105 (defsubst geiser-con--connection-requests (c)
 106   (cdr (assoc :requests c)))
 107
 108 (defsubst geiser-con--connection-current-request (c)
 109   (cdr (assoc :current c)))
 110
 111 (defsubst geiser-con--connection-reply-buffer (c)
 112   (cdr (assoc :reply c)))
 113
 114 (defsubst geiser-con--connection-completed (c r)
 115   (geiser-con--request-deactivate r)
 116   (puthash (geiser-con--request-id r) r (cdr (assoc :completed c))))
 117
 118 (defun geiser-con--connection-clean-current-request (c)
 119   (let* ((cell (assoc :current c))
 120          (req (cdr cell)))
 121     (when req
 122       (geiser-con--connection-completed c req)
 123       (setcdr cell nil))))
 124
 125 (defun geiser-con--connection-add-request (c r)
 126   (let ((reqs (assoc :requests c)))
 127     (setcdr reqs (append (cdr reqs) (list r)))))
 128
 129 (defsubst geiser-con--connection-completed-p (c id)
 130   (gethash id (cdr (assoc :completed c))))
 131
 132 (defun geiser-con--connection-pop-request (c)
 133   (let* ((reqs (assoc :requests c))
 134          (current (assoc :current c))
 135          (old-current (cdr current))
 136          (new-current (cadr reqs))
 137          (new-reqs (cddr reqs)))
 138     (when old-current (geiser-con--connection-completed c old-current))
 139     (setcdr reqs new-reqs)
 140     (if (and new-current
 141              (geiser-con--request-deactivated-p new-current))
 142         (geiser-con--connection-pop-request c)
 143       (setcdr current new-current))))
 144
 145 (defun geiser-con--connection-inc-count (c)
 146   (let* ((cnt (assoc :count c))
 147          (new (1+ (cdr cnt))))
 148     (setcdr cnt new)
 149     new))
 150
 151 \f
 152 ;;; Connection setup:
 153 (make-variable-buffer-local
 154  (defvar geiser-con--debugging-prompt-regexp nil))
 155
 156 (make-variable-buffer-local
 157  (defvar geiser-con--debugging-inhibits-eval t))
 158
 159 (make-variable-buffer-local
 160  (defvar geiser-con--debugging-preamble-regexp nil))
 161
 162 (defun geiser-con--is-debugging (&optional con)
 163   (with-current-buffer (or (and con (geiser-con--connection-buffer con))
 164                            (current-buffer))
 165     (and geiser-con--debugging-prompt-regexp
 166          geiser-con--debugging-inhibits-eval
 167          comint-last-prompt-overlay
 168          (string-match-p geiser-con--debugging-prompt-regexp
 169                          (buffer-substring (overlay-start
 170                                             comint-last-prompt-overlay)
 171                                            (overlay-end
 172                                             comint-last-prompt-overlay))))))
 173
 174 (defsubst geiser-con--has-entered-debugger (con)
 175   (with-current-buffer (geiser-con--connection-buffer con)
 176     (and geiser-con--debugging-prompt-regexp
 177          (re-search-backward geiser-con--debugging-prompt-regexp nil t)
 178          (or (null geiser-con--debugging-preamble-regexp)
 179              (save-excursion
 180                (re-search-backward geiser-con--debugging-preamble-regexp
 181                                    nil t))))))
 182
 183 (defun geiser-con--connection-teardown ()
 184   (when geiser-con--connection
 185     (kill-buffer
 186      (geiser-con--connection-reply-buffer geiser-con--connection))))
 187
 188 (defun geiser-con--setup-connection (buffer
 189                                      prompt-regexp
 190                                      &optional debug-prompt-regexp
 191                                      debug-preamble-regexp)
 192   (with-current-buffer buffer
 193     (geiser-con--connection-teardown)
 194     (setq geiser-con--debugging-prompt-regexp debug-prompt-regexp)
 195     (setq geiser-con--debugging-preamble-regexp debug-preamble-regexp)
 196     (setq geiser-con--connection (geiser-con--make-connection buffer))
 197     (set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
 198     (setq comint-prompt-regexp
 199           (if debug-prompt-regexp
 200               (format "\\(%s\\)\\|\\(%s\\)" prompt-regexp debug-prompt-regexp)
 201             prompt-regexp))
 202     (add-hook 'comint-redirect-hook 'geiser-con--comint-redirect-hook nil t)))
 203
 204 \f
 205 ;;; Requests handling:
 206
 207 (defun geiser-con--comint-buffer-form (con)
 208   (with-current-buffer (geiser-con--connection-reply-buffer con)
 209     (goto-char (point-max))
 210     (if (geiser-con--has-entered-debugger con)
 211         `((error (key . geiser-debugger))
 212           (output . ,(buffer-substring (point-min) (point))))
 213       (condition-case nil
 214           (progn
 215             (goto-char (point-min))
 216             (re-search-forward "((\\(result\\|error\\)\\>")
 217             (goto-char (match-beginning 0))
 218             (let ((form (read (current-buffer))))
 219               (if (listp form) form (error ""))))
 220         (error `((error (key . geiser-con-error))
 221                  (output . ,(buffer-string))))))))
 222
 223 (defun geiser-con--process-next (con)
 224   (when (not (geiser-con--connection-current-request con))
 225     (let* ((buffer (geiser-con--connection-buffer con))
 226            (req (geiser-con--connection-pop-request con))
 227            (str (and req (geiser-con--request-string req)))
 228            (rbuffer (geiser-con--connection-reply-buffer con)))
 229       (when (and buffer (buffer-live-p buffer) req str)
 230         (with-current-buffer rbuffer
 231           (delete-region (point-min) (point-max)))
 232         (set-buffer buffer)
 233         (if (geiser-con--is-debugging)
 234             (geiser-con--connection-completed con req)
 235           (geiser-log--info "<%s>: %s" (geiser-con--request-id req) str)
 236           (comint-redirect-send-command (format "%s" str) rbuffer nil t))))))
 237
 238 (defun geiser-con--process-completed-request (req)
 239   (let* ((cont (geiser-con--request-continuation req))
 240          (id (geiser-con--request-id req))
 241          (rstr (geiser-con--request-string req))
 242          (buffer (geiser-con--request-buffer req))
 243          (con (geiser-con--request-connection req))
 244          (form (geiser-con--comint-buffer-form con)))
 245     (if (not cont)
 246         (geiser-log--warn "<%s> Droping result for request %S: %s"
 247                           id rstr form)
 248       (condition-case cerr
 249           (with-current-buffer (or buffer (current-buffer))
 250             (funcall cont form)
 251             (geiser-con--request-deactivate req)
 252             (geiser-log--info "<%s>: processed" id))
 253         (error (geiser-log--error
 254                 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))
 255     (geiser-con--connection-clean-current-request con)))
 256
 257 (defun geiser-con--comint-redirect-hook ()
 258   (if (not geiser-con--connection)
 259       (geiser-log--error "No connection in buffer")
 260     (let ((req (geiser-con--connection-current-request
 261                 geiser-con--connection)))
 262       (if (not req)
 263           (geiser-log--error "No current request")
 264         (geiser-con--process-completed-request req)))))
 265
 266 (defadvice comint-redirect-setup
 267   (after geiser-con--advice
 268          (output-buffer comint-buffer finished-regexp &optional echo))
 269   (with-current-buffer comint-buffer
 270     (when geiser-con--eot-regexp
 271       (setq comint-redirect-finished-regexp geiser-con--eot-regexp))
 272     (when geiser-con--connection (setq mode-line-process nil))))
 273 (ad-activate 'comint-redirect-setup)
 274
 275 \f
 276 ;;; Message sending interface:
 277
 278 (defconst geiser-con--error-message "Geiser connection not active")
 279
 280 (defvar geiser-connection-timeout 30000
 281   "Time limit, in msecs, blocking on synchronous evaluation requests")
 282
 283 (defun geiser-con--send-string/wait (b/p str cont &optional timeout sbuf)
 284   (save-current-buffer
 285     (let* ((con (geiser-con--get-connection b/p))
 286            (proc (and con (geiser-con--connection-process con))))
 287       (unless proc (error geiser-con--error-message))
 288       (when (geiser-con--is-debugging con) (error "REPL is in debug mode"))
 289       (let* ((req (geiser-con--make-request con str cont sbuf))
 290              (id (geiser-con--request-id req))
 291              (timeout (/ (or timeout geiser-connection-timeout) 1000.0))
 292              (waitsecs 0.1))
 293         (geiser-con--connection-add-request con req)
 294         (with-timeout (timeout (geiser-con--request-deactivate req))
 295           (condition-case nil
 296               (while (and (geiser-con--connection-process con)
 297                           (not (geiser-con--connection-completed-p con id)))
 298                 (geiser-con--process-next con)
 299                 (accept-process-output proc waitsecs nil t))
 300             (error (geiser-con--request-deactivate req))))))))
 301
 302 \f
 303 (provide 'geiser-connection)
 304 ;;; geiser-connection.el ends here