Compare commits
10 commits
8bcf623f2f
...
408a531995
Author | SHA1 | Date | |
---|---|---|---|
408a531995 | |||
f89b52c944 | |||
702f5917b1 | |||
076c96a331 | |||
b73bfa3311 | |||
115587f60b | |||
df884561b6 | |||
b04c59dfc7 | |||
3449bdded6 | |||
d98cb8a910 |
2 changed files with 444 additions and 280 deletions
12
README.md
Normal file
12
README.md
Normal file
|
@ -0,0 +1,12 @@
|
||||||
|
# Gudap
|
||||||
|
|
||||||
|
Combining the powers of Emacs' [GUD](https://www.gnu.org/software/emacs/manual/html_node/emacs/Debuggers.html) and [DAP](https://microsoft.github.io/debug-adapter-protocol/).
|
||||||
|
|
||||||
|
# Usage
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
(use-package gudap
|
||||||
|
:load-path "/path/to/gudap/")
|
||||||
|
|
||||||
|
(gudap)
|
||||||
|
```
|
712
gudap.el
712
gudap.el
|
@ -31,73 +31,443 @@
|
||||||
|
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(require 'eglot)
|
|
||||||
(require 'jsonrpc)
|
(require 'jsonrpc)
|
||||||
|
(require 'gud)
|
||||||
|
|
||||||
(defgroup gudap nil
|
(defgroup gudap nil
|
||||||
"Interaction with Debug Adapter Protocol servers."
|
"Interaction with Debug Adapter Protocol servers."
|
||||||
:prefix "gudap-"
|
:prefix "gudap-"
|
||||||
:group 'applications)
|
:group 'applications)
|
||||||
|
|
||||||
(defclass gudap-connection ()
|
(defclass gudap-server ()
|
||||||
((name
|
((name
|
||||||
:initarg :name)
|
:initarg :name)
|
||||||
(-process
|
(dap-process
|
||||||
:initarg :process
|
:initarg :dap-process
|
||||||
:accessor gudap--process)
|
:accessor gudap-dap-process)
|
||||||
(-expected-bytes
|
(gud-buffer
|
||||||
:accessor gudap--expected-bytes)
|
:initarg :gud-buffer
|
||||||
(-sent-requests
|
:accessor gudap-gud-buffer)
|
||||||
:initform (make-hash-table)
|
(events-buffer
|
||||||
:accessor gudap--sent-requests) ;; seq to request command
|
:initarg :events-buffer
|
||||||
(next-seq
|
:accessor gudap-events-buffer)
|
||||||
:initform 0
|
(launch-config
|
||||||
:accessor gudap--next-seq)))
|
:initarg :launch-config
|
||||||
|
:accessor gudap-launch-config)
|
||||||
|
(expected-bytes
|
||||||
|
:initform nil
|
||||||
|
:accessor gudap-expected-bytes)
|
||||||
|
(seq
|
||||||
|
:initform 1
|
||||||
|
:accessor gudap-seq)
|
||||||
|
(initialized
|
||||||
|
:initform nil
|
||||||
|
:accessor gudap-initialized)
|
||||||
|
(breakpoints
|
||||||
|
:initform (make-hash-table :test 'equal)
|
||||||
|
:accessor gudap-breakpoints)
|
||||||
|
(capabilities
|
||||||
|
:accessor gudap-capabilities)
|
||||||
|
(callbacks
|
||||||
|
:initform (make-hash-table :test 'equal)
|
||||||
|
:accessor gudap-callbacks)
|
||||||
|
(current-thread
|
||||||
|
:initform nil
|
||||||
|
:accessor gudap-current-thread)
|
||||||
|
(current-frame
|
||||||
|
:initform nil
|
||||||
|
:accessor gudap-current-frame)
|
||||||
|
(stopped
|
||||||
|
:initform t
|
||||||
|
:accessor gudap-stopped)))
|
||||||
|
|
||||||
(defun gudap--test ()
|
(defclass breakpoint ()
|
||||||
(let* ((dap-process (make-process :name "lldb-vscode"
|
((id
|
||||||
:buffer (generate-new-buffer "lldb-vscode")
|
:initarg :id
|
||||||
:command '("lldb-vscode")
|
:accessor gudap-bp-id)
|
||||||
:connection-type 'pipe
|
(verified
|
||||||
:filter 'gudap--process-filter
|
:initarg :verified
|
||||||
:coding 'utf-8-emacs-unix))
|
:accessor gudap-bp-verified)
|
||||||
(conn (make-instance gudap-connection
|
(source
|
||||||
:name "lldb-vscode-conn"
|
:initarg :source
|
||||||
:process dap-process)))
|
:accessor gudap-bp-source)
|
||||||
(process-put dap-process 'gudap-connection conn)
|
(line
|
||||||
(setq gudap--current-connection conn)
|
:initarg :line
|
||||||
(gudap-send-request conn 'initialize nil)))
|
:accessor gudap-bp-line)))
|
||||||
|
|
||||||
|
(defclass source-breakpoint (breakpoint)
|
||||||
|
((condition
|
||||||
|
:initarg :condition
|
||||||
|
:initform nil
|
||||||
|
:accessor gudap-source-bp-condition)))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-bp-update ((bp source-breakpoint) server-bp)
|
||||||
|
(cl-destructuring-bind (&key id verified source line &allow-other-keys) server-bp
|
||||||
|
(make-instance 'source-breakpoint
|
||||||
|
:id id
|
||||||
|
:verified verified
|
||||||
|
:source source
|
||||||
|
:line line
|
||||||
|
:condition (gudap-source-bp-condition bp))))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-bp-params ((bp source-breakpoint))
|
||||||
|
(with-slots (line condition) bp
|
||||||
|
(list :line line
|
||||||
|
:condition condition)))
|
||||||
|
|
||||||
|
(defun gudap-bps-params (bps)
|
||||||
|
(mapcar 'gudap-bp-params bps))
|
||||||
|
|
||||||
|
(defvar gudap-server-programs-and-launch
|
||||||
|
'(((c++-mode c-mode rust-mode) "lldb-vscode" (lambda ()
|
||||||
|
(list :name "gudap-lldb"
|
||||||
|
:type "lldb-vscode"
|
||||||
|
:request "launch"
|
||||||
|
:program (read-file-name "Program to debug? "))))))
|
||||||
|
(defvar gudap-active-server nil)
|
||||||
|
|
||||||
|
(defun gudap--buffer-line ()
|
||||||
|
(save-restriction
|
||||||
|
(widen)
|
||||||
|
(+ (count-lines (point-min) (point))
|
||||||
|
(if (bolp) 1 0))))
|
||||||
|
|
||||||
|
(defmacro gudap-with-initialized (server-var &rest body)
|
||||||
|
(declare (indent defun))
|
||||||
|
`(let* ((server ,server-var)
|
||||||
|
(initialized (gudap-initialized server)))
|
||||||
|
(if initialized
|
||||||
|
(progn ,@body))))
|
||||||
|
|
||||||
|
(defun gudap--gud-run (arg)
|
||||||
|
(gudap-with-initialized gudap-active-server
|
||||||
|
(gudap-send-request
|
||||||
|
gudap-active-server
|
||||||
|
'configurationDone
|
||||||
|
'())))
|
||||||
|
|
||||||
|
(defun gudap--gud-cont (arg)
|
||||||
|
(gudap-with-initialized gudap-active-server
|
||||||
|
(gudap-send-request
|
||||||
|
server
|
||||||
|
'continue
|
||||||
|
(list :threadId (gudap-current-thread server)))))
|
||||||
|
|
||||||
|
(defun gudap-update-breakpoints (server file-path bps server-bps)
|
||||||
|
(puthash file-path
|
||||||
|
(cl-loop for bp across bps
|
||||||
|
for server-bp across server-bps
|
||||||
|
collect (gudap-bp-update bp server-bp))
|
||||||
|
(gudap-breakpoints server)))
|
||||||
|
|
||||||
|
(defun gudap--gud-break (arg)
|
||||||
|
(gudap-with-initialized gudap-active-server
|
||||||
|
(let* ((file-path (buffer-file-name))
|
||||||
|
(current-bps (gethash file-path (gudap-breakpoints server)))
|
||||||
|
(new-bp (make-instance 'source-breakpoint
|
||||||
|
:line (line-number-at-pos)
|
||||||
|
:condition (if (> arg 1) (read-string "Expression: "))))
|
||||||
|
(bps (vconcat (cons new-bp current-bps))))
|
||||||
|
(gudap-send-request
|
||||||
|
server
|
||||||
|
'setBreakpoints
|
||||||
|
(list :source (gudap--dap-type-source file-path)
|
||||||
|
:breakpoints (vconcat (mapcar 'gudap-bp-params bps)))
|
||||||
|
(lambda (server success body)
|
||||||
|
(gudap-update-breakpoints server file-path bps (plist-get body :breakpoints)))))))
|
||||||
|
|
||||||
|
(defun gudap--gud-break-cond (arg)
|
||||||
|
(gudap--gud-break (read-string "Expression: ")))
|
||||||
|
|
||||||
|
(defun gudap--gud-remove (arg)
|
||||||
|
(gudap-with-initialized gudap-active-server
|
||||||
|
(let* ((file-path (buffer-file-name))
|
||||||
|
(line (line-number-at-pos))
|
||||||
|
(current-breakpoints (gethash file-path (gudap-breakpoints server))))
|
||||||
|
(if current-breakpoints
|
||||||
|
(let* ((filtered-breakpoints (seq-filter
|
||||||
|
(lambda (bp) (/= line (gudap-bp-line bp)))
|
||||||
|
current-breakpoints))
|
||||||
|
(source-breakpoints (vconcat (gudap-bps-params filtered-breakpoints))))
|
||||||
|
(if (= (length current-breakpoints) (length source-breakpoints))
|
||||||
|
(gudap--message "No breakpoints at location!")
|
||||||
|
(remhash file-path (gudap-breakpoints server))
|
||||||
|
(gudap-send-request
|
||||||
|
server
|
||||||
|
'setBreakpoints
|
||||||
|
(list :source (gudap--dap-type-source file-path)
|
||||||
|
:breakpoints source-breakpoints)
|
||||||
|
(lambda (server success body)
|
||||||
|
(gudap-update-breakpoints server file-path source-breakpoints (plist-get body :breakpoints))))))
|
||||||
|
(gudap--message "No breakpoints at location!")))))
|
||||||
|
|
||||||
|
(defun gudap--gud-next (arg)
|
||||||
|
(gudap-with-initialized gudap-active-server
|
||||||
|
(if (gudap-stopped server)
|
||||||
|
(gudap-send-request
|
||||||
|
server
|
||||||
|
'next
|
||||||
|
(list :threadId (gudap-current-thread server))))))
|
||||||
|
|
||||||
|
(defun gudap--gud-stepi (arg)
|
||||||
|
(gudap-with-initialized gudap-active-server
|
||||||
|
(if (gudap-stopped server)
|
||||||
|
(gudap-send-request
|
||||||
|
server
|
||||||
|
'stepIn
|
||||||
|
(list :threadId (gudap-current-thread server))))))
|
||||||
|
|
||||||
|
(defun gudap--dap-type-source (file-path)
|
||||||
|
(list :path file-path))
|
||||||
|
|
||||||
|
(defmacro def-gudap-cmd (gud-cmd gudap-fn key)
|
||||||
|
`(progn
|
||||||
|
(defalias ',gud-cmd (lambda (arg)
|
||||||
|
(interactive "p")
|
||||||
|
(,gudap-fn arg)))
|
||||||
|
,(if key `(local-set-key ,(concat "\C-c" key) #',gud-cmd))
|
||||||
|
,(if key `(define-key gud-global-map ,key #',gud-cmd))))
|
||||||
|
|
||||||
|
(defun gudap ()
|
||||||
|
(interactive)
|
||||||
|
(let ((program-and-launch-config (gudap--guess-contact))
|
||||||
|
(gud-comint-buffer (gud-common-init "cat"
|
||||||
|
(lambda (_file args) args)
|
||||||
|
#'identity)))
|
||||||
|
(setq comint-prompt-regexp "^>")
|
||||||
|
(gudap--connect (car program-and-launch-config) (cdr program-and-launch-config) gud-comint-buffer)
|
||||||
|
|
||||||
|
(def-gudap-cmd gud-break gudap--gud-break "\C-b")
|
||||||
|
(def-gudap-cmd gud-cont gudap--gud-cont "\C-r")
|
||||||
|
(def-gudap-cmd gud-run gudap--gud-run nil)
|
||||||
|
(def-gudap-cmd gud-remove gudap--gud-remove "\C-d")
|
||||||
|
(def-gudap-cmd gud-next gudap--gud-next "\C-n")
|
||||||
|
(def-gudap-cmd gud-stepi gudap--gud-stepi "\C-i")
|
||||||
|
|
||||||
|
(setq gdb-first-prompt t)
|
||||||
|
(setq gud-running nil)
|
||||||
|
(add-hook 'comint-input-filter-functions
|
||||||
|
(lambda (input) (gudap-gud-input gudap-active-server input)))
|
||||||
|
(gudap-gud-prompt gudap-active-server)))
|
||||||
|
|
||||||
|
;; (setq-local gud-minor-mode 'gdbmi)
|
||||||
|
;; (setq-local gdb-control-level 0)
|
||||||
|
|
||||||
|
;; (gdb-setup-windows))
|
||||||
|
|
||||||
|
(defun gudap--gdb-update ()
|
||||||
|
(when gdb-first-prompt
|
||||||
|
(gdb-force-mode-line-update
|
||||||
|
(propertize "initializing..." 'face font-lock-variable-name-face))
|
||||||
|
(gudap--gdb-init-1)
|
||||||
|
(setq gdb-first-prompt nil))
|
||||||
|
|
||||||
|
(gdb-get-buffer-create 'gdb-threads-buffer)
|
||||||
|
(gdb-get-buffer-create 'gdb-breakpoints-buffer)
|
||||||
|
|
||||||
|
;;(gdb-get-changed-registers)
|
||||||
|
(unless no-proc
|
||||||
|
(gdb-emit-signal gdb-buf-publisher 'update))
|
||||||
|
|
||||||
|
;; (when (and (boundp 'speedbar-frame) (frame-live-p speedbar-frame))
|
||||||
|
;; (dolist (var gdb-var-list)
|
||||||
|
;; (setcar (nthcdr 5 var) nil))
|
||||||
|
;; (gdb-var-update))
|
||||||
|
)
|
||||||
|
|
||||||
|
(defun gdb-init-1 ()
|
||||||
|
;; (Re-)initialize.
|
||||||
|
(setq gdb-selected-frame nil
|
||||||
|
gdb-frame-number nil
|
||||||
|
gdb-thread-number nil
|
||||||
|
gdb-var-list nil
|
||||||
|
gdb-output-sink 'user
|
||||||
|
gdb-location-alist nil
|
||||||
|
gdb-source-file-list nil
|
||||||
|
gdb-last-command nil
|
||||||
|
gdb-token-number 0
|
||||||
|
gdb-handler-list '()
|
||||||
|
gdb-prompt-name nil
|
||||||
|
gdb-first-done-or-error t
|
||||||
|
gdb-target-async-checked nil
|
||||||
|
gdb-buffer-fringe-width (car (window-fringes))
|
||||||
|
gdb-debug-log nil
|
||||||
|
gdb-source-window-list nil
|
||||||
|
gdb-inferior-status nil
|
||||||
|
gdb-continuation nil
|
||||||
|
gdb-buf-publisher '()
|
||||||
|
gdb-threads-list '()
|
||||||
|
gdb-breakpoints-list '()
|
||||||
|
gdb-register-names '()
|
||||||
|
gdb-supports-non-stop nil
|
||||||
|
gdb-non-stop nil
|
||||||
|
gdb-debuginfod-enable gdb-debuginfod-enable-setting)
|
||||||
|
(gdb-force-mode-line-update
|
||||||
|
(propertize "initializing..." 'face font-lock-variable-name-face)))
|
||||||
|
|
||||||
|
(defun gudap-shutdown ()
|
||||||
|
(interactive)
|
||||||
|
(kill-buffer (process-buffer (gudap-dap-process gudap-active-server)))
|
||||||
|
(kill-buffer (gudap-gud-buffer gudap-active-server))
|
||||||
|
(kill-buffer (gudap-events-buffer gudap-active-server))
|
||||||
|
(setq gudap-active-server nil))
|
||||||
|
|
||||||
|
(defun gudap--connect (server-command launch-config gud-buffer)
|
||||||
|
(let* ((nickname server-command)
|
||||||
|
(readable-name (format "GUDAP (%s)" nickname))
|
||||||
|
(dap-proc (make-process :name readable-name
|
||||||
|
:buffer (get-buffer-create (format " *%s events*" readable-name))
|
||||||
|
:command (list server-command)
|
||||||
|
:filter 'gudap--process-filter
|
||||||
|
:noquery t
|
||||||
|
:connection-type 'pipe
|
||||||
|
:coding 'utf-8-emacs-unix))
|
||||||
|
(server (make-instance 'gudap-server
|
||||||
|
:name readable-name
|
||||||
|
:dap-process dap-proc
|
||||||
|
:gud-buffer gud-buffer
|
||||||
|
:events-buffer (get-buffer-create (format "*%s log*" readable-name))
|
||||||
|
:launch-config launch-config)))
|
||||||
|
(process-put dap-proc 'gudap-server server)
|
||||||
|
(setq gudap-active-server server)
|
||||||
|
(gudap-send-request server 'initialize (gudap--initialize-arguments))))
|
||||||
|
|
||||||
|
(defun gudap--guess-contact ()
|
||||||
|
(let* ((guessed-mode (if buffer-file-name major-mode))
|
||||||
|
(program-and-launch (gudap--lookup-program-and-launch guessed-mode))
|
||||||
|
(server-program (cadr program-and-launch))
|
||||||
|
(launch-config-uneval (caddr program-and-launch))
|
||||||
|
(launch-config (or (and (functionp launch-config-uneval)
|
||||||
|
(funcall launch-config-uneval))
|
||||||
|
(and (listp launch-config-uneval)
|
||||||
|
launch-config-uneval))))
|
||||||
|
(cons server-program launch-config)))
|
||||||
|
|
||||||
|
(defun gudap--lookup-program-and-launch (mode-name)
|
||||||
|
(cl-loop for p-l in gudap-server-programs-and-launch
|
||||||
|
if (or
|
||||||
|
(and (listp (car p-l)) (member mode-name (car p-l)))
|
||||||
|
(and (symbolp (car p-l)) (equal mode-name (car p-l))))
|
||||||
|
return p-l))
|
||||||
|
|
||||||
|
;;; REQUESTS
|
||||||
|
|
||||||
(defun gudap--cleanup ()
|
|
||||||
(kill-process ((gudap--process gudap--current-connection)))
|
|
||||||
(setq gudap--current-connection nil))
|
|
||||||
|
|
||||||
(cl-defgeneric gudap-send-request (server command arguments))
|
(cl-defgeneric gudap-send-request (server command arguments))
|
||||||
|
|
||||||
(cl-defmethod gudap-send-request (server (command (eql initialize)) arguments)
|
(cl-defmethod gudap-send-request (server command arguments &optional callback-fn)
|
||||||
(puthash (gudap--next-seq server) 'initialize (gudap--sent-requests server))
|
(if callback-fn
|
||||||
|
(puthash (gudap-seq server) callback-fn (gudap-callbacks server)))
|
||||||
(gudap--connection-send
|
(gudap--connection-send
|
||||||
server
|
server
|
||||||
(list :type "request"
|
(list :type "request"
|
||||||
:command "initialize"
|
:command (symbol-name command)
|
||||||
:arguments (gudap--initialize-arguments))))
|
:arguments arguments)))
|
||||||
|
|
||||||
|
|
||||||
(cl-defgeneric gudap-handle-response (server type body))
|
;;; RESPONSES
|
||||||
|
|
||||||
(cl-defmethod gudap-handle-response (server type body)
|
(cl-defgeneric gudap-handle-response (server command success body err-msg)
|
||||||
(gudap--message "%s" body))
|
"Handler for DAP response.")
|
||||||
|
|
||||||
(cl-defmethod gudap-handle-response (server (type (eql initialize)) body)
|
(cl-defmethod gudap-handle-response (server (_type (eql initialize)) _success _body _err-msg)
|
||||||
(gudap--message "initialized: %s" body))
|
(gudap-send-request server 'launch (gudap-launch-config server)))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-handle-response (server (type (eql evaluate)) (success (eql t)) body _err-msg)
|
||||||
|
(gudap-gud-output server (plist-get body :result)))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-handle-response (server (type (eql evaluate)) _success _body err-msg)
|
||||||
|
(gudap-gud-output server err-msg))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-handle-response (server (type (eql continue)) (success (eql t)) _body err-msg)
|
||||||
|
(setf (gudap-stopped server) nil))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-handle-response (server command success body err-msg)
|
||||||
|
(gudap--message "unknown response: %s" body))
|
||||||
|
|
||||||
|
;;; EVENTS
|
||||||
|
|
||||||
(cl-defgeneric gudap-handle-event (server event body))
|
(cl-defgeneric gudap-handle-event (server event body))
|
||||||
|
|
||||||
(cl-defmethod gudap-handle-event (server event body)
|
(cl-defmethod gudap-handle-event (server event body)
|
||||||
(gudap--message "%s" message))
|
(gudap--message "%s" body))
|
||||||
|
|
||||||
|
(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
|
||||||
|
(gudap-gud-output server output))))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-handle-event (server (event (eql initialized)) body)
|
||||||
|
(setf (gudap-initialized server) t))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-handle-event (server (event (eql terminated)) body)
|
||||||
|
(setf (gudap-initialized server) nil
|
||||||
|
(gudap-stopped server) t))
|
||||||
|
|
||||||
|
(defun gudap-gud-goto-frame-from-stack-trace (server success stack-trace-body)
|
||||||
|
(when success
|
||||||
|
(let* ((stack-frames (plist-get stack-trace-body :stackFrames))
|
||||||
|
(top-frame (aref stack-frames 0))
|
||||||
|
(path (plist-get (plist-get top-frame :source) :path))
|
||||||
|
(line (plist-get top-frame :line)))
|
||||||
|
(setf (gudap-current-frame server) (plist-get top-frame :id))
|
||||||
|
(setq gud-last-frame (cons path line)))
|
||||||
|
(gud-display-frame)))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-handle-event (server (event (eql stopped)) body)
|
||||||
|
(cl-destructuring-bind (&key reason threadId &allow-other-keys) body
|
||||||
|
(cond
|
||||||
|
( ;; breakpoint
|
||||||
|
(or (equal reason "breakpoint") (equal reason "step"))
|
||||||
|
(setf (gudap-current-thread server) threadId
|
||||||
|
(gudap-stopped server) t)
|
||||||
|
(gudap-send-request server
|
||||||
|
'stackTrace
|
||||||
|
(list :threadId threadId
|
||||||
|
:levels 1)
|
||||||
|
'gudap-gud-goto-frame-from-stack-trace)))))
|
||||||
|
|
||||||
|
;;; REVERSE REQUESTS
|
||||||
|
|
||||||
(cl-defgeneric gudap-handle-request (server command arguments))
|
(cl-defgeneric gudap-handle-request (server command arguments))
|
||||||
|
|
||||||
|
;;; UTILS
|
||||||
|
|
||||||
|
(cl-defgeneric gudap-print-received (server received))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-print-received (server received)
|
||||||
|
(with-current-buffer (gudap-events-buffer server)
|
||||||
|
(goto-char (point-max))
|
||||||
|
(insert (format "received:\n%s\n\n" (pp-to-string received)))))
|
||||||
|
|
||||||
|
(cl-defgeneric gudap-print-sent (server sent))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-print-sent (server sent)
|
||||||
|
(with-current-buffer (gudap-events-buffer server)
|
||||||
|
(goto-char (point-max))
|
||||||
|
(insert (format "sent:\n%s\n\n" (pp-to-string sent)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;; GUD
|
||||||
|
|
||||||
|
(cl-defmethod gudap-gud-output (server output)
|
||||||
|
(let* ((gud-buffer (gudap-gud-buffer server))
|
||||||
|
(gud-process (get-buffer-process gud-buffer)))
|
||||||
|
(gud-filter gud-process (format "\n%s\n> " output))))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-gud-prompt (server)
|
||||||
|
(let ((gud-process (get-buffer-process (gudap-gud-buffer server))))
|
||||||
|
(gud-filter gud-process "> ")))
|
||||||
|
|
||||||
|
(cl-defmethod gudap-gud-input (server input)
|
||||||
|
(let ((gud-process (get-buffer-process (gudap-gud-buffer server))))
|
||||||
|
(gudap-send-request server
|
||||||
|
'evaluate
|
||||||
|
(list :expression input
|
||||||
|
:frameId (gudap-current-frame server)
|
||||||
|
:context "repl"))))
|
||||||
|
|
||||||
(defun gudap--initialize-arguments ()
|
(defun gudap--initialize-arguments ()
|
||||||
(list :clientId "gudap"
|
(list :clientId "gudap"
|
||||||
:clientName "gudap"
|
:clientName "gudap"
|
||||||
|
@ -116,18 +486,21 @@
|
||||||
:supportsArgsCanBeInterpretedByShell nil
|
:supportsArgsCanBeInterpretedByShell nil
|
||||||
:supportsStartDebuggingRequest nil))
|
:supportsStartDebuggingRequest nil))
|
||||||
|
|
||||||
;; Utils
|
(defun gudap--path (source)
|
||||||
|
(plist-get source :path))
|
||||||
|
|
||||||
|
;; Utils
|
||||||
|
|
||||||
(defun gudap--message (format &rest args)
|
(defun gudap--message (format &rest args)
|
||||||
"Message out with FORMAT with ARGS."
|
"Message out with FORMAT with ARGS."
|
||||||
(message "[gudap] %s" (apply #'format format args)))
|
(message "[gudap] %s" (apply #'format format args)))
|
||||||
|
|
||||||
|
|
||||||
;; JSONRPC-ish handling
|
;; JSONRPC-ish handling
|
||||||
|
|
||||||
(defvar gudap--in-process-filter nil
|
(defvar gudap--in-process-filter nil
|
||||||
"Non-nil if inside `dap--process-filter'.")
|
"Non-nil if inside `dap--process-filter'.")
|
||||||
|
|
||||||
|
;; adapted from jsonrpc.el
|
||||||
(cl-defun gudap--process-filter (proc string)
|
(cl-defun gudap--process-filter (proc string)
|
||||||
"Called when new data STRING has arrived for PROC."
|
"Called when new data STRING has arrived for PROC."
|
||||||
(when gudap--in-process-filter
|
(when gudap--in-process-filter
|
||||||
|
@ -144,8 +517,8 @@
|
||||||
(when (buffer-live-p (process-buffer proc))
|
(when (buffer-live-p (process-buffer proc))
|
||||||
(with-current-buffer (process-buffer proc)
|
(with-current-buffer (process-buffer proc)
|
||||||
(let* ((gudap--in-process-filter t)
|
(let* ((gudap--in-process-filter t)
|
||||||
(connection (process-get proc 'gudap-connection))
|
(server (process-get proc 'gudap-server))
|
||||||
(expected-bytes (gudap--expected-bytes connection)))
|
(expected-bytes (gudap-expected-bytes server)))
|
||||||
;; Insert the text, advancing the process marker.
|
;; Insert the text, advancing the process marker.
|
||||||
;;
|
;;
|
||||||
(save-excursion
|
(save-excursion
|
||||||
|
@ -165,7 +538,7 @@
|
||||||
(and (search-forward-regexp
|
(and (search-forward-regexp
|
||||||
"\\(?:.*: .*\r\n\\)*Content-Length: \
|
"\\(?:.*: .*\r\n\\)*Content-Length: \
|
||||||
*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
|
*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
|
||||||
(+ (point) 200)
|
nil
|
||||||
t)
|
t)
|
||||||
(string-to-number (match-string 1))))
|
(string-to-number (match-string 1))))
|
||||||
(unless expected-bytes
|
(unless expected-bytes
|
||||||
|
@ -196,7 +569,7 @@
|
||||||
;; buffer, shielding proc buffer from
|
;; buffer, shielding proc buffer from
|
||||||
;; tamper
|
;; tamper
|
||||||
(with-temp-buffer
|
(with-temp-buffer
|
||||||
(gudap--connection-receive connection
|
(gudap--connection-receive server
|
||||||
json-message)))))
|
json-message)))))
|
||||||
(goto-char message-end)
|
(goto-char message-end)
|
||||||
(let ((inhibit-read-only t))
|
(let ((inhibit-read-only t))
|
||||||
|
@ -208,258 +581,37 @@
|
||||||
(setq done :waiting-for-more-bytes-in-this-message))))))))
|
(setq done :waiting-for-more-bytes-in-this-message))))))))
|
||||||
;; Saved parsing state for next visit to this filter
|
;; Saved parsing state for next visit to this filter
|
||||||
;;
|
;;
|
||||||
(setf (gudap--expected-bytes connection) expected-bytes))))))
|
(setf (gudap-expected-bytes server) expected-bytes))))))
|
||||||
|
|
||||||
(defun gudap--connection-receive (conn message)
|
(defun gudap--connection-receive (conn message)
|
||||||
(cl-destructuring-bind (&key seq type event body arguments &allow-other-keys) message
|
(gudap-print-received conn message)
|
||||||
|
(cl-destructuring-bind (&key seq request_seq type command event body arguments success message &allow-other-keys) message
|
||||||
(cond
|
(cond
|
||||||
|
(;; callback present
|
||||||
|
(gethash request_seq (gudap-callbacks conn))
|
||||||
|
(funcall (gethash request_seq (gudap-callbacks conn)) conn success body)
|
||||||
|
(remhash request_seq (gudap-callbacks conn)))
|
||||||
(;; event
|
(;; event
|
||||||
(string-equal type "event")
|
(string-equal type "event")
|
||||||
(gudap-handle-event conn (intern event) body))
|
(gudap-handle-event conn (intern event) body))
|
||||||
(;; response
|
(;; response
|
||||||
(string-equal type "response")
|
(string-equal type "response")
|
||||||
(let ((request-type (gethash seq (gudap--sent-requests conn))))
|
(gudap-handle-response conn (intern command) success body message))
|
||||||
(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
|
(;; reverse request
|
||||||
(string-equal type "request")
|
(string-equal type "request")
|
||||||
(gudap-handle-request conn (intern command) arguments)))))
|
(gudap-handle-request conn (intern command) arguments)))))
|
||||||
|
|
||||||
(defun gudap--connection-send (conn message)
|
(defun gudap--connection-send (conn message)
|
||||||
(setq message (plist-put message :seq (gudap--next-seq conn)))
|
(setq message (plist-put message :seq (gudap-seq conn)))
|
||||||
|
(gudap-print-sent conn message)
|
||||||
(let* ((json-object-type 'plist)
|
(let* ((json-object-type 'plist)
|
||||||
(json (jsonrpc--json-encode message))
|
(json (jsonrpc--json-encode message))
|
||||||
(headers `(("Content-Length" . ,(format "%d" (string-bytes json)))))
|
(headers `(("Content-Length" . ,(format "%d" (string-bytes json)))))
|
||||||
(content (cl-loop for (header . value) in headers
|
(content (cl-loop for (header . value) in headers
|
||||||
concat (concat header ": " value "\r\n") into header-section
|
concat (concat header ": " value "\r\n") into header-section
|
||||||
finally return (format "%s\r\n%s" header-section json))))
|
finally return (format "%s\r\n%s" header-section json))))
|
||||||
(process-send-string (gudap--process conn) content))
|
(process-send-string (gudap-dap-process conn) content))
|
||||||
(setf (gudap--next-seq conn) (1+ (gudap--next-seq conn))))
|
(setf (gudap-seq conn) (1+ (gudap-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
|
;;;###autoload
|
||||||
(provide 'gudap)
|
(provide 'gudap)
|
||||||
|
|
Loading…
Add table
Reference in a new issue