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