elisp/geiser-connection.el

   1 ;;; geiser-connection.el -- talking to a scheme process
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2013 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 ;;; Commentary:
  13
  14 ;; Connection datatype and functions for managing request queues
  15 ;; between emacs and inferior guile processes.
  16
  17 \f
  18 ;;; Code:
  19
  20 (require 'geiser-log)
  21 (require 'geiser-syntax)
  22 (require 'geiser-base)
  23 (require 'geiser-impl)
  24
  25 (require 'tq)
  26
  27 \f
  28 ;;; Buffer connections:
  29
  30 (make-variable-buffer-local
  31  (defvar geiser-con--connection nil))
  32
  33 (defun geiser-con--get-connection (buffer/proc)
  34   (if (processp buffer/proc)
  35       (geiser-con--get-connection (process-buffer buffer/proc))
  36     (with-current-buffer buffer/proc geiser-con--connection)))
  37
  38 \f
  39 ;;; Request datatype:
  40
  41 (defun geiser-con--make-request (con str cont &optional sender-buffer)
  42   (list (cons :id (geiser-con--connection-inc-count con))
  43         (cons :string str)
  44         (cons :continuation cont)
  45         (cons :buffer (or sender-buffer (current-buffer)))
  46         (cons :connection con)))
  47
  48 (defsubst geiser-con--request-id (req)
  49   (cdr (assq :id req)))
  50
  51 (defsubst geiser-con--request-string (req)
  52   (cdr (assq :string req)))
  53
  54 (defsubst geiser-con--request-continuation (req)
  55   (cdr (assq :continuation req)))
  56
  57 (defsubst geiser-con--request-buffer (req)
  58   (cdr (assq :buffer req)))
  59
  60 (defsubst geiser-con--request-connection (req)
  61   (cdr (assq :connection req)))
  62
  63 (defsubst geiser-con--request-deactivate (req)
  64   (setcdr (assq :continuation req) nil))
  65
  66 (defsubst geiser-con--request-deactivated-p (req)
  67   (null (cdr (assq :continuation req))))
  68
  69 \f
  70 ;;; Connection datatype:
  71
  72 (defun geiser-con--tq-create (process)
  73   (let ((tq (tq-create process)))
  74     (set-process-filter process
  75                         `(lambda (p s) (geiser-con--tq-filter ',tq s)))
  76     tq))
  77
  78 (defun geiser-con--tq-filter (tq in)
  79   (when (buffer-live-p (tq-buffer tq))
  80     (with-current-buffer (tq-buffer tq)
  81       (if (tq-queue-empty tq)
  82           (progn (geiser-log--error "Unexpected queue input:\n %s" in)
  83                  (delete-region (point-min) (point-max)))
  84         (goto-char (point-max))
  85         (insert in)
  86         (goto-char (point-min))
  87         (when (re-search-forward (tq-queue-head-regexp tq) nil t)
  88           (unwind-protect
  89               (funcall (tq-queue-head-fn tq)
  90                        (tq-queue-head-closure tq)
  91                        (buffer-substring (point-min) (point)))
  92             (delete-region (point-min) (point-max))
  93             (tq-queue-pop tq)))))))
  94
  95 (defun geiser-con--combined-prompt (prompt debug)
  96   (format "\\(%s%s\\)" prompt (if debug (format "\\|%s" debug) "")))
  97
  98 (defun geiser-con--connection-eot-re (prompt debug)
  99   (geiser-con--combined-prompt (format "\n%s" prompt)
 100                                (and debug (format "\n%s" debug))))
 101
 102 (defun geiser-con--make-connection (proc prompt debug-prompt)
 103   (list t
 104         (cons :filter (process-filter proc))
 105         (cons :tq (geiser-con--tq-create proc))
 106         (cons :tq-filter (process-filter proc))
 107         (cons :eot (geiser-con--connection-eot-re prompt debug-prompt))
 108         (cons :prompt prompt)
 109         (cons :debug-prompt debug-prompt)
 110         (cons :is-debugging nil)
 111         (cons :count 0)
 112         (cons :completed (make-hash-table :weakness 'value))))
 113
 114 (defsubst geiser-con--connection-process (c)
 115   (tq-process (cdr (assq :tq c))))
 116
 117 (defsubst geiser-con--connection-filter (c)
 118   (cdr (assq :filter c)))
 119
 120 (defsubst geiser-con--connection-tq-filter (c)
 121   (cdr (assq :tq-filter c)))
 122
 123 (defsubst geiser-con--connection-tq (c)
 124   (cdr (assq :tq c)))
 125
 126 (defsubst geiser-con--connection-eot (c)
 127   (cdr (assq :eot c)))
 128
 129 (defsubst geiser-con--connection-prompt (c)
 130   (cdr (assq :prompt c)))
 131
 132 (defsubst geiser-con--connection-debug-prompt (c)
 133   (cdr (assq :debug-prompt c)))
 134
 135 (defsubst geiser-con--connection-is-debugging (c)
 136   (cdr (assq :is-debugging c)))
 137
 138 (defsubst geiser-con--connection-set-debugging (c d)
 139   (setcdr (assq :is-debugging c) d))
 140
 141 (defun geiser-con--connection-update-debugging (c txt)
 142   (let* ((dp (geiser-con--connection-debug-prompt c))
 143          (is-d (and (stringp dp) (string-match dp txt))))
 144     (geiser-con--connection-set-debugging c is-d)
 145     is-d))
 146
 147 (defsubst geiser-con--connection-completed (c r)
 148   (geiser-con--request-deactivate r)
 149   (puthash (geiser-con--request-id r) r (cdr (assoc :completed c))))
 150
 151 (defsubst geiser-con--connection-completed-p (c id)
 152   (gethash id (cdr (assoc :completed c))))
 153
 154 (defun geiser-con--connection-inc-count (c)
 155   (let* ((cnt (assoc :count c))
 156          (new (1+ (cdr cnt))))
 157     (setcdr cnt new)
 158     new))
 159
 160 (defun geiser-con--has-entered-debugger (con answer)
 161   (and (not (geiser-con--connection-is-debugging con))
 162        (let ((p (car (last (split-string answer "\n" t)))))
 163          (and p (geiser-con--connection-update-debugging con p)))))
 164
 165 (defun geiser-con--connection-eot-p (con txt)
 166   (and txt
 167        (string-match-p (geiser-con--connection-eot con) txt)))
 168
 169 (defun geiser-con--connection-close (con)
 170   (let ((tq (geiser-con--connection-tq con)))
 171     (and tq (tq-close tq))))
 172
 173 (defvar geiser-con--startup-prompt nil)
 174 (defun geiser-con--startup-prompt (p s)
 175   (setq geiser-con--startup-prompt
 176         (concat geiser-con--startup-prompt s))
 177   nil)
 178
 179 (defun geiser-con--connection-deactivate (c &optional no-wait)
 180   (when (car c)
 181     (let* ((tq (geiser-con--connection-tq c))
 182            (proc (geiser-con--connection-process c))
 183            (proc-filter (geiser-con--connection-filter c)))
 184       (unless no-wait
 185         (while (and (not (tq-queue-empty tq))
 186                     (accept-process-output proc 0.1))))
 187       (set-process-filter proc proc-filter)
 188       (setcar c nil))))
 189
 190 (defun geiser-con--connection-activate (c)
 191   (when (not (car c))
 192     (let* ((tq (geiser-con--connection-tq c))
 193            (proc (geiser-con--connection-process c))
 194            (tq-filter (geiser-con--connection-tq-filter c)))
 195       (while (accept-process-output proc 0.01))
 196       (set-process-filter proc tq-filter)
 197       (setcar c t))))
 198
 199 \f
 200 ;;; Requests handling:
 201
 202 (defun geiser-con--req-form (req answer)
 203   (let ((con (geiser-con--request-connection req)))
 204     (if (geiser-con--has-entered-debugger con answer)
 205         `((error (key . geiser-debugger))
 206           (output . ,answer))
 207       (condition-case err
 208           (let ((start (string-match "((\\(?:result)?\\|error\\) " answer)))
 209             (or (and start (car (read-from-string answer start)))
 210                 `((error (key . retort-syntax)) (output . ,answer))))
 211         (error `((error (key . geiser-con-error))
 212                  (output . ,(format "%s\n(%s)"
 213                                     answer (error-message-string err)))))))))
 214
 215 (defun geiser-con--process-completed-request (req answer)
 216   (let ((cont (geiser-con--request-continuation req))
 217         (id (geiser-con--request-id req))
 218         (rstr (geiser-con--request-string req))
 219         (form (geiser-con--req-form req answer))
 220         (buffer (or (geiser-con--request-buffer req) (current-buffer)))
 221         (con (geiser-con--request-connection req)))
 222     (if (not cont)
 223         (geiser-log--warn "<%s> Dropping result for request %S: %s"
 224                           id rstr form)
 225       (condition-case cerr
 226           (with-current-buffer buffer
 227             (funcall cont form)
 228             (geiser-log--info "<%s>: processed" id))
 229         (error (geiser-log--error
 230                 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))
 231     (geiser-con--connection-completed con req)))
 232
 233 (defun geiser-con--connection-add-request (c r)
 234   (let ((rstr (geiser-con--request-string r)))
 235     (geiser-log--info "REQUEST: <%s>: %s"
 236                       (geiser-con--request-id r)
 237                       rstr)
 238     (geiser-con--connection-activate c)
 239     (tq-enqueue (geiser-con--connection-tq c)
 240                 (concat rstr "\n")
 241                 (geiser-con--connection-eot c)
 242                 r
 243                 'geiser-con--process-completed-request
 244                 t)))
 245
 246 \f
 247 ;;; Message sending interface:
 248
 249 (defun geiser-con--send-string (con str cont &optional sbuf)
 250   (let ((req (geiser-con--make-request con str cont sbuf)))
 251     (geiser-con--connection-add-request con req)
 252     req))
 253
 254 (defvar geiser-connection-timeout 30000
 255   "Time limit, in msecs, blocking on synchronous evaluation requests")
 256
 257 (defun geiser-con--send-string/wait (con str cont &optional timeout sbuf)
 258   (save-current-buffer
 259     (let ((proc (and con (geiser-con--connection-process con))))
 260       (unless proc (error "Geiser connection not active"))
 261       (let* ((req (geiser-con--send-string con str cont sbuf))
 262              (id (geiser-con--request-id req))
 263              (timeout (/ (or timeout geiser-connection-timeout) 1000.0)))
 264         (with-timeout (timeout (geiser-con--request-deactivate req))
 265           (condition-case nil
 266               (while (and (geiser-con--connection-process con)
 267                           (not (geiser-con--connection-completed-p con id)))
 268                 (accept-process-output proc (/ timeout 10)))
 269             (error (geiser-con--request-deactivate req))))))))
 270
 271 \f
 272 (provide 'geiser-connection)