Operate multiple connections simultaneously

extensions/lisp-mode/connection.lisp

@@ -10,6 +10,8 @@
   (:import-from :lem-lisp-mode/reader
                 :read-from-string*)
   (:export :current-connection)
+  (:export :*broadcast*
+           :with-broadcast-connections)
   (:export :connection
            :connection-hostname
            :connection-port
@@ -345,3 +347,18 @@ to check if input is available."
 
 (defmethod self-connection-p ((connection self-connection))
   t)
+
+;;; broadcast
+
+(defvar *broadcast* t)
+
+(defun call-with-broadcast-connections (function)
+  (if (or (self-connection-p (current-connection))
+          (not *broadcast*))
+      (funcall function (current-connection))
+      (dolist (connection (lem-lisp-mode/connections:connection-list))
+        (unless (self-connection-p connection)
+          (funcall function connection)))))
+
+(defmacro with-broadcast-connections ((connection) &body body)
+  `(call-with-broadcast-connections (lambda (,connection) ,@body)))

extensions/lisp-mode/ext/eval.lisp

@@ -3,6 +3,10 @@
   (:import-from :lem-lisp-mode/inspector
                 :lisp-inspect
                 :open-inspector)
+  (:import-from :lem-lisp-mode/connection
+                :new-request-id
+                :send-message
+                :with-broadcast-connections)
   (:export :redisplay-evaluated-message))
 (in-package :lem-lisp-mode/eval)
 
@@ -143,19 +147,22 @@
   (remove-eval-result-overlay-between start end)
   (let ((spinner (lem/loading-spinner:start-loading-spinner :region :start start :end end))
         (string (points-to-string start end))
-        (request-id (lem-lisp-mode/connection:new-request-id)))
+        (request-id (new-request-id)))
     (setf (spinner-eval-request-id spinner) request-id)
-    (lem-lisp-mode/internal:with-remote-eval
-        (`(micros/pretty-eval:pretty-eval ,string) :request-id request-id)
-      (lambda (value)
-        (alexandria:destructuring-ecase value
-          ((:ok result)
-           (destructuring-bind (&key value id) result
+    (with-broadcast-connections (connection)
+      (lem-lisp-mode/internal:with-remote-eval
+          (`(micros/pretty-eval:pretty-eval ,string)
+           :request-id request-id
+           :connection connection)
+        (lambda (value)
+          (alexandria:destructuring-ecase value
+            ((:ok result)
+             (destructuring-bind (&key value id) result
+               (lem/loading-spinner:stop-loading-spinner spinner)
+               (display-spinner-message spinner value nil id)))
+            ((:abort condition)
              (lem/loading-spinner:stop-loading-spinner spinner)
-             (display-spinner-message spinner value nil id)))
-          ((:abort condition)
-           (lem/loading-spinner:stop-loading-spinner spinner)
-           (display-spinner-message spinner condition t)))))))
+             (display-spinner-message spinner condition t))))))))
 
 (defun eval-last-expression (point)
   (with-point ((start point)
@@ -175,8 +182,9 @@
 (define-command lisp-eval-interrupt-at-point () ()
   (dolist (spinner (lem/loading-spinner:get-line-spinners (current-point)))
     (let ((request-id (spinner-eval-request-id spinner)))
-      (lem-lisp-mode/connection:send-message (current-connection)
-                                             `(:interrupt-thread ,request-id)))))
+      (with-broadcast-connections (connection)
+        (send-message connection
+                      `(:interrupt-thread ,request-id))))))
 
 (defun get-evaluation-value-id-at-point (point)
   (alexandria:when-let* ((overlay (find-overlay point))

extensions/lisp-mode/lisp-mode.lisp

@@ -334,29 +334,31 @@
 
 (defun lisp-eval-async (form &optional cont (package (current-package)))
   (let ((buffer (current-buffer)))
-    (with-remote-eval (form :package package)
+    (with-broadcast-connections (connection)
+      (with-remote-eval (form :package package :connection connection)
+        (lambda (value)
+          (alexandria:destructuring-ecase value
+            ((:ok result)
+             (when cont
+               (let ((prev (current-buffer)))
+                 (setf (current-buffer) buffer)
+                 (funcall cont result)
+                 (unless (eq (current-buffer)
+                             (window-buffer (current-window)))
+                   (setf (current-buffer) prev)))))
+            ((:abort condition)
+             (display-message "Evaluation aborted on ~A." condition))))))))
+
+(defun eval-with-transcript (form &key (package (current-package)))
+  (with-broadcast-connections (connection)
+    (with-remote-eval (form :package package :connection connection)
       (lambda (value)
         (alexandria:destructuring-ecase value
-          ((:ok result)
-           (when cont
-             (let ((prev (current-buffer)))
-               (setf (current-buffer) buffer)
-               (funcall cont result)
-               (unless (eq (current-buffer)
-                           (window-buffer (current-window)))
-                 (setf (current-buffer) prev)))))
+          ((:ok x)
+           (display-message "~A" x))
           ((:abort condition)
            (display-message "Evaluation aborted on ~A." condition)))))))
 
-(defun eval-with-transcript (form &key (package (current-package)))
-  (with-remote-eval (form :package package)
-    (lambda (value)
-      (alexandria:destructuring-ecase value
-        ((:ok x)
-         (display-message "~A" x))
-        ((:abort condition)
-         (display-message "Evaluation aborted on ~A." condition))))))
-
 (defun re-eval-defvar (string)
   (eval-with-transcript `(micros:re-evaluate-defvar ,string)))
 
@@ -497,9 +499,10 @@
      (micros/backend:filename-to-pathname ,directory))))
 
 (define-command lisp-interrupt () ()
-  (send-message-string
-   (current-connection)
-   (format nil "(:emacs-interrupt ~A)" (current-micros-thread))))
+  (with-broadcast-connections (connection)
+    (send-message-string
+     connection
+     (format nil "(:emacs-interrupt ~A)" (current-micros-thread)))))
 
 (defun prompt-for-sexp (string &optional initial)
   (prompt-for-string string
@@ -886,6 +889,11 @@
   (bt2:interrupt-thread *wait-message-thread*
                        (lambda () (error 'change-connection))))
 
+(defun message-waiting-some-connections-p (&key (timeout 0))
+  (with-broadcast-connections (connection)
+    (when (message-waiting-p connection :timeout timeout)
+      (return-from message-waiting-some-connections-p t))))
+
 (defun start-thread ()
   (unless *wait-message-thread*
     (setf *wait-message-thread*
@@ -905,7 +913,7 @@
                                     (unless (connected-p)
                                       (setf *wait-message-thread* nil)
                                       (return-from exit))
-                                    (when (message-waiting-p (current-connection) :timeout 1)
+                                    (when (message-waiting-some-connections-p :timeout 1)
                                       (let ((barrior t))
                                         (send-event (lambda ()
                                                       (unwind-protect (progn (pull-events)
@@ -957,10 +965,11 @@
 
 (defun pull-events ()
   (when (connected-p)
-    (handler-case (loop :while (message-waiting-p (current-connection))
-                        :do (dispatch-message (read-message (current-connection))))
-      (disconnected ()
-        (remove-and-change-connection (current-connection))))))
+    (with-broadcast-connections (connection)
+      (handler-case (loop :while (message-waiting-p connection)
+                          :do (dispatch-message (read-message connection)))
+        (disconnected ()
+          (remove-and-change-connection connection))))))
 
 (defun read-from-minibuffer (thread tag prompt initial-value)
   (let ((input (prompt-for-sexp prompt initial-value)))

extensions/lisp-mode/message-definitions.lisp

@@ -4,7 +4,8 @@
   (declare (ignore target))
   (write-string-to-repl string)
   (when thread
-    (send-message (current-connection) `(:write-done ,thread))))
+    (with-broadcast-connections (connection)
+      (send-message connection `(:write-done ,thread)))))
 
 (define-message (:write-object string id type)
   (write-object-to-repl string id type))
@@ -19,7 +20,8 @@
   (new-package name prompt-string))
 
 (define-message (:return value id)
-  (finish-evaluated (current-connection) value id))
+  (with-broadcast-connections (connection)
+    (finish-evaluated connection value id)))
 
 (define-message (:read-from-minibuffer thread tag prompt initial-value)
   (read-from-minibuffer thread tag prompt initial-value))
@@ -28,16 +30,18 @@
   (dispatch-message `(:emacs-return ,thread ,tag ,(prompt-for-y-or-n-p question))))
 
 (define-message (:emacs-return-string thread tag string)
-  (send-message-string
-   (current-connection)
-   (format nil "(:emacs-return-string ~A ~A ~S)"
-           thread
-           tag
-           string)))
+  (with-broadcast-connections (connection)
+    (send-message-string
+     connection
+     (format nil "(:emacs-return-string ~A ~A ~S)"
+             thread
+             tag
+             string))))
 
 (define-message (:new-features features)
-  (setf (connection-features (current-connection))
-        features))
+  (with-broadcast-connections (connection)
+    (setf (connection-features connection)
+          features)))
 
 (define-message (:indentation-update info)
   (indentation-update info))
@@ -54,15 +58,17 @@
     (dispatch-message `(:emacs-return ,thread ,tag ,result))))
 
 (define-message (:emacs-return thread tag value)
-  (send-message-string
-   (current-connection)
-   (format nil "(:emacs-return ~A ~A ~S)" thread tag value)))
+  (with-broadcast-connections (connection)
+    (send-message-string
+     connection
+     (format nil "(:emacs-return ~A ~A ~S)" thread tag value))))
 
 (define-message (:debug-condition thread message)
   (assert thread)
   (display-message "~A" message))
 
 (define-message (:ping thread tag)
-  (send-message-string
-   (current-connection)
-   (format nil "(:emacs-pong ~A ~A)" thread tag)))
+  (with-broadcast-connections (connection)
+    (send-message-string
+     connection
+     (format nil "(:emacs-pong ~A ~A)" thread tag))))