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 ()
 163   (and geiser-con--debugging-prompt-regexp
 164        geiser-con--debugging-inhibits-eval
 165        comint-last-prompt-overlay
 166        (string-match-p geiser-con--debugging-prompt-regexp
 167                        (buffer-substring (overlay-start
 168                                           comint-last-prompt-overlay)
 169                                          (overlay-end
 170                                           comint-last-prompt-overlay)))))
 171
 172 (defsubst geiser-con--has-entered-debugger (con)
 173   (with-current-buffer (geiser-con--connection-buffer con)
 174     (and geiser-con--debugging-prompt-regexp
 175          (re-search-backward geiser-con--debugging-prompt-regexp nil t)
 176          (or (null geiser-con--debugging-preamble-regexp)
 177              (save-excursion
 178                (re-search-backward geiser-con--debugging-preamble-regexp
 179                                    nil t))))))
 180
 181 (defun geiser-con--connection-teardown ()
 182   (when geiser-con--connection
 183     (kill-buffer
 184      (geiser-con--connection-reply-buffer geiser-con--connection))))
 185
 186 (defun geiser-con--setup-connection (buffer
 187                                      prompt-regexp
 188                                      &optional debug-prompt-regexp
 189                                      debug-preamble-regexp)
 190   (with-current-buffer buffer
 191     (geiser-con--connection-teardown)
 192     (setq geiser-con--debugging-prompt-regexp debug-prompt-regexp)
 193     (setq geiser-con--debugging-preamble-regexp debug-preamble-regexp)
 194     (setq geiser-con--connection (geiser-con--make-connection buffer))
 195     (set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
 196     (setq comint-prompt-regexp
 197           (if debug-prompt-regexp
 198               (format "\\(%s\\)\\|\\(%s\\)" prompt-regexp debug-prompt-regexp)
 199             prompt-regexp))
 200     (add-hook 'comint-redirect-hook 'geiser-con--comint-redirect-hook nil t)))
 201
 202 \f
 203 ;;; Requests handling:
 204
 205 (defun geiser-con--comint-buffer-form (con)
 206   (with-current-buffer (geiser-con--connection-reply-buffer con)
 207     (goto-char (point-max))
 208     (if (geiser-con--has-entered-debugger con)
 209         `((error (key . geiser-debugger))
 210           (output . ,(buffer-substring (point-min) (point))))
 211       (condition-case nil
 212           (progn
 213             (goto-char (point-min))
 214             (re-search-forward "((\\(result\\|error\\)\\>")
 215             (goto-char (match-beginning 0))
 216             (let ((form (read (current-buffer))))
 217               (if (listp form) form (error ""))))
 218         (error `((error (key . geiser-con-error))
 219                  (output . ,(buffer-string))))))))
 220
 221 (defun geiser-con--process-next (con)
 222   (when (not (geiser-con--connection-current-request con))
 223     (let* ((buffer (geiser-con--connection-buffer con))
 224            (req (geiser-con--connection-pop-request con))
 225            (str (and req (geiser-con--request-string req)))
 226            (rbuffer (geiser-con--connection-reply-buffer con)))
 227       (when (and buffer (buffer-live-p buffer) req str)
 228         (with-current-buffer rbuffer
 229           (delete-region (point-min) (point-max)))
 230         (set-buffer buffer)
 231         (if (geiser-con--is-debugging)
 232             (geiser-con--connection-completed con req)
 233           (geiser-log--info "<%s>: %s" (geiser-con--request-id req) str)
 234           (comint-redirect-send-command (format "%s" str) rbuffer nil t))))))
 235
 236 (defun geiser-con--process-completed-request (req)
 237   (let* ((cont (geiser-con--request-continuation req))
 238          (id (geiser-con--request-id req))
 239          (rstr (geiser-con--request-string req))
 240          (buffer (geiser-con--request-buffer req))
 241          (con (geiser-con--request-connection req))
 242          (form (geiser-con--comint-buffer-form con)))
 243     (if (not cont)
 244         (geiser-log--warn "<%s> Droping result for request %S: %s"
 245                           id rstr form)
 246       (condition-case cerr
 247           (with-current-buffer (or buffer (current-buffer))
 248             (funcall cont form)
 249             (geiser-con--request-deactivate req)
 250             (geiser-log--info "<%s>: processed" id))
 251         (error (geiser-log--error
 252                 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))
 253     (geiser-con--connection-clean-current-request con)))
 254
 255 (defun geiser-con--comint-redirect-hook ()
 256   (if (not geiser-con--connection)
 257       (geiser-log--error "No connection in buffer")
 258     (let ((req (geiser-con--connection-current-request
 259                 geiser-con--connection)))
 260       (if (not req)
 261           (geiser-log--error "No current request")
 262         (geiser-con--process-completed-request req)))))
 263
 264 (defadvice comint-redirect-setup
 265   (after geiser-con--advice
 266          (output-buffer comint-buffer finished-regexp &optional echo))
 267   (with-current-buffer comint-buffer
 268     (when geiser-con--eot-regexp
 269       (setq comint-redirect-finished-regexp geiser-con--eot-regexp))
 270     (when geiser-con--connection (setq mode-line-process nil))))
 271 (ad-activate 'comint-redirect-setup)
 272
 273 \f
 274 ;;; Message sending interface:
 275
 276 (defconst geiser-con--error-message "Geiser connection not active")
 277
 278 (defvar geiser-connection-timeout 30000
 279   "Time limit, in msecs, blocking on synchronous evaluation requests")
 280
 281 (defun geiser-con--send-string/wait (buffer/proc str cont
 282                                                  &optional timeout sbuf)
 283   (save-current-buffer
 284     (let* ((con (geiser-con--get-connection buffer/proc))
 285            (proc (and con (geiser-con--connection-process con))))
 286       (unless proc
 287         (error geiser-con--error-message))
 288       (with-current-buffer (geiser-con--connection-buffer con)
 289         (when (geiser-con--is-debugging)
 290           (error "Geiser REPL is in debug mode")))
 291       (let* ((req (geiser-con--make-request con str cont sbuf))
 292              (id (and req (geiser-con--request-id req)))
 293              (time (or timeout geiser-connection-timeout))
 294              (step 100)
 295              (waitsecs (/ step 1000.0)))
 296         (when id
 297           (geiser-con--connection-add-request con req)
 298           (geiser-con--process-next con)
 299           (condition-case nil
 300               (while (and (> time 0)
 301                           (geiser-con--connection-process con)
 302                           (not (geiser-con--connection-completed-p con id)))
 303                 (unless (accept-process-output nil waitsecs nil nil)
 304                   (geiser-con--process-next con)
 305                   (setq time (- time step))))
 306             (error (setq time 0)))
 307           (or (> time 0)
 308               (geiser-con--request-deactivate req)
 309               nil))))))
 310
 311 \f
 312 (provide 'geiser-connection)
 313 ;;; geiser-connection.el ends here