Merge pull request #1521 from lem-project/lisp-mode-broadcast-eval

lisp-mode: broadcast eval

extensions/lisp-mode/swank-protocol.lisp → extensions/lisp-mode/connection.lisp

@@ -1,25 +1,34 @@
-(defpackage :lem-lisp-mode/swank-protocol
-  (:use :cl :lem-lisp-mode/errors)
+(uiop:define-package :lem-lisp-mode/connection
+  (:use :cl
+        :lem-lisp-mode/errors)
   (:import-from :trivial-types
                 :association-list
                 :proper-list)
+  (:import-from :lem-lisp-mode/rpc
+                :write-message-to-stream
+                :read-message-from-stream)
+  (:import-from :lem-lisp-mode/reader
+                :read-from-string*)
+  (:export :current-connection)
+  (:export :*broadcast*
+           :with-broadcast-connections)
   (:export :connection
            :connection-hostname
            :connection-port
-           :connection-request-count
            :connection-package
            :connection-prompt-string
            :connection-features
            :connection-command
            :connection-process
            :connection-process-directory
-           :connection-plist)
+           :connection-plist
+           :self-connection-p)
   (:export :new-connection
-           :log-message
            :read-message-string
            :send-message-string
            :send-message
            :message-waiting-p
+           :new-request-id
            :remote-eval-from-string
            :remote-eval
            :finish-evaluated
@@ -35,9 +44,8 @@
            :connection-machine-type
            :connection-machine-version
            :connection-swank-version
-           :connection-value)
-  (:documentation "Low-level implementation of a client for the Swank protocol."))
-(in-package :lem-lisp-mode/swank-protocol)
+           :connection-value))
+(in-package :lem-lisp-mode/connection)
 
 (defmacro with-swank-syntax (() &body body)
   `(with-standard-io-syntax
@@ -46,44 +54,19 @@
            (*print-readably* nil))
        ,@body)))
 
-;;; Encoding and decoding messages
+(defvar *connection* nil)
 
-(defun encode-integer (integer)
-  "Encode an integer to a 0-padded 16-bit hexadecimal string."
-  (babel:string-to-octets (format nil "~6,'0,X" integer)))
+(defun current-connection ()
+  *connection*)
 
-(defun decode-integer (string)
-  "Decode a string representing a 0-padded 16-bit hex string to an integer."
-  (parse-integer string :radix 16))
+(defun (setf current-connection) (connection)
+  (setf *connection* connection))
 
-;; Writing and reading messages to/from streams
+(defgeneric self-connection-p (connection))
 
-(defun write-message-to-stream (stream message)
-  "Write a string to a stream, prefixing it with length information for Swank."
-  (let* ((octets (babel:string-to-octets message))
-         (length-octets (encode-integer (length octets)))
-         (msg (make-array (+ (length length-octets)
-                             (length octets))
-                          :element-type '(unsigned-byte 8))))
-    (replace msg length-octets)
-    (replace msg octets :start1 (length length-octets))
-    (write-sequence msg stream)))
+(defclass <connection> () ())
 
-(defun read-message-from-stream (stream)
-  "Read a string from a string.
-
-Parses length information to determine how many characters to read."
-  (let ((length-buffer (make-array 6 :element-type '(unsigned-byte 8))))
-    (when (/= 6 (read-sequence length-buffer stream))
-      (error 'disconnected))
-    (let* ((length (decode-integer (babel:octets-to-string length-buffer)))
-           (buffer (make-array length :element-type '(unsigned-byte 8))))
-      (read-sequence buffer stream)
-      (babel:octets-to-string buffer))))
-
-;;; Data
-
-(defclass connection ()
+(defclass connection (<connection>)
   ((hostname
     :reader connection-hostname
     :initarg :hostname
@@ -99,11 +82,6 @@ Parses length information to determine how many characters to read."
     :initarg :socket
     :type usocket:stream-usocket
     :documentation "The usocket socket.")
-   (request-count
-    :accessor connection-request-count
-    :initform 0
-    :type integer
-    :documentation "A number that is increased and sent along with every request.")
    (package
     :accessor connection-package
     :initform "COMMON-LISP-USER"
@@ -149,6 +127,9 @@ Parses length information to determine how many characters to read."
    (plist :initform nil :accessor connection-plist))
   (:documentation "A connection to a remote Lisp."))
 
+(defmethod self-connection-p ((connection <connection>))
+  nil)
+
 (defmethod connection-value ((connection connection) key)
   (getf (connection-plist connection) key))
 
@@ -165,6 +146,12 @@ Parses length information to determine how many characters to read."
                                     :port port
                                     :socket socket)))
     (setup connection)
+
+    (when (and (member (connection-hostname connection) '("127.0.0.1" "localhost") :test 'equal)
+               (equal (connection-pid connection)
+                      (micros/backend:getpid)))
+      (change-class connection 'self-connection))
+
     connection))
 
 (defun read-return-message (connection &key (timeout 5))
@@ -226,12 +213,6 @@ Parses length information to determine how many characters to read."
   (read-all-messages connection)
   (log:debug "Setup is done now"))
 
-(defvar *event-log* '())
-
-(defun log-message (string)
-  "Log a message."
-  (push string *event-log*))
-
 (defun read-message-string (connection)
   "Read a message string from a Swank connection.
 
@@ -287,16 +268,18 @@ to check if input is available."
 
 ;;; Sending messages
 
-(defun new-request-id (connection)
-  (incf (connection-request-count connection)))
+(defvar *request-id-counter* 0)
+
+(defun new-request-id ()
+  (incf *request-id-counter*))
 
 (defun remote-eval-from-string (connection
                                 string
                                 &key continuation
                                      thread
                                      package
                                      request-id)
-  (let* ((request-id (or request-id (new-request-id connection)))
+  (let* ((request-id (or request-id (new-request-id)))
          (msg (format nil
                       "(:emacs-rex ~A ~S ~A ~A)"
                       string
@@ -347,55 +330,6 @@ to check if input is available."
 
 ;;; Reading/parsing messages
 
-(defun read-atom (in)
-  (let ((token
-          (coerce (loop :for c := (peek-char nil in nil)
-                        :until (or (null c) (member c '(#\( #\) #\space #\newline #\tab)))
-                        :collect c
-                        :do (read-char in))
-                  'string)))
-    (handler-case (values (read-from-string token) nil)
-      (error ()
-        (ppcre:register-groups-bind (prefix name) ("(.*?)::?(.*)" token)
-          (values (intern (string-upcase (string-left-trim ":" name))
-                          :keyword)
-                  (when prefix
-                    (read-from-string prefix))))))))
-
-(defun read-list (in)
-  (read-char in)
-  (loop :until (eql (peek-char t in) #\))
-        :collect (read-ahead in)
-        :finally (read-char in)))
-
-(defun read-sharp (in)
-  (read-char in)
-  (case (peek-char nil in)
-    ((#\()
-     (let ((list (read-list in)))
-       (make-array (length list) :initial-contents list)))
-    ((#\\)
-     (read-char in)
-     (read-char in))
-    (otherwise
-     (unread-char #\# in))))
-
-(defun read-ahead (in)
-  (let ((c (peek-char t in)))
-    (case c
-      ((#\()
-       (read-list in))
-      ((#\")
-       (read in))
-      ((#\#)
-       (read-sharp in))
-      (otherwise
-       (read-atom in)))))
-
-(defun read-from-string* (string)
-  (with-input-from-string (in string)
-    (read-ahead in)))
-
 (defun read-message (connection)
   "Read an arbitrary message from a connection."
   (with-swank-syntax ()
@@ -404,3 +338,27 @@ to check if input is available."
 (defun read-all-messages (connection)
   (loop while (message-waiting-p connection) collecting
     (read-message connection)))
+
+
+;;; self connection
+
+(defclass self-connection (connection)
+  ())
+
+(defmethod self-connection-p ((connection self-connection))
+  t)
+
+;;; broadcast
+
+(defvar *broadcast* nil)
+
+(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/connection-list.lisp → extensions/lisp-mode/ext/connection-list.lisp

@@ -1,7 +1,7 @@
 (defpackage :lem-lisp-mode/connection-list
   (:use :cl
         :lem
-        :lem-lisp-mode/swank-protocol
+        :lem-lisp-mode/connection
         :lem-lisp-mode/internal)
   (:export :lisp-connection-list))
 (in-package :lem-lisp-mode/connection-list)

extensions/lisp-mode/eval.lisp → 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)
 
@@ -75,7 +79,7 @@
 
 ;; copied from src/display.lisp, TODO: extract this utils
 (defun compute-evaluated-background-color ()
-  (let ((color (parse-color (lem-core::background-color))))
+  (let ((color (parse-color (background-color))))
     (multiple-value-bind (h s v)
         (rgb-to-hsv (color-red color)
                     (color-green color)
@@ -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/swank-protocol::new-request-id (current-connection))))
+        (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/swank-protocol::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/inspector.lisp → extensions/lisp-mode/ext/inspector.lisp

@@ -293,7 +293,7 @@
 (define-message (:inspect what thread tag)
   (let ((hook (when (and thread tag)
                 (alexandria:curry (lambda (sexp)
-                                    (lem-lisp-mode/swank-protocol:send-message-string
+                                    (lem-lisp-mode/connection:send-message-string
                                      (current-connection)
                                      sexp))
                                   `(:emacs-return ,thread ,tag nil)))))

extensions/lisp-mode/internal-package.lisp

@@ -6,13 +6,13 @@
         :lem/button
         :lem/loading-spinner
         :lem-lisp-mode/errors
-        :lem-lisp-mode/swank-protocol
+        :lem-lisp-mode/connection
         :lem-lisp-mode/connections
         :lem-lisp-mode/message-dispatcher
         :lem-lisp-mode/ui-mode
         :lem-lisp-mode/grammar)
   (:export
-   ;; reexport swank-protocol.lisp
+   ;; reexport micros-protocol.lisp
    :connection-value)
   (:export
    ;; lisp-ui-mode.lisp
@@ -68,7 +68,8 @@
    :show-description
    :lisp-eval-describe
    :lisp-describe-symbol
-   :connect-to-swank
+   :connect-to-micros
+   :connect-to-multiple-servers
    :slime-connect
    :show-source-location
    :source-location-to-xref-location
@@ -102,7 +103,7 @@
    ;; message.lisp
    :display-message
    ;; package.lisp
-   :lisp-listen-in-current-package 
+   :lisp-listen-in-current-package
    ;;
    :self-connection
    :self-connection-p