gudap/gudap.el

;;; gudap.el --- Debug Adapter Protocol client for Emacs -*- lexical-binding: t -*-

;; Author: Dominik Martinez <dominikmartinez@pm.me>
;; URL:
;; Version: 0.1.0
;; Package-Requires:
;; Keywords: languages, debug, dap

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or (at
;; your option) any later version.

;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; gudap.el is a Debug Adapter Protocol client for Emacs.
;;
;; To use, add the following to your init file:
;;
;;   (require 'gudap)
;;
;; Code ~heavily~ adapted from Eglot.

;;; Code:

(require 'jsonrpc)
(require 'gud)

(defgroup gudap nil
  "Interaction with Debug Adapter Protocol servers."
  :prefix "gudap-"
  :group 'applications)

(defclass gudap-server ()
  ((name
    :initarg :name)
   (dap-process
    :initarg :dap-process
    :accessor gudap-dap-process)
   (gud-buffer
    :initarg :gud-buffer
    :accessor gudap-gud-buffer)
   (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-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)
   (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)))

(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))))

(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))

(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 ()
  (interactive)
  (gudap-with-initialized gudap-active-server
    (gudap-send-request
     gudap-active-server
     'configurationDone
     '())))

(defun gudap--gud-cont ()
  (interactive)
  (gudap-with-initialized gudap-active-server
    (gudap-send-request
     server
     'continue
     (list :threadId (gudap-current-thread server)))))


(defun gudap--gud-break ()
  (interactive)
  (gudap-with-initialized gudap-active-server
    (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)))))

(defun gudap--gud-remove ()
  (interactive)
  (gudap-with-initialized gudap-active-server
    (let* ((file-path (buffer-file-name))
	   (line (line-number-at-pos))
	   (old-breakpoints (gethash file-path (gudap-breakpoints server))))
      (if old-breakpoints
	  (let* ((filtered-breakpoints (seq-filter
					(lambda (bp) (/= line (plist-get bp :line)))
					old-breakpoints))
		 (source-breakpoints (vconcat (gudap--breakpoints-source-breakpoints filtered-breakpoints))))
	    (if (= (length old-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))))
	(gudap--message "No breakpoints at location!")))))
	
(defun gudap--dap-type-source (file-path)
  (list :path file-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)

    (defalias 'gud-break 'gudap--gud-break)
    (defalias 'gud-cont 'gudap--gud-cont)
    (defalias 'gud-run 'gudap--gud-run)
    (defalias 'gud-remove 'gudap--gud-remove)

    (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))

(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 callback-fn)
  (if callback-fn
      (puthash (gudap-seq server) callback-fn (gudap-callbacks server)))
  (gudap--connection-send
   server
   (list :type "request"
	 :command (symbol-name command)
	 :arguments arguments)))



;;; RESPONSES

(cl-defgeneric gudap-handle-response (server command success body err-msg)
  "Handler for DAP response.")

(cl-defmethod gudap-handle-response (server (_type (eql initialize)) _success _body _err-msg)
  (gudap-send-request server 'launch (gudap-launch-config server)))

(cl-defmethod gudap-handle-response (server (type (eql setBreakpoints)) (success (eql t)) body _err-msg)
  (gudap-update-breakpoints server (plist-get body :breakpoints)))

(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 command success body err-msg)
  (gudap--message "unknown response: %s" body))

;;; EVENTS

(cl-defgeneric gudap-handle-event (server event body))

(cl-defmethod gudap-handle-event (server event body)
  (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))

(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
      (equal reason "breakpoint")
      (setf (gudap-current-thread server) threadId)
      (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))

;;; 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 ()
  (list :clientId "gudap"
	:clientName "gudap"
	:adapterId "gudap"
	:locale "en-US"
	:linesStartAt1 t
	:columnsStartAt1 t
	:pathFormat "path"
	:supportsVariableType nil
	:supportsVariablePaging nil
	:supportsRunInTerminalRequest nil
	:supportsMemoryReferences nil
	:supportsProgressReporting nil
	:supportsInvalidatedEvent nil
	:supportsMemoryEvent nil
	:supportsArgsCanBeInterpretedByShell nil
	:supportsStartDebuggingRequest nil))

