;;; 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 ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or (at ;; your option) any later version. ;; This program is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; 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) (dap-process :initarg :dap-process :accessor dap-process) (event-dispatcher :initform #'ignore :initarg :event-dispatcher) (request-dispatcher :initform #'ignore :initarg :request-dispatcher) (response-dispatcher :initform #'ignore :initarg :response-dispatcher) (message-queue :initform '() :accessor message-queue) (expected-seq :initform 1 :accessor expected-seq) (expected-bytes :accessor expected-bytes) (comint-process :initarg :comint-process :accessor comint-process))) (cl-defgeneric connection-live-p (connection)) (cl-defmethod connection-live-p ((connection dap-connection)) (process-live-p (dap-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 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-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) (let* ((nickname (project-name project)) (readable-name (format "GUDAP (%s/%s)" nickname managed-modes)) (dap-proc (make-process :name readable-name :buffer (generate-new-buffer readable-name) :command contact :filter 'dap--process-filter :sentinel 'dap--server-sentinel :noquery t)) (comint-name (format "%s comint" readable-name)) (comint-proc (make-process :name comint-name :buffer (generate-new-buffer comint-name) :command nil :noquery t)) (conn (make-instance class :name readable-name :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) (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 () "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 ((conn (process-get proc 'dap-connection))) (remhash (eglot--current-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-queue-full-p (message-queue conn)) (dap-connection-process-messages conn t)) (setf (message-queue conn) (dap-queue-insert (message-queue conn) message)) (dap-connection-process-messages conn)) (defun dap-queue-insert (queue message) (if (dap-queue-full-p queue) (error "Queue full.")) (let ((seq (plist-get :seq message)) (next-seq (plist-get :seq (cadr queue)))) (cond ( (not next-seq) (list message)) ( (> seq next-seq) (cons (car queue) (dap-queue-insert (cdr queue) message))) ( t (cons message queue))))) (defun dap-queue-full-p (queue) (length= queue dap-buffer-size)) (defun dap-connection-process-messages (conn &optional all) (let ((next-message (car (message-queue conn)))) (while (and next-message (or all (= (plist-get next-message :seq) (expected-seq conn)))) (dap-process-message conn (pop (message-queue conn))) (setq next-message (car (message-queue 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