Working breakpoint with gud goto

This commit is contained in:
dominik martinez 2023-09-06 22:55:19 -04:00
parent d98cb8a910
commit 3449bdded6

137
gudap.el
View file

@ -48,30 +48,67 @@
:accessor gudap--process) :accessor gudap--process)
(-expected-bytes (-expected-bytes
:accessor gudap--expected-bytes) :accessor gudap--expected-bytes)
(-sent-requests
:initform (make-hash-table)
:accessor gudap--sent-requests) ;; seq to request command
(gud-buffer (gud-buffer
:initarg :gud-buffer :initarg :gud-buffer
:accessor gudap-gud-buffer) :accessor gudap-gud-buffer)
(next-seq (next-seq
:initform 0 :initform 1
:accessor gudap--next-seq))) :accessor gudap--next-seq)
(initialized
:initform nil
:accessor gudap-initialized)
(breakpoints ;; file path to list of plists (:line lineNum)
:initform (make-hash-table :test 'equal)
:accessor gudap-breakpoints)
(capabilities
:accessor gudap-capabilities)
(request-args ;; map of req_seq to list of request arguments
:initform (make-hash-table)
:accessor gudap-request-args)))
(defvar gudap-server-programs (defvar gudap-server-programs-and-launch
'(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug")) '(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug"))
(c++-mode . "lldb-vscode"))) (c++-mode . "lldb-vscode")))
(defvar gudap-active-server nil)
(defun gudap--buffer-line ()
(save-restriction
(widen)
(+ (count-lines (point-min) (point))
(if (bolp) 1 0))))
(defun gudap--gud-break ()
(interactive)
(let* ((server gudap-active-server)
(file-path (buffer-file-name))
(old-breakpoints (gethash file-path (gudap-breakpoints server)))
(new-breakpoints (cons (list :line (gudap--buffer-line)) old-breakpoints)))
(gudap-send-request
server
'setBreakpoints
(list :source (gudap--dap-type-source file-path)
:breakpoints (vconcat new-breakpoints)
:lines (vconcat (mapcar (lambda (bp) (plist-get bp :line)) new-breakpoints))))))
(defun gudap--dap-type-sourcebreak (line)
(list :line line))
(defun gudap--dap-type-source (&optional path)
(let ((path (or path
(buffer-file-name))))
(list :path path)))
(defun gudap (server-command) (defun gudap (server-command)
(gudap--connect server-command)) (gudap--connect server-command)
(defalias 'gud-break 'gudap--gud-break))
(defun gudap--connect (server-command) (defun gudap--connect (server-command)
(let* ((nickname server-command) (let* ((nickname server-command)
(readable-name (format "GUDAP (%s)" nickname)) (readable-name (format "GUDAP (%s)" nickname))
(gud-buffer (gud-common-init "cat" (gud-buffer (gud-common-init "cat"
(lambda (_file args) args) (lambda (_file args) args)
#'identity #'identity))
(lambda (m) (gudap--message "%s" m))))
(dap-proc (make-process :name readable-name (dap-proc (make-process :name readable-name
:buffer (generate-new-buffer readable-name) :buffer (generate-new-buffer readable-name)
:command (list server-command) :command (list server-command)
@ -83,30 +120,61 @@
:name readable-name :name readable-name
:process dap-proc :process dap-proc
:gud-buffer gud-buffer))) :gud-buffer gud-buffer)))
(process-put dap-proc 'gudap-connection conn))) (process-put dap-proc 'gudap-connection conn)
(setq gudap-active-server conn)
(gudap-send-request conn 'initialize (gudap--initialize-arguments))))
(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 extra)
(puthash (gudap--next-seq server) 'initialize (gudap--sent-requests server)) (puthash (gudap--next-seq server)
(append arguments extra)
(gudap-request-args 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))
(cl-defmethod gudap-handle-response (server type body) (cl-defgeneric gudap-handle-response (server command req-args success body))
(gudap--message "%s" body))
(cl-defmethod gudap-handle-response (server (type (eql initialize)) body) (cl-defmethod gudap-handle-response (server (type (eql initialize)) req-args success body)
(gudap--message "initialized")) (gudap--message "initialized"))
(cl-defmethod gudap-handle-response (server (type (eql setBreakpoints)) req-args (success (eql t)) body)
(let ((req-path (gudap--path (plist-get req-args :source)))
(req-breakpoints (plist-get req-args :breakpoints))
(res-breakpoints (plist-get body :breakpoints)))
(if (not (eql (length req-breakpoints) (length res-breakpoints)))
(gudap--message "mismatched breakpoints, ignoring")
(let ((valid-breakpoints (cl-loop for req-bp across req-breakpoints
for res-bp across res-breakpoints
for req-line = (plist-get req-bp :line)
for res-line = (plist-get res-bp :line)
if (plist-get res-bp :verified)
collect (list :line (or res-line req-line)))))
(puthash req-path valid-breakpoints (gudap-breakpoints server))))))
(cl-defmethod gudap-handle-response (server (type (eql stackTrace)) req-args (success (eql t)) body)
(if (plist-get req-args :show)
(cl-destructuring-bind (&key stackFrames &allow-other-keys) body
(if (length> stackFrames 0)
(let* ((cur-frame (aref stackFrames 0))
(path (gudap--path (plist-get cur-frame :source)))
(line (plist-get cur-frame :line)))
(if (> line 0)
(progn
(setq gud-last-frame (cons path line))
(gud-display-frame))))))))
(cl-defmethod gudap-handle-response (server command req-args success body)
(gudap--message "unknown response: %s" body))
(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) (cl-defmethod gudap-handle-event (server (event (eql output)) body)
(let ((gud-process (get-buffer-process (gudap-gud-buffer server)))) (let ((gud-process (get-buffer-process (gudap-gud-buffer server))))
@ -116,8 +184,24 @@
(pcase category (pcase category
("console" (gud-filter gud-process output)))))) ("console" (gud-filter gud-process output))))))
(cl-defmethod gudap-handle-event (server (event (eql initialized)) body)
(setf (gudap-initialized server) t))
(cl-defmethod gudap-handle-event (server (event (eql stopped)) body)
(cl-destructuring-bind (&key reason threadId &allow-other-keys) body
(pcase reason
("breakpoint"
(gudap-gud-output server (format "breakpoint hit"))
(gudap-send-request server 'stackTrace `(:threadId ,threadId) '(:show t))))))
(cl-defgeneric gudap-handle-request (server command arguments)) (cl-defgeneric gudap-handle-request (server command arguments))
(cl-defgeneric gudap-gud-output (server output))
(cl-defmethod gudap-gud-output (server output)
(let ((gud-process (get-buffer-process (gudap-gud-buffer server))))
(gud-filter gud-process (format "%s\n" output))))
(defun gudap--initialize-arguments () (defun gudap--initialize-arguments ()
(list :clientId "gudap" (list :clientId "gudap"
:clientName "gudap" :clientName "gudap"
@ -136,6 +220,9 @@
:supportsArgsCanBeInterpretedByShell nil :supportsArgsCanBeInterpretedByShell nil
:supportsStartDebuggingRequest nil)) :supportsStartDebuggingRequest nil))
(defun gudap--path (source)
(plist-get source :path))
;; Utils ;; Utils
(defun gudap--message (format &rest args) (defun gudap--message (format &rest args)
@ -230,24 +317,24 @@
(setf (gudap--expected-bytes connection) expected-bytes)))))) (setf (gudap--expected-bytes connection) 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--message "received message: %s" message)
(cl-destructuring-bind (&key seq request_seq type command event body arguments success &allow-other-keys) message
(cond (cond
(;; 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)))) (let ((request-args (gethash request_seq (gudap-request-args conn))))
(if request-type (gudap-handle-response conn (intern command) request-args success body)
(gudap-handle-response conn request-type body) (remhash request_seq (gudap-request-args conn))))
(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--next-seq conn)))
(gudap--message "sent message: %s" 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)))))