From 827e8008ba8fe22bb2b8a0d3a89663711ec3e52c Mon Sep 17 00:00:00 2001 From: dominik martinez Date: Sat, 10 Jun 2023 13:52:12 -0400 Subject: [PATCH] Initial commit --- gudap.el | 255 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 255 insertions(+) create mode 100644 gudap.el diff --git a/gudap.el b/gudap.el new file mode 100644 index 0000000..b448347 --- /dev/null +++ b/gudap.el @@ -0,0 +1,255 @@ +;;; gudap.el --- Debug Adapter Protocol client for Emacs -*- lexical-binding: t -*- + +;; Author: Dominik Martinez +;; 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