gudap/gudap.el

467 lines
17 KiB
EmacsLisp

;;; 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
;; 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 <https://www.gnu.org/licenses/>.
;;; 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)
(defclass gudap-connection ()
((name
:initarg :name)
(-process
:initarg :process
:accessor gudap--process)
(-expected-bytes
:accessor gudap--expected-bytes)
(-sent-requests
:initform (make-hash-table)
:accessor gudap--sent-requests) ;; seq to request command
(next-seq
:initform 0
:accessor gudap--next-seq)))
(defun gudap--test ()
(let* ((dap-process (make-process :name "lldb-vscode"
:buffer (generate-new-buffer "lldb-vscode")
:command '("lldb-vscode")
:connection-type 'pipe
:filter 'gudap--process-filter
:coding 'utf-8-emacs-unix))
(conn (make-instance gudap-connection
:name "lldb-vscode-conn"
:process dap-process)))
(process-put dap-process 'gudap-connection conn)
(setq gudap--current-connection conn)
(gudap-send-request conn 'initialize nil)))
(defun gudap--cleanup ()
(kill-process ((gudap--process gudap--current-connection)))
(setq gudap--current-connection nil))
(cl-defgeneric gudap-send-request (server command arguments))
(cl-defmethod gudap-send-request (server (command (eql initialize)) arguments)
(puthash (gudap--next-seq server) 'initialize (gudap--sent-requests server))
(gudap--connection-send
server
(list :type "request"
:command "initialize"
:arguments (gudap--initialize-arguments))))
(cl-defgeneric gudap-handle-response (server type body))
(cl-defmethod gudap-handle-response (server type body)
(gudap--message "%s" body))
(cl-defmethod gudap-handle-response (server (type (eql initialize)) body)
(gudap--message "initialized: %s" body))
(cl-defgeneric gudap-handle-event (server event body))
(cl-defmethod gudap-handle-event (server event body)
(gudap--message "%s" message))
(cl-defgeneric gudap-handle-request (server command arguments))
(defun gudap--initialize-arguments ()
(list :clientId "gudap"
:clientName "gudap"
:adapterId "gudap"
:locale "en-US"
:linesStartAt1 t
:columnsStartAt1 t
:pathFormat "path"
:supportsVariableType nil
:supportsVariablePaging nil
:supportsRunInTerminalRequest nil
:supportsMemoryReferences nil
:supportsProgressReporting nil
:supportsInvalidatedEvent nil
:supportsMemoryEvent nil
:supportsArgsCanBeInterpretedByShell nil
:supportsStartDebuggingRequest nil))
;; Utils
(defun gudap--message (format &rest args)
"Message out with FORMAT with ARGS."
(message "[gudap] %s" (apply #'format format args)))
;; JSONRPC-ish handling
(defvar gudap--in-process-filter nil
"Non-nil if inside `dap--process-filter'.")
(cl-defun gudap--process-filter (proc string)
"Called when new data STRING has arrived for PROC."
(when gudap--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 #'gudap--process-filter proc string)
(cl-return-from gudap--process-filter))
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
(let* ((gudap--in-process-filter t)
(connection (process-get proc 'gudap-connection))
(expected-bytes (gudap--expected-bytes connection)))
;; Insert the text, advancing the process marker.
;;
(save-excursion
(goto-char (process-mark proc))
(let ((inhibit-read-only t)) (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) 200)
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
(gudap--connection-receive connection
json-message)))))
(goto-char message-end)
(let ((inhibit-read-only t))
(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 (gudap--expected-bytes connection) expected-bytes))))))
(defun gudap--connection-receive (conn message)
(cl-destructuring-bind (&key seq type event body arguments &allow-other-keys) message
(cond
(;; event
(string-equal type "event")
(gudap-handle-event conn (intern event) body))
(;; response
(string-equal type "response")
(let ((request-type (gethash seq (gudap--sent-requests conn))))
(if request-type
(gudap-handle-response conn request-type body)
(gudap--message "received response to a nonexistent request. ignoring")))
(remhash seq (gudap--sent-requests conn)))
(;; reverse request
(string-equal type "request")
(gudap-handle-request conn (intern command) arguments)))))
(defun gudap--connection-send (conn message)
(setq message (plist-put message :seq (gudap--next-seq conn)))
(let* ((json-object-type 'plist)
(json (jsonrpc--json-encode message))
(headers `(("Content-Length" . ,(format "%d" (string-bytes json)))))
(content (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))))
(process-send-string (gudap--process conn) content))
(setf (gudap--next-seq conn) (1+ (gudap--next-seq conn))))
;; (defvar gudap-server-programs
;; '(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug"))))
;; (defvar gudap-launch-args
;; `(((elixir-mode elixir-ts-mode) . (("phx" . ,(lambda (project)
;; (list :type "mix_task"
;; :name "phx.server"
;; :request "launch"
;; :task "phx.server"
;; :projectDir (file-truename (project-root project)))))))))
;; (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 (gudap--guess-contact))
;; (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--guess-contact ()
;; (let ((eglot-server-programs gudap-server-programs))
;; (eglot--guess-contact t)))
;; (defun gudap--lookup-launch-args (mode)
;; (let ((eglot-server-programs gudap-launch-args))
;; (eglot--lookup-mode mode)))
;; (defun gudap-shutdown ()
;; (interactive)
;; (let* ((conn (gudap-current-connection)))
;; (if (dap-process conn)
;; (kill-buffer (process-buffer (dap-process conn))))
;; (if (comint-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 (if (integerp (cadr contact))
;; (open-network-stream
;; readable-name
;; (generate-new-buffer readable-name)
;; (car contact)
;; (cadr contact)
;; :sentinel 'dap--server-sentinel
;; :noquery t)
;; (make-process :name readable-name
;; :buffer (generate-new-buffer readable-name)
;; :command contact
;; :sentinel 'dap--server-sentinel
;; :noquery t
;; :connection-type 'pipe
;; :coding 'utf-8-emacs-unix)))
;; (comint-name (format "%s SHELL" 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
;; :response-dispatcher 'gudap-response-dispatcher
;; :comint-process comint-proc
;; :launch-args (alist-get managed-modes gudap-launch-args nil nil #'equal))))
;; (set-process-filter dap-proc 'dap--process-filter)
;; (setq gudap--cached-connection conn)
;; (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)
;; (dap--send-initialize 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)))
;; (
;; (equal event "initialized")
;; (dap--send-all-breakpoints conn)
;; (dap--send-config-done conn)))))
;; (defun gudap-response-dispatcher (conn message)
;; (cl-destructuring-bind (&key command request_seq body &allow-other-keys)
;; message
;; (cond
;; (
;; (equal command "setBreakpoints")
;; (gudap--verify-breakpoints conn message)))))
;; (defun gudap--verify-breakpoints (conn message)
;; (cl-destructuring-bind (&key request_seq body &allow-other-keys)
;; message
;; (let* ((bp-results-vector (plist-get body :breakpoints))
;; (bp-results (append bp-results-vector nil)) ;; convert to list
;; (bp-path (gethash request_seq (breakpoints-req-seq conn)))
;; (pending-bps (gethash bp-path (breakpoints conn)))
;; (valid-bps (gudap--validate-breakpoints pending-bps bp-results)))
;; (puthash bp-path valid-bps (breakpoints conn))
;; (remhash request_seq (breakpoints-req-seq conn))
;; (message "breakpoints validated"))))
;; (defun gudap--validate-breakpoints (bps bp-results)
;; (if (/= (length bps) (length bp-results))
;; (error "Breakpoints and breakpoints results must be the same length."))
;; (let ((bp (car bps))
;; (bp-result (car bp-results)))
;; (cond
;; (
;; (null bp)
;; '())
;; (
;; (plist-get bp-result :verified)
;; (cons bp (gudap--validate-breakpoints (cdr bps) (cdr bp-results))))
;; (
;; (not (plist-get bp-result :verified))
;; (gudap--validate-breakpoints (cdr bps) (cdr bp-results))))))
;; (defun dap--send-breakpoints (conn path breakpoints)
;; (puthash (next-seq conn) path (breakpoints-req-seq conn))
;; (dap-connection-send
;; conn
;; (list :seq (next-seq conn)
;; :type "request"
;; :command "setBreakpoints"
;; :arguments
;; (list :source `(:path ,path)
;; :breakpoints (vconcat breakpoints)))))
;; (defun dap--send-all-breakpoints (conn)
;; (maphash
;; (lambda (path bps)
;; (dap--send-breakpoints conn path bps))
;; (breakpoints conn)))
;; (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 gudap-launch (conn)
;; (interactive (list (gudap-current-connection)))
;; (let* ((launch-keys (mapcar (lambda (elem) (car elem)) (launch-args conn)))
;; (launch-key (read-from-minibuffer "What launch config to use? "
;; launch-keys))
;; (launch-args (funcall (alist-get launch-key (launch-args conn) nil nil #'equal) (project-current))))
;; (dap--send-launch conn launch-args)))
;; (defun dap--send-initialize (conn)
;; (let ((message (list :seq (next-seq conn)
;; :type "request"
;; :command "initialize"
;; :arguments (list :adapterID "dummy"
;; :supportsProgressReporting t))))
;; (dap-connection-send conn message)))
;; (defun dap--send-launch (conn launch-args)
;; (let ((message (list :seq (next-seq conn)
;; :type "request"
;; :command "launch"
;; :arguments launch-args)))
;; (dap-connection-send conn message)))
;; (defun dap--send-config-done (conn)
;; (let ((message (list :seq (next-seq conn)
;; :type "request"
;; :command "configurationDone")))
;; (dap-connection-send conn message)))
;; (defun dap--server-sentinel (proc event)
;; (let ((conn (process-get proc 'dap-connection)))
;; (remhash (eglot--current-project) gudap--connections-by-project))
;; (setq gudap--cached-connection nil))
;; (defun dap-connection-send (conn message)
;; ;; (message "\nSending message:\n")
;; ;; (pp message)
;; ;; (message "\n")
;; (let* ((json-object-type 'plist)
;; (json (jsonrpc--json-encode message))
;; (headers `(("Content-Length" . ,(format "%d" (string-bytes json)))))
;; (content (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))))
;; (process-send-string (dap-process conn) content))
;; (setf (next-seq conn) (1+ (next-seq conn))))
;;;###autoload
(provide 'gudap)
;;; gudap.el ends here