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)
(-expected-bytes
:accessor gudap--expected-bytes)
(-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)))
:initform 1
: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"))
(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)
(gudap--connect server-command))
(gudap--connect server-command)
(defalias 'gud-break 'gudap--gud-break))
(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))))
#'identity))
(dap-proc (make-process :name readable-name
:buffer (generate-new-buffer readable-name)
:command (list server-command)
@ -83,30 +120,61 @@
:name readable-name
:process dap-proc
: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-defmethod gudap-send-request (server (command (eql initialize)) arguments)
(puthash (gudap--next-seq server) 'initialize (gudap--sent-requests server))
(cl-defmethod gudap-send-request (server command arguments &optional extra)
(puthash (gudap--next-seq server)
(append arguments extra)
(gudap-request-args server))
(gudap--connection-send
server
(list :type "request"
:command "initialize"
:arguments (gudap--initialize-arguments))))
:command (symbol-name command)
:arguments arguments)))
(cl-defgeneric gudap-handle-response (server type body))
(cl-defmethod gudap-handle-response (server type body)
(gudap--message "%s" body))
(cl-defgeneric gudap-handle-response (server command req-args success 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"))
(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-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))))
@ -116,8 +184,24 @@
(pcase category
("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-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 ()
(list :clientId "gudap"
:clientName "gudap"
@ -136,6 +220,9 @@
:supportsArgsCanBeInterpretedByShell nil
:supportsStartDebuggingRequest nil))
(defun gudap--path (source)
(plist-get source :path))
;; Utils
(defun gudap--message (format &rest args)
@ -230,24 +317,24 @@
(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
(gudap--message "received message: %s" message)
(cl-destructuring-bind (&key seq request_seq type command event body arguments success &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)))
(let ((request-args (gethash request_seq (gudap-request-args conn))))
(gudap-handle-response conn (intern command) request-args success body)
(remhash request_seq (gudap-request-args 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)))
(gudap--message "sent message: %s" message)
(let* ((json-object-type 'plist)
(json (jsonrpc--json-encode message))
(headers `(("Content-Length" . ,(format "%d" (string-bytes json)))))