Debugging working
This commit is contained in:
parent
df884561b6
commit
115587f60b
1 changed files with 261 additions and 49 deletions
310
gudap.el
310
gudap.el
|
|
@ -45,14 +45,21 @@
|
|||
(dap-process
|
||||
:initarg :dap-process
|
||||
:accessor gudap-dap-process)
|
||||
(expected-bytes
|
||||
:accessor gudap-expected-bytes)
|
||||
(gud-buffer
|
||||
:initarg :gud-buffer
|
||||
:accessor gudap-gud-buffer)
|
||||
(next-seq
|
||||
(events-buffer
|
||||
:initarg :events-buffer
|
||||
:accessor gudap-events-buffer)
|
||||
(launch-config
|
||||
:initarg :launch-config
|
||||
:accessor gudap-launch-config)
|
||||
(expected-bytes
|
||||
:initform nil
|
||||
:accessor gudap-expected-bytes)
|
||||
(seq
|
||||
:initform 1
|
||||
:accessor gudap-next-seq)
|
||||
:accessor gudap-seq)
|
||||
(initialized
|
||||
:initform nil
|
||||
:accessor gudap-initialized)
|
||||
|
|
@ -60,12 +67,17 @@
|
|||
:initform (make-hash-table :test 'equal)
|
||||
:accessor gudap-breakpoints)
|
||||
(capabilities
|
||||
:accessor gudap-capabilities)))
|
||||
:accessor gudap-capabilities)
|
||||
(callbacks
|
||||
:initform (make-hash-table :test 'equal)
|
||||
:accessor gudap-callbacks)))
|
||||
|
||||
(defvar gudap-server-programs-and-launch
|
||||
'(((elixir-mode elixir-ts-mode) . ("elixir-ls-debug"))
|
||||
(c++-mode . "lldb-vscode")))
|
||||
|
||||
'(((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 ()
|
||||
|
|
@ -74,55 +86,198 @@
|
|||
(+ (count-lines (point-min) (point))
|
||||
(if (bolp) 1 0))))
|
||||
|
||||
(defun gudap--source-breakpoint (&optional breakpoint)
|
||||
(if breakpoint
|
||||
(cl-destructuring-bind (&key line column &allow-other-keys) breakpoint
|
||||
(list :line line))
|
||||
(list :line (line-number-at-pos))))
|
||||
|
||||
(defun gudap--breakpoints-source-breakpoints (breakpoints)
|
||||
"Convert BREAKPOINTS to source breakpoints for setBreakpoints request."
|
||||
(mapcar 'gudap--source-breakpoint breakpoints))
|
||||
|
||||
(defun gudap--source (filepath)
|
||||
(list :path filepath))
|
||||
|
||||
(defun gudap--gud-run ()
|
||||
(interactive)
|
||||
(with-slots (initialized) gudap-active-server
|
||||
(if initialized
|
||||
(gudap-send-request
|
||||
gudap-active-server
|
||||
'configurationDone
|
||||
'()))))
|
||||
|
||||
(defun gudap--gud-cont ()
|
||||
(interactive)
|
||||
(let* ((server gudap-active-server)
|
||||
(initialized (gudap-initialized server)))
|
||||
(if initialized
|
||||
(gudap-send-request
|
||||
server
|
||||
'continue
|
||||
(list :threadId 58886)))))
|
||||
|
||||
|
||||
(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))))))
|
||||
(initialized (gudap-initialized server)))
|
||||
(if initialized
|
||||
(let* ((file-path (buffer-file-name))
|
||||
(old-breakpoints (gethash file-path (gudap-breakpoints server)))
|
||||
(source-breakpoints (vconcat (cons (gudap--source-breakpoint)
|
||||
(gudap--breakpoints-source-breakpoints old-breakpoints)))))
|
||||
(gudap-send-request
|
||||
server
|
||||
'setBreakpoints
|
||||
(list :source (gudap--dap-type-source file-path)
|
||||
:breakpoints source-breakpoints)))
|
||||
(gudap--message "Can't set breakpoints, debugger isn't initialized yet."))))
|
||||
|
||||
(defun gudap--dap-type-sourcebreak (line)
|
||||
(list :line line))
|
||||
(defun gudap--dap-type-source (file-path)
|
||||
(list :path file-path))
|
||||
|
||||
(defun gudap--dap-type-source (&optional path)
|
||||
(let ((path (or path
|
||||
(buffer-file-name))))
|
||||
(list :path path)))
|
||||
(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)
|
||||
|
||||
(defun gudap (server-command)
|
||||
(gudap--connect server-command)
|
||||
(defalias 'gud-break 'gudap--gud-break))
|
||||
(defalias 'gud-break 'gudap--gud-break)
|
||||
(defalias 'gud-cont 'gudap--gud-cont)
|
||||
(defalias 'gud-run 'gudap--gud-run)
|
||||
|
||||
(defun gudap--connect (server-command)
|
||||
(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))
|
||||
(gud-buffer (gud-common-init "cat"
|
||||
(lambda (_file args) args)
|
||||
#'identity))
|
||||
(dap-proc (make-process :name readable-name
|
||||
:buffer (generate-new-buffer 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)))
|
||||
: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))
|
||||
|
||||
(cl-defgeneric gudap-update-breakpoints (server breakpoints))
|
||||
|
||||
(cl-defmethod gudap-update-breakpoints (server breakpoints)
|
||||
"Breakpoints are assumed to belong to the same source"
|
||||
(if (length> breakpoints 0)
|
||||
(cl-loop for breakpoint across breakpoints
|
||||
with path = (plist-get (plist-get (aref breakpoints 0) :source) :path)
|
||||
with updated-breakpoints = '() do
|
||||
(cl-destructuring-bind (&key verified &allow-other-keys) breakpoint
|
||||
(if verified
|
||||
(push breakpoint updated-breakpoints)))
|
||||
finally
|
||||
(puthash path updated-breakpoints (gudap-breakpoints server)))))
|
||||
|
||||
;;; REQUESTS
|
||||
|
||||
(cl-defgeneric gudap-send-request (server command arguments))
|
||||
|
||||
(cl-defmethod gudap-send-request (server command arguments &optional extra)
|
||||
(cl-defmethod gudap-send-request (server command arguments &optional callback-fn)
|
||||
(if callback-fn
|
||||
(puthash (gudap-seq server) callback-fn (gudap-callbacks server)))
|
||||
(gudap--connection-send
|
||||
server
|
||||
(list :type "request"
|
||||
|
|
@ -130,17 +285,23 @@
|
|||
:arguments arguments)))
|
||||
|
||||
|
||||
|
||||
;;; RESPONSES
|
||||
|
||||
(cl-defgeneric gudap-handle-response (server command success body)
|
||||
"Handler for DAP response.")
|
||||
|
||||
(cl-defmethod gudap-handle-response (_server (_type (eql initialize)) _success _body)
|
||||
(gudap--message "initialized"))
|
||||
(cl-defmethod gudap-handle-response (server (_type (eql initialize)) _success _body)
|
||||
(gudap-send-request server 'launch (gudap-launch-config server)))
|
||||
|
||||
(cl-defmethod gudap-handle-response (server (type (eql setBreakpoints)) (success (eql t)) body))
|
||||
(cl-defmethod gudap-handle-response (server (type (eql setBreakpoints)) (success (eql t)) body)
|
||||
(gudap-update-breakpoints server (plist-get body :breakpoints)))
|
||||
|
||||
(cl-defmethod gudap-handle-response (server command success body)
|
||||
(gudap--message "unknown response: %s" body))
|
||||
|
||||
;;; EVENTS
|
||||
|
||||
(cl-defgeneric gudap-handle-event (server event body))
|
||||
|
||||
(cl-defmethod gudap-handle-event (server event body)
|
||||
|
|
@ -151,21 +312,68 @@
|
|||
(cl-destructuring-bind
|
||||
(&key category output group variablesReference source line column data)
|
||||
body
|
||||
(pcase category
|
||||
("console" (gud-filter gud-process output))))))
|
||||
(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))
|
||||
(defun gudap-gud-goto-frame-from-stack-trace (success stack-trace-body)
|
||||
(when success
|
||||
(let* ((top-frame (aref (plist-get stack-trace-body :stackFrames) 0))
|
||||
(path (plist-get (plist-get top-frame :source) :path))
|
||||
(line (plist-get top-frame :line)))
|
||||
(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
|
||||
(equal reason "breakpoint")
|
||||
(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-gud-output (server output))
|
||||
;;; 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-process (get-buffer-process (gudap-gud-buffer server))))
|
||||
(gud-filter gud-process (format "%s\n" output))))
|
||||
(gud-filter gud-process (format "%s\n" output))
|
||||
(gudap-gud-prompt server)))
|
||||
|
||||
(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))))
|
||||
;; send to dap server
|
||||
))
|
||||
|
||||
(defun gudap--initialize-arguments ()
|
||||
(list :clientId "gudap"
|
||||
|
|
@ -188,7 +396,7 @@
|
|||
(defun gudap--path (source)
|
||||
(plist-get source :path))
|
||||
|
||||
;; Utils
|
||||
;; Utils
|
||||
|
||||
(defun gudap--message (format &rest args)
|
||||
"Message out with FORMAT with ARGS."
|
||||
|
|
@ -199,7 +407,7 @@
|
|||
(defvar gudap--in-process-filter nil
|
||||
"Non-nil if inside `dap--process-filter'.")
|
||||
|
||||
;; taken from jsonrpc.el
|
||||
;; adapted from jsonrpc.el
|
||||
(cl-defun gudap--process-filter (proc string)
|
||||
"Called when new data STRING has arrived for PROC."
|
||||
(when gudap--in-process-filter
|
||||
|
|
@ -283,9 +491,13 @@
|
|||
(setf (gudap-expected-bytes server) expected-bytes))))))
|
||||
|
||||
(defun gudap--connection-receive (conn message)
|
||||
(gudap--message "received message: %s" message)
|
||||
(gudap-print-received conn message)
|
||||
(cl-destructuring-bind (&key seq request_seq type command event body arguments success &allow-other-keys) message
|
||||
(cond
|
||||
(;; callback present
|
||||
(gethash request_seq (gudap-callbacks conn))
|
||||
(funcall (gethash request_seq (gudap-callbacks conn)) success body)
|
||||
(remhash request_seq (gudap-callbacks conn)))
|
||||
(;; event
|
||||
(string-equal type "event")
|
||||
(gudap-handle-event conn (intern event) body))
|
||||
|
|
@ -297,8 +509,8 @@
|
|||
(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)
|
||||
(setq message (plist-put message :seq (gudap-seq conn)))
|
||||
(gudap-print-sent conn message)
|
||||
(let* ((json-object-type 'plist)
|
||||
(json (jsonrpc--json-encode message))
|
||||
(headers `(("Content-Length" . ,(format "%d" (string-bytes json)))))
|
||||
|
|
@ -306,7 +518,7 @@
|
|||
concat (concat header ": " value "\r\n") into header-section
|
||||
finally return (format "%s\r\n%s" header-section json))))
|
||||
(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))))
|
||||
|
||||
;;;###autoload
|
||||
(provide 'gudap)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue