[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master e0b9944b69f: Jsonrpc: overhaul logging mechanics
|
From: |
João Távora |
|
Subject: |
master e0b9944b69f: Jsonrpc: overhaul logging mechanics |
|
Date: |
Thu, 21 Dec 2023 19:31:32 -0500 (EST) |
branch: master
commit e0b9944b69ff72923c29756fcfcea9528a3f5069
Author: João Távora <joaotavora@gmail.com>
Commit: João Távora <joaotavora@gmail.com>
Jsonrpc: overhaul logging mechanics
* lisp/jsonrpc.el (jsonrpc-connection): Rework.
(initialize-instance :after jsonrpc-connection): New method.
(slot-missing jsonrpc-connection :events-buffer-scrollback-size oset):
New hack.
(jsonrpc-connection-receive): Rework.
(initialize-instance :after jsonrpc-process-connection): Rework
from non-after version.
(jsonrpc-connection-send)
(jsonrpc--call-deferred)
(jsonrpc--process-sentinel)
(jsonrpc--async-request-1, jsonrpc--debug, jsonrpc--log-event)
(jsonrpc--forwarding-buffer): Rework.
(jsonrpc--run-event-hook): New helper.
(jsonrpc-event-hook): New hook.
* lisp/progmodes/eglot.el (eglot-lsp-server): Fix project slot
initform.
(eglot--connect): Use new jsonrpc-connection initarg.
* test/lisp/progmodes/eglot-tests.el (eglot--sniffing): Use
jsonrpc-event-hook.
(eglot-test-basic-completions): Fix test.
---
lisp/jsonrpc.el | 390 ++++++++++++++++++++++++-------------
lisp/progmodes/eglot.el | 3 +-
test/lisp/progmodes/eglot-tests.el | 71 ++++---
3 files changed, 293 insertions(+), 171 deletions(-)
diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el
index 8b34728fb95..453452b4520 100644
--- a/lisp/jsonrpc.el
+++ b/lisp/jsonrpc.el
@@ -71,16 +71,15 @@
(-request-continuations
:initform nil
:accessor jsonrpc--request-continuations
- :documentation "An alist of request IDs to continuation lambdas.")
+ :documentation "An alist of request IDs to continuation specs.")
(-events-buffer
:initform nil
:accessor jsonrpc--events-buffer
:documentation "A buffer pretty-printing the JSONRPC events")
- (-events-buffer-scrollback-size
- :initform nil
- :initarg :events-buffer-scrollback-size
- :accessor jsonrpc--events-buffer-scrollback-size
- :documentation "Max size of events buffer. 0 disables, nil means
infinite.")
+ (-events-buffer-config
+ :initform '(:size nil :format full)
+ :initarg :events-buffer-config
+ :documentation "Plist configuring the events buffer functions.")
(-deferred-actions
:initform (make-hash-table :test #'equal)
:accessor jsonrpc--deferred-actions
@@ -98,7 +97,7 @@ request that is higher up in the stack but couldn't run.")
:accessor jsonrpc--next-request-id
:documentation "Next number used for a request"))
:documentation "Base class representing a JSONRPC connection.
-The following initargs are accepted:
+The following keyword argument initargs are accepted:
:NAME (mandatory), a string naming the connection
@@ -112,7 +111,33 @@ RESULT) or signal an error of type `jsonrpc-error'.
:NOTIFICATION-DISPATCHER (optional), a function of three
arguments (CONN METHOD PARAMS) for handling JSONRPC
notifications. CONN, METHOD and PARAMS are the same as in
-:REQUEST-DISPATCHER.")
+:REQUEST-DISPATCHER.
+
+:EVENTS-BUFFER-CONFIG is a plist. Its `:size' stipulates the
+size of the log buffer (0 disables, nil means infinite). The
+`:format' property is a symbol for choosing the log entry format.")
+
+(cl-defmethod initialize-instance :after
+ ((c jsonrpc-connection) ((&key (events-buffer-scrollback-size
+ nil
+ e-b-s-s-supplied-p)
+ &allow-other-keys)
+ t))
+ (when e-b-s-s-supplied-p
+ (warn
+ "`:events-buffer-scrollback-size' deprecated. Use
`events-buffer-config'.")
+ (with-slots ((plist -events-buffer-config)) c
+ (setf plist (copy-sequence plist)
+ plist (plist-put plist :size events-buffer-scrollback-size)))))
+
+(cl-defmethod slot-missing ((_c jsonrpc-connection)
+ (_n (eql :events-buffer-scrollback-size))
+ (_op (eql oset))
+ _)
+ ;; Yuck! But this just coerces EIEIO to backward-compatibly accept
+ ;; the :e-b-s-s initarg that is no longer associated with a slot
+ ;; #pineForCLOS..
+ )
;;; API mandatory
(cl-defgeneric jsonrpc-connection-send (conn &key id method params result
error)
@@ -169,7 +194,10 @@ Return a plist of jsonrpc.el's internal representation of a
JSONRPC message."
;; TODO: describe representations and serialization in manual and
;; link here.
- (:method (_s remote-message) remote-message))
+ (:method (_s remote-message)
+ (cl-loop for (k v) on remote-message by #'cddr
+ unless (eq k :jsonrpc-json)
+ collect k and collect v)))
;;; Convenience
@@ -207,48 +235,64 @@ circumvent that.")
"Process MESSAGE just received from CONN.
This function will destructure MESSAGE and call the appropriate
dispatcher in CONN."
- (cl-destructuring-bind (&key method id error params result _jsonrpc)
+ (cl-destructuring-bind (&rest whole &key method id error params result
_jsonrpc)
(jsonrpc-convert-from-endpoint conn message)
- (jsonrpc--log-event conn message 'server
- (cond ((and method id) 'request)
- (method 'notification)
- (id 'reply)))
- (with-slots (last-error
- (rdispatcher -request-dispatcher)
- (ndispatcher -notification-dispatcher)
- (sr-alist -sync-request-alist))
- conn
- (setf last-error error)
- (cond
- (;; A remote request
- (and method id)
- (let* ((debug-on-error (and debug-on-error
- (not jsonrpc-inhibit-debug-on-error)))
- (reply
- (condition-case-unless-debug _ignore
- (condition-case oops
- `(:result ,(funcall rdispatcher conn (intern method)
params))
- (jsonrpc-error
- `(:error
- (:code
- ,(or (alist-get 'jsonrpc-error-code (cdr oops))
-32603)
- :message ,(or (alist-get 'jsonrpc-error-message
- (cdr oops))
- "Internal error")))))
- (error
- '(:error (:code -32603 :message "Internal error"))))))
- (apply #'jsonrpc--reply conn id method reply)))
- (;; A remote notification
- method
- (funcall ndispatcher conn (intern method) params))
- (;; A remote response, but it can't run yet, because there's an
- ;; outstanding sync request (bug#67945)
- (and id sr-alist (not (eq id (caar sr-alist))))
- (push (cons (jsonrpc--remove conn id) (list result error))
- (cdr (car sr-alist))))
- (;; A remote response that can run
- (jsonrpc--continue conn id result error))))
- (jsonrpc--call-deferred conn)))
+ (unwind-protect
+ (with-slots (last-error
+ (rdispatcher -request-dispatcher)
+ (ndispatcher -notification-dispatcher)
+ (sr-alist -sync-request-alist))
+ conn
+ (setf last-error error)
+ (cond
+ (;; A remote request
+ (and method id)
+ (let* ((debug-on-error (and debug-on-error
+ (not jsonrpc-inhibit-debug-on-error)))
+ (reply
+ (condition-case-unless-debug _ignore
+ (condition-case oops
+ `(:result ,(funcall rdispatcher conn (intern
method)
+ params))
+ (jsonrpc-error
+ `(:error
+ (:code
+ ,(or (alist-get 'jsonrpc-error-code (cdr oops))
+ -32603)
+ :message ,(or (alist-get 'jsonrpc-error-message
+ (cdr oops))
+ "Internal error")))))
+ (error
+ '(:error (:code -32603 :message "Internal error"))))))
+ (apply #'jsonrpc--reply conn id method reply)))
+ (;; A remote notification
+ method
+ (funcall ndispatcher conn (intern method) params))
+ (id
+ (let ((cont
+ ;; remove the continuation
+ (jsonrpc--remove conn id)))
+ (pcase-let ((`(,_ ,method ,_ ,_ ,_) cont))
+ (if (keywordp method)
+ (setq method (substring (symbol-name method) 1)))
+ (setq whole (plist-put whole :method method)))
+ (cond (;; A remote response, but it can't run yet,
+ ;; because there's an outstanding sync request
+ ;; (bug#67945)
+ (and sr-alist (not (eq id (caar sr-alist))))
+ (push (cons cont (list result error))
+ (cdr (car sr-alist))))
+ (;; A remote response that can run
+ (jsonrpc--continue conn id cont result error)))))))
+ (jsonrpc--run-event-hook
+ conn 'server
+ :json (plist-get message :jsonrpc-json)
+ :kind (cond ((and method id) 'request)
+ (method 'notification)
+ (id 'reply))
+ :message whole
+ :foreign-message message)
+ (jsonrpc--call-deferred conn))))
;;; Contacting the remote endpoint
@@ -369,10 +413,11 @@ ignored."
;; to protect against user-quit (C-g) or the
;; `cancel-on-input' case.
(pcase-let* ((`(,id ,_) id-and-timer))
+ ;; Discard the continuation
(jsonrpc--remove connection id (list deferred (current-buffer)))
;; We still call `jsonrpc--continue' to run any
;; "anxious" continuations.
- (jsonrpc--continue connection id nil nil)))))
+ (jsonrpc--continue connection id)))))
(when (eq 'error (car retval))
(signal 'jsonrpc-error
(cons
@@ -426,8 +471,7 @@ headers such as \"Content-Length:\".
:ON-SHUTDOWN (optional), a function of one argument, the
connection object, called when the process dies.")
-(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots)
- (cl-call-next-method)
+(cl-defmethod initialize-instance :after ((conn jsonrpc-process-connection)
slots)
(cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots
;; FIXME: notice the undocumented bad coupling in the stderr
;; buffer name, it must be named exactly like this we expect when
@@ -437,7 +481,7 @@ connection object, called when the process dies.")
;; `after-change-functions'. Alternatively, we need a new initarg
;; (but maybe not a slot).
(let* ((stderr-buffer-name (format "*%s stderr*" name))
- (stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name
"[stderr]" conn))
+ (stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name
"[stderr] " conn))
(hidden-name (concat " " stderr-buffer-name)))
;; If we are correctly coupled to the client, the process now
;; created should pick up the `stderr-buffer' just created, which
@@ -475,15 +519,17 @@ connection object, called when the process dies.")
_partial)
"Send MESSAGE, a JSON object, to CONNECTION."
(when method
- (plist-put args :method
- (cond ((keywordp method) (substring (symbol-name method) 1))
- ((symbolp method) (symbol-name method))
- ((stringp method) method)
- (t (error "[jsonrpc] invalid method %s" method)))))
- (let* ((subtype (cond ((or result-supplied-p error) 'reply)
+ ;; sanitize method into a string
+ (setq args
+ (plist-put args :method
+ (cond ((keywordp method) (substring (symbol-name method)
1))
+ ((symbolp method) (symbol-name method))
+ ((stringp method) method)
+ (t (error "[jsonrpc] invalid method %s" method))))))
+ (let* ((kind (cond ((or result-supplied-p error) 'reply)
(id 'request)
(method 'notification)))
- (converted (jsonrpc-convert-to-endpoint connection args subtype))
+ (converted (jsonrpc-convert-to-endpoint connection args kind))
(json (jsonrpc--json-encode converted))
(headers
`(("Content-Length" . ,(format "%d" (string-bytes json)))
@@ -494,7 +540,13 @@ connection object, called when the process dies.")
(cl-loop for (header . value) in headers
concat (concat header ": " value "\r\n") into header-section
finally return (format "%s\r\n%s" header-section json)))
- (jsonrpc--log-event connection converted 'client subtype)))
+ (jsonrpc--run-event-hook
+ connection
+ 'client
+ :json json
+ :kind kind
+ :message args
+ :foreign-message converted)))
(defun jsonrpc-process-type (conn)
"Return the `process-type' of JSONRPC connection CONN."
@@ -572,20 +624,22 @@ With optional CLEANUP, kill any associated buffers."
(defun jsonrpc--call-deferred (connection)
"Call CONNECTION's deferred actions, who may again defer themselves."
(when-let ((actions (hash-table-values (jsonrpc--deferred-actions
connection))))
- (jsonrpc--debug connection `(:maybe-run-deferred
- ,(mapcar (apply-partially #'nth 2) actions)))
+ (jsonrpc--run-event-hook
+ connection 'internal
+ :log-text (format "re-attempting deffered requests %s"
+ (mapcar (apply-partially #'nth 2) actions)))
(mapc #'funcall (mapcar #'car actions))))
(defun jsonrpc--process-sentinel (proc change)
"Called when PROC undergoes CHANGE."
(let ((connection (process-get proc 'jsonrpc-connection)))
- (jsonrpc--debug connection `(:message "Connection state changed" :change
,change))
+ (jsonrpc--debug connection "Connection state change: `%s'" change)
(when (not (process-live-p proc))
(with-current-buffer (jsonrpc-events-buffer connection)
(let ((inhibit-read-only t))
(insert "\n----------b---y---e---b---y---e----------\n")))
;; Cancel outstanding timers
- (mapc (jsonrpc-lambda (_id _success _error timer)
+ (mapc (jsonrpc-lambda (_id _method _success-fn _error-fn timer)
(when timer (cancel-timer timer)))
(jsonrpc--request-continuations connection))
(maphash (lambda (_ triplet)
@@ -595,8 +649,8 @@ With optional CLEANUP, kill any associated buffers."
(process-put proc 'jsonrpc-sentinel-cleanup-started t)
(unwind-protect
;; Call all outstanding error handlers
- (mapc (jsonrpc-lambda (_id _success error _timer)
- (funcall error '(:code -1 :message "Server died")))
+ (mapc (jsonrpc-lambda (_id _method _success-fn error-fn _timer)
+ (funcall error-fn '(:code -1 :message "Server died")))
(jsonrpc--request-continuations connection))
(jsonrpc--message "Server exited with status %s" (process-exit-status
proc))
(delete-process proc)
@@ -657,6 +711,9 @@ With optional CLEANUP, kill any associated buffers."
(cdr oops)
(buffer-string))
nil)))
(when message
+ (setq message
+ (plist-put message :jsonrpc-json
+ (buffer-string)))
(process-put proc 'jsonrpc-mqueue
(nconc (process-get proc
'jsonrpc-mqueue)
@@ -692,21 +749,22 @@ Return the full continuation (ID SUCCESS-FN ERROR-FN
TIMER)"
(with-slots ((conts -request-continuations) (defs -deferred-actions)) conn
(if deferred-spec (remhash deferred-spec defs))
(when-let ((ass (assq id conts)))
- (cancel-timer (elt (cdr ass) 2))
+ (cl-destructuring-bind (_ _ _ _ timer) ass
+ (cancel-timer timer))
(setf conts (delete ass conts))
ass)))
-(defun jsonrpc--schedule (conn id success-fn error-fn timer)
- (push (list id success-fn error-fn timer)
+(defun jsonrpc--schedule (conn id method success-fn error-fn timer)
+ (push (list id method success-fn error-fn timer)
(jsonrpc--request-continuations conn)))
-(defun jsonrpc--continue (conn id result error)
- (pcase-let* ((`(,cont-id ,success-fn ,error-fn ,_timer)
- (jsonrpc--remove conn id))
+(defun jsonrpc--continue (conn id &optional cont result error)
+ (pcase-let* ((`(,cont-id ,_method ,success-fn ,error-fn ,_timer)
+ cont)
(head (pop (jsonrpc--sync-request-alist conn)))
(anxious (cdr head)))
(cond (anxious
- (unless (= (car head) id)
+ (when (not (= (car head) id)) ; sanity check
(error "internal error: please report this bug"))
;; If there are "anxious" `jsonrpc-request' continuations
;; that should already have been run, they should run now.
@@ -719,7 +777,7 @@ Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)"
(if error (later error-fn error)
(later success-fn result)))
(cl-loop for (acont ares aerr) in anxious
- for (_id success-fn error-fn) = acont
+ for (_id _method success-fn error-fn) = acont
if aerr do (later error-fn aerr)
else do (later success-fn ares))))
(cont-id
@@ -760,17 +818,20 @@ TIMEOUT is nil)."
(lambda ()
(jsonrpc--remove connection id (list deferred buf))
(if timeout-fn (funcall timeout-fn)
- (jsonrpc--debug
- connection `(:timed-out ,method :id ,id
- :params
,params)))))))))))
+ (jsonrpc--run-event-hook
+ connection 'internal
+ :log-text (format "timed-out '%s' (id=%s)"
method id)
+ :id id))))))))))
(when deferred
(if (jsonrpc-connection-ready-p connection deferred)
;; Server is ready, we jump below and send it immediately.
(remhash (list deferred buf) (jsonrpc--deferred-actions connection))
;; Otherwise, save in `jsonrpc--deferred-actions' and exit non-locally
(unless old-id
- (jsonrpc--debug connection `(:deferring ,method :id ,id :params
- ,params)))
+ (jsonrpc--run-event-hook
+ connection 'internal
+ :log-text (format "deferring '%s' (id=%s)" method id)
+ :id id))
(puthash (list deferred buf)
(list (lambda ()
(when (buffer-live-p buf)
@@ -793,22 +854,22 @@ TIMEOUT is nil)."
(when sync-request
(push (list id) (jsonrpc--sync-request-alist connection)))
- (jsonrpc--schedule connection
- id
- (or success-fn
- (lambda (&rest _ignored)
- (jsonrpc--debug
- connection (list :message "success ignored"
- :id id))))
- (or error-fn
- (jsonrpc-lambda (&key code message
&allow-other-keys)
- (jsonrpc--debug
- connection (list
- :message
- (format "error ignored, status set
(%s)"
- message)
- :id id :error code))))
- (funcall maybe-timer))
+ (jsonrpc--schedule
+ connection id method
+ (or success-fn
+ (lambda (&rest _ignored)
+ (jsonrpc--run-event-hook
+ connection 'internal
+ :log-text (format "success ignored")
+ :id id)))
+ (or error-fn
+ (jsonrpc-lambda (&key code message &allow-other-keys)
+ (jsonrpc--run-event-hook
+ connection 'internal
+ :log-text (format "error %s ignored: %s ignored"
+ code message)
+ :id id)))
+ (funcall maybe-timer))
(list id timer)))
(defun jsonrpc--message (format &rest args)
@@ -817,10 +878,11 @@ TIMEOUT is nil)."
(defun jsonrpc--debug (server format &rest args)
"Debug message for SERVER with FORMAT and ARGS."
- (jsonrpc--log-event
- server (if (stringp format)
- `(:message ,(apply #'format format args))
- format)))
+ (with-current-buffer (jsonrpc-events-buffer server)
+ (jsonrpc--log-event
+ server 'internal
+ :log-text (apply #'format format args)
+ :type 'debug)))
(defun jsonrpc--warn (format &rest args)
"Warning message with FORMAT and ARGS."
@@ -830,39 +892,97 @@ TIMEOUT is nil)."
(apply #'format format args)
:warning)))
-(defun jsonrpc--log-event (connection message &optional origin subtype)
- "Log a JSONRPC-related event.
-CONNECTION is the current connection. MESSAGE is a JSON-like
-plist. ORIGIN is a symbol saying where event originated.
-SUBTYPE tells more about the event."
- (let ((max (jsonrpc--events-buffer-scrollback-size connection)))
+(cl-defun jsonrpc--run-event-hook (connection
+ origin
+ &rest plist
+ &key _kind _json _message _foreign-message
_log-text
+ &allow-other-keys)
+ (with-current-buffer (jsonrpc-events-buffer connection)
+ (run-hook-wrapped 'jsonrpc-event-hook
+ (lambda (fn)
+ (apply fn connection origin plist)))))
+
+(defvar jsonrpc-event-hook (list #'jsonrpc--log-event)
+ "Hook run when JSON-RPC events are emitted.
+This hooks runs in the events buffer of every `jsonrpc-connection'
+when an event is originated by either endpoint. Each hook function
+is passed the arguments described by the lambda list:
+
+ (CONNECTION ORIGIN &key JSON KIND MESSAGE FOREIGN-MESSAGE LOG-TEXT
+ &allow-other-keys)
+
+ CONNECTION the `jsonrpc-connection' instance.
+ ORIGIN one of the symbols `client' ,`server'.
+ JSON the raw JSON string content.
+ KIND one of the symbols `request' ,`notification',
+ `reply'.
+ MESSAGE a plist representing the exchanged message in
+ jsonrpc.el's internal format
+ FOREIGN-MESSAGE a plist representing the exchanged message in
+ the remote endpoint's format.
+ LOG-TEXT text used for events of `internal' origin.
+ ID id of a message that this event refers to.
+ TYPE `error', `debug' or the default `info'.
+
+Except for CONNECTION and ORIGIN all other keys are optional.
+Unlisted keys may appear in the plist.
+
+Do not use this hook to write JSON-RPC protocols, use other parts
+of the API instead.")
+
+(cl-defun jsonrpc--log-event (connection origin
+ &key kind message
+ foreign-message log-text json
+ type
+ &allow-other-keys)
+ "Log a JSONRPC-related event. Installed in `jsonrpc-event-hook'."
+ (let* ((props (slot-value connection '-events-buffer-config))
+ (max (plist-get props :size))
+ (format (plist-get props :format)))
(when (or (null max) (cl-plusp max))
- (with-current-buffer (jsonrpc-events-buffer connection)
- (cl-destructuring-bind (&key _method id error &allow-other-keys)
message
- (let* ((inhibit-read-only t)
- (type
- (concat (format "%s" (or origin 'internal))
- (if origin (format "-%s" (or subtype 'message))))))
- (goto-char (point-max))
- (prog1
- (let ((msg (format "[%s]%s%s %s:\n%s"
- type
- (if id (format " (id:%s)" id) "")
- (if error " ERROR" "")
- (current-time-string)
- (pp-to-string message))))
- (when error
- (setq msg (propertize msg 'face 'error)))
- (insert-before-markers msg))
- ;; Trim the buffer if it's too large
- (when max
- (save-excursion
- (goto-char (point-min))
- (while (> (buffer-size) max)
- (delete-region (point) (progn (forward-line 1)
- (forward-sexp 1)
- (forward-line 2)
- (point)))))))))))))
+ (cl-destructuring-bind (&key method id error &allow-other-keys) message
+ (let* ((inhibit-read-only t)
+ (depth (length (jsonrpc--sync-request-alist connection)))
+ (msg
+ (cond ((eq format 'full)
+ (format "[jsonrpc] %s[%s]%s %s\n"
+ (pcase type ('error "E") ('debug "D") (_ "e"))
+ (format-time-string "%H:%M:%S.%3N")
+ (if (eq origin 'internal)
+ ""
+ (format " %s%s %s%s"
+ (make-string (* 2 depth) ? )
+ (pcase origin
+ ('client "-->")
+ ('server "<--")
+ (_ ""))
+ (or method "")
+ (if id (format "(%s)" id) "")))
+ (or json log-text)))
+ (t
+ (format "[%s]%s%s %s:\n%s"
+ (concat (format "%s" (or origin 'internal))
+ (if origin (format "-%s" (or kind
'message))))
+ (if id (format " (id:%s)" id) "")
+ (if error " ERROR" "")
+ (format-time-string "%H:%M:%S.%3N")
+ (if foreign-message (pp-to-string
foreign-message)
+ log-text))))))
+ (goto-char (point-max))
+ ;; XXX: could use `run-at-time' to delay server logs
+ ;; slightly to play nice with verbose servers' stderr.
+ (when error
+ (setq msg (propertize msg 'face 'error)))
+ (insert-before-markers msg)
+ ;; Trim the buffer if it's too large
+ (when max
+ (save-excursion
+ (goto-char (point-min))
+ (while (> (buffer-size) max)
+ (delete-region (point) (progn (forward-line 1)
+ (forward-sexp 1)
+ (forward-line 2)
+ (point)))))))))))
(defun jsonrpc--forwarding-buffer (name prefix conn)
"Helper for `jsonrpc-process-connection' helpers.
@@ -885,7 +1005,9 @@ PREFIX to CONN's events buffer."
do (with-current-buffer (jsonrpc-events-buffer conn)
(goto-char (point-max))
(let ((inhibit-read-only t))
- (insert (format "%s %s\n" prefix line))))
+ (insert
+ (propertize (format "%s %s\n" prefix line)
+ 'face 'shadow))))
until (eobp)))
nil t))
(current-buffer)))
diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el
index 2a3c2201e21..c849ff5c37e 100644
--- a/lisp/progmodes/eglot.el
+++ b/lisp/progmodes/eglot.el
@@ -993,6 +993,7 @@ ACTION is an LSP object of either `CodeAction' or `Command'
type."
:documentation "Flag set when server is shutting down."
:accessor eglot--shutdown-requested)
(project
+ :initform nil
:documentation "Project associated with server."
:accessor eglot--project)
(progress-reporters
@@ -1512,7 +1513,7 @@ This docstring appeases checkdoc, that's all."
(apply
#'make-instance class
:name readable-name
- :events-buffer-scrollback-size eglot-events-buffer-size
+ :events-buffer-config `(:size ,eglot-events-buffer-size :format
full)
:notification-dispatcher (funcall spread
#'eglot-handle-notification)
:request-dispatcher (funcall spread #'eglot-handle-request)
:on-shutdown #'eglot--on-shutdown
diff --git a/test/lisp/progmodes/eglot-tests.el
b/test/lisp/progmodes/eglot-tests.el
index 996ff276e68..f2da3295b49 100644
--- a/test/lisp/progmodes/eglot-tests.el
+++ b/test/lisp/progmodes/eglot-tests.el
@@ -199,38 +199,40 @@ directory hierarchy."
&rest body)
"Run BODY saving LSP JSON messages in variables, most recent first."
(declare (indent 1) (debug (sexp &rest form)))
- (let ((log-event-ad-sym (make-symbol "eglot--event-sniff")))
- `(unwind-protect
- (let ,(delq nil (list server-requests
- server-notifications
- server-replies
- client-requests
- client-notifications
- client-replies))
- (advice-add
- #'jsonrpc--log-event :before
- (lambda (_proc message &optional origin subtype)
- (let ((req-p (eq subtype 'request))
- (notif-p (eq subtype 'notification))
- (reply-p (eql subtype 'reply)))
- (cond
- ((eq origin 'server)
- (cond (req-p ,(when server-requests
- `(push message ,server-requests)))
- (notif-p ,(when server-notifications
- `(push message ,server-notifications)))
- (reply-p ,(when server-replies
- `(push message ,server-replies)))))
- ((eq origin 'client)
- (cond (req-p ,(when client-requests
- `(push message ,client-requests)))
- (notif-p ,(when client-notifications
- `(push message ,client-notifications)))
- (reply-p ,(when client-replies
- `(push message ,client-replies))))))))
- '((name . ,log-event-ad-sym)))
- ,@body)
- (advice-remove #'jsonrpc--log-event ',log-event-ad-sym))))
+ (let ((log-event-hook-sym (make-symbol "eglot--event-sniff")))
+ `(let* (,@(delq nil (list server-requests
+ server-notifications
+ server-replies
+ client-requests
+ client-notifications
+ client-replies)))
+ (cl-flet ((,log-event-hook-sym (_connection
+ origin
+ &key _json kind message _foreign-message
+ &allow-other-keys)
+ (let ((req-p (eq kind 'request))
+ (notif-p (eq kind 'notification))
+ (reply-p (eql kind 'reply)))
+ (cond
+ ((eq origin 'server)
+ (cond (req-p ,(when server-requests
+ `(push message ,server-requests)))
+ (notif-p ,(when server-notifications
+ `(push message
,server-notifications)))
+ (reply-p ,(when server-replies
+ `(push message ,server-replies)))))
+ ((eq origin 'client)
+ (cond (req-p ,(when client-requests
+ `(push message ,client-requests)))
+ (notif-p ,(when client-notifications
+ `(push message
,client-notifications)))
+ (reply-p ,(when client-replies
+ `(push message
,client-replies)))))))))
+ (unwind-protect
+ (progn
+ (add-hook 'jsonrpc-event-hook #',log-event-hook-sym)
+ ,@body)
+ (remove-hook 'jsonrpc-event-hook #',log-event-hook-sym))))))
(cl-defmacro eglot--wait-for ((events-sym &optional (timeout 1) message) args
&body body)
(declare (indent 2) (debug (sexp sexp sexp &rest form)))
@@ -542,10 +544,7 @@ directory hierarchy."
`(("project" . (("coiso.c" . "#include <stdio.h>\nint main () {fprin"))))
(with-current-buffer
(eglot--find-file-noselect "project/coiso.c")
- (eglot--sniffing (:server-notifications s-notifs)
- (eglot--wait-for-clangd)
- (eglot--wait-for (s-notifs 20) (&key method &allow-other-keys)
- (string= method "textDocument/publishDiagnostics")))
+ (eglot--wait-for-clangd)
(goto-char (point-max))
(completion-at-point)
(message (buffer-string))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- master e0b9944b69f: Jsonrpc: overhaul logging mechanics,
João Távora <=