gudap/gudap.el

620 lines
21 KiB
EmacsLisp
Raw Normal View History

2023-06-10 13:52:12 -04:00
;;; 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
2023-06-10 13:55:15 -04:00
;; 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/>.
2023-06-10 13:52:12 -04:00
;;; 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)
2023-09-04 15:44:45 -04:00
(require 'gud)
2023-06-10 13:52:12 -04:00
(defgroup gudap nil
"Interaction with Debug Adapter Protocol servers."
:prefix "gudap-"
:group 'applications)
2024-02-29 19:43:09 -05:00
(defclass gudap-server ()
2023-06-10 13:52:12 -04:00
((name
:initarg :name)
2024-02-29 19:43:09 -05:00
(dap-process
:initarg :dap-process
:accessor gudap-dap-process)
2023-09-04 15:44:45 -04:00
(gud-buffer
:initarg :gud-buffer
:accessor gudap-gud-buffer)
2024-06-06 13:48:47 -04:00
(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
2023-09-06 22:55:19 -04:00
:initform 1
2024-06-06 13:48:47 -04:00
:accessor gudap-seq)
2023-09-06 22:55:19 -04:00
(initialized
:initform nil
:accessor gudap-initialized)
2024-06-06 16:51:19 -04:00
(breakpoints
2023-09-06 22:55:19 -04:00
:initform (make-hash-table :test 'equal)
:accessor gudap-breakpoints)
(capabilities
2024-06-06 13:48:47 -04:00
:accessor gudap-capabilities)
(callbacks
:initform (make-hash-table :test 'equal)
2024-06-06 15:16:14 -04:00
:accessor gudap-callbacks)
(current-thread
:initform nil
:accessor gudap-current-thread)
(current-frame
:initform nil
2024-06-06 15:27:39 -04:00
:accessor gudap-current-frame)
(stopped
:initform t
:accessor gudap-stopped)))
2023-09-03 22:06:57 -04:00
2024-06-06 16:51:19 -04:00
(defclass breakpoint ()
((id
:initarg :id
:accessor gudap-bp-id)
(verified
:initarg :verified
:accessor gudap-bp-verified)
(source
:initarg :source
:accessor gudap-bp-source)
(line
:initarg :line
:accessor gudap-bp-line)))
(defclass source-breakpoint (breakpoint)
((condition
:initarg :condition
:initform nil
:accessor gudap-source-bp-condition)))
(cl-defmethod gudap-bp-update ((bp source-breakpoint) server-bp)
(cl-destructuring-bind (&key id verified source line &allow-other-keys) server-bp
(make-instance 'source-breakpoint
:id id
:verified verified
:source source
:line line
:condition (gudap-source-bp-condition bp))))
(cl-defmethod gudap-bp-params ((bp source-breakpoint))
(with-slots (line condition) bp
(list :line line
:condition condition)))
(defun gudap-bps-params (bps)
(mapcar 'gudap-bp-params bps))
2023-09-06 22:55:19 -04:00
(defvar gudap-server-programs-and-launch
2024-06-06 13:48:47 -04:00
'(((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? "))))))
2023-09-06 22:55:19 -04:00
(defvar gudap-active-server nil)
(defun gudap--buffer-line ()
(save-restriction
(widen)
(+ (count-lines (point-min) (point))
(if (bolp) 1 0))))
2024-06-06 15:16:14 -04:00
(defmacro gudap-with-initialized (server-var &rest body)
(declare (indent defun))
`(let* ((server ,server-var)
(initialized (gudap-initialized server)))
(if initialized
(progn ,@body))))
2024-06-18 17:16:10 -04:00
(defun gudap--gud-run (arg)
2024-06-06 15:16:14 -04:00
(gudap-with-initialized gudap-active-server
(gudap-send-request
gudap-active-server
'configurationDone
'())))
2024-06-06 13:48:47 -04:00
2024-06-18 17:16:10 -04:00
(defun gudap--gud-cont (arg)
2024-06-06 15:16:14 -04:00
(gudap-with-initialized gudap-active-server
(gudap-send-request
server
'continue
(list :threadId (gudap-current-thread server)))))
2024-06-06 13:48:47 -04:00
2024-06-06 16:51:19 -04:00
(defun gudap-update-breakpoints (server file-path bps server-bps)
(puthash file-path
(cl-loop for bp across bps
for server-bp across server-bps
collect (gudap-bp-update bp server-bp))
(gudap-breakpoints server)))
2024-06-06 13:48:47 -04:00
2024-06-18 17:16:10 -04:00
(defun gudap--gud-break (arg)
2024-06-06 15:16:14 -04:00
(gudap-with-initialized gudap-active-server
(let* ((file-path (buffer-file-name))
2024-06-06 16:51:19 -04:00
(current-bps (gethash file-path (gudap-breakpoints server)))
(new-bp (make-instance 'source-breakpoint
:line (line-number-at-pos)
2024-06-18 17:16:10 -04:00
:condition (if (> arg 1) (read-string "Expression: "))))
2024-06-06 16:51:19 -04:00
(bps (vconcat (cons new-bp current-bps))))
2024-06-06 15:16:14 -04:00
(gudap-send-request
server
'setBreakpoints
(list :source (gudap--dap-type-source file-path)
2024-06-06 16:51:19 -04:00
:breakpoints (vconcat (mapcar 'gudap-bp-params bps)))
(lambda (server success body)
(gudap-update-breakpoints server file-path bps (plist-get body :breakpoints)))))))
2024-06-18 17:16:10 -04:00
(defun gudap--gud-break-cond (arg)
2024-06-06 16:51:19 -04:00
(gudap--gud-break (read-string "Expression: ")))
2024-06-06 15:16:14 -04:00
2024-06-18 17:16:10 -04:00
(defun gudap--gud-remove (arg)
2024-06-06 15:16:14 -04:00
(gudap-with-initialized gudap-active-server
(let* ((file-path (buffer-file-name))
(line (line-number-at-pos))
2024-06-06 16:51:19 -04:00
(current-breakpoints (gethash file-path (gudap-breakpoints server))))
(if current-breakpoints
2024-06-06 15:16:14 -04:00
(let* ((filtered-breakpoints (seq-filter
2024-06-06 16:51:19 -04:00
(lambda (bp) (/= line (gudap-bp-line bp)))
current-breakpoints))
(source-breakpoints (vconcat (gudap-bps-params filtered-breakpoints))))
(if (= (length current-breakpoints) (length source-breakpoints))
2024-06-06 15:16:14 -04:00
(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)
2024-06-06 16:51:19 -04:00
:breakpoints source-breakpoints)
(lambda (server success body)
(gudap-update-breakpoints server file-path source-breakpoints (plist-get body :breakpoints))))))
2024-06-06 15:16:14 -04:00
(gudap--message "No breakpoints at location!")))))
2024-06-06 15:27:39 -04:00
2024-06-18 17:16:10 -04:00
(defun gudap--gud-next (arg)
2024-06-06 15:27:39 -04:00
(gudap-with-initialized gudap-active-server
(if (gudap-stopped server)
(gudap-send-request
server
'next
(list :threadId (gudap-current-thread server))))))
2024-06-18 17:16:10 -04:00
(defun gudap--gud-stepi (arg)
2024-06-06 15:27:39 -04:00
(gudap-with-initialized gudap-active-server
(if (gudap-stopped server)
(gudap-send-request
server
'stepIn
(list :threadId (gudap-current-thread server))))))
2024-06-06 15:16:14 -04:00
2024-06-06 13:48:47 -04:00
(defun gudap--dap-type-source (file-path)
(list :path file-path))
2024-06-18 17:16:10 -04:00
(defmacro def-gudap-cmd (gud-cmd gudap-fn key)
`(progn
(defalias ',gud-cmd (lambda (arg)
(interactive "p")
(,gudap-fn arg)))
,(if key `(local-set-key ,(concat "\C-c" key) #',gud-cmd))
,(if key `(define-key gud-global-map ,key #',gud-cmd))))
2024-06-06 13:48:47 -04:00
(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)
2024-06-18 17:16:10 -04:00
(def-gudap-cmd gud-break gudap--gud-break "\C-b")
(def-gudap-cmd gud-cont gudap--gud-cont "\C-r")
(def-gudap-cmd gud-run gudap--gud-run nil)
(def-gudap-cmd gud-remove gudap--gud-remove "\C-d")
(def-gudap-cmd gud-next gudap--gud-next "\C-n")
(def-gudap-cmd gud-stepi gudap--gud-stepi "\C-i")
2024-06-06 13:48:47 -04:00
(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)
2023-09-04 15:44:45 -04:00
(let* ((nickname server-command)
(readable-name (format "GUDAP (%s)" nickname))
(dap-proc (make-process :name readable-name
2024-06-06 13:48:47 -04:00
:buffer (get-buffer-create (format " *%s events*" readable-name))
2023-09-04 15:44:45 -04:00
:command (list server-command)
:filter 'gudap--process-filter
:noquery t
:connection-type 'pipe
:coding 'utf-8-emacs-unix))
2024-02-29 19:43:09 -05:00
(server (make-instance 'gudap-server
2024-06-06 13:48:47 -04:00
: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)))
2024-02-29 19:43:09 -05:00
(process-put dap-proc 'gudap-server server)
(setq gudap-active-server server)
(gudap-send-request server 'initialize (gudap--initialize-arguments))))
2023-09-04 15:44:45 -04:00
2024-06-06 13:48:47 -04:00
(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))
;;; REQUESTS
2023-09-03 22:06:57 -04:00
(cl-defgeneric gudap-send-request (server command arguments))
2024-06-06 13:48:47 -04:00
(cl-defmethod gudap-send-request (server command arguments &optional callback-fn)
(if callback-fn
(puthash (gudap-seq server) callback-fn (gudap-callbacks server)))
2023-09-03 22:06:57 -04:00
(gudap--connection-send
server
(list :type "request"
2023-09-06 22:55:19 -04:00
:command (symbol-name command)
:arguments arguments)))
2023-09-03 22:06:57 -04:00
2024-06-06 13:48:47 -04:00
;;; RESPONSES
2024-06-06 15:16:14 -04:00
(cl-defgeneric gudap-handle-response (server command success body err-msg)
2024-02-29 19:43:09 -05:00
"Handler for DAP response.")
2023-09-03 22:06:57 -04:00
2024-06-06 15:16:14 -04:00
(cl-defmethod gudap-handle-response (server (_type (eql initialize)) _success _body _err-msg)
2024-06-06 13:48:47 -04:00
(gudap-send-request server 'launch (gudap-launch-config server)))
2023-09-03 22:06:57 -04:00
2024-06-06 15:16:14 -04:00
(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))
2024-06-06 15:27:39 -04:00
(cl-defmethod gudap-handle-response (server (type (eql continue)) (success (eql t)) _body err-msg)
(setf (gudap-stopped server) nil))
2024-06-06 15:16:14 -04:00
(cl-defmethod gudap-handle-response (server command success body err-msg)
2023-09-06 22:55:19 -04:00
(gudap--message "unknown response: %s" body))
2024-06-06 13:48:47 -04:00
;;; EVENTS
2023-09-03 22:06:57 -04:00
(cl-defgeneric gudap-handle-event (server event body))
(cl-defmethod gudap-handle-event (server event body)
2023-09-06 22:55:19 -04:00
(gudap--message "%s" body))
2023-09-03 22:06:57 -04:00
2023-09-04 15:44:45 -04:00
(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
2024-06-06 15:16:14 -04:00
(gudap-gud-output server output))))
2023-09-04 15:44:45 -04:00
2023-09-06 22:55:19 -04:00
(cl-defmethod gudap-handle-event (server (event (eql initialized)) body)
(setf (gudap-initialized server) t))
2024-06-06 15:16:14 -04:00
(cl-defmethod gudap-handle-event (server (event (eql terminated)) body)
2024-06-06 15:27:39 -04:00
(setf (gudap-initialized server) nil
(gudap-stopped server) t))
2024-06-06 13:48:47 -04:00
2024-06-06 15:16:14 -04:00
(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)))
2024-06-06 13:48:47 -04:00
(cl-defmethod gudap-handle-event (server (event (eql stopped)) body)
(cl-destructuring-bind (&key reason threadId &allow-other-keys) body
(cond
( ;; breakpoint
2024-06-06 15:27:39 -04:00
(or (equal reason "breakpoint") (equal reason "step"))
(setf (gudap-current-thread server) threadId
(gudap-stopped server) t)
2024-06-06 13:48:47 -04:00
(gudap-send-request server
'stackTrace
(list :threadId threadId
:levels 1)
'gudap-gud-goto-frame-from-stack-trace)))))
;;; REVERSE REQUESTS
2023-09-06 22:55:19 -04:00
2023-09-03 22:06:57 -04:00
(cl-defgeneric gudap-handle-request (server command arguments))
2024-06-06 13:48:47 -04:00
;;; 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
2023-09-06 22:55:19 -04:00
(cl-defmethod gudap-gud-output (server output)
2024-06-06 15:16:14 -04:00
(let* ((gud-buffer (gudap-gud-buffer server))
(gud-process (get-buffer-process gud-buffer)))
(gud-filter gud-process (format "\n%s\n> " output))))
2024-06-06 13:48:47 -04:00
(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))))
2024-06-06 15:16:14 -04:00
(gudap-send-request server
'evaluate
(list :expression input
:frameId (gudap-current-frame server)
:context "repl"))))
2023-09-06 22:55:19 -04:00
2023-09-03 22:06:57 -04:00
(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))
2023-09-06 22:55:19 -04:00
(defun gudap--path (source)
(plist-get source :path))
2024-06-06 13:48:47 -04:00
;; Utils
2023-09-03 22:06:57 -04:00
(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
2023-06-10 13:52:12 -04:00
"Non-nil if inside `dap--process-filter'.")
2024-06-06 13:48:47 -04:00
;; adapted from jsonrpc.el
2023-09-03 22:06:57 -04:00
(cl-defun gudap--process-filter (proc string)
2023-06-10 13:52:12 -04:00
"Called when new data STRING has arrived for PROC."
2023-09-03 22:06:57 -04:00
(when gudap--in-process-filter
2023-06-10 13:52:12 -04:00
;; 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)
2023-09-03 22:06:57 -04:00
(run-at-time 0 nil #'gudap--process-filter proc string)
(cl-return-from gudap--process-filter))
2023-06-10 13:52:12 -04:00
(when (buffer-live-p (process-buffer proc))
(with-current-buffer (process-buffer proc)
2023-09-03 22:06:57 -04:00
(let* ((gudap--in-process-filter t)
2024-02-29 19:43:09 -05:00
(server (process-get proc 'gudap-server))
(expected-bytes (gudap-expected-bytes server)))
2023-06-10 13:52:12 -04:00
;; Insert the text, advancing the process marker.
;;
(save-excursion
(goto-char (process-mark proc))
2023-09-03 22:06:57 -04:00
(let ((inhibit-read-only t)) (insert string))
2023-06-10 13:52:12 -04:00
(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"
2024-02-29 19:41:22 -05:00
nil
2023-06-10 13:52:12 -04:00
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
2024-02-29 19:43:09 -05:00
(gudap--connection-receive server
2023-09-03 22:06:57 -04:00
json-message)))))
2023-06-10 13:52:12 -04:00
(goto-char message-end)
2023-09-03 22:06:57 -04:00
(let ((inhibit-read-only t))
(delete-region (point-min) (point)))
2023-06-10 13:52:12 -04:00
(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
;;
2024-02-29 19:43:09 -05:00
(setf (gudap-expected-bytes server) expected-bytes))))))
2023-09-03 22:06:57 -04:00
(defun gudap--connection-receive (conn message)
2024-06-06 13:48:47 -04:00
(gudap-print-received conn message)
2024-06-06 15:16:14 -04:00
(cl-destructuring-bind (&key seq request_seq type command event body arguments success message &allow-other-keys) message
2023-06-10 13:52:12 -04:00
(cond
2024-06-06 13:48:47 -04:00
(;; callback present
(gethash request_seq (gudap-callbacks conn))
2024-06-06 15:16:14 -04:00
(funcall (gethash request_seq (gudap-callbacks conn)) conn success body)
2024-06-06 13:48:47 -04:00
(remhash request_seq (gudap-callbacks conn)))
2023-06-10 13:52:12 -04:00
(;; event
2023-09-03 22:06:57 -04:00
(string-equal type "event")
(gudap-handle-event conn (intern event) body))
2023-06-10 13:52:12 -04:00
(;; response
2023-09-03 22:06:57 -04:00
(string-equal type "response")
2024-06-06 15:16:14 -04:00
(gudap-handle-response conn (intern command) success body message))
2023-09-03 22:06:57 -04:00
(;; reverse request
(string-equal type "request")
(gudap-handle-request conn (intern command) arguments)))))
(defun gudap--connection-send (conn message)
2024-06-06 13:48:47 -04:00
(setq message (plist-put message :seq (gudap-seq conn)))
(gudap-print-sent conn message)
2023-09-03 22:06:57 -04:00
(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))))
2024-02-29 19:43:09 -05:00
(process-send-string (gudap-dap-process conn) content))
2024-06-06 13:48:47 -04:00
(setf (gudap-seq conn) (1+ (gudap-seq conn))))
2023-09-03 22:06:57 -04:00
2023-06-10 13:52:12 -04:00
;;;###autoload
(provide 'gudap)
;;; gudap.el ends here