(defun gudap--path (source)
  (plist-get source :path))

;; Utils

(defun gudap--message (format &rest args)
  "Message out with FORMAT with ARGS."
  (message "[gudap] %s" (apply #'format format args)))

;; JSONRPC-ish handling

(defvar gudap--in-process-filter nil
  "Non-nil if inside `dap--process-filter'.")

;; 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
    ;; Problematic recursive process filters may happen if
    ;; `dap--connection-receive', called by us, eventually calls
    ;; client code which calls `process-send-string' (which see) to,
    ;; say send a follow-up message.  If that happens to writes enough
    ;; bytes for pending output to be received, we will lose JSONRPC
    ;; messages.  In that case, remove recursiveness by re-scheduling
    ;; ourselves to run from within a timer as soon as possible
    ;; (bug#60088)
    (run-at-time 0 nil #'gudap--process-filter proc string)
    (cl-return-from gudap--process-filter))
  (when (buffer-live-p (process-buffer proc))
    (with-current-buffer (process-buffer proc)
      (let* ((gudap--in-process-filter t)
	     (server (process-get proc 'gudap-server))
             (expected-bytes (gudap-expected-bytes server)))
        ;; Insert the text, advancing the process marker.
        ;;
        (save-excursion
          (goto-char (process-mark proc))
          (let ((inhibit-read-only t)) (insert string))
          (set-marker (process-mark proc) (point)))
        ;; Loop (more than one message might have arrived)
        ;;
        (unwind-protect
            (let (done)
              (while (not done)
                (cond
                 ((not expected-bytes)
                  ;; Starting a new message
                  ;;
                  (setq expected-bytes
                        (and (search-forward-regexp
                              "\\(?:.*: .*\r\n\\)*Content-Length: \
*\\([[:digit:]]+\\)\r\n\\(?:.*: .*\r\n\\)*\r\n"
			      nil
                              t)
                             (string-to-number (match-string 1))))
                  (unless expected-bytes
                    (setq done :waiting-for-new-message)))
                 (t
                  ;; Attempt to complete a message body
                  ;;
                  (let ((available-bytes (- (position-bytes (process-mark proc))
                                            (position-bytes (point)))))
                    (cond
                     ((>= available-bytes
                          expected-bytes)
                      (let* ((message-end (byte-to-position
                                           (+ (position-bytes (point))
                                              expected-bytes))))
                        (unwind-protect
                            (save-restriction
                              (narrow-to-region (point) message-end)
                              (let* ((json-message
                                      (condition-case-unless-debug oops
                                          (jsonrpc--json-read)
                                        (error
                                         (jsonrpc--warn "Invalid JSON: %s %s"
                                                        (cdr oops) (buffer-string))
                                         nil))))
                                (when json-message
                                  ;; Process content in another
                                  ;; buffer, shielding proc buffer from
                                  ;; tamper
                                  (with-temp-buffer
                                    (gudap--connection-receive server
                                                               json-message)))))
                          (goto-char message-end)
			  (let ((inhibit-read-only t))
                            (delete-region (point-min) (point)))
                          (setq expected-bytes nil))))
                     (t
                      ;; Message is still incomplete
                      ;;
                      (setq done :waiting-for-more-bytes-in-this-message))))))))
          ;; Saved parsing state for next visit to this filter
          ;;
          (setf (gudap-expected-bytes server) expected-bytes))))))

(defun gudap--connection-receive (conn 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
     (;; 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
      (string-equal type "event")
      (gudap-handle-event conn (intern event) body))
     (;; response
      (string-equal type "response")
      (gudap-handle-response conn (intern command) success body message))
     (;; 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-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)))))
	 (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 (gudap-dap-process conn) content))
  (setf (gudap-seq conn) (1+ (gudap-seq conn))))

;;;###autoload
(provide 'gudap)

;;; gudap.el ends here