From f9ba2bb7d478b577a48af60be6eb9b54880b3f7c Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Thu, 11 Nov 2010 03:01:33 +0100
Subject: Partial work (connections working)

---
 elisp/geiser-connection.el | 274 ++++++++++++++++-----------------------------
 1 file changed, 97 insertions(+), 177 deletions(-)

(limited to 'elisp/geiser-connection.el')

diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el
index dc669aa..d1e7d59 100644
--- a/elisp/geiser-connection.el
+++ b/elisp/geiser-connection.el
@@ -19,8 +19,7 @@
 (require 'geiser-base)
 (require 'geiser-impl)
 
-(require 'comint)
-(require 'advice)
+(require 'tq)
 
 
 ;;; Buffer connections:
@@ -71,234 +70,155 @@
 
 ;;; Connection datatype:
 
-(defsubst geiser-con--make-connection (buffer)
+(defun geiser-con--make-connection (proc prompt debug-prompt)
   (list :geiser-connection
-        (cons :requests (list))
-        (cons :current nil)
+        (cons :tq (tq-create proc))
+        (cons :eot (format "\\(%s%s\\)"
+                           prompt
+                           (if debug-prompt
+                               (format "\\|%s" debug-prompt)
+                             "")))
+        (cons :prompt prompt)
+        (cons :debug-prompt debug-prompt)
         (cons :count 0)
-        (cons :completed (make-hash-table :weakness 'value))
-        (cons :buffer buffer)
-        (cons :reply (geiser-con--make-reply-buffer buffer))))
-
-(defvar geiser-con--eot-regexp nil)
-(geiser-impl--register-local-variable
- 'geiser-con--eot-regexp 'eot-regexp nil
- "A regular expression used to detect end of transmissions.
-By default, Geiser uses the prompt regexp.")
-
-(defun geiser-con--make-reply-buffer (buffer)
-  (let ((name (concat " geiser-con-reply: " (buffer-name buffer)))
-        (eot (with-current-buffer buffer geiser-con--eot-regexp)))
-    (with-current-buffer (get-buffer-create name)
-      (setq geiser-con--eot-regexp eot)
-      (current-buffer))))
+        (cons :completed (make-hash-table :weakness 'value))))
+
+(defun geiser-con--connection-swap-proc (con proc)
+  (let* ((this-proc (geiser-con--connection-process con))
+         (this-filter (process-filter this-proc))
+         (this-buffer (process-buffer this-proc))
+         (filter (process-filter proc))
+         (buffer (process-buffer proc))
+         (tq (geiser-con--connection-tq con)))
+    (set-process-filter this-proc filter)
+    (set-process-buffer this-proc buffer)
+    (set-process-filter proc this-filter)
+    (set-process-buffer proc this-buffer)
+    (setcdr tq (cons proc (tq-buffer tq)))
+    this-proc))
 
 (defsubst geiser-con--connection-p (c)
   (and (listp c) (eq (car c) :geiser-connection)))
 
-(defsubst geiser-con--connection-buffer (c)
-  (cdr (assoc :buffer c)))
-
 (defsubst geiser-con--connection-process (c)
-  (get-buffer-process (geiser-con--connection-buffer c)))
+  (tq-process (cdr (assoc :tq c))))
+
+(defsubst geiser-con--connection-tq (c)
+  (cdr (assoc :tq c)))
 
-(defsubst geiser-con--connection-requests (c)
-  (cdr (assoc :requests c)))
+(defsubst geiser-con--connection-eot (c)
+  (cdr (assoc :eot c)))
 
-(defsubst geiser-con--connection-current-request (c)
-  (cdr (assoc :current c)))
+(defsubst geiser-con--connection-prompt (c)
+  (cdr (assoc :prompt c)))
 
-(defsubst geiser-con--connection-reply-buffer (c)
-  (cdr (assoc :reply c)))
+(defsubst geiser-con--connection-debug-prompt (c)
+  (cdr (assoc :debug-prompt c)))
 
 (defsubst geiser-con--connection-completed (c r)
   (geiser-con--request-deactivate r)
   (puthash (geiser-con--request-id r) r (cdr (assoc :completed c))))
 
-(defun geiser-con--connection-clean-current-request (c)
-  (let* ((cell (assoc :current c))
-         (req (cdr cell)))
-    (when req
-      (geiser-con--connection-completed c req)
-      (setcdr cell nil))))
-
-(defun geiser-con--connection-add-request (c r)
-  (let ((reqs (assoc :requests c)))
-    (setcdr reqs (append (cdr reqs) (list r)))))
-
 (defsubst geiser-con--connection-completed-p (c id)
   (gethash id (cdr (assoc :completed c))))
 
-(defun geiser-con--connection-pop-request (c)
-  (let* ((reqs (assoc :requests c))
-         (current (assoc :current c))
-         (old-current (cdr current))
-         (new-current (cadr reqs))
-         (new-reqs (cddr reqs)))
-    (when old-current (geiser-con--connection-completed c old-current))
-    (setcdr reqs new-reqs)
-    (if (and new-current
-             (geiser-con--request-deactivated-p new-current))
-        (geiser-con--connection-pop-request c)
-      (setcdr current new-current))))
-
 (defun geiser-con--connection-inc-count (c)
   (let* ((cnt (assoc :count c))
          (new (1+ (cdr cnt))))
     (setcdr cnt new)
     new))
 
-
-;;; Connection setup:
-(make-variable-buffer-local
- (defvar geiser-con--debugging-prompt-regexp nil))
-
-(make-variable-buffer-local
- (defvar geiser-con--debugging-inhibits-eval t))
-
-(make-variable-buffer-local
- (defvar geiser-con--debugging-preamble-regexp nil))
-
-(defun geiser-con--is-debugging (&optional con)
-  (with-current-buffer (or (and con (geiser-con--connection-buffer con))
-                           (current-buffer))
-    (and geiser-con--debugging-prompt-regexp
-         geiser-con--debugging-inhibits-eval
-         comint-last-prompt-overlay
-         (string-match-p geiser-con--debugging-prompt-regexp
-                         (buffer-substring (overlay-start
-                                            comint-last-prompt-overlay)
-                                           (overlay-end
-                                            comint-last-prompt-overlay))))))
-
-(defsubst geiser-con--has-entered-debugger (con)
-  (with-current-buffer (geiser-con--connection-buffer con)
-    (and geiser-con--debugging-prompt-regexp
-         (re-search-backward geiser-con--debugging-prompt-regexp nil t)
-         (or (null geiser-con--debugging-preamble-regexp)
-             (save-excursion
-               (re-search-backward geiser-con--debugging-preamble-regexp
-                                   nil t))))))
-
-(defun geiser-con--connection-teardown ()
-  (when geiser-con--connection
-    (kill-buffer
-     (geiser-con--connection-reply-buffer geiser-con--connection))))
-
-(defun geiser-con--setup-connection (buffer
-                                     prompt-regexp
-                                     &optional debug-prompt-regexp
-                                     debug-preamble-regexp)
-  (with-current-buffer buffer
-    (geiser-con--connection-teardown)
-    (setq geiser-con--debugging-prompt-regexp debug-prompt-regexp)
-    (setq geiser-con--debugging-preamble-regexp debug-preamble-regexp)
-    (setq geiser-con--connection (geiser-con--make-connection buffer))
-    (set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
-    (setq comint-prompt-regexp
-	  (if debug-prompt-regexp
-	      (format "\\(%s\\)\\|\\(%s\\)" prompt-regexp debug-prompt-regexp)
-	    prompt-regexp))
-    (add-hook 'comint-redirect-hook 'geiser-con--comint-redirect-hook nil t)))
+(defun geiser-con--has-entered-debugger (con answer)
+  (let ((dp (geiser-con--connection-debug-prompt con)))
+    (and (stringp dp) (string-match dp answer))))
+
+(defun geiser-con--connection-close (con)
+  (let ((tq (geiser-con--connection-tq con)))
+    (and tq (tq-close tq))))
+
+(defvar geiser-con--connection-sentinel nil)
+(defun geiser-con--connection-sentinel (p s)
+  (setq geiser-con--connection-sentinel
+        (concat geiser-con--connection-sentinel s)))
+
+(defun geiser-con--open-connection (host port prompt debug-prompt)
+  (setq geiser-con--connection-sentinel "")
+  (let ((proc (make-network-process :name "geiser-con"
+                                    :host host
+                                    :service port
+                                    :filter 'geiser-con--connection-sentinel
+                                    :noquery t)))
+    (with-timeout (10
+                   (error (format "Timeout connecting to %s:%s" host port)))
+      (while (not (string-match prompt geiser-con--connection-sentinel))
+        (accept-process-output proc 1)))
+    (geiser-con--make-connection proc prompt debug-prompt)))
 
 
 ;;; Requests handling:
 
-(defun geiser-con--comint-buffer-form (con)
-  (with-current-buffer (geiser-con--connection-reply-buffer con)
-    (goto-char (point-max))
-    (if (geiser-con--has-entered-debugger con)
+(defun geiser-con--req-form (req answer)
+  (let ((con (geiser-con--request-connection req)))
+    (if (geiser-con--has-entered-debugger con answer)
         `((error (key . geiser-debugger))
-          (output . ,(buffer-substring (point-min) (point))))
-      (condition-case nil
-          (progn
-            (goto-char (point-min))
-            (re-search-forward "((\\(result\\|error\\)\\>")
-            (goto-char (match-beginning 0))
-            (let ((form (read (current-buffer))))
-              (if (listp form) form (error ""))))
+          (output . ,answer))
+      (condition-case err
+          (car (read-from-string answer))
         (error `((error (key . geiser-con-error))
-                 (output . ,(buffer-string))))))))
-
-(defun geiser-con--process-next (con)
-  (when (not (geiser-con--connection-current-request con))
-    (let* ((buffer (geiser-con--connection-buffer con))
-           (req (geiser-con--connection-pop-request con))
-           (str (and req (geiser-con--request-string req)))
-           (rbuffer (geiser-con--connection-reply-buffer con)))
-      (when (and buffer (buffer-live-p buffer) req str)
-        (with-current-buffer rbuffer
-          (delete-region (point-min) (point-max)))
-        (set-buffer buffer)
-        (if (geiser-con--is-debugging)
-            (geiser-con--connection-completed con req)
-          (geiser-log--info "<%s>: %s" (geiser-con--request-id req) str)
-          (comint-redirect-send-command (format "%s" str) rbuffer nil t))))))
-
-(defun geiser-con--process-completed-request (req)
-  (let* ((cont (geiser-con--request-continuation req))
-         (id (geiser-con--request-id req))
-         (rstr (geiser-con--request-string req))
-         (buffer (geiser-con--request-buffer req))
-         (con (geiser-con--request-connection req))
-         (form (geiser-con--comint-buffer-form con)))
+                 (output . ,(format "%s\n(%s)"
+                                    answer
+                                    (error-message-string err)))))))))
+
+(defun geiser-con--process-completed-request (req answer)
+  (let ((cont (geiser-con--request-continuation req))
+        (id (geiser-con--request-id req))
+        (rstr (geiser-con--request-string req))
+        (form (geiser-con--req-form req answer))
+        (buffer (or (geiser-con--request-buffer req) (current-buffer)))
+        (con (geiser-con--request-connection req)))
     (if (not cont)
         (geiser-log--warn "<%s> Droping result for request %S: %s"
                           id rstr form)
       (condition-case cerr
-          (with-current-buffer (or buffer (current-buffer))
+          (with-current-buffer buffer
             (funcall cont form)
-            (geiser-con--request-deactivate req)
             (geiser-log--info "<%s>: processed" id))
         (error (geiser-log--error
                 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))
-    (geiser-con--connection-clean-current-request con)))
-
-(defun geiser-con--comint-redirect-hook ()
-  (if (not geiser-con--connection)
-      (geiser-log--error "No connection in buffer")
-    (let ((req (geiser-con--connection-current-request
-                geiser-con--connection)))
-      (if (not req)
-          (geiser-log--error "No current request")
-        (geiser-con--process-completed-request req)))))
-
-(defadvice comint-redirect-setup
-  (after geiser-con--advice
-         (output-buffer comint-buffer finished-regexp &optional echo))
-  (with-current-buffer comint-buffer
-    (when geiser-con--eot-regexp
-      (setq comint-redirect-finished-regexp geiser-con--eot-regexp))
-    (when geiser-con--connection (setq mode-line-process nil))))
-(ad-activate 'comint-redirect-setup)
+    (geiser-con--connection-completed con req)))
+
+(defun geiser-con--connection-add-request (c r)
+  (tq-enqueue (geiser-con--connection-tq c)
+              (geiser-con--request-string r)
+              (geiser-con--connection-eot c)
+              r
+              'geiser-con--process-completed-request
+              t))
 
 
 ;;; Message sending interface:
 
-(defconst geiser-con--error-message "Geiser connection not active")
+(defun geiser-con--send-string (con str cont &optional sbuf)
+  (let ((req (geiser-con--make-request con str cont sbuf)))
+    (geiser-con--connection-add-request con req)
+    req))
 
 (defvar geiser-connection-timeout 30000
   "Time limit, in msecs, blocking on synchronous evaluation requests")
 
-(defun geiser-con--send-string/wait (b/p str cont &optional timeout sbuf)
+(defun geiser-con--send-string/wait (con str cont &optional timeout sbuf)
   (save-current-buffer
-    (let* ((con (geiser-con--get-connection b/p))
-           (proc (and con (geiser-con--connection-process con))))
-      (unless proc (error geiser-con--error-message))
-      (when (geiser-con--is-debugging con) (error "REPL is in debug mode"))
-      (let* ((req (geiser-con--make-request con str cont sbuf))
+    (let ((proc (and con (geiser-con--connection-process con))))
+      (unless proc (error "Geiser connection not active"))
+      (let* ((req (geiser-con--send-string con str cont sbuf))
              (id (geiser-con--request-id req))
-             (timeout (/ (or timeout geiser-connection-timeout) 1000.0))
-             (waitsecs 0.1))
-        (geiser-con--connection-add-request con req)
+             (timeout (/ (or timeout geiser-connection-timeout) 1000.0)))
         (with-timeout (timeout (geiser-con--request-deactivate req))
           (condition-case nil
               (while (and (geiser-con--connection-process con)
                           (not (geiser-con--connection-completed-p con id)))
-                (geiser-con--process-next con)
-                (accept-process-output proc waitsecs nil t))
+                (accept-process-output proc (/ timeout 10)))
             (error (geiser-con--request-deactivate req))))))))
 
 
 (provide 'geiser-connection)
-;;; geiser-connection.el ends here
-- 
cgit v1.2.3