Initial commit
This commit is contained in:
commit
827e8008ba
1 changed files with 255 additions and 0 deletions
255
gudap.el
Normal file
255
gudap.el
Normal file
|
|
@ -0,0 +1,255 @@
|
|||
;;; gudap.el --- Debug Adapter Protocol client for Emacs -*- lexical-binding: t -*-
|
||||
|
||||
;; Author: Dominik Martinez <dominikmartinez@pm.me>
|
||||
;; URL:
|
||||
;; Version: 0.1.0
|
||||
;; Package-Requires:
|
||||
;; Keywords: languages, debug, dap
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; gudap.el is a Debug Adapter Protocol client for Emacs.
|
||||
;;
|
||||
;; To use, add the following to your init file:
|
||||
;;
|
||||
;; (require 'gudap)
|
||||
;;
|
||||
;; Code ~heavily~ adapted from Eglot.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'eglot)
|
||||
(require 'jsonrpc)
|
||||
|
||||
(defgroup gudap nil
|
||||
"Interaction with Debug Adapter Protocol servers."
|
||||
:prefix "gudap-"
|
||||
:group 'applications)
|
||||
|
||||
(defconst dap-buffer-size 200)
|
||||
|
||||
(defclass dap-connection ()
|
||||
((name
|
||||
:initarg :name)
|
||||
(process
|
||||
:initarg :process
|
||||
:accessor process)
|
||||
(event-dispatcher
|
||||
:initform #'ignore
|
||||
:initarg :event-dispatcher)
|
||||
(request-dispatcher
|
||||
:initform #'ignore
|
||||
:initarg :request-dispatcher)
|
||||
(response-dispatcher
|
||||
:initform #'ignore
|
||||
:initarg :response-dispatcher)
|
||||
(buffer
|
||||
:initform '()
|
||||
:accessor buffer)
|
||||
(expected-seq
|
||||
:initform 1
|
||||
:accessor expected-seq)
|
||||
(expected-bytes
|
||||
:accessor expected-bytes)))
|
||||
|
||||
(cl-defgeneric connection-live-p (connection))
|
||||
|
||||
(cl-defmethod connection-live-p ((connection dap-connection))
|
||||
(process-live-p (process connection)))
|
||||
|
||||
(defvar gudap-server-programs '(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug"))))
|
||||
|
||||
(defvar gudap--connections-by-project (make-hash-table :test #'equal)
|
||||
"Keys are projects. Values are lists of dap connecections.")
|
||||
|
||||
(defvar gudap--cached-connection nil)
|
||||
|
||||
(defun gudap-reset ()
|
||||
(interactive)
|
||||
(clrhash gudap--connections-by-project)
|
||||
(setq gudap--cached-connection nil))
|
||||
|
||||
(defun gudap (managed-major-modes project _class contact language-id &optional interactive)
|
||||
(interactive (let ((eglot-server-programs gudap-server-programs))
|
||||
(eglot--guess-contact t)))
|
||||
(let* ((current-conn (gudap-current-connection))
|
||||
(live-p (and current-conn (connection-live-p current-conn))))
|
||||
(if (and live-p
|
||||
interactive
|
||||
(y-or-n-p "[gudap] Live process found, reconnect instead? "))
|
||||
(gudap-reconnect current-conn interactive)
|
||||
(when live-p (ignore-errors (gudap-shutdown current-conn)))
|
||||
(gudap--connect managed-major-modes project 'dap-connection contact language-id))))
|
||||
|
||||
(defun gudap--connect (managed-modes project class contact language-id)
|
||||
(let* ((nickname (project-name project))
|
||||
(readable-name (format "GUDAP (%s/%s)" nickname managed-modes))
|
||||
(process (make-process :name readable-name
|
||||
:buffer readable-name
|
||||
:command contact
|
||||
:filter 'dap--process-filter
|
||||
:sentinel 'dap--server-sentinel))
|
||||
(server (make-instance class
|
||||
:name readable-name
|
||||
:process process
|
||||
:event-dispatcher 'gudap-event-dispatcher)))
|
||||
(process-put process 'dap-connection server)
|
||||
(puthash project
|
||||
(cons server
|
||||
(gethash project gudap--connections-by-project '()))
|
||||
gudap--connections-by-project)))
|
||||
|
||||
(defun gudap-event-dispatcher (conn message)
|
||||
(pp message))
|
||||
|
||||
(defun gudap-current-connection ()
|
||||
"Return logical Gudap server for current buffer, nil if none."
|
||||
(setq gudap--cached-connection
|
||||
(or gudap--cached-connection
|
||||
(gethash (eglot--current-project) gudap--connections-by-project))))
|
||||
|
||||
(defun dap--server-sentinel (proc event)
|
||||
(message "gudap sentinel event: %s" event)
|
||||
(let ((server (process-get proc 'dap-connection)))
|
||||
(puthash (eglot--current-project)
|
||||
(remove server (gethash (eglot--current-project) gudap--connections-by-project))
|
||||
gudap--connections-by-project))
|
||||
(setq gudap--cached-connection nil))
|
||||
|
||||
(defvar dap--in-process-filter nil
|
||||
"Non-nil if inside `dap--process-filter'.")
|
||||
|
||||
(cl-defun dap--process-filter (proc string)
|
||||
"Called when new data STRING has arrived for PROC."
|
||||
(when dap--in-process-filter
|
||||
;; Problematic recursive process filters may happen if
|
||||
;; `dap--connection-receive', called by us, eventually calls
|
||||
;; client code which calls `process-send-string' (which see) to,
|
||||
;; say send a follow-up message. If that happens to writes enough
|
||||
;; bytes for pending output to be received, we will lose JSONRPC
|
||||
;; messages. In that case, remove recursiveness by re-scheduling
|
||||
;; ourselves to run from within a timer as soon as possible
|
||||
;; (bug#60088)
|
||||
(run-at-time 0 nil #'dap--process-filter proc string)
|
||||
(cl-return-from dap--process-filter))
|
||||
(when (buffer-live-p (process-buffer proc))
|
||||
(with-current-buffer (process-buffer proc)
|
||||
(let* ((inhibit-read-only t)
|
||||
(dap--in-process-filter t)
|
||||
(connection (process-get proc 'dap-connection))
|
||||
(expected-bytes (expected-bytes connection)))
|
||||
;; Insert the text, advancing the process marker.
|
||||
;;
|
||||
(save-excursion
|
||||
(goto-char (process-mark proc))
|
||||
(insert string)
|
||||
(set-marker (process-mark proc) (point)))
|
||||
;; Loop (more than one message might have arrived)
|
||||
;;
|
||||
(unwind-protect
|
||||
(let (done)
|
||||
(while (not done)
|
||||
(cond
|
||||
((not expected-bytes)
|
||||
;; Starting a new message
|
||||
;;
|
||||
(setq expected-bytes
|
||||
(and (search-forward-regexp
|
||||
"\\(?:.*: .*\r\n\\)*Content-Length: \
|
||||
*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
|
||||
(+ (point) 100)
|
||||
t)
|
||||
(string-to-number (match-string 1))))
|
||||
(unless expected-bytes
|
||||
(setq done :waiting-for-new-message)))
|
||||
(t
|
||||
;; Attempt to complete a message body
|
||||
;;
|
||||
(let ((available-bytes (- (position-bytes (process-mark proc))
|
||||
(position-bytes (point)))))
|
||||
(cond
|
||||
((>= available-bytes
|
||||
expected-bytes)
|
||||
(let* ((message-end (byte-to-position
|
||||
(+ (position-bytes (point))
|
||||
expected-bytes))))
|
||||
(unwind-protect
|
||||
(save-restriction
|
||||
(narrow-to-region (point) message-end)
|
||||
(let* ((json-message
|
||||
(condition-case-unless-debug oops
|
||||
(jsonrpc--json-read)
|
||||
(error
|
||||
(jsonrpc--warn "Invalid JSON: %s %s"
|
||||
(cdr oops) (buffer-string))
|
||||
nil))))
|
||||
(when json-message
|
||||
;; Process content in another
|
||||
;; buffer, shielding proc buffer from
|
||||
;; tamper
|
||||
(with-temp-buffer
|
||||
(dap-connection-receive connection
|
||||
json-message)))))
|
||||
(goto-char message-end)
|
||||
(delete-region (point-min) (point))
|
||||
(setq expected-bytes nil))))
|
||||
(t
|
||||
;; Message is still incomplete
|
||||
;;
|
||||
(setq done :waiting-for-more-bytes-in-this-message))))))))
|
||||
;; Saved parsing state for next visit to this filter
|
||||
;;
|
||||
(setf (expected-bytes connection) expected-bytes))))))
|
||||
|
||||
(defun dap-connection-receive (conn message)
|
||||
(if (dap-buffer-full (buffer conn))
|
||||
(dap-connection-process-messages conn t))
|
||||
(setf (buffer conn) (dap-buffer-insert (buffer conn) message))
|
||||
(dap-connection-process-messages conn))
|
||||
|
||||
(defun dap-buffer-insert (buffer message)
|
||||
(if (dap-buffer-full-p buffer)
|
||||
(error "Buffer full."))
|
||||
(let ((seq (plist-get :seq message))
|
||||
(next-seq (plist-get :seq (cadr buffer))))
|
||||
(cond
|
||||
(
|
||||
(not next-seq)
|
||||
(list message))
|
||||
(
|
||||
(> seq next-seq)
|
||||
(cons (car buffer) (dap-message-buffer-insert (cdr buffer) message)))
|
||||
(
|
||||
t
|
||||
(cons message buffer)))))
|
||||
|
||||
(defun dap-buffer-full-p (buffer)
|
||||
(length= buffer dap-buffer-size))
|
||||
|
||||
(defun dap-connection-process-messages (conn &optional all)
|
||||
(let ((next-message (car (buffer conn))))
|
||||
(while (and next-message
|
||||
(or all
|
||||
(= (plist-get next-message :seq) (expected-seq conn))))
|
||||
(dap-process-message conn (pop (buffer conn)))
|
||||
(setq next-message (car (buffer conn))))))
|
||||
|
||||
(defun dap-process-message (conn message)
|
||||
(cl-destructuring-bind (&key seq type &allow-other-keys)
|
||||
message
|
||||
(setf (expected-seq conn) (1+ seq))
|
||||
(cond
|
||||
(;; event
|
||||
(equal type "event")
|
||||
(funcall (slot-value conn 'event-dispatcher) conn message))
|
||||
(;; request
|
||||
(equal type "request")
|
||||
(funcall (slot-value conn 'request-dispatcher) conn message))
|
||||
(;; response
|
||||
(equal type "response")
|
||||
(funcall (slot-value conn 'response-dispatcher) conn message)))))
|
||||
|
||||
;;;###autoload
|
||||
(provide 'gudap)
|
||||
|
||||
;;; gudap.el ends here
|
||||
Loading…
Add table
Reference in a new issue