diff --git a/gudap.el b/gudap.el index fcdbd6d..c0cbeaf 100644 --- a/gudap.el +++ b/gudap.el @@ -33,6 +33,7 @@ (require 'eglot) (require 'jsonrpc) +(require 'gud) (defgroup gudap nil "Interaction with Debug Adapter Protocol servers." @@ -50,28 +51,40 @@ (-sent-requests :initform (make-hash-table) :accessor gudap--sent-requests) ;; seq to request command + (gud-buffer + :initarg :gud-buffer + :accessor gudap-gud-buffer) (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))) +(defvar gudap-server-programs + '(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug")) + (c++-mode . "lldb-vscode"))) + +(defun gudap (server-command) + (gudap--connect server-command)) + +(defun gudap--connect (server-command) + (let* ((nickname server-command) + (readable-name (format "GUDAP (%s)" nickname)) + (gud-buffer (gud-common-init "cat" + (lambda (_file args) args) + #'identity + (lambda (m) (gudap--message "%s" m)))) + (dap-proc (make-process :name readable-name + :buffer (generate-new-buffer readable-name) + :command (list server-command) + :filter 'gudap--process-filter + :noquery t + :connection-type 'pipe + :coding 'utf-8-emacs-unix)) + (conn (make-instance 'gudap-connection + :name readable-name + :process dap-proc + :gud-buffer gud-buffer))) + (process-put dap-proc 'gudap-connection conn))) -(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) @@ -81,7 +94,6 @@ (list :type "request" :command "initialize" :arguments (gudap--initialize-arguments)))) - (cl-defgeneric gudap-handle-response (server type body)) @@ -89,13 +101,21 @@ (gudap--message "%s" body)) (cl-defmethod gudap-handle-response (server (type (eql initialize)) body) - (gudap--message "initialized: %s" body)) + (gudap--message "initialized")) (cl-defgeneric gudap-handle-event (server event body)) (cl-defmethod gudap-handle-event (server event body) (gudap--message "%s" message)) +(cl-defmethod gudap-handle-event (server (event (eql output)) body) + (let ((gud-process (get-buffer-process (gudap-gud-buffer server)))) + (cl-destructuring-bind + (&key category output group variablesReference source line column data) + body + (pcase category + ("console" (gud-filter gud-process output)))))) + (cl-defgeneric gudap-handle-request (server command arguments)) (defun gudap--initialize-arguments () @@ -122,7 +142,6 @@ "Message out with FORMAT with ARGS." (message "[gudap] %s" (apply #'format format args))) - ;; JSONRPC-ish handling (defvar gudap--in-process-filter nil @@ -238,229 +257,6 @@ (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)