Working output event

This commit is contained in:
dominik martinez 2023-06-10 16:29:36 -04:00
parent c87ab6ed16
commit e691a92178

117
gudap.el
View file

@ -44,9 +44,9 @@
(defclass dap-connection () (defclass dap-connection ()
((name ((name
:initarg :name) :initarg :name)
(process (dap-process
:initarg :process :initarg :dap-process
:accessor process) :accessor dap-process)
(event-dispatcher (event-dispatcher
:initform #'ignore :initform #'ignore
:initarg :event-dispatcher) :initarg :event-dispatcher)
@ -56,24 +56,27 @@
(response-dispatcher (response-dispatcher
:initform #'ignore :initform #'ignore
:initarg :response-dispatcher) :initarg :response-dispatcher)
(buffer (message-queue
:initform '() :initform '()
:accessor buffer) :accessor message-queue)
(expected-seq (expected-seq
:initform 1 :initform 1
:accessor expected-seq) :accessor expected-seq)
(expected-bytes (expected-bytes
:accessor expected-bytes))) :accessor expected-bytes)
(comint-process
:initarg :comint-process
:accessor comint-process)))
(cl-defgeneric connection-live-p (connection)) (cl-defgeneric connection-live-p (connection))
(cl-defmethod connection-live-p ((connection dap-connection)) (cl-defmethod connection-live-p ((connection dap-connection))
(process-live-p (process connection))) (process-live-p (dap-process connection)))
(defvar gudap-server-programs '(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug")))) (defvar gudap-server-programs '(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug"))))
(defvar gudap--connections-by-project (make-hash-table :test #'equal) (defvar gudap--connections-by-project (make-hash-table :test #'equal)
"Keys are projects. Values are lists of dap connecections.") "Keys are projects. Values are dap connecections.")
(defvar gudap--cached-connection nil) (defvar gudap--cached-connection nil)
@ -94,26 +97,62 @@
(when live-p (ignore-errors (gudap-shutdown current-conn))) (when live-p (ignore-errors (gudap-shutdown current-conn)))
(gudap--connect managed-major-modes project 'dap-connection contact language-id)))) (gudap--connect managed-major-modes project 'dap-connection contact language-id))))
(defun gudap-shutdown ()
(interactive)
(let* ((conn (gudap-current-connection)))
(kill-buffer (process-buffer (dap-process conn)))
(kill-buffer (process-buffer (comint-process conn))))
(remhash (eglot--current-project) gudap--connections-by-project)
(setq gudap--cached-connection nil))
(defun gudap--connect (managed-modes project class contact language-id) (defun gudap--connect (managed-modes project class contact language-id)
(let* ((nickname (project-name project)) (let* ((nickname (project-name project))
(readable-name (format "GUDAP (%s/%s)" nickname managed-modes)) (readable-name (format "GUDAP (%s/%s)" nickname managed-modes))
(process (make-process :name readable-name (dap-proc (make-process :name readable-name
:buffer readable-name :buffer (generate-new-buffer readable-name)
:command contact :command contact
:filter 'dap--process-filter :filter 'dap--process-filter
:sentinel 'dap--server-sentinel)) :sentinel 'dap--server-sentinel
(server (make-instance class :noquery t))
:name readable-name (comint-name (format "%s comint" readable-name))
:process process (comint-proc (make-process :name comint-name
:event-dispatcher 'gudap-event-dispatcher))) :buffer (generate-new-buffer comint-name)
(process-put process 'dap-connection server) :command nil
(puthash project :noquery t))
(cons server (conn (make-instance class
(gethash project gudap--connections-by-project '())) :name readable-name
gudap--connections-by-project))) :dap-process dap-proc
:event-dispatcher 'gudap-event-dispatcher
:comint-process comint-proc)))
(process-put dap-proc 'dap-connection conn)
(process-put comint-proc 'dap-connection conn)
(puthash project conn gudap--connections-by-project)
(gudap--init-comint conn)))
(defun gudap--init-comint (conn)
(let ((buffer (process-buffer (comint-process conn))))
(with-current-buffer buffer
(comint-mode)
(setq-local comint-input-sender #'gudap-comint-receive)
(setq-local comint-prompt-regexp "^> ")
(setq-local comint-use-prompt-regexp t))))
(defun gudap-comint-receive (proc message)
(message message))
(defun gudap-comint-send (conn message)
(comint-output-filter
(comint-process conn)
(format "%s\n" message)))
(defun gudap-event-dispatcher (conn message) (defun gudap-event-dispatcher (conn message)
(pp message)) (cl-destructuring-bind (&key event body &allow-other-keys)
message
(cond
(
(equal event "output")
(gudap-comint-send conn (plist-get body :output))))))
(defun gudap-current-connection () (defun gudap-current-connection ()
"Return logical Gudap server for current buffer, nil if none." "Return logical Gudap server for current buffer, nil if none."
@ -123,10 +162,8 @@
(defun dap--server-sentinel (proc event) (defun dap--server-sentinel (proc event)
(message "gudap sentinel event: %s" event) (message "gudap sentinel event: %s" event)
(let ((server (process-get proc 'dap-connection))) (let ((conn (process-get proc 'dap-connection)))
(puthash (eglot--current-project) (remhash (eglot--current-project) gudap--connections-by-project))
(remove server (gethash (eglot--current-project) gudap--connections-by-project))
gudap--connections-by-project))
(setq gudap--cached-connection nil)) (setq gudap--cached-connection nil))
(defvar dap--in-process-filter nil (defvar dap--in-process-filter nil
@ -215,37 +252,37 @@
(setf (expected-bytes connection) expected-bytes)))))) (setf (expected-bytes connection) expected-bytes))))))
(defun dap-connection-receive (conn message) (defun dap-connection-receive (conn message)
(if (dap-buffer-full (buffer conn)) (if (dap-queue-full-p (message-queue conn))
(dap-connection-process-messages conn t)) (dap-connection-process-messages conn t))
(setf (buffer conn) (dap-buffer-insert (buffer conn) message)) (setf (message-queue conn) (dap-queue-insert (message-queue conn) message))
(dap-connection-process-messages conn)) (dap-connection-process-messages conn))
(defun dap-buffer-insert (buffer message) (defun dap-queue-insert (queue message)
(if (dap-buffer-full-p buffer) (if (dap-queue-full-p queue)
(error "Buffer full.")) (error "Queue full."))
(let ((seq (plist-get :seq message)) (let ((seq (plist-get :seq message))
(next-seq (plist-get :seq (cadr buffer)))) (next-seq (plist-get :seq (cadr queue))))
(cond (cond
( (
(not next-seq) (not next-seq)
(list message)) (list message))
( (
(> seq next-seq) (> seq next-seq)
(cons (car buffer) (dap-message-buffer-insert (cdr buffer) message))) (cons (car queue) (dap-queue-insert (cdr queue) message)))
( (
t t
(cons message buffer))))) (cons message queue)))))
(defun dap-buffer-full-p (buffer) (defun dap-queue-full-p (queue)
(length= buffer dap-buffer-size)) (length= queue dap-buffer-size))
(defun dap-connection-process-messages (conn &optional all) (defun dap-connection-process-messages (conn &optional all)
(let ((next-message (car (buffer conn)))) (let ((next-message (car (message-queue conn))))
(while (and next-message (while (and next-message
(or all (or all
(= (plist-get next-message :seq) (expected-seq conn)))) (= (plist-get next-message :seq) (expected-seq conn))))
(dap-process-message conn (pop (buffer conn))) (dap-process-message conn (pop (message-queue conn)))
(setq next-message (car (buffer conn)))))) (setq next-message (car (message-queue conn))))))
(defun dap-process-message (conn message) (defun dap-process-message (conn message)
(cl-destructuring-bind (&key seq type &allow-other-keys) (cl-destructuring-bind (&key seq type &allow-other-keys)