diff --git a/gudap.el b/gudap.el index 736f153..9ad8aa0 100644 --- a/gudap.el +++ b/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)