;;; dape.el --- Debug Adapter Protocol for Emacs -*- lexical-binding: t -*- ;; Copyright (C) 2023-2026 Free Software Foundation, Inc. ;; Author: Daniel Pettersson ;; Maintainer: Daniel Pettersson ;; Created: 2023 ;; License: GPL-3.0-or-later ;; Version: 0.26.0 ;; Homepage: https://github.com/svaante/dape ;; Package-Requires: ((emacs "29.1") (jsonrpc "1.0.25")) ;; This file is not part of GNU Emacs. ;; 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 . ;;; Commentary: ;; Dape is a debug adapter client for Emacs. The debug adapter ;; protocol, much like its more well-known counterpart, the language ;; server protocol, aims to establish a common API for programming ;; tools. However, instead of functionalities such as code ;; completions, it provides a standardized interface for debuggers. ;; To begin a debugging session, invoke the `dape' command. In the ;; minibuffer prompt, enter a debug adapter configuration name from ;; `dape-configs'. ;; For complete functionality, make sure to enable `eldoc-mode' in your ;; source buffers and `repeat-mode' for more pleasant key mappings. ;; Package looks is heavily inspired by gdb-mi.el ;;; Code: (require 'cl-lib) (require 'subr-x) (require 'seq) (require 'font-lock) (require 'pulse) (require 'comint) (require 'repeat) (require 'compile) (require 'project) (require 'gdb-mi) (require 'hexl) (require 'tramp) (require 'jsonrpc) ;;; Custom (defgroup dape nil "Debug Adapter Protocol for Emacs." :prefix "dape-" :group 'applications) (defcustom dape-adapter-dir (file-name-as-directory (concat user-emacs-directory "debug-adapters")) "Directory to store downloaded adapters in." :type 'string) (defcustom dape-configs `((attach modes nil ensure (lambda (config) (unless (plist-get config 'port) (user-error "Missing `port' property"))) host "localhost" :request "attach") (launch modes nil command-cwd dape-command-cwd ensure (lambda (config) (unless (plist-get config 'command) (user-error "Missing `command' property"))) :request "launch") ,(let* ((extension-directory (expand-file-name (file-name-concat dape-adapter-dir "bash-debug" "extension"))) (bashdb-dir (file-name-concat extension-directory "bashdb_dir"))) `(bash-debug modes (sh-mode bash-ts-mode) ensure (lambda (config) (dape-ensure-command config) (let ((dap-debug-server-path (car (plist-get config 'command-args)))) (unless (file-exists-p dap-debug-server-path) (user-error "File %S does not exist" dap-debug-server-path)))) command "node" command-args (,(file-name-concat extension-directory "out" "bashDebug.js")) fn (lambda (config) (thread-first config (plist-put :pathBashdbLib ,bashdb-dir) (plist-put :pathBashdb (file-name-concat ,bashdb-dir "bashdb")) (plist-put :env `(:BASHDB_HOME ,,bashdb-dir . ,(plist-get config :env))))) :type "bashdb" :cwd dape-cwd :program dape-buffer-default :args [] :pathBash "bash" :pathCat "cat" :pathMkfifo "mkfifo" :pathPkill "pkill")) (cpptools modes (c-mode c-ts-mode c++-mode c++-ts-mode) ensure dape-ensure-command command-cwd dape-command-cwd command ,(file-name-concat dape-adapter-dir "cpptools" "extension" "debugAdapters" "bin" "OpenDebugAD7") fn (lambda (config) ;; For MI=GDB the :program path need to be absolute (let ((program (plist-get config :program))) (if (file-name-absolute-p program) config (thread-last (tramp-file-local-name (dape--guess-root config)) (expand-file-name program) (plist-put config :program))))) :type "cppdbg" :request "launch" :cwd "." :program "a.out" :MIMode ,(seq-find 'executable-find '("lldb" "gdb"))) ,@(let ((debugpy `( modes (python-mode python-ts-mode) ensure (lambda (config) (dape-ensure-command config) (let ((python (dape-config-get config 'command))) (unless (zerop (process-file-shell-command (format "%s -c \"import debugpy.adapter\"" python))) (user-error "%s module debugpy is not installed" python)))) command "python" command-args ("-m" "debugpy.adapter" "--host" "0.0.0.0" "--port" :autoport) port :autoport :request "launch" :type "python" :cwd dape-cwd)) (common `( :args [] :justMyCode nil :console "integratedTerminal" :showReturnValue t :stopOnEntry nil))) `((debugpy ,@debugpy :program dape-buffer-default ,@common) (debugpy-module ,@debugpy :module (car (last (file-name-split (directory-file-name default-directory)))) ,@common))) (dlv modes (go-mode go-ts-mode) ensure dape-ensure-command command "dlv" command-args ("dap" "--listen" "127.0.0.1::autoport") command-cwd dape-command-cwd command-insert-stderr t port :autoport :request "launch" :type "go" :cwd "." :program ".") (flutter ensure dape-ensure-command modes (dart-mode) command "flutter" command-args ("debug_adapter") command-cwd dape-command-cwd :type "dart" :cwd "." :program "lib/main.dart" :toolArgs ["-d" "all"]) (gdb ensure (lambda (config) (dape-ensure-command config) (let* ((default-directory (or (dape-config-get config 'command-cwd) default-directory)) (command (dape-config-get config 'command)) (output (shell-command-to-string (format "%s --version" command))) (version (save-match-data (when (string-match "GNU gdb \\(?:(.*) \\)?\\([0-9.]+\\)" output) (string-to-number (match-string 1 output)))))) (unless (>= version 14.1) (user-error "Requires gdb version >= 14.1")))) modes (c-mode c-ts-mode c++-mode c++-ts-mode hare-mode hare-ts-mode) command-cwd dape-command-cwd command "gdb" command-args ("--interpreter=dap") :request "launch" :program "a.out" :args [] :stopAtBeginningOfMainSubprogram nil) ,@(let ((gdb-common `( ensure (lambda (config) (dape-ensure-command config) (let* ((default-directory (or (dape-config-get config 'command-cwd) default-directory)) (command (dape-config-get config 'command)) (output (shell-command-to-string (format "%s --version" command))) (version (save-match-data (when (string-match "GNU gdb \\(?:(.*) \\)?\\([0-9.]+\\)" output) (string-to-number (match-string 1 output)))))) (unless (>= version 14.1) (user-error "Requires gdb version >= 14.1")))) command "gdb" command-args ("--interpreter=dap") :request "launch" :stopAtBeginningOfMainSubprogram nil))) `((gdb-go-test ,@gdb-common modes (go-mode go-ts-mode) command-cwd (file-name-directory (buffer-file-name)) compile (format "go test -c -o %s -gcflags='all=-N -l'" (expand-file-name "__test.bin" temporary-file-directory)) ;; compile without optimizations :program (expand-file-name "__test.bin" temporary-file-directory) :args []) (gdb-go ,@gdb-common modes (go-mode go-ts-mode) command-cwd (file-name-directory (buffer-file-name)) compile (format "go build -o %s -gcflags='all=-N -l'" (expand-file-name "__binary.bin" temporary-file-directory)) ;; compile without optimizations :request "launch" :program (expand-file-name "__binary.bin" temporary-file-directory) :args []))) (godot modes (gdscript-mode) port 6006 :request "launch" :type "server") ,@(let ((js-debug `( ensure ,(lambda (config) (dape-ensure-command config) (when-let* ((runtime-executable (dape-config-get config :runtimeExecutable))) (dape--ensure-executable runtime-executable)) (let ((dap-debug-server-path (car (plist-get config 'command-args)))) (unless (file-exists-p dap-debug-server-path) (user-error "File %S does not exist" dap-debug-server-path)))) command "node" command-args (,(expand-file-name (file-name-concat dape-adapter-dir "js-debug" "src" "dapDebugServer.js")) :autoport) port :autoport))) `((js-debug-node modes (js-mode js-ts-mode) ,@js-debug :type "pwa-node" :cwd dape-cwd :program dape-buffer-default :console "internalConsole") (js-debug-ts-node modes (typescript-mode typescript-ts-mode) ,@js-debug :type "pwa-node" :runtimeExecutable "ts-node" :cwd dape-cwd :program dape-buffer-default :console "internalConsole") (js-debug-tsx modes (typescript-mode typescript-ts-mode) ,@js-debug :type "pwa-node" :runtimeExecutable "tsx" :cwd dape-cwd :program dape-buffer-default :console "internalConsole") (js-debug-node-attach modes (js-mode js-ts-mode typescript-mode typescript-ts-mode) ,@js-debug :type "pwa-node" :request "attach" :port 9229) (js-debug-chrome modes (js-mode js-ts-mode typescript-mode typescript-ts-mode) ,@js-debug :type "pwa-chrome" :url "http://localhost:3000" :webRoot dape-cwd))) ,@(let ((lldb-common `( modes ( c-mode c-ts-mode c++-mode c++-ts-mode rust-mode rust-ts-mode rustic-mode) ensure dape-ensure-command command-cwd dape-command-cwd :cwd "." :program "a.out"))) `((lldb-vscode command "lldb-vscode" :type "lldb-vscode" ,@lldb-common) (lldb-dap command "lldb-dap" :type "lldb-dap" ,@lldb-common))) (netcoredbg modes (csharp-mode csharp-ts-mode) ensure dape-ensure-command command "netcoredbg" command-args ["--interpreter=vscode"] :request "launch" :cwd dape-cwd :program (if-let* ((dlls (file-expand-wildcards (file-name-concat "bin" "Debug" "*" "*.dll")))) (file-relative-name (file-relative-name (car dlls))) ".dll") :stopAtEntry nil) (ocamlearlybird ensure dape-ensure-command modes (tuareg-mode caml-mode) command "ocamlearlybird" command-args ("debug") :type "ocaml" :program (file-name-concat (dape-cwd) "_build" "default" "bin" (concat (file-name-base (dape-buffer-default)) ".bc")) :console "internalConsole" :stopOnEntry nil :arguments []) (rdbg modes (ruby-mode ruby-ts-mode) ensure dape-ensure-command command "rdbg" command-args ("-O" "--host" "0.0.0.0" "--port" :autoport "-c" "--" :-c) fn (lambda (config) (plist-put config 'command-args (mapcar (lambda (arg) (if (eq arg :-c) (plist-get config '-c) arg)) (plist-get config 'command-args)))) port :autoport command-cwd dape-command-cwd :type "Ruby" ;; -- examples: ;; rails server ;; bundle exec ruby foo.rb ;; bundle exec rake test -c (concat "ruby " (dape-buffer-default))) (jdtls modes (java-mode java-ts-mode) ensure (lambda (config) (let ((file (dape-config-get config :filePath))) (unless (and (stringp file) (file-exists-p file)) (user-error "Unable to locate :filePath `%s'" file)) (with-current-buffer (find-file-noselect file) (unless (and (featurep 'eglot) (eglot-current-server)) (user-error "No eglot instance active in buffer %s" (current-buffer))) (unless (seq-contains-p (eglot--server-capable :executeCommandProvider :commands) "vscode.java.resolveClasspath") (user-error "Jdtls instance does not bundle java-debug-server, please install"))))) fn (lambda (config) (with-current-buffer (find-file-noselect (dape-config-get config :filePath)) (if-let* ((server (eglot-current-server))) (pcase-let ((`[,module-paths ,class-paths] (eglot-execute-command server "vscode.java.resolveClasspath" (vector (plist-get config :mainClass) (plist-get config :projectName)))) (port (eglot-execute-command server "vscode.java.startDebugSession" nil))) (thread-first config (plist-put 'port port) (plist-put :modulePaths module-paths) (plist-put :classPaths class-paths))) server))) ,@(cl-flet ((resolve-main-class (key) (ignore-errors (let* ((main-classes (with-no-warnings (eglot-execute-command (eglot-current-server) "vscode.java.resolveMainClass" (file-name-nondirectory (directory-file-name (dape-cwd)))))) (main-class (or (seq-find (lambda(val) (equal (plist-get val :filePath) (buffer-file-name))) main-classes) (aref main-classes 0)))) (plist-get main-class key))))) `(:filePath ,(lambda () (or (resolve-main-class :filePath) (expand-file-name (dape-buffer-default) (dape-cwd)))) :mainClass ,(lambda () (resolve-main-class :mainClass)) :projectName ,(lambda () (resolve-main-class :projectName)))) :args "" :stopOnEntry nil :type "java" :request "launch" :vmArgs " -XX:+ShowCodeDetailsInExceptionMessages" :console "integratedConsole" :internalConsoleOptions "neverOpen") (xdebug modes (php-mode php-ts-mode) ensure (lambda (config) (dape-ensure-command config) (let ((dap-debug-server-path (car (plist-get config 'command-args)))) (unless (file-exists-p dap-debug-server-path) (user-error "File %S does not exist" dap-debug-server-path)))) command "node" command-args (,(expand-file-name (file-name-concat dape-adapter-dir "php-debug" "extension" "out" "phpDebug.js"))) :type "php" :port 9003)) "This variable holds the dape configurations as an alist. In this alist, the car element serves as a symbol identifying each configuration. Each configuration, in turn, is a property list (plist) where keys can be symbols or keywords. Symbol keys (Used by dape): - fn: Function or list of functions, takes config and returns config. If list functions are applied in order. See `dape-default-config-functions'. - ensure: Function to ensure that adapter is available. - command: Shell command to initiate the debug adapter. - command-args: List of string arguments for the command. - command-cwd: Working directory for the command, if not supplied `default-directory' will be used. - command-env: Property list (plist) of environment variables to set when running the command. Keys can be strings, symbols or keywords. - command-insert-stderr: If non-nil treat stderr from adapter as stderr output from debugged program. - prefix-local: Path prefix for Emacs file access. - prefix-remote: Path prefix for debugger file access. - host: Host of the debug adapter. - port: Port of the debug adapter. - modes: List of modes where the configuration is active in `dape' completions. - compile: Executes a shell command with `dape-compile-function'. - defer-launch-attach: If launch/attach request should be sent after initialize or configurationDone. If nil launch/attach are sent after initialize request else it's sent after configurationDone. This key exist to accommodate the two different interpretations of the DAP specification. See: GDB bug 32090. Note: The char - carries special meaning when reading options in `dape' and therefore should not be used be used as an key. See `dape-history-add'. Connection to Debug Adapter: - If command is specified and not port, dape communicates with the debug adapter through stdin/stdout. - If host and port are specified, dape connects to the debug adapter. If command is specified, dape waits until the command initializes before connecting to host and port. Keywords in configuration: Keywords (symbols starting with colon) are transmitted to the adapter during the initialize and launch/attach requests. Refer to `json-serialize' for detailed information on how dape serializes these keyword elements. Dape uses nil as false. Functions and symbols: - If a value is a function, its return value replaces the key's value before execution. The function is called with no arguments. - If a value is a symbol, it resolves recursively before execution." :type '(alist :key-type (symbol :tag "Name") :value-type (plist :options (((const :tag "List of modes where config is active in `dape' completions" modes) (repeat function)) ((const :tag "Ensures adapter availability" ensure) function) ((const :tag "Transforms configuration at runtime" fn) (choice function (repeat function))) ((const :tag "Shell command to initiate the debug adapter" command) (choice string symbol)) ((const :tag "List of string arguments for command" command-args) (repeat string)) ((const :tag "List of environment variables to set when running the command" command-env) (plist :key-type (restricted-sexp :match-alternatives (stringp symbolp keywordp) :tag "Variable") :value-type (string :tag "Value"))) ((const :tag "Treat stderr from adapter as program output" command-insert-stderr) boolean) ((const :tag "Working directory for command" command-cwd) (choice string symbol)) ((const :tag "Path prefix for Emacs file access" prefix-local) string) ((const :tag "Path prefix for debugger file access" prefix-remote) string) ((const :tag "Host of debug adapter" host) string) ((const :tag "Port of debug adapter" port) natnum) ((const :tag "Compile cmd" compile) string) ((const :tag "Use configurationDone as trigger for launch/attach" defer-launch-attach) boolean) ((const :tag "Adapter type" :type) string) ((const :tag "Request type launch/attach" :request) string))))) (defcustom dape-default-config-functions '(dape-config-autoport dape-config-tramp) "Functions applied on config before starting debugging session. Each function is called with one argument CONFIG and should return an PLIST of the format specified in `dape-configs'. Functions are evaluated after functions defined in fn symbol in `dape-configs'. See fn in `dape-configs' function signature." :type '(repeat function)) (defcustom dape-command nil "Initial contents for `dape' completion. Sometimes it is useful for files or directories to supply local values for this variable. Example value: \(launch :program \"a.out\")" :type 'sexp) ;;;###autoload(put 'dape-command 'safe-local-variable #'listp) (defcustom dape-key-prefix "\C-x\C-a" "Prefix of all dape commands." :type 'key-sequence) (define-obsolete-variable-alias 'dape-buffer-window-arrangment 'dape-buffer-window-arrangement "0.3.0") (defcustom dape-buffer-window-arrangement 'left "How to generally display buffers. For additional configuration of which mode buffers are placed in which windows, see `dape-info-buffer-window-groups'. If further customization is needed, use `display-buffer-alist'. Note that each buffer is displayed with `display-buffer' action ALIST entry `category' as `dape-info-' + group index, which can be used with `display-buffer-alist' for group-based actions. See `dape--display-buffer' for additional details." :type '(choice (const :tag "GUD gdb like" gud) (const :tag "Left side" left) (const :tag "Right side" right) (const :tag "Use `display-buffer-base-action'" nil))) (defcustom dape-variable-auto-expand-alist '((hover . 1) (repl . 0) (watch . 1)) "Default expansion depth for displaying variables. Each entry consists of a context (such as `hover', `repl', or `watch') paired with a number indicating how many levels deep the variable should be expanded by default." :type '(alist :key-type (choice (natnum :tag "Scope number (Locals 0 etc.)") (const :tag "Eldoc hover" hover) (const :tag "In REPL buffer" repl) (const :tag "In watch buffer" watch) (const :tag "All contexts" nil)) :value-type (natnum :tag "Levels expanded"))) (defcustom dape-stepping-granularity 'line "The granularity of one step in the stepping requests." :type '(choice (const :tag "Step statement" statement) (const :tag "Step line" line) (const :tag "Step instruction" instruction))) (defcustom dape-stack-trace-levels 20 "The number of stack frames fetched." :type 'natnum) (defcustom dape-display-source-buffer-action `((display-buffer-reuse-window display-buffer-same-window display-buffer-use-some-window)) "`display-buffer' action used when displaying source buffer." :type 'sexp) (define-obsolete-variable-alias 'dape-on-start-hooks 'dape-start-hook "0.13.0") (defcustom dape-start-hook '(dape-repl dape-info) "Called when session starts." :type 'hook) (define-obsolete-variable-alias 'dape-on-stopped-hooks 'dape-stopped-hook "0.13.0") (defcustom dape-stopped-hook '( dape-memory-revert dape-disassemble-revert dape--emacs-grab-focus) "Called when session stopped." :type 'hook) (define-obsolete-variable-alias 'dape-update-ui-hooks 'dape-update-ui-hook "0.13.0") (defcustom dape-update-ui-hook '(dape-info-update) "Called when it's sensible to refresh UI." :type 'hook) (defcustom dape-display-source-hook '() "Called in buffer when placing overlay arrow for stack frame." :type 'hook) (defcustom dape-mime-mode-alist '(("text/x-lldb.disassembly" . asm-mode) ("text/javascript" . js-mode)) "Alist of MIME types vs corresponding major mode functions. Each element should look like (MIME-TYPE . MODE) where MIME-TYPE is a string and MODE is the major mode function to use for buffers of this MIME type." :type '(alist :key-type string :value-type function)) (define-obsolete-variable-alias 'dape-read-memory-default-count 'dape-memory-page-size "0.8.0") (defcustom dape-memory-page-size 1024 "The bytes read with `dape-memory'." :type 'natnum) (defcustom dape-info-buffer-window-groups '((dape-info-scope-mode dape-info-watch-mode) (dape-info-stack-mode dape-info-modules-mode dape-info-sources-mode) (dape-info-breakpoints-mode dape-info-threads-mode)) "Window grouping rules for `dape-info' buffers. Each list of MODEs is displayed in the same window. The first item of each group is displayed by `dape-info'. MODE can also be \(`dape-info-scope-mode' INDEX), displaying scope at INDEX. All modes need not to be present in an group." :type '(repeat (repeat (choice (function :tag "Info mode") (list :tag "Scope index" (const dape-info-scope-mode) (natnum :tag "Index")))))) (defcustom dape-info-hide-mode-line (and (memql dape-buffer-window-arrangement '(left right)) t) "Hide mode line in dape info buffers." :type 'boolean) (defcustom dape-info-variable-table-aligned nil "Align columns in variable tables." :type 'boolean) (defcustom dape-info-variable-table-row-config `((name . 0) (value . 0) (type . 0)) "Configuration for table rows of variables. An ALIST that controls the display of the name, type and value of variables. The key controls which column to change whereas the value determines the maximum number of characters to display in each column. A value of 0 means there is no limit. Additionally, the order the element in the ALIST determines the left-to-right display order of the properties." :type '(alist :key-type (choice (const :tag "Name" name) (const :tag "Value" value) (const :tag "Type" type)) :value-type (choice (const :tag "Full" 0) (natnum :tag "Width")))) (defcustom dape-info-thread-buffer-locations t "Show file information or library names in threads buffer." :type 'boolean) (defcustom dape-info-thread-buffer-addresses nil "Show addresses for thread frames in threads buffer." :type 'boolean) (defcustom dape-info-stack-buffer-locations t "Show file information or library names in stack buffer." :type 'boolean) (defcustom dape-info-stack-buffer-modules nil "Show module information in stack buffer if adapter supports it." :type 'boolean) (defcustom dape-info-stack-buffer-addresses t "Show frame addresses in stack buffer." :type 'boolean) (defcustom dape-info-file-name-max 25 "Max length of file name in dape info buffers." :type 'integer) (defcustom dape-inlay-hints t "Inlay variable hints." :type '(choice (const :tag "No inlay hints." nil) (const :tag "Inlay current line and previous line (same as 2)." t) (natnum :tag "Number of lines with hints."))) (defcustom dape-inlay-hints-variable-name-max 25 "Max length of variable name in inlay hints." :type 'integer) (defcustom dape-repl-echo-shell-output nil "Echo dape shell output in REPL." :type 'boolean) (defcustom dape-repl-use-shorthand t "Dape `dape-repl-commands' can be invoked with first char of command." :type 'boolean) (defcustom dape-repl-commands '(("debug" . dape) ("next" . dape-next) ("continue" . dape-continue) ("pause" . dape-pause) ("step" . dape-step-in) ("out" . dape-step-out) ("up" . dape-stack-select-up) ("down" . dape-stack-select-down) ("threads" . dape-repl-threads) ("stack" . dape-repl-stack) ("modules" . dape-repl-modules) ("sources" . dape-repl-sources) ("breakpoints" . dape-repl-breakpoints) ("scope" . dape-repl-scope) ("watch" . dape-repl-watch) ("eval" . dape-repl-eval) ("restart" . dape-restart) ("kill" . dape-kill) ("disconnect" . dape-disconnect-quit) ("quit" . dape-quit)) "Commands available in REPL buffer." :type '(alist :key-type string :value-type function)) (defcustom dape-breakpoint-margin-string "B" "String to display breakpoint in margin." :type 'string) (defcustom dape-default-breakpoints-file (locate-user-emacs-file "dape-breakpoints") "Default file for loading and saving breakpoints. See `dape-breakpoint-load' and `dape-breakpoint-save'." :type 'file) (define-obsolete-variable-alias 'dape-compile-fn 'dape-compile-function "0.21.0") (defcustom dape-compile-function #'compile "Function to compile with. The function is called with a command string." :type 'function) (define-obsolete-variable-alias 'dape-cwd-fn 'dape-cwd-function "0.21.0") (defcustom dape-cwd-function #'dape--default-cwd "Function to get current working directory. The function should return a string representing the absolute file path of the current working directory, usually the current project's root. See `dape--default-cwd'." :type 'function) (define-obsolete-variable-alias 'dape-compile-compile-hooks 'dape-compile-hook "0.13.0") (defcustom dape-compile-hook nil "Called after dape compilation finishes. The hook is run with one argument, the compilation buffer when compilation is successful." :type 'hook) (defcustom dape-minibuffer-hint t "Show `dape-configs' hints in minibuffer." :type 'boolean) (defcustom dape-read-config-hook nil "Called before `dape-configs' is evaluated into completion candidates." :type 'hook) (defcustom dape-minibuffer-hint-ignore-properties '( ensure fn modes command command-args command-env command-insert-stderr defer-launch-attach :type :request) "Properties to be ignored in minibuffer \"Run adapter\" hints. See `dape-minibuffer-hint'." :type '(repeat symbol)) (defcustom dape-history-add 'input "How to push configuration options onto `dape-history'. - input: Store input as it is read from the minibuffer. - expanded: Each key in the input is evaluated, and only options that differ from the base configuration in `dape-configs' are stored. - shell-like: Like expanded, but stores options in a shell-like format. Characters after - are interpreted in a shell-style format, with ENV, PROGRAM, and ARGS. Useful for adapters that accept :env, :program, and :args as launch options. Example: \"launch - ENV=value program arg1 arg2\"." :type '(choice (const :tag "Input" input) (const :tag "After evaluation of each key" expanded) (const :tag "Shell like with - separator" shell-like))) (defcustom dape-ui-debounce-time 0.1 "Number of seconds to debounce `revert-buffer' for UI buffers." :type 'float) (defcustom dape-request-timeout jsonrpc-default-request-timeout "Number of seconds until a request is deemed to be timed out." :type 'natnum) (defcustom dape-debug nil "If non-nil add debug info in REPL and events buffer. Debug logging has an noticeable effect on performance." :type 'boolean) ;;; Face (defface dape-breakpoint-face '((t :inherit font-lock-keyword-face)) "Face used to display breakpoint overlays.") (defface dape-breakpoint-until-face '((t :inherit font-lock-doc-face)) "Face used to display until breakpoint overlays.") (defface dape-log-face '((t :inherit dape-breakpoint-face :height 0.85 :box (:line-width -1))) "Face used to display log breakpoints.") (defface dape-expression-face '((t :inherit dape-breakpoint-face :height 0.85 :box (:line-width -1))) "Face used to display conditional breakpoints.") (defface dape-hits-face '((t :inherit dape-breakpoint-face :height 0.85 :box (:line-width -1))) "Face used to display hits breakpoints.") (defface dape-exception-description-face '((t :inherit (error tooltip) :extend t :stipple nil)) "Face used to display exception descriptions inline.") (defface dape-source-line-face '((t)) "Face used to display stack frame source line overlays.") (defface dape-repl-error-face '((t :inherit compilation-mode-line-fail :extend t)) "Face used in REPL for non 0 exit codes.") (defface dape-header-line-active-face '((t :inherit mode-line)) "Face for active Dape header tabs.") (defface dape-header-line-inactive-face '((t :inherit mode-line-inactive)) "Face for inactive Dape header tabs.") (defface dape-header-line-hover-face '((t :inherit mode-line-highlight)) "Face for hovered Dape header tabs.") ;;; Forward declarations (defvar hl-line-mode) (defvar hl-line-sticky-flag) (declare-function global-hl-line-highlight "hl-line" ()) (declare-function hl-line-highlight "hl-line" ()) ;;; Vars (defvar dape-history nil "History variable for `dape'.") (defvar dape--breakpoints nil "List of `dape--breakpoint' objects (source, data, and exception).") (defvar dape--watched nil "List of watched expressions.") (defvar dape--connections nil "List of active root debug adapter connections.") (defvar dape--connection-counter 0 "Monotonically increasing counter for unique connection names.") (defvar dape--connection-selected nil "Selected debug adapter connection. If valid connection, this connection will be of highest priority when querying for connections with `dape--live-connection'.") (define-minor-mode dape-active-mode "On when dape debugging session is active. Non interactive global minor mode." :global t :interactive nil) ;;; Utils (defun dape--warn (format &rest args) "Display warning/error message with FORMAT and ARGS." (dape--repl-insert-error (format "* %s *\n" (apply #'format format args)))) (defun dape--message (format &rest args) "Display message with FORMAT and ARGS." (dape--repl-insert (format "* %s *\n" (apply #'format format args)))) (defmacro dape--with-request-bind (vars fn-args &rest body) "Call FN with ARGS and execute BODY on callback with VARS bound. VARS are bound from the arguments that the callback is invoked with. FN-ARGS is a list of (FN . ARGS). FN is called with ARGS followed by a callback function. BODY is evaluated in the buffer that was active when this macro was invoked. If that buffer is no longer live, BODY is evaluated in the buffer current at callback execution time. See `cl-destructuring-bind' for details on valid bind forms for VARS." (declare (indent 2)) (let ((old-buffer (make-symbol "old-buffer"))) `(let ((,old-buffer (current-buffer))) (,(car fn-args) ,@(cdr fn-args) (cl-function (lambda ,vars (with-current-buffer (if (buffer-live-p ,old-buffer) ,old-buffer (current-buffer)) ,@body))))))) (defmacro dape--with-request (fn-args &rest body) "Call `dape-request' like FN with ARGS and execute BODY on callback. FN-ARGS is be an cons pair as FN . ARGS. BODY is guaranteed to be evaluated with the current buffer if live. See `cl-destructuring-bind' for bind forms." (declare (indent 1)) `(dape--with-request-bind (&rest _) ,fn-args ,@body)) (defun dape--request-continue (cb &optional error) "Shorthand to call CB with ERROR in an `dape-request' like way." (when (functionp cb) (funcall cb nil error))) (defun dape--call-with-debounce (timer backoff fn) "Call FN with a debounce of BACKOFF seconds. This function utilizes TIMER to store state. It cancels the TIMER and schedules FN to run after current time + BACKOFF seconds. If BACKOFF is non-zero, FN will be evaluated within timer context." (cond ((zerop backoff) (cancel-timer timer) (funcall fn)) (t (cancel-timer timer) (timer-set-time timer (timer-relative-time nil backoff)) (timer-set-function timer fn) (timer-activate timer)))) (defmacro dape--with-debounce (timer backoff &rest body) "Eval BODY forms with a debounce of BACKOFF seconds using TIMER. Helper macro for `dape--call-with-debounce'." (declare (indent 2)) `(dape--call-with-debounce ,timer ,backoff (lambda () ,@body))) (defmacro dape--with-line (buffer line &rest body) "Save point and buffer then execute BODY on LINE in BUFFER." (declare (indent 2)) `(with-current-buffer ,buffer (save-excursion (goto-char (point-min)) (forward-line (1- ,line)) ,@body))) (defun dape--next-like-command (conn command) "Helper for interactive step like commands. Run step like COMMAND on CONN. If ARG is set run COMMAND ARG times." (if (not (dape--stopped-threads conn)) (user-error "No stopped threads") (dape--with-request-bind (_body error) (dape-request conn command `(,@(dape--thread-id-object conn) ,@(when (dape--capable-p conn :supportsSteppingGranularity) (list :granularity (symbol-name dape-stepping-granularity))))) (if error (message "Failed to \"%s\": %s" command error) ;; From specification [continued] event: ;; A debug adapter is not expected to send this event in ;; response to a request that implies that execution ;; continues, e.g. launch or continue. (dape-handle-event conn 'continued nil))))) (defun dape--maybe-select-thread (conn thread-id &optional force) "Maybe set selected THREAD-ID and CONN. If FORCE is non-nil, force selection of the thread. If the thread is selected, also select CONN if no connection has been selected yet, or if the currently selected connection has no stopped threads. See `dape--connection-selected'." (when (and thread-id (or force (not (dape--thread-id conn)))) (setf (dape--thread-id conn) thread-id) ;; Update selected connection if the current one is not live or ;; has no stopped threads. (unless (and (member dape--connection-selected (dape--live-connections)) (dape--stopped-threads dape--connection-selected)) (setq dape--connection-selected conn)))) (defun dape--threads-make-update-handle (conn) "Return an threads update update handle for CONN. See `dape--threads-set-status'." (setf (dape--threads-update-handle conn) (1+ (dape--threads-update-handle conn)))) (defun dape--threads-set-status ( conn thread-id all-threads status &optional update-handle) "Set string STATUS thread(s) for CONN. If THREAD-ID is non-nil set status for thread with :id equal to THREAD-ID to STATUS. If ALL-THREADS is non-nil set status of all all threads to STATUS. Ignore status update if UPDATE-HANDLE is not the last handle created by `dape--threads-make-update-handle'." (unless update-handle (setq update-handle (dape--threads-make-update-handle conn))) (when (> update-handle (dape--threads-last-update-handle conn)) (setf (dape--threads-last-update-handle conn) update-handle) (let* ((threads (dape--threads conn)) (thread (cl-find thread-id threads :key (lambda (th) (plist-get th :id))))) (unless thread (setf (dape--threads conn) (nconc threads `(( :id ,thread-id :name ,(format "thread-%s" thread-id) :status ,status))))) (cond (;; Set status on all threads all-threads (cl-loop for th in threads do (plist-put th :status status))) (;; Set status only on specified thread thread (plist-put thread :status status)))))) (defun dape--thread-id-object (conn) "Construct a thread id object for CONN." (when-let* ((thread-id (dape--thread-id conn))) (list :threadId thread-id))) (defun dape--stopped-threads (conn) "List of stopped threads for CONN." (when conn (mapcan (lambda (thread) (when (equal (plist-get thread :status) 'stopped) (list thread))) (dape--threads conn)))) (defun dape--current-thread (conn) "Current thread plist for CONN." (when conn (cl-find-if (lambda (thread) (eq (plist-get thread :id) (dape--thread-id conn))) (dape--threads conn)))) (defun dape--file-name-1 (conn filename remote-p) "Return FILENAME path with prefix substitution applied. The substitution is configured by CONN or last known connection. If REMOTE-P is non-nil, translate from local to adapter format. Otherwise, translate from adapter to local format. See `dape-configs' symbols prefix-local prefix-remote." (if-let* ((config (dape--config (or conn (dape--live-connection 'last t)))) (;; Skip if no prefixes configured (or (plist-member config 'prefix-local) (plist-member config 'prefix-remote))) (;; Is set in `dape--launch-or-attach' command-cwd (plist-get config 'command-cwd)) (expanded-file (expand-file-name filename (if remote-p (tramp-file-local-name command-cwd) command-cwd))) (prefix-local (or (plist-get config 'prefix-local) "")) (prefix-remote (or (plist-get config 'prefix-remote) "")) (from-prefix (if remote-p prefix-local prefix-remote)) (to-prefix (if remote-p prefix-remote prefix-local)) (;; Substitute if there is a match or `from-prefix' is "" (string-prefix-p from-prefix expanded-file))) (concat to-prefix (string-remove-prefix from-prefix expanded-file)) filename)) (defun dape--file-name-local (conn filename) "Return FILENAME string for `find-file' configured by CONN. See `dape--file-name-1'." (dape--file-name-1 conn filename nil)) (defun dape--file-name-remote (conn filename) "Return FILENAME string for adapter configured by CONN. See `dape--file-name-1'." (dape--file-name-1 conn filename 'remote)) (defun dape--capable-p (conn thing) "Return non-nil if CONN capable of THING." (eq (plist-get (dape--capabilities conn) thing) t)) (defun dape--current-stack-frame (conn) "Current stack frame plist for CONN." (let ((stack-frames (plist-get (dape--current-thread conn) :stackFrames))) (or (when conn (cl-find (dape--stack-id conn) stack-frames :key (lambda (frame) (plist-get frame :id)))) (car stack-frames)))) (defun dape--object-to-marker (conn plist) "Return marker created from PLIST and CONN config. Marker is created from PLIST keys :source and :line. Note requires `dape--source-ensure' if source is by reference." (when-let* ((source (plist-get plist :source)) (line (or (plist-get plist :line) 1)) (buffer (or ;; Take buffer by source reference (when-let* ((reference (plist-get source :sourceReference)) (buffer (plist-get (dape--source-buffers (dape--root-of conn)) reference)) ((buffer-live-p buffer))) buffer) ;; Take buffer by path (when-let* ((remote-path (plist-get source :path)) (filename (dape--file-name-local conn remote-path)) ((file-exists-p filename))) (find-file-noselect filename t))))) (dape--with-line buffer line (when-let* ((column (plist-get plist :column))) (when (> column 0) (forward-char (1- column)))) (point-marker)))) (defvar-local dape--original-margin nil "Bookkeeping for buffer margin width.") (defun dape--indicator (string bitmap face) "Return indicator string in margin (STRING) or fringe (BITMAP). The indicator is `propertize'd with with FACE." (if (and (window-system) (not (eql (frame-parameter (selected-frame) 'left-fringe) 0))) (propertize " " 'display `(left-fringe ,bitmap ,face)) (setq-local dape--original-margin (or dape--original-margin left-margin-width) left-margin-width 2) (when-let* ((window (get-buffer-window (current-buffer)))) (set-window-margins window left-margin-width)) (propertize " " 'display `((margin left-margin) ,(propertize string 'face face))))) (defun dape--default-cwd () "Try to guess current project absolute file path with `project'." (or (when-let* ((project (project-current))) (expand-file-name (project-root project))) default-directory)) (defun dape-cwd () "Use `dape-cwd-function' to guess current working as local path." (tramp-file-local-name (funcall dape-cwd-function))) (defun dape-command-cwd () "Use `dape-cwd-function' to guess current working directory." (funcall dape-cwd-function)) (defun dape-buffer-default () "Return current buffers file name." (unless (buffer-file-name) (user-error "No buffer file name")) (tramp-file-local-name (file-relative-name (buffer-file-name) (dape-command-cwd)))) (defun dape--guess-root (config) "Return best guess root path from CONFIG." (or (dape-config-get config 'command-cwd) default-directory)) (defun dape-config-autoport (config) "Handle :autoport in CONFIG keys `port', `command-args', and `command-env'. If `port' is the symbol `:autoport', replace it with a random free port number. In addition, replace all occurences of `:autoport' (symbol or string) in `command-args' and all property values of `command-env' with the value of config key `port'." (when (eq (plist-get config 'port) :autoport) ;; Stolen from `Eglot' (let ((port-probe (make-network-process :name "dape-port-probe-dummy" :server t :host "localhost" :service 0))) (plist-put config 'port (unwind-protect (process-contact port-probe :service) (delete-process port-probe))))) (when-let* ((port (plist-get config 'port)) (port-string (number-to-string port)) (replace-fn (lambda (arg) (cond ((eq arg :autoport) port-string) ((stringp arg) (string-replace ":autoport" port-string arg)) (t arg))))) (when-let* ((command-args (plist-get config 'command-args))) (plist-put config 'command-args (seq-map replace-fn command-args))) (when-let* ((command-env (plist-get config 'command-env))) (plist-put config 'command-env (cl-loop for (key value) on command-env by #'cddr collect key collect (apply replace-fn (list value)))))) config) (defun dape-config-tramp (config) "Infer `prefix-local' and `host' on CONFIG if in tramp context. If `tramp-tramp-file-p' is nil for command-cwd or command-cwd is nil and `tramp-tramp-file-p' is nil for `defualt-directory' return config as is." (when-let* ((default-directory (or (plist-get config 'command-cwd) default-directory)) ((tramp-tramp-file-p default-directory)) (parts (tramp-dissect-file-name default-directory))) (when (and (not (plist-get config 'prefix-local)) (not (plist-get config 'prefix-remote)) (plist-get config 'command)) (let ((prefix-local (tramp-completion-make-tramp-file-name (tramp-file-name-method parts) (tramp-file-name-user parts) (tramp-file-name-host parts) ""))) (dape--message "Remote connection detected, setting `prefix-local' to %S" prefix-local) (plist-put config 'prefix-local prefix-local))) (when (and (plist-get config 'command) (plist-get config 'port) (not (plist-get config 'host)) (equal (tramp-file-name-method parts) "ssh")) (let ((host (file-remote-p default-directory 'host))) (dape--message "Remote connection detected, setting `host' to %S" host) (plist-put config 'host host)))) config) (defun dape--ensure-executable (executable) "Ensure that EXECUTABLE exist on system." (unless (or (and (file-name-absolute-p executable) (file-remote-p default-directory) (file-executable-p (concat (file-remote-p default-directory) executable))) (file-executable-p executable) (executable-find executable t)) (user-error "Unable to locate %S (default-directory %s)" executable default-directory))) (defun dape-ensure-command (config) "Ensure that `command' from CONFIG exist system." (dape--ensure-executable (dape-config-get config 'command))) (defun dape--overlay-region () "List of beg and end of current line." (list (line-beginning-position) (1- (line-beginning-position 2)))) (defun dape--format-file-name-line (filename line) "Formats FILENAME and LINE to string." (let* ((conn (dape--live-connection 'last t)) (config (and conn (dape--config (dape--root-of conn)))) (root-guess (dape--guess-root config)) ;; Normalize paths for `file-relative-name' (filename (tramp-file-local-name filename)) (root-guess (tramp-file-local-name root-guess))) (concat (string-truncate-left (file-relative-name filename root-guess) dape-info-file-name-max) (when line (format ":%d" line))))) (defun dape--kill-buffers (&optional skip-process-buffers) "Kill all dape buffers. On SKIP-PROCESS-BUFFERS skip deletion of buffers which has processes." (cl-loop for buffer in (buffer-list) when (and (buffer-live-p buffer) (buffer-match-p '(or "\\*dape-source .+\\*" "\\*dape-.+ events\\*" "\\*dape-.+ output\\*" "\\*dape-.+ stderr\\*" (major-mode . dape-repl-mode) (major-mode . dape-memory-mode) (major-mode . dape-shell-mode) (major-mode . dape-disassemble-mode) (derived-mode . dape-info-parent-mode)) buffer) (not (and skip-process-buffers (get-buffer-process buffer)))) do (condition-case err (let ((window (get-buffer-window buffer))) (kill-buffer buffer) (when (window-live-p window) (delete-window window))) (error (message (error-message-string err)))))) (defun dape--display-buffer (buffer) "Display BUFFER according to `dape-buffer-window-arrangement'." (pcase-let* ((mode (buffer-local-value 'major-mode buffer)) (group (cl-position (with-current-buffer buffer (dape--info-window-group)) dape-info-buffer-window-groups)) (`(,fns . ,alist) (pcase dape-buffer-window-arrangement ((or 'left 'right) (pcase mode ('dape-repl-mode `((display-buffer-in-side-window) (side . bottom) (slot . -1))) ('dape-shell-mode `((display-buffer-in-side-window) (side . bottom) (slot . 0))) ((guard group) `((display-buffer-in-side-window) (side . ,dape-buffer-window-arrangement) (slot . ,(1- group)))))) ('gud (pcase mode ('dape-repl-mode '((display-buffer-in-side-window) (side . top) (slot . -1))) ('dape-shell-mode '((display-buffer-pop-up-window) (direction . right) (dedicated . t))) ((guard group) `((display-buffer-in-side-window) ,@(nth group '(((side . top) (slot . 1)) ((side . bottom) (slot . -1)) ((side . bottom) (slot . 0)) ((side . top) (slot . 0)) ((side . bottom) (slot . 1)))))))) (_ nil))) (category (when group (intern (format "dape-info-%s" group))))) (display-buffer buffer `((display-buffer-reuse-window . ,fns) (category . ,category) (dedicated . 'weakly) ,@alist)))) (defmacro dape--mouse-command (name doc command) "Create mouse command with NAME, DOC which call COMMAND." (declare (indent 1)) `(defun ,name (event) ,doc (interactive "e") (save-selected-window (let ((start (event-start event))) (select-window (posn-window start)) (save-excursion (goto-char (posn-point start)) (call-interactively ',command)))))) (defmacro dape--buffer-map (name fn &rest bindings) "Helper macro to create a keymap named NAME for an info buffer. FN is bound to RET, mouse 2 and BINDINGS is a plist of (KEY FN) pairs which is bound on map." (declare (indent defun)) `(defvar ,name (let ((map (make-sparse-keymap))) (define-key map "\r" #',fn) (define-key map [mouse-2] #',fn) (define-key map [follow-link] 'mouse-face) ,@(cl-loop for (key f) on bindings by 'cddr collect `(define-key map ,key ,f)) map))) (defmacro dape--command-at-line (name properties modes doc &rest body) "Helper macro to create info command with NAME and DOC. Binds PROPERTIES on string properties from current line and binds them then executes BODY. Which MODES this command is applicable." (declare (indent defun)) `(defun ,name (&optional event) ,doc (interactive (list last-input-event) ,@modes) (if event (posn-set-point (event-end event))) (let (,@properties) (save-excursion (beginning-of-line) ,@(mapcar (lambda (property) `(setq ,property (get-text-property (point) ',property))) properties)) (if (or ,@properties) (progn ,@body) (user-error "Command `%s' not available at point" ',name))))) (defun dape--emacs-grab-focus () "If `display-graphic-p' focus Emacs." (select-frame-set-input-focus (selected-frame))) (define-minor-mode dape-many-windows "Toggle many-buffer debug layout and simple layout. The mode modifies `dape-start-hook' to remove or add the complex layout for future debugging sessions." :global t :init-value t (if dape-many-windows (add-hook 'dape-start-hook #'dape-info) (remove-hook 'dape-start-hook #'dape-info) (dolist (buffer (dape--info-buffer-list)) (when-let* ((window (get-buffer-window buffer))) (quit-window t window)))) (when dape-active-mode (when dape-many-windows (dape-info nil)) (when-let* ((conn (dape--live-connection 'parent t)) (buffer (dape--shell-buffer conn))) (dape--display-buffer buffer)) (when-let* ((window (get-buffer-window "*dape-repl*"))) (quit-window nil window)) (dape-repl))) ;;; Connection (defun dape--live-connection (type &optional nowarn require-selected) "Return connection instance of TYPE. TYPE is expected to be one of the following symbols: - parent: Parent connection. - last: Last created child connection or parent which has an active thread. - running: Last created child connection or parent which has an active thread but no stopped threads. - stopped: Last created child connection or parent which has stopped threads. If NOWARN is non-nil does not error on no active process. If REQUIRE-SELECTED is non-nil require returned connection to be the selected one, this has no effect when TYPE is parent. See `dape--connection-selected'." (let* ((connections (dape--live-connections)) (selected (cl-find dape--connection-selected connections)) (ordered `(,@(when selected (list selected)) ,@(unless (and require-selected selected) (reverse connections)))) (conn (pcase type ('parent (or (and selected (dape--root-of selected)) (and connections (dape--root-of (car connections))))) ('last (cl-find-if #'dape--thread-id ordered)) ('running (cl-find-if (lambda (conn) (and (dape--thread-id conn) (not (dape--stopped-threads conn)))) ordered)) ('stopped (cl-find-if (lambda (conn) (and (dape--stopped-threads conn))) ordered))))) (unless (or nowarn conn) (user-error "No %sdebug connection" ;; `parent' and `last' does not make sense to the user (if (memq type '(running stopped)) (format "%s " type) ""))) conn)) (defun dape--live-connections () "Get all live connections." (cl-labels ((live-connections-1 (conn) (when (and conn (jsonrpc-running-p conn)) (cons conn (mapcan #'live-connections-1 ;; New children are `push'ed onto the ;; children list, therefore children ;; are `reverse'd to guarantee LIFO ;; order. (reverse (dape--children conn))))))) (mapcan #'live-connections-1 dape--connections))) (defun dape--live-connections-root () "Get all live root (parent-less) connections." (cl-remove-if #'dape--parent (dape--live-connections))) (defclass dape-connection (jsonrpc-process-connection) ((last-id :initform 0 :documentation "Used for converting JSONRPC's `id' to DAP' `seq'.") (n-sent-notifs :initform 0 :documentation "Used for converting JSONRPC's `id' to DAP' `seq'.") (children :accessor dape--children :initarg :children :initform (list) :documentation "Child connections. Used by startDebugging adapters.") (parent :accessor dape--parent :initarg :parent :initform #'ignore :documentation "Parent connection. Used by startDebugging adapters.") (config :accessor dape--config :initarg :config :initform #'ignore :documentation "Current session configuration plist.") (server-process :accessor dape--server-process :initarg :server-process :initform #'ignore :documentation "Debug adapter server process.") (threads :accessor dape--threads :initform nil :documentation "Session plist of thread data.") (threads-update-handle :initform 0 :accessor dape--threads-update-handle :documentation "Current handle for updating thread state.") (threads-last-update-handle :initform 0 :accessor dape--threads-last-update-handle :documentation "Last handle used when updating thread state") (capabilities :accessor dape--capabilities :initform nil :documentation "Session capabilities plist.") (thread-id :accessor dape--thread-id :initform nil :documentation "Selected thread id.") (stack-id :accessor dape--stack-id :initform nil :documentation "Selected stack id.") (modules :accessor dape--modules :initform nil :documentation "List of modules.") (sources :accessor dape--sources :initform nil :documentation "List of loaded sources.") (state :accessor dape--state :initform nil :documentation "Session state.") (state-reason :accessor dape--state-reason :initform nil :documentation "Reason for state.") (exception-description :accessor dape--exception-description :initform nil :documentation "Exception description.") (initialized-p :accessor dape--initialized-p :initform nil :documentation "If connection has been initialized.") (restart-in-progress-p :accessor dape--restart-in-progress-p :initform nil :documentation "If restart request is in flight.") (shell-buffer :accessor dape--shell-buffer :initform nil :documentation "Shell buffer.") (source-buffers :accessor dape--source-buffers :initform nil :documentation "Plist of source reference to buffer.") (stderr-buffer :accessor dape--stderr-buffer :initform nil :initarg :stderr-buffer :documentation "Stderr buffer for process.")) :documentation "Represents a DAP debugger. Wraps a process for DAP communication.") (defun dape--root-of (conn) "Return root connection of CONN." (if (dape--parent conn) (dape--root-of (dape--parent conn)) conn)) (defun dape--session-connections (conn) "Return all live connections in CONN's session." (let ((root (dape--root-of conn))) (cl-remove-if-not (lambda (c) (eq (dape--root-of c) root)) (dape--live-connections)))) (cl-defstruct (dape--breakpoint (:constructor nil)) "Base breakpoint object." disabled verified id hits) (cl-defstruct (dape--source-breakpoint (:include dape--breakpoint)) "Source/line breakpoint." location type value) (cl-defstruct (dape--data-breakpoint (:include dape--breakpoint)) "Data/hardware breakpoint." data-id access-type name) (cl-defstruct (dape--exception-breakpoint (:include dape--breakpoint)) "Exception filter breakpoint." filter label default) (cl-defstruct (dape--function-breakpoint (:include dape--breakpoint)) "Function breakpoint." name) (cl-defmethod jsonrpc-convert-to-endpoint ((conn dape-connection) message subtype) "Convert jsonrpc CONN MESSAGE with SUBTYPE to DAP format." (cl-destructuring-bind (&key method id error params (result nil result-supplied-p)) message (with-slots (last-id n-sent-notifs) conn (cond ((eq subtype 'notification) `( :type "event" :seq ,(+ last-id (cl-incf n-sent-notifs)) :event ,method :body ,params)) ((eq subtype 'request) `( :type "request" :seq ,(+ (setq last-id id) n-sent-notifs) :command ,method ,@(when params `(:arguments ,params)))) (error `( :type "response" :seq ,(+ (setq last-id id) n-sent-notifs) :request_seq ,last-id :success :json-false :message ,(plist-get error :message) :body ,(plist-get error :data))) (t `( :type "response" :seq ,(+ (setq last-id id) n-sent-notifs) :request_seq ,last-id :command ,method :success t ,@(and result `(:body ,result)))))))) (cl-defmethod jsonrpc-convert-from-endpoint ((_conn dape-connection) dap-message) "Convert JSONRPCesque DAP-MESSAGE to JSONRPC plist." (cl-destructuring-bind (&key type request_seq seq command arguments event body &allow-other-keys) dap-message (when (stringp seq) ;; dirty dirty netcoredbg (setq seq (string-to-number seq))) (cond ((string= type "event") `(:method ,event :params ,body)) ((string= type "response") ;; Skipping :error field to skip error handling by signal `(:id ,request_seq :result ,dap-message)) (command `(:id ,seq :method ,command :params ,arguments))))) ;;; Outgoing requests (defconst dape--timeout-error "Request timeout" "Error string for request timeout. Useful for `eq' comparison to derive request timeout error.") (defvar dape--request-blocking nil "If non-nil do request in a blocking manner.") (defun dape-request (conn command arguments &optional cb) "Send request with COMMAND and ARGUMENTS to adapter CONN. If callback function CB is supplied, it's called on timeout and success. CB will be called with PLIST and ERROR. On success, ERROR will be nil. On failure, ERROR will be an string. If `dape--request-blocking' is non-nil do blocking request." (cl-flet ((success-fn (result) (funcall cb (plist-get result :body) (unless (eq (plist-get result :success) t) (or (plist-get result :message) (plist-get (plist-get (plist-get result :body) :error) :format) "")))) (timeout-fn () (dape--warn "Command %S timed out after %d seconds (see \ `dape-request-timeout')" command dape-request-timeout) (funcall cb nil dape--timeout-error))) (if dape--request-blocking (let ((result (jsonrpc-request conn command arguments))) (when cb (success-fn result))) (jsonrpc-async-request conn command arguments :success-fn (when cb #'success-fn) :error-fn #'ignore ; will never be called :timeout-fn (when cb #'timeout-fn) :timeout dape-request-timeout)))) (defun dape--initialize (conn) "Initialize CONN." (dape--with-request-bind (body error) (dape-request conn :initialize `( :clientID "dape" :adapterID ,(plist-get (dape--config conn) :type) :pathFormat "path" :linesStartAt1 t :columnsStartAt1 t ;;:locale "en-US" ;;:supportsVariableType t ;;:supportsVariablePaging t :supportsRunInTerminalRequest t ;;:supportsMemoryReferences t ;;:supportsInvalidatedEvent t ;;:supportsMemoryEvent t :supportsArgsCanBeInterpretedByShell t :supportsProgressReporting t :supportsStartDebuggingRequest t )) (if error (progn (dape--warn "Initialize failed with %S" error) (dape-kill conn)) (setf (dape--capabilities conn) body) ;; See `defer-launch-attach' in `dape-configs' (unless (plist-get (dape--config conn) 'defer-launch-attach) (dape--launch-or-attach conn))))) (defun dape--launch-or-attach-arguments (conn) "Return plist of launch/attach arguments for CONN." ;; Transform config to jsonrpc serializable format ;; Remove all non `keywordp' keys and transform null to ;; :json-false (cl-labels ((transform-value (value) (pcase value ('nil :json-false) ;; Need a way to create json null values (see #72) (:null nil) ((pred vectorp) (cl-map 'vector #'transform-value value)) ((pred listp) (create-body value)) (_ value))) (create-body (config) (cl-loop for (key value) on config by 'cddr when (keywordp key) append (list key (transform-value value))))) (create-body (dape--config conn)))) (defun dape--launch-or-attach (conn) "Launch or attach CONN." (dape--with-request-bind (_body error) (dape-request conn (or (plist-get (dape--config conn) :request) :launch) (dape--launch-or-attach-arguments conn)) (when error (dape--warn "%s" error) (dape-kill conn)))) (defun dape--set-breakpoints-in-source (conn source &optional cb) "Set breakpoints in SOURCE for adapter CONN. SOURCE is expected to be buffer or file name string. See `dape-request' for expected CB signature." (cl-flet ((objectify (breakpoint) (let ((plist `(:line ,(dape--breakpoint-line breakpoint)))) (pcase (dape--source-breakpoint-type breakpoint) ('log (if (dape--capable-p conn :supportsLogPoints) (plist-put plist :logMessage (dape--source-breakpoint-value breakpoint)) (dape--warn "Adapter does not support `dape-breakpoint-log'"))) ('expression (if (dape--capable-p conn :supportsConditionalBreakpoints) (plist-put plist :condition (dape--source-breakpoint-value breakpoint)) (dape--warn "Adapter does not support `dape-breakpoint-expression'"))) ('hits (if (dape--capable-p conn :supportsHitConditionalBreakpoints) (plist-put plist :hitCondition (dape--source-breakpoint-value breakpoint)) (dape--warn "Adapter does not support `dape-breakpoint-hits'")))) plist))) (let ((;; Importantly `breakpoints' is not the same object as ;; `dape--breakpoints' otherwise we would get hurt by ;; mutations while request-in-flight. breakpoints (cl-loop for b in dape--breakpoints when (and (dape--source-breakpoint-p b) (equal (dape--breakpoint-source b) source) (not (dape--breakpoint-disabled b))) collect b)) (source-object (pcase source ((pred stringp) `(:path ,(dape--file-name-remote conn source))) ((pred bufferp) (or ;; Is source buffer (see `dape--source-make-buffer')? (cl-loop with buffers = (dape--source-buffers (dape--root-of conn)) for (reference buffer) on buffers by #'cddr when (eq buffer source) return `(:sourceReference ,reference)) ;; Other buffer? (when-let* ((filename (dape--file-name-remote conn (buffer-file-name source)))) `(:path ,filename))))))) (if (not source-object) (dape--request-continue cb) (dape--with-request-bind ((&key ((:breakpoints updates)) &allow-other-keys) error) (dape-request conn :setBreakpoints `( :breakpoints ,(cl-map 'vector #'objectify breakpoints) :lines ,(cl-map 'vector #'dape--breakpoint-line breakpoints) :source ,source-object)) (if error (dape--warn "Failed to set breakpoints in %s; %s" source error) (cl-loop for breakpoint in breakpoints for update across updates do (dape--breakpoint-update conn breakpoint update)) (dape--request-continue cb error))))))) (defun dape--set-exception-breakpoints (conn &optional cb) "Set the exception breakpoints for adapter CONN. See `dape-request' for expected CB signature." (let ((exceptions (cl-remove-if-not #'dape--exception-breakpoint-p dape--breakpoints))) (if (not exceptions) (dape--request-continue cb) (dape-request conn :setExceptionBreakpoints `(:filters ,(cl-map 'vector #'dape--exception-breakpoint-filter (cl-remove-if #'dape--breakpoint-disabled exceptions))) cb)))) (defun dape--configure-exceptions (conn &optional cb) "Configure exception breakpoints for adapter CONN. See `dape-request' for expected CB signature." (let ((old-exceptions (cl-remove-if-not #'dape--exception-breakpoint-p dape--breakpoints))) (setq dape--breakpoints (cl-remove-if #'dape--exception-breakpoint-p dape--breakpoints)) (dolist (filter (append (plist-get (dape--capabilities conn) :exceptionBreakpointFilters) nil)) (let* ((id (plist-get filter :filter)) (old (cl-find id old-exceptions :key #'dape--exception-breakpoint-filter :test #'equal)) (enabled (if old (not (dape--breakpoint-disabled old)) (eq (plist-get filter :default) t)))) ;; Append to keep exceptions at bottom of breakpoint list. (setq dape--breakpoints (nconc dape--breakpoints (list (make-dape--exception-breakpoint :filter id :label (plist-get filter :label) :default (plist-get filter :default) :disabled (not enabled)))))))) (dape--with-request (dape--set-exception-breakpoints conn) (run-hooks 'dape-update-ui-hook) (dape--request-continue cb))) (defun dape--set-breakpoints (conn cb) "Set breakpoints for adapter CONN. See `dape-request' for expected CB signature." (if-let* ((sources (thread-last dape--breakpoints (cl-remove-if-not #'dape--source-breakpoint-p) (seq-group-by #'dape--breakpoint-source) (mapcar #'car)))) (cl-loop with responses = 0 for source in sources do (dape--with-request (dape--set-breakpoints-in-source conn source) (setf responses (1+ responses)) (when (length= sources responses) (dape--request-continue cb)))) (dape--request-continue cb))) (defun dape--set-data-breakpoints (conn cb) "Set data breakpoints for adapter CONN. See `dape-request' for expected CB signature." (let ((data-breakpoints (cl-remove-if-not #'dape--data-breakpoint-p dape--breakpoints))) (if (dape--capable-p conn :supportsDataBreakpoints) (dape--with-request-bind ((&key breakpoints &allow-other-keys) error) (dape-request conn :setDataBreakpoints (list :breakpoints (cl-map 'vector (lambda (bp) (list :dataId (dape--data-breakpoint-data-id bp) :accessType (dape--data-breakpoint-access-type bp))) data-breakpoints))) (when error (dape--message "Failed to setup data breakpoints: %s" error)) (cl-loop for bp in data-breakpoints for res across (or breakpoints []) unless (eq (plist-get res :verified) t) collect bp into unverified finally do (when unverified (dape--warn "Failed setting data breakpoints for %s" (mapconcat #'dape--data-breakpoint-name unverified ", "))) ;; FIXME Should not remove unverified-breakpoints as they ;; might be verified by another live connection. (setq dape--breakpoints (cl-set-difference dape--breakpoints unverified))) (dape--request-continue cb error)) (setq dape--breakpoints (cl-remove-if #'dape--data-breakpoint-p dape--breakpoints)) (dape--request-continue cb)))) (defun dape--set-function-breakpoints (conn &optional cb) "Set function breakpoints for adapter CONN. See `dape-request' for expected CB signature." (let ((function-breakpoints (cl-remove-if-not #'dape--function-breakpoint-p dape--breakpoints))) (if (dape--capable-p conn :supportsFunctionBreakpoints) (dape--with-request-bind ((&key breakpoints &allow-other-keys) error) (dape-request conn :setFunctionBreakpoints `(:breakpoints ,(cl-map 'vector (lambda (b) `(:name ,(dape--function-breakpoint-name b))) function-breakpoints))) (when error (dape--warn "Failed to set function breakpoints: %s" error)) (cl-loop for breakpoint in function-breakpoints for res across (or breakpoints []) do (setf (dape--breakpoint-id breakpoint) (plist-put (dape--breakpoint-id breakpoint) conn (plist-get res :id)) (dape--breakpoint-verified breakpoint) (plist-put (dape--breakpoint-verified breakpoint) conn (eq (plist-get res :verified) t)))) (dape--request-continue cb error)) (dape--request-continue cb)))) (defun dape--update-threads (conn cb) "Update threads for CONN in-place if possible. See `dape-request' for expected CB signature." (dape--with-request-bind ((&key threads &allow-other-keys) error) (dape-request conn :threads nil) (setf (dape--threads conn) (mapcar (lambda (new-thread) (if-let* ((old-thread (cl-find-if (lambda (old-thread) (eql (plist-get new-thread :id) (plist-get old-thread :id))) (dape--threads conn)))) (plist-put old-thread :name (plist-get new-thread :name)) new-thread)) (append threads nil))) (dape--maybe-select-thread conn (cl-some (lambda (thread) (plist-get thread :id)) (dape--threads conn))) (dape--request-continue cb error))) (defun dape--stack-trace (conn thread nof cb) "Update stack trace in THREAD plist with NOF frames by adapter CONN. See `dape-request' for expected CB signature." (let ((current-nof (length (plist-get thread :stackFrames))) (total-frames (plist-get thread :totalFrames)) (value-formatting-p (dape--capable-p conn :supportsValueFormattingOptions)) (delayed-stack-trace-p (dape--capable-p conn :supportsDelayedStackTraceLoading))) (if (or (not (equal (plist-get thread :status) 'stopped)) (not (integerp (plist-get thread :id))) (eql current-nof total-frames) (and delayed-stack-trace-p (<= nof current-nof)) (and (not delayed-stack-trace-p) (> current-nof 0))) (dape--request-continue cb) (dape--with-request-bind ((&key stackFrames totalFrames &allow-other-keys) error) (dape-request conn :stackTrace `( :threadId ,(plist-get thread :id) ,@(when delayed-stack-trace-p `( :startFrame ,current-nof :levels ,(- nof current-nof))) ,@(when (and dape-info-stack-buffer-modules value-formatting-p) `(:format (:module t))))) (cond ((not delayed-stack-trace-p) (plist-put thread :stackFrames (append stackFrames nil))) ;; Sanity check delayed stack trace ((length= (plist-get thread :stackFrames) current-nof) (plist-put thread :stackFrames (append (plist-get thread :stackFrames) stackFrames nil)))) (plist-put thread :totalFrames (and (numberp totalFrames) totalFrames)) (dape--request-continue cb error))))) (defun dape--variables (conn object cb) "Update OBJECTs variables by adapter CONN. See `dape-request' for expected CB signature." (let ((variables-reference (plist-get object :variablesReference))) (if (or (not (numberp variables-reference)) (zerop variables-reference) (plist-get object :variables) (not (jsonrpc-running-p conn))) (dape--request-continue cb) (dape--with-request-bind ((&key variables &allow-other-keys) _error) (dape-request conn :variables (list :variablesReference variables-reference)) (plist-put object :variables (thread-last variables (cl-map 'list #'identity) (seq-filter #'identity))) (dape--request-continue cb))))) (defun dape--variables-recursive (conn object path pred cb) "Update variables recursivly. Get variable data from CONN and put result on OBJECT until PRED is nil. PRED is called with PATH and OBJECT. See `dape-request' for expected CB signature." (if-let* ((objects (cl-loop for variable in (or (plist-get object :scopes) (plist-get object :variables)) for name = (plist-get variable :name) for expensive-p = (eq (plist-get variable :expensive) t) when (and (not expensive-p) (funcall pred (cons name path))) collect variable))) (let ((responses 0)) (dolist (object objects) (dape--with-request (dape--variables conn object) (dape--with-request (dape--variables-recursive conn object (cons (plist-get object :name) path) pred) (when (length= objects (cl-incf responses)) (dape--request-continue cb)))))) (dape--request-continue cb))) (defun dape--evaluate-expression (conn frame-id expression context cb) "Send evaluate request to adapter CONN. FRAME-ID specifies which frame the EXPRESSION is evaluated in and CONTEXT which the result is going to be displayed in. See `dape-request' for expected CB signature." (dape-request conn :evaluate (append (when (dape--stopped-threads conn) (list :frameId frame-id)) (list :expression expression :context context)) cb)) (defun dape--set-variable (conn reference variable value) "Set VARIABLE to VALUE with REFERENCE in for CONN. Calls :setVariable endpoint if REFERENCE is an number and :setExpression if not. Runs the appropriate hooks on non error responses." (cond (;; `variable' from :variable request - with reference (and (dape--capable-p conn :supportsSetVariable) (numberp reference)) (dape--with-request-bind (body error) (dape-request conn :setVariable (list :variablesReference reference :name (plist-get variable :name) :value value)) (if error (message "%s" error) ;; Would make more sense to update all variables after ;; setVariable request but certain adapters cache "variable" ;; response so we just update the variable in question in ;; place. (plist-put variable :variables nil) (cl-loop for (key value) on body by 'cddr do (plist-put variable key value)) (run-hooks 'dape-update-ui-hook)))) (;; `variable' from :evaluate request - w/o reference (and (dape--capable-p conn :supportsSetExpression) (or (plist-get variable :evaluateName) (plist-get variable :name))) (dape--with-request-bind (_body error) (dape-request conn :setExpression (list :frameId (plist-get (dape--current-stack-frame conn) :id) :expression (or (plist-get variable :evaluateName) (plist-get variable :name)) :value value)) (if error (message "%s" error) ;; Update all variables (dape--update conn 'variables nil)))) ((user-error "Unable to set variable")))) (defun dape--scopes (conn stack-frame cb) "Send scopes request to CONN for STACK-FRAME plist. See `dape-request' for expected CB signature." (if-let* ((id (plist-get stack-frame :id)) ((not (plist-get stack-frame :scopes)))) (dape--with-request-bind ((&key scopes &allow-other-keys) error) (dape-request conn :scopes (list :frameId id)) (plist-put stack-frame :scopes (append scopes nil)) (dape--request-continue cb error)) (dape--request-continue cb))) (defun dape--update (conn &optional invalidate display-source-p) "Update adapter CONN data and UI. Use INVALIDATE to invalidate `stack-frames' or `variables'. If DISPLAY-SOURCE-P is non-nil, display displayable top frame." ;; Invalidate parts of each thread's data (when invalidate (dolist (thread (dape--threads conn)) (pcase invalidate ('stack-frames (setf (plist-get thread :stackFrames) nil (plist-get thread :totalFrames) nil)) ('variables (dolist (frame (plist-get thread :stackFrames)) (setf (plist-get frame :scopes) nil)))))) ;; Hydrate current thread's data (unless cached) (dape--with-request (dape--stack-trace conn (dape--current-thread conn) 1) (when display-source-p ;; Display source ASAP (top frame has just been acquired) (dape--stack-frame-display conn)) (dape--with-request (dape--scopes conn (dape--current-stack-frame conn)) ;; Scopes buffers needs scopes in place... for some reason (run-hooks 'dape-update-ui-hook)))) ;;; Incoming requests (cl-defgeneric dape-handle-request (_conn _command _arguments) "Sink for all unsupported requests." nil) (define-derived-mode dape-shell-mode shell-mode "Shell" "Major mode for interacting with an debugged program." :interactive nil (setq-local revert-buffer-function (lambda (&rest _) (dape-restart)))) (cl-defmethod dape-handle-request (conn (_command (eql runInTerminal)) arguments) "Handle runInTerminal requests. Starts a new adapter CONNs from ARGUMENTS." (let* ((default-directory (or (when-let* ((cwd (plist-get arguments :cwd))) (dape--file-name-local conn cwd)) default-directory)) (process-environment (append (cl-loop for (key value) on (plist-get arguments :env) by 'cddr collect (format "%s=%s" (substring (format "%s" key) 1) value)) ;; XXX Compat with directory-aware environment managing ;; modes. Capturing environment after `run-mode-hooks' ;; have been called in `default-directory'. (with-temp-buffer (fundamental-mode) process-environment) process-environment)) (name "*dape-shell*") (buffer (get-buffer-create ;; Reuse buffer if owner is not live (if (cl-find name (dape--live-connections-root) :key (lambda (c) (buffer-name (dape--shell-buffer c))) :test #'equal) (generate-new-buffer-name name) name)))) (setf (dape--shell-buffer (dape--root-of conn)) buffer) (with-current-buffer buffer (dape-shell-mode) (shell-command-save-pos-or-erase)) (let ((process (make-process :name "dape shell" :buffer buffer :command (let ((args (append (plist-get arguments :args) nil))) (if (plist-get arguments :argsCanBeInterpretedByShell) (list shell-file-name shell-command-switch (mapconcat #'identity args " ")) args)) :filter (if dape-repl-echo-shell-output (lambda (process string) (let ((before (marker-position (process-mark process)))) (comint-output-filter process string) (dape--repl-insert (with-current-buffer (process-buffer process) (buffer-substring before (process-mark process)))))) #'comint-output-filter) :sentinel #'shell-command-sentinel :file-handler t))) (unless dape-repl-echo-shell-output (dape--display-buffer buffer)) (list :processId (process-id process))))) (cl-defmethod dape-handle-request (conn (_command (eql startDebugging)) arguments) "Handle adapter CONNs startDebugging requests with ARGUMENTS. Starts a new adapter connection as per request of the debug adapter." (let ((config (plist-get arguments :configuration)) (request (plist-get arguments :request))) (cl-loop with socket-conn-p = (plist-get (dape--config conn) 'port) for (key value) on (dape--config conn) by 'cddr unless (or (keywordp key) (and socket-conn-p (eq key 'command))) do (plist-put config key value)) (when request (plist-put config :request request)) (let ((new-connection (dape--create-connection config (or (dape--parent conn) conn)))) (push new-connection (dape--children conn)) (dape--start-debugging new-connection))) nil) ;;; Events (cl-defgeneric dape-handle-event (_conn _event _body) "Sink for all unsupported events." nil) (cl-defmethod dape-handle-event (conn (_event (eql initialized)) _body) "Handle adapter CONNs initialized events." (setf (dape--initialized-p conn) t) (dape--update-state conn 'initialized) (dape--with-request (dape--configure-exceptions conn) (dape--with-request (dape--set-breakpoints conn) (dape--with-request (dape--set-function-breakpoints conn) (dape--with-request (dape--set-data-breakpoints conn) (dape--with-request (dape-request conn :configurationDone nil) ;; See `defer-launch-attach' in `dape-configs' (when (plist-get (dape--config conn) 'defer-launch-attach) (dape--launch-or-attach conn)))))))) (cl-defmethod dape-handle-event (conn (_event (eql capabilities)) body) "Handle adapter CONNs capabilities events. BODY is an plist of adapter capabilities." (setf (dape--capabilities conn) ;; Only changed capabilities needs to be included in body (append (plist-get body :capabilities) (dape--capabilities conn))) (dape--configure-exceptions conn)) (cl-defmethod dape-handle-event (conn (_event (eql breakpoint)) body) "Handle adapter CONNs breakpoint events. Update `dape--breakpoints' according to BODY." (when-let* ((update (plist-get body :breakpoint)) (id (plist-get update :id))) (let ((breakpoint (cl-find id dape--breakpoints :key (lambda (breakpoint) (plist-get (dape--breakpoint-id breakpoint) conn))))) (cond (breakpoint (dape--breakpoint-update conn breakpoint update)) ((not (equal (plist-get body :reason) "removed")) (dape--with-request (dape--source-ensure conn update) (when-let* ((marker (dape--object-to-marker conn update))) (dape--with-line (marker-buffer marker) (plist-get update :line) (if-let* ((breakpoints (dape--breakpoints-at-point))) (dape-breakpoint-remove-at-point 'skip-notify) (dape--message "Creating breakpoint in %s:%d" (buffer-name) (plist-get update :line))) (dape--breakpoint-update conn (dape--breakpoint-place nil nil 'skip-notify) update))))))))) (cl-defmethod dape-handle-event (conn (_event (eql module)) body) "Handle adapter CONNs module events. Stores `dape--modules' from BODY." (let ((reason (plist-get body :reason)) (id (thread-first body (plist-get :module) (plist-get :id)))) (pcase reason ("new" (push (plist-get body :module) (dape--modules conn))) ("changed" (cl-loop with plist = (cl-find id (dape--modules conn) :key (lambda (module) (plist-get module :id))) for (key value) on body by 'cddr do (plist-put plist key value))) ("removed" (cl-delete id (dape--modules conn) :key (lambda (module) (plist-get module :id))))))) (cl-defmethod dape-handle-event (conn (_event (eql loadedSource)) body) "Handle adapter CONNs loadedSource events. Stores `dape--sources' from BODY." (let ((reason (plist-get body :reason)) (id (thread-first body (plist-get :source) (plist-get :id)))) (pcase reason ("new" (push (plist-get body :source) (dape--sources conn))) ("changed" (cl-loop with plist = (cl-find id (dape--sources conn) :key (lambda (source) (plist-get source :id))) for (key value) on body by 'cddr do (plist-put plist key value))) ("removed" (cl-delete id (dape--sources conn) :key (lambda (source) (plist-get source :id))))))) (cl-defmethod dape-handle-event (conn (_event (eql process)) body) "Handle adapter CONNs process events. Logs and sets state based on BODY contents." (let ((start-method (format "%sed" (or (plist-get body :startMethod) "start")))) (dape--update-state conn (intern start-method)) (dape--message "%s %s" (capitalize start-method) (plist-get body :name)))) (defvar dape--thread-event-debounce-timer (timer-create) "Debounce context for threads request in thread event.") (cl-defmethod dape-handle-event (conn (_event (eql thread)) body) "Handle adapter CONNs thread events. Stores `dape--thread-id' and updates/adds thread in `dape--thread' from BODY." (cl-destructuring-bind (&key threadId reason &allow-other-keys) body (dape--maybe-select-thread conn threadId) (when (equal reason "started") ;; For adapters that does not send an continued request, use ;; thread started to switch from `initialized' to `running'. (dape--update-state conn 'running)) (dape--threads-set-status conn threadId nil (if (equal reason "exited") 'exited 'running)) ;; XXX vscode uses a similar optimization, which makes it part of ;; spec... some adapters will blow unless :thread is throttled. (dape--with-debounce dape--thread-event-debounce-timer 0.001 (dape--with-request (dape--update-threads conn) (run-hooks 'dape-update-ui-hook))))) (cl-defmethod dape-handle-event (conn (_event (eql stopped)) body) "Handle adapter CONNs stopped events. Sets `dape--thread-id' from BODY and invokes ui refresh with `dape--update'." (cl-destructuring-bind (&key threadId reason allThreadsStopped hitBreakpointIds &allow-other-keys) body (dape--update-state conn 'stopped reason) ;; Select thread as stopped this thread (dape--maybe-select-thread conn threadId 'force) ;; ...and frame as (car frames) (setf (dape--stack-id conn) nil) ;; Clear (and Update exception description) (setf (dape--exception-description conn) nil) (when (equal reason "exception") ;; Output exception info in overlay and REPL (let* ((texts (seq-filter #'stringp (list (plist-get body :text) (plist-get body :description)))) (str (concat (mapconcat #'identity texts ":\n\t") "\n"))) (setf (dape--exception-description conn) str) (dape--repl-insert-error str))) ;; Update number breakpoint of hits (cl-loop for id across hitBreakpointIds for breakpoint = (cl-find id dape--breakpoints :key (lambda (breakpoint) (plist-get (dape--breakpoint-id breakpoint) conn))) when breakpoint do (setf (dape--breakpoint-hits breakpoint) (1+ (or (dape--breakpoint-hits breakpoint) 0)))) ;; Set thread status ASAP to reflect the stopped state. (dape--threads-set-status conn threadId (eq allThreadsStopped t) 'stopped) (let ((update-handle ;; Need to store handle before threads request to guard ;; against an overwriting thread status if event is firing ;; while :threads request is in flight. (dape--threads-make-update-handle conn))) (dape--with-request (dape--update-threads conn) ;; Then set it again to set `stopped' on threads that where ;; not fetched before threads request. (dape--threads-set-status conn threadId (eq allThreadsStopped t) 'stopped update-handle) (dape--update conn 'stack-frames t))) (run-hooks 'dape-stopped-hook))) (cl-defmethod dape-handle-event (conn (_event (eql continued)) body) "Handle adapter CONN continued events. Sets `dape--thread-id' from BODY if not set." (cl-destructuring-bind (&key threadId (allThreadsContinued t) &allow-other-keys) body (dape--update-state conn 'running) (dape--stack-frame-cleanup) (dape--maybe-select-thread conn threadId) (dape--threads-set-status conn threadId (eq allThreadsContinued t) 'running) (run-hooks 'dape-update-ui-hook))) (cl-defmethod dape-handle-event (_conn (_event (eql output)) body) "Handle output events by printing BODY with `dape--repl-message'." (when-let* ((output (plist-get body :output))) (pcase (plist-get body :category) ((or "stdout" "console" "output") (dape--repl-insert output)) ("stderr" (dape--repl-insert-error output))))) (cl-defmethod dape-handle-event (conn (_event (eql exited)) body) "Handle adapter CONNs exited events. Prints exit code from BODY." (dape--update-state conn 'exited) (dape--stack-frame-cleanup) (dape--message "Exit code %d" (plist-get body :exitCode))) (cl-defmethod dape-handle-event (conn (_event (eql terminated)) _body) "Handle adapter CONNs terminated events. Killing the adapter and it's CONN." (let ((child-conn-p (dape--parent conn))) (dape--with-request (dape-kill conn) (when (not child-conn-p) ;; XXX Remove duplicated terminated print for dlv (unless (eq (dape--state conn) 'terminated) (dape--message "Session terminated")) (dape--update-state conn 'terminated) (run-hooks 'dape-update-ui-hook))))) ;;; Startup/Setup (defun dape--start-debugging (conn) "Preform some cleanup and start debugging with CONN." (unless (dape--parent conn) (dape--stack-frame-cleanup) (dape--breakpoints-reset) (cl-loop for (_ buffer) on (dape--source-buffers conn) by 'cddr when (buffer-live-p buffer) do (kill-buffer buffer)) (setf (dape--source-buffers conn) nil) (unless dape-active-mode (dape-active-mode +1)) (dape--update-state conn 'starting) (run-hooks 'dape-update-ui-hook)) (dape--initialize conn)) (defun dape--create-connection (config &optional parent) "Create symbol `dape-connection' instance from CONFIG. If started by an startDebugging request expects PARENT to symbol `dape-connection'." (unless (plist-get config 'command-cwd) (plist-put config 'command-cwd (dape--guess-root config))) (let ((default-directory (plist-get config 'command-cwd)) (process-environment (cl-copy-list process-environment)) (command (cons (plist-get config 'command) (cl-map 'list 'identity (plist-get config 'command-args)))) process server-process stderr-buffer) ;; Initialize `process-environment' from `command-env' (cl-loop for (key value) on (plist-get config 'command-env) by 'cddr do (setenv (pcase key ((pred keywordp) (substring (format "%s" key) 1)) ((or (pred symbolp) (pred stringp)) (format "%s" key)) (_ (user-error "Bad type for `command-env' key %S" key))) (format "%s" value))) (cond (;; Socket connection (plist-get config 'port) ;; 1. Start server (when (plist-get config 'command) (setq stderr-buffer (with-current-buffer (generate-new-buffer " *dape-adapter stderr*") (when (plist-get config 'command-insert-stderr) (add-hook 'after-change-functions (lambda (beg end _pre-change-len) (dape--repl-insert-error (buffer-substring beg end))) nil t)) (current-buffer)) server-process (make-process :name "dape adapter" :command command :filter (lambda (_process string) (dape--repl-insert string)) :file-handler t :buffer nil :stderr stderr-buffer)) (process-put server-process 'stderr-pipe stderr-buffer) ;; XXX Tramp does not allow `make-pipe-process' as :stderr, ;; `make-process' creates one for us with an unwanted ;; sentinel (`internal-default-process-sentinel'). (when-let* ((pipe-process (get-buffer-process stderr-buffer))) (set-process-sentinel pipe-process #'ignore)) (when dape-debug (dape--message "Adapter server started with %S" (mapconcat #'identity command " ")))) ;; FIXME Why do I need this? (when (file-remote-p default-directory) (sleep-for 0.300)) ;; 2. Connect to server (let ((host (or (plist-get config 'host) "localhost")) (retries 30)) (while (and (not process) (> retries 0)) (ignore-errors (setq process (make-network-process :name (format "dape adapter%s connection" (if parent " child" "")) :host host :coding 'utf-8-emacs-unix :service (plist-get config 'port) :noquery t))) (sleep-for 0.100) (setq retries (1- retries))) (if (zerop retries) (progn (dape--warn "Unable to connect to dap server at %s:%d" host (plist-get config 'port)) (dape--message "Connection is configurable by `host' and `port' keys") ;; Barf server stderr (when-let* (server-process (buffer (process-get server-process 'stderr-pipe)) (content (with-current-buffer buffer (buffer-string))) ((not (string-empty-p content)))) (dape--repl-insert-error (concat content "\n"))) (delete-process server-process) (user-error "Unable to connect to server")) (when dape-debug (dape--message "%s to adapter established at %s:%s" (if parent "Child connection" "Connection") host (plist-get config 'port)))))) (;; Pipe connection t (let ((command (cons (plist-get config 'command) (cl-map 'list 'identity (plist-get config 'command-args))))) (setq process (make-process :name "dape adapter" :command command :connection-type 'pipe :coding 'utf-8-emacs-unix :stderr (setq stderr-buffer (generate-new-buffer "*dape-connection stderr*")) :file-handler t)) (when dape-debug (dape--message "Adapter started with %S" (mapconcat #'identity command " ")))))) (dape-connection :name (format "dape-%s<%d>" (or (and (car command) command) (when-let* ((port (plist-get config 'port))) (format "%s:%s" (or (plist-get config 'host) "localhost") port))) (cl-incf dape--connection-counter)) :config config :parent parent :server-process server-process :events-buffer-config `(:size ,(if dape-debug nil 0) :format full) :on-shutdown (lambda (conn) (unless (dape--initialized-p conn) (dape--warn "Adapter %sconnection shutdown without successfully initializing" (if (dape--parent conn) "child " ""))) ;; Is this a complete shutdown? (unless (dape--parent conn) ;; Clean source buffer (dape--stack-frame-cleanup) ;; Kill server process and its stderr buffer (when-let* ((server-process (dape--server-process conn))) (delete-process server-process) (while (process-live-p server-process) (accept-process-output nil nil 0.1))) (when-let* ((buf (dape--stderr-buffer conn)) ((buffer-live-p buf))) (when-let* ((pipe (get-buffer-process buf))) (delete-process pipe)) (kill-buffer buf)) ;; Remove from session list and update selection (setq dape--connections (delq conn dape--connections)) (when (eq dape--connection-selected conn) (when-let* ((next (car (dape--live-connections-root)))) (dape-select-session next))) ;; Run hooks and update mode line only when last session ends (unless dape--connections (dape-active-mode -1) (force-mode-line-update t)))) :request-dispatcher #'dape-handle-request :notification-dispatcher #'dape-handle-event :process process :stderr-buffer stderr-buffer))) ;;; Commands (defun dape-next (conn) "Step one line (skip functions). CONN is inferred for interactive invocations." (interactive (list (dape--live-connection 'stopped))) (dape--next-like-command conn :next)) (defun dape-step-in (conn) "Step into function/method. If not possible behaves like `dape-next'. CONN is inferred for interactive invocations." (interactive (list (dape--live-connection 'stopped))) (dape--next-like-command conn :stepIn)) (defun dape-step-out (conn) "Step out of function/method. If not possible behaves like `dape-next'. CONN is inferred for interactive invocations." (interactive (list (dape--live-connection 'stopped))) (dape--next-like-command conn :stepOut)) (defun dape-continue (conn) "Resumes execution. CONN is inferred for interactive invocations." (interactive (list (dape--live-connection 'stopped))) (unless (dape--stopped-threads conn) (user-error "No stopped threads")) (let ((body (dape--thread-id-object conn))) (unless body (user-error "Unable to derive thread to continued")) (dape--with-request-bind ((&key (allThreadsContinued t) &allow-other-keys) error) (dape-request conn :continue body) (if error (error "Failed to continue: %s" error) ;; From specification [continued] event: ;; A debug adapter is not expected to send this event in ;; response to a request that implies that execution ;; continues, e.g. launch or continue. (dape-handle-event conn 'continued `(,@body :allThreadsContinued ,allThreadsContinued)))))) (defun dape-pause (conn) "Pause execution. CONN is inferred for interactive invocations." (interactive (list (or (dape--live-connection 'running t) (dape--live-connection 'parent)))) (when (dape--stopped-threads conn) ;; cpptools crashes on pausing an paused thread (user-error "Thread is stopped")) (dape--with-request-bind (_body error) (dape-request conn :pause (or (dape--thread-id-object conn) '(:threadId 0))) (when error (error "Failed to pause: %s" error)))) (defun dape-restart (&optional conn skip-compile) "Restart debugging session. CONN is inferred for interactive invocations. SKIP-COMPILE is used internally for recursive calls." (interactive (list (dape--live-connection 'last t))) (dape--stack-frame-cleanup) (cond (;; Restart if adapter supports it (and conn (dape--capable-p conn :supportsRestartRequest)) (if (and (not skip-compile) (plist-get (dape--config conn) 'compile)) (dape--compile (dape--config conn) (lambda () (dape-restart conn 'skip-compile))) (dape--breakpoints-reset 'from-restart) (setq dape--connection-selected nil) (setf (dape--threads conn) nil (dape--thread-id conn) nil (dape--modules conn) nil (dape--sources conn) nil (dape--restart-in-progress-p conn) t) (when (length= (dape--live-connections-root) 1) (dape-active-mode -1)) (dape--with-request (dape-request conn :restart `(:arguments ,(dape--launch-or-attach-arguments conn))) (unless dape-active-mode (dape-active-mode +1)) (setf (dape--restart-in-progress-p conn) nil)))) (;; Use previous connections configuration dape--connections (let ((conn (or (and conn (dape--root-of conn)) (car dape--connections)))) (dape--with-request (dape-kill conn) (dape (dape--config conn))))) (;; Use history dape-history (dape (apply #'dape--config-eval (dape--config-from-string (car dape-history))))) ((user-error "Unable to derive session to restart, run `dape'")))) (defun dape--shutdown (conn) "Shutdown CONN and delete its jsonrpc buffers." ;; Signal the process first so the sentinel fires on iter 0 in ;; `jsonrpc-shutdown'. Preventing the misleading sentinel warning ;; (DAP has no client-initiated shutdown). (unwind-protect (let ((proc (jsonrpc--process conn))) ;; XXX Final call for timers to run while process exists. ;; May also swallow signals from non Dape owned ;; timer/sentinel/filter functions. (with-demoted-errors "%S" (accept-process-output nil 0.2)) (delete-process proc) (jsonrpc-shutdown conn t)) (unless dape-debug (kill-buffer (jsonrpc-events-buffer conn))))) (defun dape-kill (conn &optional cb with-disconnect) "Kill debug session. CB will be called after adapter termination. With WITH-DISCONNECT use disconnect instead of terminate used internally as a fallback to terminate. CONN is inferred for interactive invocations." (interactive (list (dape--live-connection 'parent))) (cond ((and conn (jsonrpc-running-p conn) (not with-disconnect) (dape--capable-p conn :supportsTerminateRequest)) (dape--with-request-bind (_body error) (dape-request conn :terminate nil) ;; We have to give up trying to kill the debuggee in an correct ;; way if the request timeout, otherwise we might force the ;; user to kill the process in some other way. (if (and error (not (eq error dape--timeout-error))) (dape-kill conn cb 'with-disconnect) (dape--shutdown conn) (dape--request-continue cb)))) ((and conn (jsonrpc-running-p conn)) (dape--with-request (dape-request conn :disconnect `( :restart :json-false ,@(when (dape--capable-p conn :supportTerminateDebuggee) '(:terminateDebuggee t)))) (dape--shutdown conn) (dape--request-continue cb))) (t (dape--request-continue cb)))) (defun dape-disconnect-quit (conn) "Kill adapter but try to keep debuggee live. This will leave a decoupled debugged process with no debugge connection. CONN is inferred for interactive invocations." (interactive (list (dape--live-connection 'parent))) (dape--kill-buffers 'skip-process-buffers) (dape--with-request (dape-request conn :disconnect '(:terminateDebuggee :json-false)) (dape--shutdown conn) (dape--kill-buffers))) (defun dape-quit () "Terminate all sessions and kill all Dape buffers." (interactive) (dape--kill-buffers 'skip-process-buffers) (if (not dape--connections) (dape--kill-buffers) (let (;; Use a lower timeout so an unresponsive adapter doesn't ;; block for too long. (dape-request-timeout 3) (conns (copy-sequence dape--connections)) (remaining (length dape--connections))) (dolist (conn conns) (dape--with-request (dape-kill conn) (cl-decf remaining) (when (zerop remaining) (dape--kill-buffers))))))) (defun dape-breakpoint-toggle () "Add or remove breakpoint at current line." (interactive) (if (cl-member nil (dape--breakpoints-at-point) :key #'dape--source-breakpoint-type) (dape-breakpoint-remove-at-point) (dape--breakpoint-place))) (defun dape-breakpoint-log (message) "Add log breakpoint at current line with MESSAGE. Expressions within {} are interpolated." (interactive (list (read-string "Log (Expressions within {} are interpolated): " (when-let* ((breakpoint (cl-find 'log (dape--breakpoints-at-point) :key #'dape--source-breakpoint-type))) (dape--source-breakpoint-value breakpoint))))) (if (string-empty-p message) (dape-breakpoint-remove-at-point) (dape--breakpoint-place 'log message))) (defun dape-breakpoint-expression (expression) "Add expression breakpoint at current line with EXPRESSION." ;; FIXME Rename to condition (interactive (list (read-string "Condition: " (when-let* ((breakpoint (cl-find 'expression (dape--breakpoints-at-point) :key #'dape--source-breakpoint-type))) (dape--source-breakpoint-value breakpoint))))) (if (string-empty-p expression) (dape-breakpoint-remove-at-point) (dape--breakpoint-place 'expression expression))) (defun dape-breakpoint-hits (condition) "Add hits breakpoint at current line with CONDITION. An hit HITS is an string matching regex: \"\\(!=\\|==\\|[%<>]\\) [:digit:]\"" (interactive (list (pcase-let ((`(_ ,operator) (let (use-dialog-box) (read-multiple-choice "Operator" '((?= "==" "Equals") (?! "!=" "Not equals") (?< "<" "Less then") (?> ">" "Greater then") (?% "%" "Modulus")))))) (thread-last operator (format "Breakpoint hit condition %s ") (read-number) (format "%s %d" operator))))) (if (string-empty-p condition) (dape-breakpoint-remove-at-point) (dape--breakpoint-place 'hits condition))) (defun dape-breakpoint-function (name) "Add function breakpoint for function NAME." (interactive (let ((default (when-let* ((sym (thing-at-point 'symbol))) (substring-no-properties sym)))) (list (read-string (format-prompt "Function name" default) nil nil default)))) (push (make-dape--function-breakpoint :name name) dape--breakpoints) (dolist (conn (dape--live-connections)) (when (dape--initialized-p conn) (dape--set-function-breakpoints conn))) (dape--display-buffer (dape--info-get-buffer-create 'dape-info-breakpoints-mode)) (run-hooks 'dape-update-ui-hook)) (defun dape-breakpoint-remove-at-point (&optional skip-notify) "Remove breakpoint, log breakpoint and expression at current line. When SKIP-NOTIFY is non-nil, do not notify adapters about removal." (interactive) (dolist (breakpoint (dape--breakpoints-at-point)) (dape--breakpoint-remove breakpoint skip-notify))) (defun dape-breakpoint-remove-all () "Remove all breakpoints." (interactive) (let* ((source-bps (cl-remove-if-not #'dape--source-breakpoint-p dape--breakpoints)) (sources (mapcar #'dape--breakpoint-source source-bps))) (dolist (breakpoint source-bps) (dape--breakpoint-remove breakpoint 'skip-notify)) (apply #'dape--breakpoint-notify-changes sources))) (defun dape-select-session (conn) "Select CONN as the active debug session." (interactive (let ((collection (cl-loop with root = (when dape--connection-selected (dape--root-of dape--connection-selected)) for c in (dape--live-connections-root) unless (eq c root) collect `(,(string-remove-prefix "dape-" (jsonrpc-name c)) ,c)))) (unless collection (user-error "No other active debug sessions")) (cdr (assoc (completing-read "Select session: " collection nil t) collection)))) (setq dape--connection-selected ;; Limit lookup scope to *this* session (let ((dape--connections (cl-loop with root = (dape--root-of conn) for conn in dape--connections when (eq (dape--root-of conn) root) collect conn))) (or (dape--live-connection 'last t) conn))) (when-let* ((buffer (dape--shell-buffer conn))) (dape--display-buffer buffer)) (dape--update dape--connection-selected nil t) (dape--mode-line-format) (force-mode-line-update t)) (defun dape-select-thread (conn thread-id) "Select current active thread. With prefix argument thread is selected by index starting at 1. The thread is identified by THREAD-ID under adapter CONN." (interactive (let* ((conn (dape--live-connection 'last)) (collection (cl-loop with index = 0 for conn in (dape--session-connections conn) append (cl-loop for thread in (dape--threads conn) collect (list (format "%s %s" (cl-incf index) (plist-get thread :name)) conn (plist-get thread :id))))) (thread-name (if (numberp current-prefix-arg) (car (nth (1- current-prefix-arg) collection)) (completing-read (format "Select thread (current %s): " (thread-first conn (dape--current-thread) (plist-get :name))) collection nil t)))) (alist-get thread-name collection nil nil #'equal))) (setf (dape--thread-id conn) thread-id) (setq dape--connection-selected conn) (dape--update conn nil t) (dape--mode-line-format)) (defun dape-select-stack (conn stack-id) "Select current active stack. With prefix argument stack is selected by index starting at 1. The stack is identified by STACK-ID under adapter CONN." (interactive (let* ((conn (dape--live-connection 'stopped)) (current-thread (dape--current-thread conn)) (collection ;; Only one stack frame is guaranteed to be available, ;; so we need to reach out to make sure we got the full set. ;; See `dape--stack-trace'. (let ((dape--request-blocking t)) (dape--with-request (dape--stack-trace conn current-thread dape-stack-trace-levels)) (mapcar (lambda (stack) (cons (plist-get stack :name) (plist-get stack :id))) (plist-get current-thread :stackFrames)))) (stack-name (if (numberp current-prefix-arg) (car (nth (1- current-prefix-arg) collection)) (completing-read (format "Select stack (current %s): " (plist-get (dape--current-stack-frame conn) :name)) collection nil t)))) (list conn (alist-get stack-name collection nil nil #'equal)))) (setf (dape--stack-id conn) stack-id) (dape--update conn nil t)) (defun dape-stack-select-up (conn n) "Select N (numeric arg) stacks above current selected stack. Use CONN to specify adapter connection." (interactive (list (dape--live-connection 'stopped) 1)) ;; Ensure all threads. See `dape--stack-trace'. (let ((dape--request-blocking t)) (dape--with-request (dape--stack-trace conn (dape--current-thread conn) dape-stack-trace-levels))) (if (dape--stopped-threads conn) (let* ((frames (plist-get (dape--current-thread conn) :stackFrames)) (current-n (cl-position (dape--current-stack-frame conn) frames))) (dape-select-stack conn (plist-get (nth (+ current-n n) frames) :id))) (message "No stopped threads"))) (defun dape-stack-select-down (conn n) "Select N (numeric arg) stacks below current selected stack. Use CONN to specify adapter connection." (interactive (list (dape--live-connection 'stopped) 1)) (dape-stack-select-up conn (* n -1))) (defun dape-watch-dwim (expression &optional remove-only-p add-only-p display-p) "Toggle watch for EXPRESSION. When called interactively the EXRPRESSION defaults to symbol at point or active region. If REMOVE-ONLY-P is non-nil only allow removal of an existing watch. If ADD-ONLY-P is non-nil only allow adding a new watch. If DISPLAY-P is non-nil display-p the watch buffer." (interactive (let* ((map (copy-keymap minibuffer-local-completion-map)) (minibuffer-local-completion-map map) (default (or (and (region-active-p) (buffer-substring (region-beginning) (region-end))) (thing-at-point 'symbol)))) (define-key map " " #'self-insert-command) (define-key map "?" #'self-insert-command) (list (string-trim (completing-read (format-prompt "Toggle watch of expression" default) (mapcar (lambda (plist) (plist-get plist :name)) dape--watched) nil nil nil nil default)) nil nil t))) (if-let* ((watched (cl-find expression dape--watched :key (lambda (plist) (plist-get plist :name)) :test #'equal))) (unless add-only-p (setq dape--watched (cl-delete watched dape--watched))) (unless remove-only-p (push (list :name expression) dape--watched))) (when display-p (dape--display-buffer (dape--info-get-buffer-create 'dape-info-watch-mode))) (run-hooks 'dape-update-ui-hook)) (defun dape-evaluate-expression (conn expression &optional context) "Evaluate expression in current session. If called interactively and region is active evaluate region. EXPRESSION should be a string to be evaluated in CONTEXT. CONN is inferred by either last stopped then last created connection." (interactive (list (or (dape--live-connection 'stopped t) (dape--live-connection 'last)) (if (region-active-p) (buffer-substring (region-beginning) (region-end)) (let ((default (thing-at-point 'symbol))) (read-string (format-prompt "Evaluate" default) nil nil default))))) (dape--with-request-bind ((&whole body &key variablesReference result &allow-other-keys) error) (dape--evaluate-expression conn (plist-get (dape--current-stack-frame conn) :id) expression (or context "repl")) (cond (error (if (string-empty-p error) (dape--warn "Failed to evaluate `%s'" (substring-no-properties expression)) (dape--repl-insert-error (concat (string-trim-right error) "\n")))) ((and (get-buffer "*dape-repl*") (numberp variablesReference) (not (zerop variablesReference))) (dape--repl-insert (concat (dape--repl-variable (plist-put body :name expression)) "\n"))) (t ;; Refresh is needed as evaluate can change values (dape--update conn 'variables nil) (dape--repl-insert (concat result "\n")))))) (defun dape-restart-frame (conn stack-id) "Restart execution from selected stack frame. The frame is identified by STACK-ID under adapter CONN." (interactive (let ((conn (dape--live-connection 'stopped t))) (list conn (dape--stack-id conn)))) (unless (dape--capable-p conn :supportsRestartFrame) (user-error "Adapter not capable of restarting frame")) (dape-select-stack conn stack-id) (let* ((current-frame (dape--current-stack-frame conn)) (frame-id (plist-get current-frame :id))) (dape--with-request-bind (_body error) (dape-request conn :restartFrame `(:frameId ,frame-id)) (when error (dape--warn "Failed to restart stack frame: %s" error))))) ;;;###autoload (defun dape (config &optional skip-compile) "Start debugging session with selected configuration. When called interactively, the command prompts for a alist KEY from `dape-configs', followed by additional property-value pairs. These pairs override the properties in the plist associated with the key in `dape-configs'. For example, interactively invoking: launch :program \"bin\" executes the `launch' configuration from `dape-configs', overriding the `:program' option with \"bin\". CONFIG is an keyword-value plist, see VALUEs in `dape-config' alist. SKIP-COMPILE argument is used internally for recursive calls and should not be specified manually. For more information see `dape-configs'." (interactive (let* ((config (dape--read-config))) (when-let* ((live (dape--live-connections-root))) (let (;; XXX Save and restore `last-command-event' to ignore ;; yes/no inputs to keep transient `repeat-mode' map. (saved-event last-command-event)) (when (yes-or-no-p (format "Session(s) %s running; kill? " (mapconcat (lambda (c) (string-remove-prefix "dape-" (jsonrpc-name c))) live ", "))) (dape--kill-busy-wait)) (setq last-command-event saved-event))) (list config))) (dape--config-ensure config t) (when-let* ((fn (or (plist-get config 'fn) 'identity)) (fns (or (and (functionp fn) (list fn)) (and (listp fn) fn)))) (setq config (seq-reduce (lambda (config fn) (funcall fn config)) (append fns dape-default-config-functions) (copy-tree config)))) (if (and (not skip-compile) (plist-get config 'compile)) (dape--compile config (lambda () (dape config 'skip-compile))) (let ((conn (dape--create-connection config))) (push conn dape--connections) (setq dape--connection-selected conn) ;; Hooks run after connection is registered so `dape-repl' ;; and `dape-info' can use the active session. (run-hooks 'dape-start-hook) (dape--start-debugging conn)))) ;;; Compile (defvar-local dape--compile-after-fn nil) (defun dape--compile-compilation-finish (buffer str) "Hook for `dape--compile-compilation-finish'. Using BUFFER and STR." (remove-hook 'compilation-finish-functions #'dape--compile-compilation-finish) (if (equal "finished\n" str) (progn (funcall dape--compile-after-fn) (run-hook-with-args 'dape-compile-hook buffer)) (dape--warn "Compilation failed \"%s\"" (string-trim-right str)))) (defun dape--compile (config fn) "Start compilation for CONFIG then call FN." (let ((default-directory (dape--guess-root config)) (command (dape-config-get config 'compile))) (funcall dape-compile-function command) (with-current-buffer (compilation-find-buffer) (setq dape--compile-after-fn fn) (add-hook 'compilation-finish-functions #'dape--compile-compilation-finish nil t)))) ;;; Memory viewer (defvar-local dape--memory-address nil "Buffer local var to keep track of current address.") (defvar dape--memory-debounce-timer (timer-create) "Debounce context for `dape-memory-revert'.") (defun dape--memory-address-number () "Return `dape--memory-address' as an number." (thread-first dape--memory-address (substring 2) (string-to-number 16))) (defun dape--memory-revert (&optional _ignore-auto _noconfirm _preserve-modes) "Revert buffer function for `dape-memory-mode'." (let* ((conn (dape--live-connection 'last)) (write-capable-p (dape--capable-p conn :supportsWriteMemoryRequest))) (unless (dape--capable-p conn :supportsReadMemoryRequest) (user-error "Adapter not capable of reading memory")) (unless dape--memory-address (user-error "`dape--memory-address' not set")) (dape--with-request-bind ((&key address data &allow-other-keys) error) (dape-request conn :readMemory (list :memoryReference dape--memory-address :count dape-memory-page-size)) (cond (error (message "Failed to read memory: %s" error)) ((not data) (message "No bytes returned from adapter")) (t (setq dape--memory-address address hexl-max-address (1- dape-memory-page-size) buffer-undo-list nil) (let ((address (dape--memory-address-number)) (temp-buffer (generate-new-buffer " *temp*" t)) (buffer-empty-p (zerop (buffer-size)))) (with-current-buffer temp-buffer (insert (base64-decode-string data)) (let (buffer-undo-list) (hexlify-buffer)) ;; Now we need to apply offset to the addresses, ughh (goto-char (point-min)) (while (re-search-forward "^[0-9a-f]+" nil t) (let ((address (thread-last (string-to-number (match-string 0) 16) (+ address) (format "%08x")))) (delete-region (match-beginning 0) (match-end 0)) ;; `hexl' does not support address over 8 hex chars (insert (append (substring address (- (length address) 8))))))) (replace-region-contents (point-min) (point-max) (lambda () temp-buffer)) (when buffer-empty-p (hexl-goto-address 0)) (kill-buffer temp-buffer)) (set-buffer-modified-p nil) (when write-capable-p (add-hook 'write-contents-functions #'dape--memory-write))))))) (defun dape--memory-write () "Write buffer contents to stopped connection." (let ((conn (dape--live-connection 'last)) (buffer (current-buffer)) (address dape--memory-address)) (with-temp-buffer (insert-buffer-substring buffer) (dehexlify-buffer) (dape--with-request-bind (_body error) (dape-request conn :writeMemory (list :memoryReference address :data (base64-encode-string (buffer-string) t))) (if error (message "Failed to write memory: %s" error) (with-current-buffer buffer (set-buffer-modified-p nil)) (message "Memory written successfully at %s" address) (dape--update conn 'variables nil))))) ;; Return `t' to signal buffer written t) (define-derived-mode dape-memory-mode hexl-mode "Memory" "Major mode for interacting with debuggee's memory." :interactive nil (setq revert-buffer-function #'dape--memory-revert mode-line-buffer-identification (append mode-line-buffer-identification '(" {" dape--memory-address "}")) eldoc-documentation-functions nil)) (define-key dape-memory-mode-map "\C-x]" #'dape-memory-next-page) (define-key dape-memory-mode-map "\C-x[" #'dape-memory-previous-page) (defun dape-memory-next-page (&optional backward) "Move address `dape-memory-page-size' forward. When BACKWARD is non-nil move backward instead." (interactive nil dape-memory-mode) (dape-memory (format "0x%08x" (funcall (if backward #'- #'+) (dape--memory-address-number) dape-memory-page-size)) t)) (defun dape-memory-previous-page () "Move address `dape-memory-page-size' backward." (interactive nil dape-memory-mode) (dape-memory-next-page 'backward)) (defun dape-memory-revert () "Revert all `dape-memory-mode' buffers." (dape--with-debounce dape--memory-debounce-timer dape-ui-debounce-time (cl-loop for buffer in (buffer-list) when (eq (buffer-local-value 'major-mode buffer) 'dape-memory-mode) do (with-current-buffer buffer (revert-buffer))))) (define-obsolete-variable-alias 'dape-read-memory 'dape-memory "0.24.0") (defun dape-memory (address &optional reuse-buffer) "View and edit memory from ADDRESS in hex dump format. If REUSE-BUFFER is non-nil reuse the current buffer to display result of memory read." (interactive (list (string-trim (let ((default (when-let* ((number (thing-at-point 'number))) (format "0x%08x" number)))) (read-string (format-prompt "View memory at address" default) nil nil default))))) (let ((conn (dape--live-connection 'stopped))) (unless (dape--capable-p conn :supportsReadMemoryRequest) (user-error "Adapter not capable of reading memory")) (let ((buffer (if reuse-buffer (current-buffer) (generate-new-buffer "*dape-memory*")))) (with-current-buffer buffer (unless (eq major-mode 'dape-memory-mode) (dape-memory-mode) (when (dape--capable-p conn :supportsWriteMemoryRequest) (message (substitute-command-keys "Write memory with `\\[save-buffer]'")))) (setq dape--memory-address address) (revert-buffer)) (select-window (dape--display-buffer buffer))))) ;;; Disassemble viewer (defvar-local dape--disassemble-overlay-arrow nil) (add-to-list 'overlay-arrow-variable-list 'dape--disassemble-overlay-arrow) (define-derived-mode dape-disassemble-mode asm-mode "Disassemble" "Major mode for viewing debuggee's disassembled code." :interactive nil ;; TODO Add support for :SetInstructionBreakpoints (setq-local dape--disassemble-overlay-arrow (make-marker) dape-stepping-granularity 'instruction)) (defvar dape--disassemble-debounce-timer (timer-create) "Debounce context for `dape-disassemble-revert'.") (defun dape-disassemble-revert () "Revert all `dape-disassemble-mode' buffers." (dape--with-debounce dape--disassemble-debounce-timer dape-ui-debounce-time (cl-loop for buffer in (buffer-list) when (eq (buffer-local-value 'major-mode buffer) 'dape-disassemble-mode) do (with-current-buffer buffer (revert-buffer))))) (defun dape-disassemble (address &optional display-p) "View disassemble of instructions at ADDRESS. If DISPLAY-P is non-nil, display buffer." (interactive (list (let ((default `(,@(when-let* ((number (thing-at-point 'number))) (list (format "0x%08x" number))) ,@(when-let* ((conn (dape--live-connection 'stopped t)) (address (plist-get (dape--current-stack-frame conn) :instructionPointerReference))) (list address))))) (string-trim (read-string (format-prompt "Disassemble at address" default) nil nil default))) t)) (if-let* ((conn (dape--live-connection 'stopped)) ((not (dape--capable-p conn :supportsDisassembleRequest)))) (user-error "Adapter does not support disassemble") (dape--with-request-bind ((&key ((:instructions instructions)) &allow-other-keys) _) (dape-request conn :disassemble `( :memoryReference ,address :instructionCount 100 :offset 0 :instructionOffset -50 :resolveSymbols t)) (cl-flet ((address-to-int (address) (string-to-number (substring address 2) 16))) (with-current-buffer (get-buffer-create "*dape-disassemble*") (dape-disassemble-mode) (erase-buffer) (cl-loop with last-symbol with last-location with ps = (address-to-int (plist-get (dape--current-stack-frame conn) :instructionPointerReference)) with source = (plist-get (dape--current-stack-frame conn) :source) with line = (plist-get (dape--current-stack-frame conn) :line) for instruction across instructions for address = (address-to-int (plist-get instruction :address)) for current-instruction-p = (equal address ps) for location = (setq last-location ;; Forward fill all location if missing as per spec (or (plist-get instruction :location) last-location)) for current-line-p = (and (equal location source) (equal (plist-get instruction :line) line)) do (when-let* ((symbol (plist-get instruction :symbol)) ((not (equal last-symbol symbol)))) (insert (concat "; " (setq last-symbol symbol) " of " (thread-first instruction (plist-get :location) (plist-get :name))) ":\n")) (when current-instruction-p (move-marker dape--disassemble-overlay-arrow (point))) (insert (propertize (format "%s:\t%s\n" (plist-get instruction :address) (plist-get instruction :instruction)) 'line-prefix (when current-line-p (dape--indicator "|" 'vertical-bar nil)) 'dape--disassemble-instruction instruction))) (setq-local revert-buffer-function (lambda (&rest _) (dape-disassemble address))) (when (or display-p (marker-position dape--disassemble-overlay-arrow)) (select-window (dape--display-buffer (current-buffer)))) (goto-char (or (marker-position dape--disassemble-overlay-arrow) (point-min))) (when (marker-position dape--disassemble-overlay-arrow) (run-hooks 'dape-display-source-hook))))))) ;;; Breakpoints (defun dape--breakpoint-buffer (breakpoint) "Return buffer visiting BREAKPOINT if exists." (when-let* (((dape--source-breakpoint-p breakpoint)) (overlay (dape--source-breakpoint-location breakpoint)) ((overlayp overlay))) (overlay-buffer overlay))) (defun dape--breakpoint-file-name (breakpoint) "Return file name for BREAKPOINT." (when-let* (((dape--source-breakpoint-p breakpoint)) (location (dape--source-breakpoint-location breakpoint))) (cond ((overlayp location) (buffer-file-name (overlay-buffer location))) ((consp location) (car location))))) (defun dape--breakpoint-line (breakpoint) "Return line number for BREAKPOINT." (when-let* (((dape--source-breakpoint-p breakpoint)) (location (dape--source-breakpoint-location breakpoint))) (cond ((overlayp location) (with-current-buffer (overlay-buffer location) (line-number-at-pos (overlay-start location)))) ((consp location) (cdr location))))) (defun dape--breakpoint-source (breakpoint) "Return the source of BREAKPOINT. Source is either a buffer or file name." (if-let* ((buffer (dape--breakpoint-buffer breakpoint))) buffer (dape--breakpoint-file-name breakpoint))) (defun dape--breakpoints-in-buffer () "Return list of source breakpoints in current buffer." (cl-remove (current-buffer) dape--breakpoints :key #'dape--breakpoint-buffer :test-not #'eq)) (defun dape--breakpoint-make-overlay (breakpoint) "Create and set overlay for BREAKPOINT." (add-hook 'kill-buffer-hook #'dape--breakpoint-buffer-kill-hook nil t) (let ((ov (apply #'make-overlay (dape--overlay-region))) (disabled-face (when (dape--breakpoint-disabled breakpoint) 'shadow))) (overlay-put ov 'modification-hooks '(dape--breakpoint-freeze)) (overlay-put ov 'category 'dape-breakpoint) (overlay-put ov 'window t) (cl-flet ((make-after-string (label face mouse-1-help mouse-1-def) (concat " " (propertize (format "%s: %s" label (dape--source-breakpoint-value breakpoint)) 'face face 'mouse-face 'highlight 'help-echo (format "mouse-1: %s" mouse-1-help) 'keymap (let ((map (make-sparse-keymap))) (define-key map [mouse-1] mouse-1-def) map))))) (pcase (dape--source-breakpoint-type breakpoint) ('log (overlay-put ov 'after-string (make-after-string "Log" (or disabled-face 'dape-log-face) "edit log message" #'dape-mouse-breakpoint-log))) ('expression (overlay-put ov 'after-string (make-after-string "Cond" (or disabled-face 'dape-expression-face) "edit break condition" #'dape-mouse-breakpoint-expression))) ('hits (overlay-put ov 'after-string (make-after-string "Hits" (or disabled-face 'dape-hits-face) "edit break hit condition" #'dape-mouse-breakpoint-hits))) ('until (overlay-put ov 'before-string (dape--indicator dape-breakpoint-margin-string 'breakpoint 'dape-breakpoint-until-face))) (_ (overlay-put ov 'before-string (dape--indicator dape-breakpoint-margin-string 'breakpoint (or disabled-face 'dape-breakpoint-face)))))) (setf (dape--source-breakpoint-location breakpoint) ov))) (dape--mouse-command dape-mouse-breakpoint-toggle "Toggle breakpoint at current line." dape-breakpoint-toggle) (dape--mouse-command dape-mouse-breakpoint-log "Add log breakpoint at current line." dape-breakpoint-log) (dape--mouse-command dape-mouse-breakpoint-expression "Add expression breakpoint at current line." dape-breakpoint-expression) (dape--mouse-command dape-mouse-breakpoint-hits "Add hits breakpoint at current line." dape-breakpoint-hits) (defvar dape-breakpoint-mode-map (let ((map (make-sparse-keymap))) (define-key map [left-fringe mouse-1] #'dape-mouse-breakpoint-toggle) (define-key map [left-margin mouse-1] #'dape-mouse-breakpoint-toggle) ;; TODO Would be nice if mouse-2 would open an menu for any ;; breakpoint type (expression, log and hit). (define-key map [left-fringe mouse-2] #'dape-mouse-breakpoint-expression) (define-key map [left-margin mouse-2] #'dape-mouse-breakpoint-expression) (define-key map [left-fringe mouse-3] #'dape-mouse-breakpoint-log) (define-key map [left-margin mouse-3] #'dape-mouse-breakpoint-log) map) "Keymap for `dape-breakpoint-mode'.") (define-minor-mode dape-breakpoint-mode "Toggle clickable breakpoint controls in fringe or margins." :lighter nil) (defun turn-on-dape-breakpoint-mode () "Turn on `dape-breakpoint-mode' if derived from `prog-mode'." (when (derived-mode-p 'prog-mode) (dape-breakpoint-mode 1))) ;;;###autoload (define-globalized-minor-mode dape-breakpoint-global-mode dape-breakpoint-mode turn-on-dape-breakpoint-mode) (defun dape--breakpoint-maybe-remove-ff-hook () "Remove the `find-file-hook' if all source breakpoints have buffers." (cl-loop for breakpoint in dape--breakpoints when (dape--source-breakpoint-p breakpoint) always (bufferp (dape--breakpoint-source breakpoint)) finally (remove-hook 'find-file-hook #'dape--breakpoint-find-file-hook))) (defun dape--breakpoint-find-file-hook () "Add overlays to breakpoints in current buffer. Called as a hook in `find-file-hook'." (when-let* ((buffer-file-name (buffer-file-name))) (cl-loop for breakpoint in dape--breakpoints when (dape--source-breakpoint-p breakpoint) for filename = (dape--breakpoint-file-name breakpoint) for line = (dape--breakpoint-line breakpoint) when (and (equal buffer-file-name filename) line) do (dape--with-line (current-buffer) line (dape--breakpoint-make-overlay breakpoint) (run-hooks 'dape-update-ui-hook)))) (dape--breakpoint-maybe-remove-ff-hook)) (defun dape--breakpoint-freeze (overlay _after _begin _end &optional _len) "Ensure OVERLAY covers the entire line." (apply #'move-overlay overlay (dape--overlay-region))) (defun dape--breakpoints-reset (&optional keep-state) "Reset breakpoints state. If KEEP-STATE is non-nil preserve ID and VERIFIED state." (dolist (breakpoint dape--breakpoints) (unless keep-state (setf (dape--breakpoint-id breakpoint) nil (dape--breakpoint-verified breakpoint) nil)) (setf (dape--breakpoint-hits breakpoint) nil))) (defun dape--breakpoints-at-point () "Return list of source breakpoints at current point." (cl-loop with current-line = (line-number-at-pos (point)) for breakpoint in dape--breakpoints when (and (dape--source-breakpoint-p breakpoint) (eq (current-buffer) (dape--breakpoint-buffer breakpoint)) (equal current-line (dape--breakpoint-line breakpoint))) collect breakpoint)) (defun dape--breakpoint-notify-changes (&rest sources) "Notify adapters of breakpoint changes in SOURCES." (dolist (source (cl-remove-duplicates sources :test #'equal)) (dolist (conn (dape--live-connections)) (when (and source (dape--initialized-p conn)) (dape--set-breakpoints-in-source conn source)))) (run-hooks 'dape-update-ui-hook)) (defun dape--breakpoint-notify-all () "Notify adapters of changes in `dape--breakpoint's sources." (apply #'dape--breakpoint-notify-changes (mapcar #'dape--breakpoint-source (cl-remove-if-not #'dape--source-breakpoint-p dape--breakpoints)))) (defun dape--breakpoint-buffer-kill-hook (&rest _) "Convert overlay breakpoints in current buffer." (let ((buffer-file-name (buffer-file-name (current-buffer)))) (dolist (breakpoint (dape--breakpoints-in-buffer)) (cond (buffer-file-name (let ((line (dape--breakpoint-line breakpoint))) (dape--breakpoint-delete-overlay breakpoint) (setf (dape--source-breakpoint-location breakpoint) `(,buffer-file-name . ,line))) (add-hook 'find-file-hook #'dape--breakpoint-find-file-hook)) (t (dape--breakpoint-remove breakpoint)))))) (defun dape--breakpoint-place (&optional type value skip-notify) "Place and return breakpoint at current line. TYPE is expected to be nil, `log', `expression', `hits', or `until'. If TYPE is `log', `expression', or `hits', VALUE should be a string. Unless SKIP-NOTIFY is non-nil, notify all connections. Note: removes existing breakpoints at the line before placing." (dape-breakpoint-remove-at-point 'skip-notify) (let ((breakpoint (make-dape--source-breakpoint :type type :value value))) (dape--breakpoint-make-overlay breakpoint) (push breakpoint dape--breakpoints) (unless skip-notify (dape--breakpoint-notify-changes (current-buffer))) breakpoint)) (defun dape--breakpoint-delete-overlay (breakpoint) "Delete overlay of BREAKPOINT and restore margin if needed." (let ((overlay (dape--source-breakpoint-location breakpoint))) (when-let* ((buffer (dape--breakpoint-buffer breakpoint))) (with-current-buffer buffer (when (and ;; If margin has been touched dape--original-margin ;; ...and no breakpoints left in margin (not (cl-some (lambda (bp) (let ((type (dape--source-breakpoint-type bp))) (or (not type) (eq 'until type)))) (dape--breakpoints-in-buffer)))) ;; ...the margin should be reset (setq-local left-margin-width dape--original-margin dape--original-margin nil) (when-let* ((window (get-buffer-window buffer))) (set-window-margins window left-margin-width right-margin-width) (redisplay t))))) (when (overlayp overlay) (delete-overlay overlay)) (setf (dape--source-breakpoint-location breakpoint) nil))) (defun dape--breakpoint-disable (breakpoint disabled) "Set BREAKPOINT overlay state to DISABLED." (setf (dape--breakpoint-disabled breakpoint) disabled) (when-let* ((buffer (dape--breakpoint-buffer breakpoint)) (line (dape--breakpoint-line breakpoint)) ((bufferp buffer))) (dape--breakpoint-delete-overlay breakpoint) (dape--with-line buffer line (dape--breakpoint-make-overlay breakpoint)))) (defun dape--breakpoint-remove (breakpoint &optional skip-notify) "Remove BREAKPOINT from `dape--breakpoints' and notify adapters. If SKIP-NOTIFY is non-nil, do not notify adapter about removal." (setq dape--breakpoints (delq breakpoint dape--breakpoints)) (when (dape--source-breakpoint-p breakpoint) (unless skip-notify (dape--breakpoint-notify-changes (dape--breakpoint-source breakpoint))) (dape--breakpoint-delete-overlay breakpoint) (dape--breakpoint-maybe-remove-ff-hook)) (run-hooks 'dape-update-ui-hook)) (defun dape--breakpoint-update (conn breakpoint update) "Update BREAKPOINT with UPDATE plist from CONN." (unless (dape--breakpoint-disabled breakpoint) ;; Update `dape--breakpoint' data (setf (dape--breakpoint-id breakpoint) (plist-put (dape--breakpoint-id breakpoint) conn (plist-get update :id)) (dape--breakpoint-verified breakpoint) (plist-put (dape--breakpoint-verified breakpoint) conn (eq (plist-get update :verified) t))) ;; Move breakpoints and notify adapters (let ((buffer (dape--breakpoint-buffer breakpoint)) (line (dape--breakpoint-line breakpoint)) (new-line (plist-get update :line))) ;; Skip work and notify if nothing has moved (when (and (numberp line) (numberp new-line) (not (eq line new-line))) (dape--breakpoint-delete-overlay breakpoint) (if buffer (dape--with-line buffer new-line (dape-breakpoint-remove-at-point 'skip-notify) (dape--breakpoint-make-overlay breakpoint) (pulse-momentary-highlight-region (line-beginning-position) (line-beginning-position 2) 'next-error)) (setcdr (dape--source-breakpoint-location breakpoint) new-line)) (dape--breakpoint-notify-changes (dape--breakpoint-source breakpoint)) (dape--message "Breakpoint in %s moved from line %s to %s" (if buffer (buffer-name buffer) (dape--breakpoint-file-name breakpoint)) line new-line)))) (run-hooks 'dape-update-ui-hook)) (defun dape-breakpoint-load (&optional filename) "Restore breakpoints from previously saved FILE. All breakpoints will be removed before loading new ones. Will open buffers containing breakpoints. Will use `dape-default-breakpoints-file' if FILENAME is nil." (interactive (list (read-file-name "Load breakpoints from file: "))) (setq filename (or filename dape-default-breakpoints-file)) (when (file-exists-p filename) (dape-breakpoint-remove-all) (let ((breakpoints (with-temp-buffer (insert-file-contents filename) (goto-char (point-min)) (nreverse (read (current-buffer)))))) (cl-loop for (filename line type value) in breakpoints if (find-buffer-visiting filename) do (dape--with-line (find-file-noselect filename) line (dape--breakpoint-place type value)) else do (add-hook 'find-file-hook #'dape--breakpoint-find-file-hook) (push (make-dape--source-breakpoint :location (cons filename line) :type type :value value) dape--breakpoints)))) (dape--breakpoint-notify-all)) (defun dape-breakpoint-save (&optional filename) "Save all breakpoints to FILE for later restoration. Will use `dape-default-breakpoints-file' if FILENAME is nil." (interactive (list (read-file-name "Save breakpoints to file: "))) (setq filename (or filename dape-default-breakpoints-file)) (with-temp-buffer (insert ";; Generated by `dape-breakpoint-save'\n" ";; Load breakpoints with `dape-breakpoint-load'\n\n") (cl-loop for breakpoint in dape--breakpoints for filename = (dape--breakpoint-file-name breakpoint) when filename collect `(,filename ,(dape--breakpoint-line breakpoint) ,(dape--source-breakpoint-type breakpoint) ,(dape--source-breakpoint-value breakpoint)) into serialized finally do (prin1 serialized (current-buffer))) ;; Skip write if nothing has changed since last save (unless (and (file-exists-p filename) (equal (buffer-string) (with-temp-buffer (insert-file-contents filename) (buffer-string)))) (write-region (point-min) (point-max) filename nil (unless (called-interactively-p 'interactive) 'quiet))))) ;;; Source buffers (defun dape--source-make-buffer (conn name reference content mime-type) "Make source buffer from REFERENCE for CONN's session. Created from NAME, MIME-TYPE, REFERENCE and CONTENT." (let ((root (dape--root-of conn)) (buffer (generate-new-buffer (format "*dape-source %s*" name)))) (setf (dape--source-buffers root) (plist-put (dape--source-buffers root) reference buffer)) (with-current-buffer buffer (when mime-type (if-let* ((mode (cdr (assoc mime-type dape-mime-mode-alist)))) (unless (eq major-mode mode) (funcall mode)) (message "Unknown mime type %s, see `dape-mime-mode-alist'" mime-type))) (setq buffer-read-only t) (let ((inhibit-read-only t)) (erase-buffer) (insert content)) (goto-char (point-min))))) (defun dape--source-ensure (conn plist cb) "Ensure that source object in PLIST exist for adapter CONN. See `dape-request' for expected CB signature." (let* ((source (plist-get plist :source)) (filename (plist-get source :path)) (reference (plist-get source :sourceReference)) (buffer (plist-get (dape--source-buffers (dape--root-of conn)) reference))) (cond ((or (and (stringp filename) (file-exists-p (dape--file-name-local conn filename))) (and (buffer-live-p buffer))) (dape--request-continue cb)) ((and (numberp reference) (< 0 reference)) (dape--with-request-bind ((&key content mimeType &allow-other-keys) error) (dape-request conn :source (list :source source :sourceReference reference)) (cond (error (dape--warn "%s" error)) (content (dape--source-make-buffer conn (plist-get source :name) reference content mimeType) (dape--request-continue cb)))))))) ;;; Stack frame source (defvar dape--overlay-arrow-position (make-marker) "Dape stack position marker.") (add-to-list 'overlay-arrow-variable-list 'dape--overlay-arrow-position) (defvar dape--stack-position-overlay nil "Dape stack position overlay for line.") (defun dape--stack-frame-cleanup () "Cleanup after `dape--stack-frame-display'." (when-let* ((buffer (marker-buffer dape--overlay-arrow-position))) (with-current-buffer buffer (dape--remove-eldoc-hook))) (when (overlayp dape--stack-position-overlay) (delete-overlay dape--stack-position-overlay)) (set-marker dape--overlay-arrow-position nil)) (defun dape--stack-frame-display-1 (conn frame selected-p first-selected-p) "Display FRAME for adapter CONN. If SELECTED-P is non-nil, this frame is selected. If FIRST-SELECTED-P is non-nil, the top frame is selected. Helper for `dape--stack-frame-display'." (dape--with-request (dape--source-ensure conn frame) ;; Delete overlay before dropping the reference (dape--stack-frame-cleanup) (when-let* ((marker (dape--object-to-marker conn frame))) (with-current-buffer (marker-buffer marker) (dape--add-eldoc-hook) (save-excursion (goto-char (marker-position marker)) (setq dape--stack-position-overlay (let ((ov (make-overlay (line-beginning-position) (line-beginning-position 2)))) (overlay-put ov 'category 'dape-source-line) (overlay-put ov 'face 'dape-source-line-face) (when-let* (first-selected-p (description (dape--exception-description conn))) (overlay-put ov 'after-string (propertize description 'face 'dape-exception-description-face))) ov) fringe-indicator-alist (unless (and selected-p first-selected-p) '((overlay-arrow . hollow-right-triangle)))) ;; Move `overaly-arrow' arrow to point (move-marker dape--overlay-arrow-position (line-beginning-position))) (when-let* ((window (display-buffer (marker-buffer marker) dape-display-source-buffer-action))) ;; Change selected window if not `dape-repl' buffer is selected (unless (with-current-buffer (window-buffer) (cl-some #'derived-mode-p '(dape-repl-mode dape-info-parent-mode dape-disassemble-mode))) (select-window window)) (with-selected-window window ;; XXX This is where point is moved after step commands. ;; Which means that `post-command-hook' has already run ;; from `dape-next' etc. Can't call the hook directly ;; from this timer context because it will lead to ;; strangeness, but we can handle the important bits. (goto-char (marker-position marker)) ;; ...like fixing `hl-line' (when (featurep 'hl-line) (cond (global-hl-line-mode (global-hl-line-highlight)) ((and hl-line-mode hl-line-sticky-flag) (hl-line-highlight)))) (run-hooks 'dape-display-source-hook))))))) (defun dape--stack-frame-display (conn) "Update stack frame arrow marker for adapter CONN. Buffer is displayed with `dape-display-source-buffer-action'." (dape--stack-frame-cleanup) (when (dape--stopped-threads conn) (cl-labels ((displayable-p (source) (or (when-let* ((reference (plist-get source :sourceReference))) (< 0 reference)) (when-let* ((remote-path (plist-get source :path)) (filename (dape--file-name-local conn remote-path))) (file-exists-p filename)))) (displayable-frame-args () (cl-loop with thread = (dape--current-thread conn) with thread-frames = (plist-get thread :stackFrames) with selected = (dape--current-stack-frame conn) for frames on thread-frames when (eq (car frames) selected) return (cl-loop for frame in frames when (displayable-p (plist-get frame :source)) return `(,frame ,(eq frame selected) ,(eq (car thread-frames) selected)))))) ;; Check if `displayable-p' frame exist among frames, ;; otherwise fetch all (e.g. :supportsDelayedStackTraceLoading ;; but frame zero is not displayable) (if-let* ((args (displayable-frame-args))) (apply #'dape--stack-frame-display-1 conn args) (dape--with-request (dape--stack-trace conn (dape--current-thread conn) dape-stack-trace-levels) (when-let* ((args (displayable-frame-args))) (apply #'dape--stack-frame-display-1 conn args))))))) ;;; Info Buffers (defvar-local dape--info-buffer-related nil "List of related buffers.") (defvar-local dape--info-buffer-index nil "Per mode buffer index.") (defvar dape--info-buffers nil "List containing `dape-info' buffers.") (defvar dape--info-buffer-display-history nil "History list in (MODE INDEX).") (defun dape--info-buffer-list () "Return all live `dape-info-parent-mode' buffers." (setq dape--info-buffers (cl-delete-if-not #'buffer-live-p dape--info-buffers))) (defun dape--info-buffer-p (mode &optional index) "Is buffer of MODE with INDEX." (and (derived-mode-p mode) (or (not index) (equal dape--info-buffer-index index)))) (defun dape--info-window-group () "Return current buffer's info group. See `dape-info-buffer-window-groups'." (cl-find-if (lambda (group) (cl-some (lambda (spec) (apply #'dape--info-buffer-p (ensure-list spec))) group)) dape-info-buffer-window-groups)) (defun dape-info-buffer-tab (&optional reversed) "Select next related buffer. If REVERSED is non-nil selects previous buffer in group. Customizable by `dape-info-buffer-window-groups'." (interactive '() dape-info-parent-mode) (unless dape--info-buffer-related (user-error "No related buffers for current buffer")) (pcase-let* ((order-fn (if reversed 'reverse 'identity)) (`(,mode ,index) (or (thread-last dape--info-buffer-related (append dape--info-buffer-related) (funcall order-fn) (seq-drop-while (pcase-lambda (`(,mode ,index)) (not (dape--info-buffer-p mode index)))) (cadr)) (car dape--info-buffer-related)))) (push `(,mode ,index) dape--info-buffer-display-history) (gdb-set-window-buffer (dape--info-get-buffer-create mode index) t))) (defvar dape-info-parent-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "") (lambda () (interactive) (dape-info-buffer-tab t))) (define-key map "\t" #'dape-info-buffer-tab) map) "Keymap for `dape-info-parent-mode'.") (defun dape--info-buffer-change-fn (&rest _rest) "Hook fn for `window-buffer-change-functions' to ensure update." (when (derived-mode-p 'dape-info-parent-mode) (ignore-errors (revert-buffer)))) (defvar-local dape--info-debounce-timer nil "Debounce context for `dape-info-parent-mode' buffers.") (cl-defmethod dape--info-revert :around (&rest _) "Wrap `dape--info-revert' methods within an debounce context. Each buffers store its own debounce context." (let ((buffer (current-buffer))) (dape--with-debounce dape--info-debounce-timer dape-ui-debounce-time (when (buffer-live-p buffer) (with-current-buffer buffer (cl-call-next-method)))))) (define-derived-mode dape-info-parent-mode special-mode "" "Major mode to derive all Dape info buffer modes from." :interactive nil (setq-local buffer-read-only t cursor-in-non-selected-windows nil revert-buffer-function #'dape--info-revert dape--info-debounce-timer (timer-create)) (add-hook 'window-buffer-change-functions #'dape--info-buffer-change-fn nil 'local) (when dape-info-hide-mode-line (setq-local mode-line-format nil)) (buffer-disable-undo)) (defun dape--info-header (name mode index help-echo mouse-face face) "Helper to create buffer header. Creates header with string NAME, mouse map to select buffer identified with MODE and INDEX (see `dape--info-buffer-index') with HELP-ECHO string, MOUSE-FACE and FACE." (let ((command (lambda (event) (interactive "e") (save-selected-window (select-window (posn-window (event-start event))) (let ((buffer (dape--info-get-buffer-create mode index))) (with-current-buffer buffer (revert-buffer)) (push `(,mode ,index) dape--info-buffer-display-history) (gdb-set-window-buffer buffer t))))) (map (make-sparse-keymap))) (define-key map (vector 'header-line 'mouse-1) command) (define-key map (vector 'header-line 'down-mouse-1) command) (propertize name 'help-echo help-echo 'mouse-face mouse-face 'face face 'keymap map))) (defun dape--info-call-update-with (fn) "Helper for `dape--info-revert' functions. Erase BUFFER content and updates `header-line-format'. FN is expected to update insert buffer contents, update `dape--info-buffer-related' and `header-line-format'." ;; Save buffer as `select-window' sets buffer (save-current-buffer (when (derived-mode-p 'dape-info-parent-mode) ;; Would be nice with `replace-buffer-contents', but it messes ;; up string properties (let ((line (line-number-at-pos (point) t)) (old-window (selected-window))) ;; Try to keep point and scroll (when-let* ((window (get-buffer-window))) (select-window window)) (save-window-excursion (let ((inhibit-read-only t)) (erase-buffer) (funcall fn)) (ignore-errors (goto-char (point-min)) (forward-line (1- line)) (beginning-of-line)) (dape--info-set-related-buffers)) (when old-window (select-window old-window)))))) (defmacro dape--info-update-with (&rest body) "Create an update function from BODY. See `dape--info-call-update-with'." (declare (indent 0)) `(dape--info-call-update-with (lambda () ,@body))) (defun dape--info-get-live-buffer (mode &optional index) "Get live dape info buffer with MODE and INDEX." (seq-find (lambda (buffer) (with-current-buffer buffer (dape--info-buffer-p mode index))) (dape--info-buffer-list))) (defun dape--info-get-buffer-create (mode &optional index) "Get or create info buffer with MODE and INDEX." (with-current-buffer (or (dape--info-get-live-buffer mode index) (get-buffer-create (dape--info-buffer-name mode index))) (unless (eq major-mode mode) (funcall mode) (when index (setq dape--info-buffer-index index)) (dape--info-set-related-buffers) (push (current-buffer) dape--info-buffers)) (current-buffer))) (defun dape-info-update () "Update and display dape info buffers." (dolist (buffer (dape--info-buffer-list)) (when (get-buffer-window buffer) (with-current-buffer buffer (revert-buffer))))) (defun dape-info (&optional maybe-kill) "Display debug info buffers showing variables, stack, etc. If MAYBE-KILL is non-nil (which is always true when called interactively) and all info buffers are already displayed, kill each buffer info buffer. See `dape-info-buffer-window-groups' for how to customize which buffers get displayed and how they are grouped." (interactive (list t)) (let (buffer-displayed-p) (cl-loop with displayed-buffers = (cl-remove-if-not #'get-buffer-window (dape--info-buffer-list)) for group in dape-info-buffer-window-groups unless (cl-loop for spec in group thereis (cl-some (lambda (buffer) (with-current-buffer buffer (apply #'dape--info-buffer-p (ensure-list spec)))) displayed-buffers)) do (setq buffer-displayed-p t) (dape--display-buffer (apply #'dape--info-get-buffer-create (or ;; Try to re-create the last window setup (cl-find-if (pcase-lambda (`(,hist-mode ,hist-index)) (cl-find-if (pcase-lambda (`(,spec-mode ,spec-index)) (and (eq hist-mode spec-mode) (or (not spec-index) (eq hist-index spec-index)))) group :key #'ensure-list)) dape--info-buffer-display-history) ;; ...or fallback to car if no history (ensure-list (car group)))))) (when (and maybe-kill (not buffer-displayed-p)) (cl-loop for buffer in (dape--info-buffer-list) do (kill-buffer buffer))) (dape-info-update))) (defconst dape--info-buffer-name-alist '((dape-info-breakpoints-mode . "Breakpoints") (dape-info-threads-mode . "Threads") (dape-info-stack-mode . "Stack") (dape-info-modules-mode . "Modules") (dape-info-sources-mode . "Sources") (dape-info-watch-mode . "Watch") (dape-info-scope-mode . "Scope")) "Lookup for `dape-info-parent-mode' derived modes names.") (defun dape--info-buffer-name (mode &optional index) "Return buffer name for MODE and INDEX." (concat (format "*dape-info %s*" (alist-get mode dape--info-buffer-name-alist)) (when (and index (> index 0)) (format "<%s>" index)))) (defun dape--info-set-related-buffers () "Set related buffers and `header-line-format'." (let* ((conn (dape--live-connection 'stopped t)) (scopes (plist-get (dape--current-stack-frame conn) :scopes))) (when (or (not dape--info-buffer-related) scopes) (setq ;; Set related buffers dape--info-buffer-related (cl-loop for spec in (dape--info-window-group) for (mode index) = (ensure-list spec) append (cond ((and (eq 'dape-info-scope-mode mode) (not index)) (cl-loop for scope in scopes for index upfrom 0 collect `(dape-info-scope-mode ,index ,(plist-get scope :name)))) ((and (eq 'dape-info-scope-mode mode) index) (when-let* ((scope (nth index scopes))) `((dape-info-scope-mode ,index ,(plist-get scope :name))))) (`((,mode nil ,(alist-get mode dape--info-buffer-name-alist)))))) ;; Show buffer tabs in header-line header-line-format (cl-loop for (mode index name) in dape--info-buffer-related append `(,(if (dape--info-buffer-p mode index) (dape--info-header name mode index nil nil 'dape-header-line-active-face) (dape--info-header name mode index "mouse-1: select" 'dape-header-line-hover-face 'dape-header-line-inactive-face)) " ")))))) ;;; Info breakpoints buffer (dape--command-at-line dape-info-breakpoint-disable (dape--breakpoint) (dape-info-breakpoints-mode) "Enable or disable breakpoint at current line without removing it." (unless (dape--source-breakpoint-p dape--breakpoint) (user-error "Disable is only supported for source breakpoints")) (dape--breakpoint-disable dape--breakpoint (not (dape--breakpoint-disabled dape--breakpoint))) (dape--breakpoint-notify-changes (dape--breakpoint-source dape--breakpoint)) (revert-buffer) (run-hooks 'dape-update-ui-hook)) (dape--command-at-line dape-info-breakpoint-dwim (dape--breakpoint) (dape-info-breakpoints-mode) "Toggle exception or goto source breakpoint at current line." (cl-typecase dape--breakpoint (dape--source-breakpoint (with-selected-window (display-buffer (or (dape--breakpoint-buffer dape--breakpoint) (find-file-noselect (dape--breakpoint-file-name dape--breakpoint))) dape-display-source-buffer-action) (goto-char (point-min)) (forward-line (1- (dape--breakpoint-line dape--breakpoint))))) (dape--exception-breakpoint (setf (dape--breakpoint-disabled dape--breakpoint) (not (dape--breakpoint-disabled dape--breakpoint))) (dolist (conn (dape--live-connections)) (dape--set-exception-breakpoints conn)) (revert-buffer) (run-hooks 'dape-update-ui-hook)))) (dape--command-at-line dape-info-breakpoint-delete (dape--breakpoint) (dape-info-breakpoints-mode) "Delete breakpoint at current line." (cl-typecase dape--breakpoint (dape--exception-breakpoint (setf (dape--breakpoint-disabled dape--breakpoint) t) (dolist (conn (dape--live-connections)) (dape--set-exception-breakpoints conn))) (dape--function-breakpoint (dape--breakpoint-remove dape--breakpoint) (dolist (conn (dape--live-connections)) (when (dape--initialized-p conn) (dape--set-function-breakpoints conn)))) (dape--data-breakpoint (dape--breakpoint-remove dape--breakpoint) (when-let* ((conn (dape--live-connection 'stopped t))) (dape--with-request (dape--set-data-breakpoints conn)))) (t (dape--breakpoint-remove dape--breakpoint))) (revert-buffer) (run-hooks 'dape-update-ui-hook)) (dape--command-at-line dape-info-breakpoint-log-edit (dape--breakpoint) (dape-info-breakpoints-mode) "Edit breakpoint at current line." (with-selected-window (display-buffer (or (dape--breakpoint-buffer dape--breakpoint) (find-file-noselect (dape--breakpoint-file-name dape--breakpoint))) dape-display-source-buffer-action) (goto-char (point-min)) (forward-line (1- (dape--breakpoint-line dape--breakpoint))) (pcase (dape--source-breakpoint-type dape--breakpoint) ('log (call-interactively #'dape-breakpoint-log)) ('expression (call-interactively #'dape-breakpoint-expression)) ('hits (call-interactively #'dape-breakpoint-hits)) (_ (user-error "Unable to edit breakpoint on line without log or \ expression breakpoint"))))) (dape--buffer-map dape-info-breakpoints-mode-line-map dape-info-breakpoint-dwim "D" #'dape-info-breakpoint-disable "d" #'dape-info-breakpoint-delete "e" #'dape-info-breakpoint-log-edit) (defvar dape-info-breakpoints-mode-map (copy-keymap dape-info-breakpoints-mode-line-map)) (define-derived-mode dape-info-breakpoints-mode dape-info-parent-mode "Breakpoints" "Major mode for viewing and editing breakpoints." :interactive nil (setq truncate-lines t)) (cl-defmethod dape--info-revert (&context (major-mode dape-info-breakpoints-mode) &rest _) "Revert buffer function for MAJOR-MODE `dape-info-breakpoints-mode'." (dape--info-update-with (let ((table (make-gdb-table)) (y (propertize "y" 'font-lock-face 'font-lock-warning-face)) (n (propertize "n" 'font-lock-face 'font-lock-doc-face))) (cl-loop for breakpoint in dape--breakpoints for enabled-or-hits = (cond ((dape--breakpoint-disabled breakpoint) n) ((when-let* ((hits (dape--breakpoint-hits breakpoint))) (propertize (format "%s" hits) 'font-lock-face 'font-lock-warning-face))) (y)) for (row prop) = (cl-typecase breakpoint (dape--function-breakpoint (let* ((verified-plist (dape--breakpoint-verified breakpoint)) (verified-p (or (not (dape--live-connection 'last t)) (cl-find-if (apply-partially #'plist-get verified-plist) (dape--live-connections))))) `(("Func " ,(dape--function-breakpoint-name breakpoint)) ( dape--breakpoint ,breakpoint ,@(unless verified-p '(font-lock-face shadow)))))) (dape--data-breakpoint `(("Data " ,(format "%s %s %s" (propertize (dape--data-breakpoint-name breakpoint) 'font-lock-face 'font-lock-variable-name-face) (dape--data-breakpoint-access-type breakpoint) (when-let* ((id (dape--data-breakpoint-data-id breakpoint))) (format "(%s)" id)))) (dape--breakpoint ,breakpoint))) (dape--source-breakpoint (let* ((line (dape--breakpoint-line breakpoint)) (verified-plist (dape--breakpoint-verified breakpoint)) (verified-p (or ;; No live connection show all as verified (not (dape--live-connection 'last t)) ;; Actually verified by any connection (cl-find-if (apply-partially #'plist-get verified-plist) (dape--live-connections)) ;; If hit then must be verified (dape--breakpoint-hits breakpoint)))) `((,(pcase (dape--source-breakpoint-type breakpoint) ('log "Log ") ('hits "Hits ") ('expression "Cond ") ('until "Until") (_ "Break")) ,(or ;; If buffer live, display part of the line (when-let* ((buffer (dape--breakpoint-buffer breakpoint))) (concat (if-let* ((filename (buffer-file-name buffer))) (dape--format-file-name-line filename line) (format "%s:%d" (buffer-name buffer) line)) (concat " " (thread-first (dape--with-line buffer line (or (thing-at-point 'line) "")) (string-trim-right) (truncate-string-to-width 80 nil nil t))))) ;; Otherwise just show filename:line (when-let* ((filename (dape--breakpoint-file-name breakpoint))) (dape--format-file-name-line filename line)))) ( dape--breakpoint ,breakpoint mouse-face highlight help-echo "mouse-2, RET: visit breakpoint" ,@(unless verified-p '(font-lock-face shadow)))))) (dape--exception-breakpoint `(("Excep" ,(dape--exception-breakpoint-label breakpoint)) ( dape--breakpoint ,breakpoint mouse-face highlight help-echo "mouse-2, RET: toggle exception")))) when row do (gdb-table-add-row table (cons enabled-or-hits row) prop)) (insert (gdb-table-string table " "))))) ;;; Info threads buffer (defvar dape--info-thread-position nil "`dape-info-thread-mode' marker for `overlay-arrow-variable-list'.") (defvar-local dape--info-threads-skip-other-p nil ;; XXX Some adapters bork on parallel stack traces "If non-nil skip fetching thread information for other threads.") (defvar dape-info--threads-tt-bench 2 "Time to Bench.") (dape--command-at-line dape-info-select-thread (dape--thread dape--conn) (dape-info-thread-mode) "Select thread at current line." (dape-select-thread dape--conn (plist-get dape--thread :id)) (revert-buffer)) (defvar dape--info-threads-font-lock-keywords '(("in \\([^ ^(]+\\)" (1 font-lock-function-name-face)) (" \\(unknown\\)" (1 font-lock-warning-face)) (" \\(stopped\\)" (1 font-lock-warning-face)) (" \\(exited\\)" (1 font-lock-warning-face)) (" \\(running\\)" (1 font-lock-string-face)) (" \\(started\\)" (1 font-lock-string-face))) "Keywords for `dape-info-threads-mode'.") (dape--buffer-map dape-info-threads-mode-line-map dape-info-select-thread ;; TODO Add bindings for individual threads. ) (defvar dape-info-threads-mode-map (copy-keymap dape-info-threads-mode-line-map)) (defun dape--info-threads-stack-info (conn cb) "Populate stack frame info for CONNs threads. See `dape-request' for expected CB signature." (let (threads) (cond ;; Current CONN is benched (dape--info-threads-skip-other-p (dape--request-continue cb)) ;; Stopped threads ((setq threads (cl-remove-if (lambda (thread) (plist-get thread :request-in-flight)) (dape--stopped-threads conn))) (let ((start-time (current-time)) (responses 0)) (dolist (thread threads) ;; Keep track of requests in flight as `revert-buffer' might ;; be called at any time, and we want keep unnecessary ;; chatter at a minimum. (plist-put thread :request-in-flight t) (dape--with-request (dape--stack-trace conn thread 1) (plist-put thread :request-in-flight nil) ;; Time response, if slow skip these kind of requests in ;; the future (saving state in buffer local variable) (when (and (not dape--info-threads-skip-other-p) (time-less-p (timer-relative-time start-time dape-info--threads-tt-bench) (current-time))) (dape--warn "Disabling stack info for other threads (slow)") (setq dape--info-threads-skip-other-p t)) ;; When all request have resolved return (when (length= threads (setf responses (1+ responses))) (dape--request-continue cb)))))) ;; No stopped threads (t (dape--request-continue cb))))) (define-derived-mode dape-info-threads-mode dape-info-parent-mode "Threads" "Major mode for viewing and selecting threads." :interactive nil (setq font-lock-defaults '(dape--info-threads-font-lock-keywords) dape--info-thread-position (make-marker)) (add-to-list 'overlay-arrow-variable-list 'dape--info-thread-position)) (cl-defmethod dape--info-revert (&context (major-mode dape-info-threads-mode) &rest _) "Revert buffer function for MAJOR-MODE `dape-info-threads-mode'." (if-let* ((conn (dape--live-connection 'last t)) ((dape--threads conn))) (dape--with-request (dape--info-threads-stack-info conn) (cl-loop initially do (set-marker dape--info-thread-position nil) with table = (make-gdb-table) with conns = (dape--session-connections conn) with current-thread = (dape--current-thread conn) with line = 0 with selected-line for conn in conns for index upfrom 1 do (cl-loop for thread in (dape--threads conn) do (cl-incf line) (when (eq current-thread thread) (setq selected-line line)) (gdb-table-add-row table `(,(format "%s" line) ,(concat (plist-get thread :name) " " (if-let* ((status (plist-get thread :status))) (format "%s" status) "") (if-let* (((equal (plist-get thread :status) 'stopped)) (top-stack (car (plist-get thread :stackFrames)))) (concat " in " (plist-get top-stack :name) (when-let* ((dape-info-thread-buffer-locations) (path (thread-first top-stack (plist-get :source) (plist-get :path))) (filename (dape--file-name-local conn path)) (line (plist-get top-stack :line))) (concat " of " (dape--format-file-name-line filename line))) (when-let* ((dape-info-thread-buffer-addresses) (addr (plist-get top-stack :instructionPointerReference))) (concat " at " addr)) " ")))) `( dape--conn ,conn dape--thread ,thread dape--selected ,(eq current-thread thread) mouse-face highlight help-echo "mouse-2, RET: select thread"))) finally do (dape--info-update-with (insert (gdb-table-string table " ")) (when selected-line (gdb-mark-line selected-line dape--info-thread-position))))) (dape--info-update-with (set-marker dape--info-thread-position nil) (insert "No thread information available.")))) ;;; Info stack buffer (defvar dape--info-stack-position nil "`dape-info-stack-mode' marker for `overlay-arrow-variable-list'.") (defvar dape--info-stack-font-lock-keywords '(("^[ 0-9]+ \\([^ ^(]+\\)" (1 font-lock-function-name-face))) "Font lock keywords used in `gdb-frames-mode'.") (dape--command-at-line dape-info-stack-select (dape--frame) (dape-info-stack--mode) "Select stack frame at current line." (dape-select-stack (dape--live-connection 'stopped) (plist-get dape--frame :id)) (revert-buffer)) (dape--command-at-line dape-info-stack-memory (dape--frame) (dape-info-stack--mode) "View and edit memory of stack frame at current line." (if-let* ((ref (plist-get dape--frame :instructionPointerReference))) (dape-memory ref) (user-error "No address for frame"))) (dape--command-at-line dape-info-stack-disassemble (dape--frame) (dape-info-stack--mode) "View disassemble of stack frame at current line." (if-let* ((address (plist-get dape--frame :instructionPointerReference))) (dape-disassemble address) (user-error "No address for frame"))) (dape--buffer-map dape-info-stack-mode-line-map dape-info-stack-select "m" #'dape-info-stack-memory "M" #'dape-info-stack-disassemble "D" #'dape-info-stack-disassemble) (defvar dape-info-stack-mode-map (copy-keymap dape-info-stack-mode-line-map)) (define-derived-mode dape-info-stack-mode dape-info-parent-mode "Stack" "Major mode for viewing and navigating the call stack." :interactive nil (setq font-lock-defaults '(dape--info-stack-font-lock-keywords) truncate-lines t dape--info-stack-position (make-marker)) (add-to-list 'overlay-arrow-variable-list 'dape--info-stack-position)) (defun dape--info-stack-buffer-insert (conn current-stack-frame stack-frames) "Helper for inserting stack info into stack buffer. Create table from CURRENT-STACK-FRAME and STACK-FRAMES and insert into current buffer with CONN config." (cl-loop with table = (make-gdb-table) with selected-line for line from 1 for frame in stack-frames do (when (eq current-stack-frame frame) (setq selected-line line)) (gdb-table-add-row table `(,(format "%s" line) ,(concat (plist-get frame :name) (when-let* ((dape-info-stack-buffer-locations) (filename (thread-first frame (plist-get :source) (plist-get :path))) (filename (dape--file-name-local conn filename))) (concat " of " (dape--format-file-name-line filename (plist-get frame :line)))) (when-let* ((dape-info-stack-buffer-addresses) (ref (plist-get frame :instructionPointerReference))) (concat " at " ref)) " ")) `( dape--frame ,frame dape--selected ,(eq current-stack-frame frame) mouse-face highlight help-echo "mouse-2, RET: select frame")) finally do (insert (gdb-table-string table " ")) (when selected-line (gdb-mark-line selected-line dape--info-stack-position)))) (cl-defmethod dape--info-revert (&context (major-mode dape-info-stack-mode) &rest _) "Revert buffer function for MAJOR-MODE `dape-info-stack-mode'." (let* ((conn (or (dape--live-connection 'stopped t t) (dape--live-connection 'last t t))) (current-thread (dape--current-thread conn)) (current-stack-frame (dape--current-stack-frame conn))) (cond ((or (not current-stack-frame) (not (dape--stopped-threads conn))) (dape--info-update-with (set-marker dape--info-stack-position nil) (cond (current-thread (insert (format "Thread \"%s\" is not stopped." (plist-get current-thread :name)))) (t (insert "No stack information available."))))) (;; Only one frame are guaranteed to be available due to ;; `supportsDelayedStackTraceLoading' optimizations (dape--with-request (dape--stack-trace conn current-thread dape-stack-trace-levels) ;; If stack trace lookup with `dape-stack-trace-levels' frames changed ;; the stack frame list, we need to update the buffer again (dape--info-update-with (dape--info-stack-buffer-insert conn current-stack-frame (plist-get current-thread :stackFrames)))))))) ;;; Info modules buffer (defvar dape--info-modules-font-lock-keywords '(("^No" (1 default)) ;; Skip fontification of placeholder string ("^\\([^ ]+\\) " (1 font-lock-function-name-face))) "Font lock keywords used in `gdb-frames-mode'.") (dape--command-at-line dape-info-modules-goto (dape--module) (dape-info-modules-mode) "Goto module at current line." (let ((conn (dape--live-connection 'last t)) (source (list :source dape--module))) (dape--with-request (dape--source-ensure conn source) (if-let* ((marker (dape--object-to-marker conn source))) (pop-to-buffer (marker-buffer marker)) (user-error "Unable to open module"))))) (dape--buffer-map dape-info-modules-mode-line-map dape-info-modules-goto) (defvar dape-info-modules-mode-map (copy-keymap dape-info-modules-mode-line-map)) (define-derived-mode dape-info-modules-mode dape-info-parent-mode "Modules" "Major mode for viewing loaded modules." :interactive nil (setq font-lock-defaults '(dape--info-modules-font-lock-keywords)) (dape--info-update-with (insert "No modules available."))) (cl-defmethod dape--info-revert (&context (major-mode dape-info-modules-mode) &rest _) "Revert buffer function for MAJOR-MODE `dape-info-modules-mode'." ;; Use last connection if current is dead (when-let* ((conn (or (dape--live-connection 'stopped t) (dape--live-connection 'last t))) (modules (dape--modules conn))) (dape--info-update-with (cl-loop with table = (make-gdb-table) for module in (reverse modules) do (gdb-table-add-row table `(,(concat (plist-get module :name) (when-let* ((path (plist-get module :path))) (concat " of " (dape--format-file-name-line path nil))) (when-let* ((address-range (plist-get module :addressRange))) (concat " at " address-range nil)) " ")) `( dape--module ,module mouse-face highlight help-echo ,(format "mouse-2: goto module"))) finally (insert (gdb-table-string table " ")))))) ;;; Info sources buffer (dape--command-at-line dape-info-sources-goto (dape--source) (dape-info-sources-mode) "Goto source at current line." (let ((conn (dape--live-connection 'last t)) (source (list :source dape--source))) (dape--with-request (dape--source-ensure conn source) (if-let* ((marker (dape--object-to-marker conn source))) (pop-to-buffer (marker-buffer marker)) (user-error "Unable to get source"))))) (dape--buffer-map dape-info-sources-mode-line-map dape-info-sources-goto) (defvar dape-info-sources-mode-map (copy-keymap dape-info-sources-mode-line-map)) (define-derived-mode dape-info-sources-mode dape-info-parent-mode "Sources" "Major mode for viewing loaded sources." :interactive nil (dape--info-update-with (insert "No sources available."))) (cl-defmethod dape--info-revert (&context (major-mode dape-info-sources-mode) &rest _) "Revert buffer function for MAJOR-MODE `dape-info-sources-mode'." ;; Use last connection if current is dead (when-let* ((conn (or (dape--live-connection 'stopped t) (dape--live-connection 'last t))) (sources (dape--sources conn))) (dape--info-update-with (cl-loop with table = (make-gdb-table) for source in (reverse sources) do (gdb-table-add-row table (list (concat (plist-get source :name) " ")) `( dape--source ,source mouse-face highlight help-echo "mouse-2, RET: goto source")) finally (insert (gdb-table-string table " ")))))) ;;; Info scope buffer (defvar dape--variable-expanded-p (make-hash-table :test 'equal) "Hash table to keep track of expanded info variables.") (defun dape--variable-expanded-p (path) "If PATH should be expanded." (gethash path dape--variable-expanded-p (when-let* ((auto-expand ;; See `dape-variable-auto-expand-alist'. ;; Expects car of PATH to specify context (or (alist-get (car (last path)) dape-variable-auto-expand-alist) (alist-get nil dape-variable-auto-expand-alist)))) (length< path (+ auto-expand 2))))) (dape--command-at-line dape-info-scope-toggle (dape--path) (dape-info-scope-mode dape-info-watch-mode) "Expand or contract variable at current line." (unless (dape--live-connection 'stopped) (user-error "No stopped threads")) (puthash dape--path (not (dape--variable-expanded-p dape--path)) dape--variable-expanded-p) (revert-buffer)) (dape--buffer-map dape-info-variable-prefix-map dape-info-scope-toggle) (dape--command-at-line dape-info-scope-watch-dwim (dape--variable) (dape-info-scope-mode dape-info-watch-mode) "Add or remove variable from watch at current line." (dape-watch-dwim (or (plist-get dape--variable :evaluateName) (plist-get dape--variable :name)) (eq major-mode 'dape-info-watch-mode) (eq major-mode 'dape-info-scope-mode)) (revert-buffer)) (dape--buffer-map dape-info-variable-name-map dape-info-scope-watch-dwim) (dape--command-at-line dape-info-variable-edit (dape--reference dape--variable) (dape-info-scope-mode dape-info-watch-mode) "Edit variable value at current line." (dape--set-variable (dape--live-connection 'stopped) dape--reference dape--variable (let ((default (or (plist-get dape--variable :value) (plist-get dape--variable :result)))) (read-string (format-prompt "Set value of %s `%s'" default (plist-get dape--variable :type) (plist-get dape--variable :name)) nil nil default)))) (dape--buffer-map dape-info-variable-value-map dape-info-variable-edit) (dape--command-at-line dape-info-scope-data-breakpoint (dape--reference dape--variable) (dape-info-scope-mode dape-info-watch-mode) "Add data breakpoint on variable at current line." (let ((conn (dape--live-connection 'stopped)) (name (or (plist-get dape--variable :evaluateName) (plist-get dape--variable :name)))) (unless (dape--capable-p conn :supportsDataBreakpoints) (user-error "Adapter does not support data breakpoints")) (dape--with-request-bind ((&key dataId description accessTypes &allow-other-keys) error) (dape-request conn :dataBreakpointInfo (if (numberp dape--reference) (list :variablesReference dape--reference :name name) (list :name name :frameId (plist-get (dape--current-stack-frame conn) :id)))) (if (or error (not (stringp dataId))) (message "Unable to set data breakpoint: %s" (or error description)) (push (make-dape--data-breakpoint :name name :data-id dataId :access-type (completing-read (format "Breakpoint type for `%s': " name) (append accessTypes nil) nil t)) dape--breakpoints) (dape--with-request (dape--set-data-breakpoints conn) ;; Make sure breakpoint buffer is displayed (dape--display-buffer (dape--info-get-buffer-create 'dape-info-breakpoints-mode)) (run-hooks 'dape-update-ui-hook)))))) (dape--command-at-line dape-info-variable-memory (dape--variable) (dape-info-scope-mode dape-info-watch-mode) "View memory of variable at current line." (if-let* ((memory-reference (plist-get dape--variable :memoryReference))) (dape-memory memory-reference) (user-error "No memory reference for `%s' variable" (plist-get dape--variable :name)))) (defvar dape-info-scope-mode-line-map (let ((map (make-sparse-keymap))) (define-key map "e" #'dape-info-scope-toggle) (define-key map "W" #'dape-info-scope-watch-dwim) (define-key map "=" #'dape-info-variable-edit) (define-key map "b" #'dape-info-scope-data-breakpoint) (define-key map "m" #'dape-info-variable-memory) map) "Keymap for buffers displaying variables.") (defvar dape-info-scope-mode-map (copy-keymap dape-info-scope-mode-line-map)) (defun dape--info-locals-table-columns-list (alist) "Format and arrange the columns in locals display based on ALIST." ;; Stolen from gdb-mi but reimpleted due to usage of dape customs ;; org function `gdb-locals-table-columns-list'. (let (columns) (dolist (config dape-info-variable-table-row-config columns) (let* ((key (car config)) (max (cdr config)) (prop-org (alist-get key alist)) (prop prop-org)) (when prop-org (setq prop (substring prop 0 (string-match-p "\n" prop))) (if (and (> max 0) (length> prop max)) (push (propertize (string-truncate-left prop max) 'help-echo prop-org) columns) (push prop columns))))) (nreverse columns))) (defun dape--info-scope-add-variable (table object reference path test-expanded &optional no-handles) "Add variable OBJECT with REFERENCE and PATH to TABLE. TEST-EXPANDED is called with PATH and OBJECT to determine if recursive calls should continue. If NO-HANDLES is non-nil skip + - handles." (let* ((name (or (plist-get object :name) "")) (name (if (string-empty-p name) (or (plist-get object :evaluateName) "") name)) (type (or (plist-get object :type) "")) (value (or (plist-get object :value) (plist-get object :result) " ")) (prefix (make-string (* (1- (length path)) 2) ?\s)) (path (cons name path)) (expanded-p (funcall test-expanded path)) row) (setq name (propertize name 'font-lock-face 'font-lock-variable-name-face 'mouse-face 'highlight 'help-echo "mouse-2: create or remove watch expression" 'keymap dape-info-variable-name-map) type (propertize type 'font-lock-face 'font-lock-type-face) value (propertize value 'mouse-face 'highlight 'help-echo "mouse-2: edit value" 'keymap dape-info-variable-value-map) prefix (cond (no-handles prefix) ((zerop (or (plist-get object :variablesReference) 0)) (concat prefix " ")) ((and expanded-p (plist-get object :variables)) (concat (propertize (concat prefix "-") 'mouse-face 'highlight 'help-echo "mouse-2: contract" 'keymap dape-info-variable-prefix-map) " ")) ((concat (propertize (concat prefix "+") 'mouse-face 'highlight 'help-echo "mouse-2: expand" 'keymap dape-info-variable-prefix-map) " "))) row (dape--info-locals-table-columns-list `((name . ,name) (type . ,type) (value . ,value)))) (setcar row (concat prefix (car row))) (gdb-table-add-row table (if dape-info-variable-table-aligned row (list (mapconcat #'identity row " "))) `( dape--variable ,object dape--path ,path ;; `dape--command-at-line' expects non-nil dape--reference ,(or reference 'nothing))) (when expanded-p ;; TODO Should be paged (dolist (variable (plist-get object :variables)) (dape--info-scope-add-variable table variable (plist-get object :variablesReference) path test-expanded no-handles))))) ;; FIXME Empty header line when adapter is killed (define-derived-mode dape-info-scope-mode dape-info-parent-mode "Scope" "Major mode for viewing and editing scoped variables." :interactive nil (setq dape--info-buffer-index 0) (dape--info-update-with (insert "No scope information available."))) (cl-defmethod dape--info-revert (&context (major-mode dape-info-scope-mode) &rest _) "Revert buffer function for MAJOR-MODE `dape-info-scope-mode'." (when-let* ((conn (or (dape--live-connection 'stopped t) (dape--live-connection 'last t))) (frame (dape--current-stack-frame conn)) (scopes (plist-get frame :scopes)) ;; FIXME Scope list could have shrunk and ;; `dape--info-buffer-index' can be out of bounds. (scope (nth dape--info-buffer-index scopes)) ;; Check for stopped threads to reduce flickering ((dape--stopped-threads conn))) (dape--with-request (dape--variables conn scope) (dape--with-request (dape--variables-recursive conn scope (list dape--info-buffer-index) #'dape--variable-expanded-p) (when (and scope scopes (dape--stopped-threads conn)) (dape--info-update-with (cl-loop with table = (make-gdb-table) for object in (plist-get scope :variables) initially do (setf (gdb-table-right-align table) dape-info-variable-table-aligned) do (dape--info-scope-add-variable table object (plist-get scope :variablesReference) (list dape--info-buffer-index) #'dape--variable-expanded-p) finally (insert (gdb-table-string table " "))))))))) ;;; Info watch buffer (defvar dape-info-watch-mode-line-map (copy-keymap dape-info-scope-mode-line-map)) (defvar dape-info-watch-mode-map (let ((map (make-composed-keymap (copy-keymap dape-info-watch-mode-line-map)))) (define-key map "\C-x\C-q" #'dape-info-watch-edit-mode) map)) (define-derived-mode dape-info-watch-mode dape-info-parent-mode "Watch" "Major mode for viewing watch expressions." :interactive nil) (cl-defmethod dape--info-revert (&context (major-mode dape-info-watch-mode) &rest _) "Revert buffer function for MAJOR-MODE `dape-info-watch-mode'." (let ((conn (dape--live-connection 'stopped t))) (cond ((not dape--watched) (dape--info-update-with (insert "No watched variable."))) (conn (let ((frame (dape--current-stack-frame conn)) (responses 0)) (dolist (plist dape--watched) (plist-put plist :variablesReference nil) (plist-put plist :variables nil) (dape--with-request-bind (body error) (dape--evaluate-expression conn (plist-get frame :id) (plist-get plist :name) "watch") (unless error (cl-loop for (key value) on body by 'cddr do (plist-put plist key value))) (when (length= dape--watched (setf responses (1+ responses))) (dape--with-request (dape--variables-recursive conn ;; Fake variables object (list :variables dape--watched) '(watch) #'dape--variable-expanded-p) (dape--info-update-with (cl-loop with table = (make-gdb-table) for watch in dape--watched initially (setf (gdb-table-right-align table) dape-info-variable-table-aligned) do (dape--info-scope-add-variable table watch nil '(watch) #'dape--variable-expanded-p) finally (insert (gdb-table-string table " ")))))))))) (t (dape--info-update-with (cl-loop with table = (make-gdb-table) for watch in dape--watched initially (setf (gdb-table-right-align table) dape-info-variable-table-aligned) do (dape--info-scope-add-variable table watch nil '(watch) #'dape--variable-expanded-p) finally (insert (gdb-table-string table " ")))))))) (defvar dape--info-watch-edit-font-lock-keywords '(("\\(.+\\)" (1 font-lock-variable-name-face)))) (defvar dape-info-watch-edit-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map text-mode-map) (define-key map "\C-c\C-c" #'dape-info-watch-finish-edit) (define-key map "\C-c\C-k" #'dape-info-watch-abort-changes) map) "Local keymap for dape watch buffer in edit mode.") (define-derived-mode dape-info-watch-edit-mode dape-info-watch-mode "Watch Edit" "Major mode for editing watch expressions." (set-buffer-modified-p nil) (setq revert-buffer-function #'dape--info-revert buffer-undo-list nil buffer-read-only nil font-lock-defaults '(dape--info-watch-edit-font-lock-keywords)) (message "%s" (substitute-command-keys "Press \\[dape-info-watch-finish-edit] when finished \ or \\[dape-info-watch-abort-changes] to abort changes")) (dape--info-set-related-buffers) (revert-buffer)) (cl-defmethod dape--info-revert (&context (major-mode dape-info-watch-edit-mode) &rest _) "Revert buffer function for MAJOR-MODE `dape-info-watch-edit-mode'." (dape--info-update-with (cl-loop for watch in dape--watched for name = (plist-get watch :name) do (insert " " name "\n")))) (defun dape-info-watch-abort-changes () "Discard watch expression edits and return to watch view." (interactive) (dape-info-watch-mode) (dape--info-set-related-buffers) (revert-buffer)) (defun dape-info-watch-finish-edit () "Update watched variables and return to `dape-info-watch-mode'." (interactive) (setq dape--watched (cl-loop for line in (split-string (buffer-string) "[\r\n]+") for trimed-line = (string-trim line) unless (string-empty-p trimed-line) collect (list :name trimed-line))) (dape-info-watch-abort-changes)) ;;; REPL buffer (defvar dape--repl-prompt "> " "Dape REPL prompt.") (defvar dape--repl-marker nil "`dape-repl-mode' marker for `overlay-arrow-variable-list'.") (defun dape--repl-insert (string) "Insert STRING into REPL. If REPL buffer is not live STRING will be displayed in minibuffer." (when (stringp string) (if-let* ((buffer (get-buffer "*dape-repl*"))) (with-current-buffer buffer (save-excursion (let (start) (if comint-last-prompt (goto-char (marker-position (car comint-last-prompt))) (goto-char (point-max))) (setq start (point-marker)) (let ((inhibit-read-only t)) (insert string)) ;; XXX Inserting at position of `comint-last-prompt'... (when comint-last-prompt (move-marker (car comint-last-prompt) (point))) ;; ...and process marker forcing us to move marker by hand. (when-let* ((process (get-buffer-process buffer))) (set-marker (process-mark process) (+ (point) (length dape--repl-prompt)))) ;; HACK Run hooks as if `comint-output-filter' was executed (let ((comint-last-output-start start)) (run-hook-with-args 'comint-output-filter-functions string))))) ;; Fallback to `message' if no repl buffer (message (string-trim string))))) (defun dape--repl-insert-error (string) "Insert STRING into REPL with error face." (dape--repl-insert (propertize string 'font-lock-face 'dape-repl-error-face))) (defun dape--repl-insert-prompt () "Insert `dape--repl-insert-prompt' into repl." (when-let* ((buffer (get-buffer "*dape-repl*")) (dummy-process (get-buffer-process buffer))) (comint-output-filter dummy-process dape--repl-prompt))) (defun dape--repl-move-marker (point) "Mark the first line containing text property `dape--selected'. The search is done backwards from POINT. The line is marked with `dape--repl-marker' and `gdb-mark-line'." (save-excursion (goto-char point) (when (text-property-search-backward 'dape--selected) (gdb-mark-line (line-number-at-pos) dape--repl-marker)))) (defun dape--repl-revert-region (&rest _) "Revert region by cont text property dape--revert-tag." (when-let* ((inhibit-read-only t) (fn (get-text-property (point) 'dape--revert-fn)) (start (save-excursion (previous-single-property-change (1+ (point)) 'dape--revert-tag))) (end (save-excursion (next-single-property-change (point) 'dape--revert-tag)))) (let ((line (line-number-at-pos (point) t)) (col (current-column))) (delete-region start end) (insert (funcall fn)) (dape--repl-move-marker (1+ (point))) (ignore-errors (goto-char (point-min)) (forward-line (1- line)) (forward-char col))))) (defun dape--repl-make-region-string (str revert-function keymap) "Return STR with local REVERT-FUNCTION and KEYMAP." (cl-loop for (start end props) in (object-intervals str) do (add-text-properties start end `( keymap ,(make-composed-keymap (list (plist-get props 'keymap) keymap)) font-lock-face ,(or (plist-get props 'font-lock-face) (plist-get props 'face)) face nil) str) finally return (propertize str 'dape--revert-tag (gensym "dape-region-tag") 'dape--revert-fn revert-function))) (defun dape--repl-variable (variable) "Return VARIABLE string representation with CONN." (when-let* ((conn (or (dape--live-connection 'stopped t) (dape--live-connection 'last t)))) (let ((dape--request-blocking t)) (dape--variables conn variable #'ignore) (dape--variables-recursive conn variable `(,(plist-get variable :name) repl) #'dape--variable-expanded-p #'ignore))) (let ((table (make-gdb-table))) (setf (gdb-table-right-align table) dape-info-variable-table-aligned) (dape--info-scope-add-variable table variable nil '(repl) #'dape--variable-expanded-p) (dape--repl-make-region-string (gdb-table-string table " ") (apply-partially #'dape--repl-variable variable) dape-info-scope-mode-line-map))) (defun dape--repl-info-string (mode index) "Return info MODE buffer content as string. See `dape--info-buffer-index' for information on INDEX." (with-temp-buffer (funcall mode) (setq dape--info-buffer-index index) (let ((dape-ui-debounce-time 0) (dape--request-blocking t)) (revert-buffer)) (ignore-errors (font-lock-ensure)) (dape--repl-make-region-string (buffer-substring (point-min) (point-max)) (apply-partially #'dape--repl-info-string mode index) (symbol-value (intern (concat (symbol-name mode) "-line-map")))))) (defun dape--repl-insert-info-buffer (mode &optional index) "Insert content from MODE into REPL buffer. See `dape--repl-info-string' for information on INDEX." (dape--repl-insert (concat (dape--repl-info-string mode index) "\n")) (when-let* ((buffer (get-buffer "*dape-repl*"))) (with-current-buffer buffer (dape--repl-move-marker (point-max))))) (defun dape--repl-shorthand-alist () "Return shorthand version of `dape-repl-commands'." (cl-loop for (str . command) in dape-repl-commands for shorthand = (cl-loop for i from 1 upto (length str) for shorthand = (substring str 0 i) unless (assoc shorthand shorthand-alist) return shorthand) collect (cons shorthand command) into shorthand-alist finally return shorthand-alist)) (defun dape--repl-input-sender (dummy-process input) "Send INPUT to DUMMY-PROCESS. Called by `comint-input-sender' in `dape-repl-mode'." (setq input (string-trim-right input "[\n\r]+")) (cond ;; Run previous input ((and (string-empty-p input) (not (string-empty-p (car (ring-elements comint-input-ring))))) (when-let* ((last (car (ring-elements comint-input-ring)))) (message "Using last input `%s'" last) (dape--repl-input-sender dummy-process last))) ;; Run command from `dape-named-commands' ((pcase-let* ((`(,cmd . ,args) (split-string (substring-no-properties input) split-string-default-separators)) (fn (or (alist-get cmd dape-repl-commands nil nil #'equal) (and dape-repl-use-shorthand (cdr (assoc cmd (dape--repl-shorthand-alist))))))) (cond ((eq 'dape-quit fn) ;; HACK: `comint-send-input' expects buffer to be live ;; on `comint-input-sender' return. (run-with-timer 0 nil #'call-interactively #'dape-quit)) ((and (commandp fn) args) nil) ((commandp fn) (dape--repl-insert-prompt) (call-interactively fn) t) (fn (dape--repl-insert-prompt) (condition-case-unless-debug err (apply fn args) (error (dape--warn "%s" (car err)))) t)))) ;; Evaluate expression (t (dape--repl-insert-prompt) (dape-evaluate-expression (or (dape--live-connection 'stopped t) (dape--live-connection 'last)) (string-trim (substring-no-properties input)))))) (defun dape--repl-completion-at-point () "Completion at point function for `dape-repl-mode'." (when-let* ((conn (or (dape--live-connection 'stopped t) (dape--live-connection 'last t))) ((dape--capable-p conn :supportsCompletionsRequest))) (let* ((line-start (comint-line-beginning-position)) (str (buffer-substring-no-properties line-start (point-max))) (column (1+ (- (point) line-start))) (bounds (or (bounds-of-thing-at-point 'word) (cons (point) (point)))) (trigger-chars (or (thread-first conn (dape--capabilities) ;; completionTriggerCharacters is an ;; unofficial array of string to trigger ;; completion on. (plist-get :completionTriggerCharacters) (append nil)) '("."))) (collection (when (and (derived-mode-p 'dape-repl-mode) ;; Add `dape-repl-commands' if completion ;; starts at beginning of prompt line. (eql (comint-line-beginning-position) (car bounds))) (cl-loop with alist = (append dape-repl-commands (when dape-repl-use-shorthand (dape--repl-shorthand-alist))) for (name . cmd) in alist for anno = (propertize (symbol-name cmd) 'face 'font-lock-builtin-face) collect `( ,name . ,(concat " " anno))))) done) (dape--with-request-bind ((&key targets &allow-other-keys) _error) (dape-request conn :completions `( :text ,str :column ,column ,@(when (dape--stopped-threads conn) `(:frameId ,(plist-get (dape--current-stack-frame conn) :id))))) (setf collection (append collection (mapcar (lambda (target) (cons (substring (or (plist-get target :text) (plist-get target :label)) (when-let* ((start (plist-get target :start)) (offset (- (car bounds) line-start)) ;; XXX Assume server sends both start ;; and length (vscode convention) or ;; bail. Seems successful in ;; identifying misbehaving servers ;; (e.g. jdtls). ((plist-get target :length)) ((< start offset))) ;; XXX Adapter gets line but Emacs completion is ;; given `word' bounds, cut prefix off candidate ;; such that it matches the bounds. (- offset start))) (concat (when-let* ((type (plist-get target :type))) (concat " " (propertize type 'face 'font-lock-type-face))) (when-let* ((detail (plist-get target :detail))) (concat " " (propertize detail 'face 'font-lock-doc-face)))))) targets)) done t)) (while-no-input (while (not done) (accept-process-output nil 0 1))) (list (car bounds) (cdr bounds) collection :annotation-function (lambda (str) (cdr (assoc (substring-no-properties str) collection))) :company-prefix-length (save-excursion (goto-char (car bounds)) (looking-back (regexp-opt trigger-chars) line-start)))))) (defun dape-repl-threads (&optional index) "List threads in REPL buffer. If INDEX is non-nil parse into number and select n+1th thread." (when-let* ((index (and index (string-to-number index)))) (cl-loop with n = 0 for conn in (dape--live-connections) for thread = (cl-loop for thread in (dape--threads conn) when (equal (cl-incf n) index) return thread) when thread return (dape-select-thread conn (plist-get thread :id)))) (dape--repl-insert-info-buffer 'dape-info-threads-mode)) (defun dape-repl-stack (&optional index) "List modules in REPL buffer. If INDEX is non-nil parse into number and select n+1th stack." (when-let* ((index (and index (string-to-number index))) (conn (dape--live-connection 'stopped t)) (frames (plist-get (dape--current-thread conn) :stackFrames))) (dape-select-stack conn (plist-get (nth (1- index) frames) :id))) (dape--repl-insert-info-buffer 'dape-info-stack-mode)) (defun dape-repl-modules () "List modules in REPL buffer." (dape--repl-insert-info-buffer 'dape-info-modules-mode)) (defun dape-repl-sources () "List sources in REPL buffer." (dape--repl-insert-info-buffer 'dape-info-sources-mode)) (defun dape-repl-breakpoints () "List breakpoints in REPL buffer." (dape--repl-insert-info-buffer 'dape-info-breakpoints-mode)) (defun dape-repl-scope (&optional index) "List variables of scope INDEX in REPL buffer. If INDEX is non-nil parse into number and show n+1th scope." (dape--repl-insert-info-buffer 'dape-info-scope-mode (string-to-number (or index "")))) (defun dape-repl-watch (&rest expression) "List watched variables in REPL buffer. If EXPRESSION is non blank add or remove expression to watch list." (when expression (dape-watch-dwim (string-join expression " "))) (dape--repl-insert-info-buffer 'dape-info-watch-mode)) (defun dape-repl-eval (&rest expression) "Evaluate EXPRESSION in REPL buffer." (dape-evaluate-expression (dape--live-connection 'last) (string-join expression " ") "watch")) (define-derived-mode dape-repl-mode comint-mode "REPL" "Major mode for interacting with Dape and the debugger. Uses the interface provided by `comint-mode'." :group 'dape :interactive nil (setq-local revert-buffer-function #'dape--repl-revert-region dape--repl-marker (make-marker) comint-prompt-read-only t comint-scroll-to-bottom-on-input t ;; Always keep prompt at the bottom of the window scroll-conservatively 101 comint-input-sender 'dape--repl-input-sender comint-prompt-regexp (concat "^" (regexp-quote dape--repl-prompt)) comint-process-echoes nil) (add-to-list 'overlay-arrow-variable-list 'dape--repl-marker) (add-hook 'completion-at-point-functions #'dape--repl-completion-at-point nil t) ;; Stolen from ielm ;; Start a dummy process just to please comint (unless (comint-check-proc (current-buffer)) (let ((process (start-process "dape repl" (current-buffer) nil))) (add-hook 'kill-buffer-hook (lambda () (delete-process process)) nil t)) (set-process-query-on-exit-flag (get-buffer-process (current-buffer)) nil) (set-process-filter (get-buffer-process (current-buffer)) #'comint-output-filter) (insert (format "* Welcome to the Dape REPL * Available Dape commands: %s Any other input or input starting with a space is sent directly to the debugger. An empty line will repeat the last command.\n\n" (with-temp-buffer (insert " " (mapconcat (pcase-lambda (`(,str . ,command)) (setq str (concat str)) (when dape-repl-use-shorthand (set-text-properties 0 (thread-last (dape--repl-shorthand-alist) (rassoc command) (car) (length)) '(font-lock-face help-key-binding) str)) str) dape-repl-commands ", ")) (let ((fill-column 72) (adaptive-fill-mode t)) (fill-region (point-min) (point-max))) (buffer-string)))) (set-marker (process-mark (get-buffer-process (current-buffer))) (point)) (comint-output-filter (get-buffer-process (current-buffer)) dape--repl-prompt))) (defun dape-repl () "Create and display Dape REPL buffer." (interactive) (with-current-buffer (get-buffer-create "*dape-repl*") (unless (eq major-mode 'dape-repl-mode) (dape-repl-mode)) (let ((window (dape--display-buffer (current-buffer)))) (when (called-interactively-p 'interactive) (select-window window))))) ;;; Inlay hints (defface dape-inlay-hint-face '((t (:height 0.8 :inherit shadow))) "Face used for inlay-hint overlays.") (defface dape-inlay-hint-highlight-face '((t (:height 0.8 :inherit highlight))) "Face used for highlighting parts of inlay-hint overlays.") (defvar dape--inlay-hint-overlays nil "List of all hint overlays.") (defvar dape--inlay-hint-debounce-timer (timer-create) "Debounce timer.") (defvar dape--inlay-hint-symbols-fn #'dape--inlay-hint-collect-symbols "Function returning variable names.") (defvar dape--inlay-hint-seperator (propertize " | " 'face 'dape-inlay-hint-face) "Hint delimiter.") (defun dape--inlay-hint-collect-symbols (start end) "Return list of variable symbol candidates between START and END. Excludes symbols that are part of strings, comments or documentation." (unless (<= (- end start) 300) ;; Clamp the region size to prevent performance issues (setq end (+ start 300))) (save-excursion (goto-char start) (cl-loop for symbol = (thing-at-point 'symbol) when (and symbol ;; Skip symbols in strings, comments, or docstrings (not (memql (get-text-property 0 'face symbol) '(font-lock-string-face font-lock-doc-face font-lock-comment-face)))) collect (list symbol) into symbol-list for previous-point = (point) do (forward-thing 'symbol) while (and (< previous-point (point)) (<= (point) end)) finally return (delete-dups symbol-list)))) (defun dape--inlay-hint-create-overlay () "Create and prepare new overlay and maintain the old ones." (when-let* ((stack-overlay dape--stack-position-overlay) (buffer (overlay-buffer stack-overlay)) (overlay (with-current-buffer buffer (pcase-let ((`(,line-start . ,line-end) (save-excursion (goto-char (overlay-start stack-overlay)) (beginning-of-line) (cons (point) (line-end-position))))) (unless (cl-find 'dape-inlay-hint (overlays-in line-start line-end) :key (lambda (ov) (overlay-get ov 'category))) (let ((overlay (make-overlay line-start line-end))) (overlay-put overlay 'category 'dape-inlay-hint) (overlay-put overlay 'evaporate t) (overlay-put overlay 'dape-symbols (funcall dape--inlay-hint-symbols-fn line-start line-end)) overlay)))))) ;; Maintain the hints, keeping old ones based on value of ;; `dape-inlay-hints'. (setq dape--inlay-hint-overlays (cl-loop for overlay in (cons overlay dape--inlay-hint-overlays) for index from 0 for max-overlays = (if (eq dape-inlay-hints t) 2 dape-inlay-hints) if (< index max-overlays) collect overlay else do (delete-overlay overlay))))) (defun dape--inlay-hint-update-overlay-contents (scopes) "Update overlay after-string variables in SCOPES. This is a helper function for `dape-inlay-hints-update'." ;; 1. Update each overlay's symbol list with (NAME VALUE UPDATED-P) (cl-loop with all-symbols = (cl-loop for overlay in dape--inlay-hint-overlays when (overlayp overlay) append (overlay-get overlay 'dape-symbols)) for scope in (reverse scopes) do (cl-loop for variable in (plist-get scope :variables) for value = (plist-get variable :value) for name = (plist-get variable :name) do (cl-loop for symbol-entry in all-symbols for (hint-name previous-value) = symbol-entry for updated-p = (and previous-value (not (equal previous-value value))) when (equal name hint-name) do (setcdr symbol-entry `(,value ,updated-p))))) ;; 2. Format and display the overlays after-string's (cl-loop for overlay in dape--inlay-hint-overlays when (overlayp overlay) do (cl-loop with symbols = (overlay-get overlay 'dape-symbols) for (symbol-name value updated-p) in symbols when value collect (concat ;; Variable name with interactive properties (propertize (format "%s :" symbol-name) 'face 'dape-inlay-hint-face 'mouse-face 'highlight 'keymap (let ((keymap (make-sparse-keymap)) (captured-symbol symbol-name)) (define-key keymap [mouse-1] (lambda () (interactive) (dape-watch-dwim captured-symbol nil 'only-add 'display))) keymap) 'help-echo (format "mouse-1: add `%s' to watch" symbol-name)) " " ;; ..and value, truncating if necessary (propertize (truncate-string-to-width (substring value 0 (string-match-p "\n" value)) dape-inlay-hints-variable-name-max nil nil t) 'help-echo value 'face (if updated-p 'dape-inlay-hint-highlight-face 'dape-inlay-hint-face))) into formatted-strings ;; Set after-string to display hint finally do (when formatted-strings (thread-last (mapconcat #'identity formatted-strings dape--inlay-hint-seperator) (format " %s") (overlay-put overlay 'after-string)))))) (defun dape-inlay-hints-update () "Update inlay hints with current variable values." (when-let* (((or (eq dape-inlay-hints t) (and (numberp dape-inlay-hints) (< 0 dape-inlay-hints)))) (connection (dape--live-connection 'stopped t)) (current-frame (dape--current-stack-frame connection)) (scopes (plist-get current-frame :scopes))) ;; Prepare a new overlay for current selected stack's position (dape--inlay-hint-create-overlay) ;; Fetch all scopes (dape--with-debounce dape--inlay-hint-debounce-timer 0.05 (let ((responses 0)) (dolist (scope scopes) (dape--with-request (dape--variables connection scope) (when (length= scopes (cl-incf responses)) ;; Update each overlay with the new variables (dape--inlay-hint-update-overlay-contents scopes)))))))) (defun dape--inlay-hints-clean-up () "Delete inlay hint overlays." (unless dape-active-mode (dolist (inlay-hint dape--inlay-hint-overlays) (when (overlayp inlay-hint) (delete-overlay inlay-hint))) (setq dape--inlay-hint-overlays nil))) (add-hook 'dape-update-ui-hook #'dape-inlay-hints-update) (add-hook 'dape-active-mode-hook #'dape--inlay-hints-clean-up) ;;; Run until point (defun dape-until (conn) "Run until point. CONN is inferred for interactive invocations." (interactive (list (or (dape--live-connection 'stopped t) (dape--live-connection 'parent)))) ;; Ensure that `dape-until' state is reset (add-hook 'dape-active-mode-hook #'dape--until-reset) (add-hook 'dape-stopped-hook #'dape--until-reset) (if (cl-member 'until (dape--breakpoints-at-point) :key #'dape--source-breakpoint-type) (dape-breakpoint-remove-at-point) (let (;; Block to ensure breakpoints changes before continue (dape--request-blocking t)) ;; Disable all non disabled breakpoints temporarily (cl-loop for breakpoint in dape--breakpoints unless (or (not (dape--source-breakpoint-p breakpoint)) (dape--breakpoint-disabled breakpoint) (eq (dape--source-breakpoint-type breakpoint) 'until)) do (dape--breakpoint-disable breakpoint 'until) finally do (dape--breakpoint-notify-all)) (dape--breakpoint-place 'until) (when (dape--stopped-threads conn) (dape-continue conn))))) (defun dape--until-reset () "Reset run until point state." (let (notification-required-p) (dolist (breakpoint dape--breakpoints) (cond (;; Remove all `until' breakpoints (and (dape--source-breakpoint-p breakpoint) (eq (dape--source-breakpoint-type breakpoint) 'until)) (dape--breakpoint-remove breakpoint)) (;; Enable all disabled breakpoints (eq (dape--breakpoint-disabled breakpoint) 'until) (setq notification-required-p t) (dape--breakpoint-disable breakpoint nil)))) (when notification-required-p (dape--breakpoint-notify-all)))) ;;; Minibuffer config hints (defface dape-minibuffer-hint-separator-face '((t :inherit shadow :strike-through t)) "Face used to separate hint overlay.") (defvar dape--minibuffer-suggestions nil "Suggested configurations in minibuffer.") (defvar dape--minibuffer-last-buffer nil "Helper var for `dape--minibuffer-hint'.") (defvar dape--minibuffer-cache nil "Helper var for `dape--minibuffer-hint'.") (defvar dape--minibuffer-hint-overlay nil "Overlay for `dape--minibuffer-hint'.") (defun dape--minibuffer-hint (&rest _) "Display current configuration in minibuffer in overlay." (pcase-let* ((`(,key ,config ,error-message ,hint-rows) dape--minibuffer-cache) (str (string-trim (buffer-substring-no-properties (minibuffer-prompt-end) (point-max)))) (`(,hint-key ,hint-config) (ignore-errors (dape--config-from-string str))) (default-directory (or (with-current-buffer dape--minibuffer-last-buffer (ignore-errors (dape--guess-root hint-config))) default-directory)) (use-cache (and (equal hint-key key) (equal hint-config config))) (use-ensure-cache ;; Ensure is expensive so we are cheating and don't re run ;; ensure if an ensure has evaled without signaling once (and (equal hint-key key) (not error-message))) (error-message (if use-ensure-cache error-message (condition-case err (progn (with-current-buffer dape--minibuffer-last-buffer (dape--config-ensure hint-config t)) nil) (error (error-message-string err))))) (hint-rows (if use-cache hint-rows (cl-loop with base-config = (alist-get hint-key dape-configs) for (key value) on hint-config by 'cddr unless (or (memq key dape-minibuffer-hint-ignore-properties) (memq key displayed-keys) (and (eq key 'port) (eq value :autoport))) collect key into displayed-keys and collect (concat (propertize (format "%s" key) 'face 'font-lock-keyword-face) " " (with-current-buffer dape--minibuffer-last-buffer (condition-case err (propertize (format "%S" (dape--config-eval-value value nil 'skip-interactive)) 'face (when (equal value (plist-get base-config key)) 'shadow)) (error (propertize (error-message-string err) 'face 'error))))))))) (setq dape--minibuffer-cache (list hint-key hint-config error-message hint-rows)) (overlay-put dape--minibuffer-hint-overlay 'before-string (concat (propertize " " 'cursor 0) (when error-message (format "%s" (propertize error-message 'face 'error))))) (overlay-put dape--minibuffer-hint-overlay 'after-string (when (and dape-minibuffer-hint hint-rows) (concat "\n" (propertize " " 'face 'dape-minibuffer-hint-separator-face 'display '(space :align-to right)) "\n" (mapconcat #'identity hint-rows "\n")))) (move-overlay dape--minibuffer-hint-overlay (point-max) (point-max) (current-buffer)))) ;;; Config (defun dape-config-get (config prop) "Return PROP value in CONFIG evaluated." (dape--config-eval-value (plist-get config prop) nil 'skip-interactive)) (defun dape--plistp (object) "Non-nil if and only if OBJECT is a valid plist." (and (listp object) (zerop (% (length object) 2)))) (defun dape--config-eval-value (value &optional skip-functions skip-interactive) "Return recursively evaluated VALUE. If SKIP-FUNCTIONS is non-nil return VALUE as is if `functionp' is non-nil. If SKIP-INTERACTIVE is non-nil return VALUE as is if `functionp' is non-nil and function uses the minibuffer." (pcase value ;; On function (or list that starts with a non keyword symbol) ((or (pred functionp) (and `(,x . ,_) (guard (and (symbolp x) (not (keywordp x)))))) (if skip-functions value ;; Try to eval function, signal on minibuffer (let ((enable-recursive-minibuffers (not skip-interactive))) (if (functionp value) (funcall-interactively value) (eval value t))))) ;; On plist recursively evaluate ((pred dape--plistp) (dape--config-eval-1 value skip-functions skip-interactive)) ;; On vector evaluate each item ((pred vectorp) (cl-map 'vector (lambda (value) (dape--config-eval-value value skip-functions skip-interactive)) value)) ;; On symbol evaluate symbol value ((and (pred symbolp) ;; Guard against infinite recursion (guard (not (eq (symbol-value value) value)))) (dape--config-eval-value (symbol-value value) skip-functions skip-interactive)) ;; Otherwise just value (_ value))) (defun dape--config-eval-1 (config &optional skip-functions skip-interactive) "Return evaluated CONFIG. See `dape--config-eval-value' for SKIP-FUNCTIONS and SKIP-INTERACTIVE." (cl-loop for (key value) on config by 'cddr append (cond ((memql key '(modes fn ensure)) (list key value)) ((list key (dape--config-eval-value value skip-functions skip-interactive)))))) (defun dape--config-eval (key options &optional skip-functions) "Evaluate config with KEY and OPTIONS. See `dape--config-eval-value' for SKIP-FUNCTIONS." (let ((base-config (alist-get key dape-configs))) (unless base-config (user-error "Unable to find `%s' in `dape-configs', available \ configurations: %s" key (mapconcat (lambda (e) (symbol-name (car e))) dape-configs ", "))) (dape--config-eval-1 (seq-reduce (apply-partially 'apply 'plist-put) (nreverse (seq-partition options 2)) (copy-tree base-config)) skip-functions))) (defun dape--config-from-string (str) "Return list of (KEY CONFIG) from STR. Expects STR format: \”ALIST-KEY KEY VALUE ... - ENV= PROGRAM ARG ...\” Where ALIST-KEY exists in `dape-configs'." (let ((buffer (current-buffer)) name read-config base-config) (with-temp-buffer ;; Keep possible local `dape-configs' value (setq-local dape-configs (buffer-local-value 'dape-configs buffer)) (insert str) (goto-char (point-min)) (unless (setq name (ignore-errors (read (current-buffer)))) (user-error "Expects config name (%s)" (mapconcat (lambda (e) (symbol-name (car e))) dape-configs ", "))) (unless (alist-get name dape-configs) (user-error "No configuration named `%s'" name)) (setq base-config (copy-tree (alist-get name dape-configs))) (ignore-errors (while ;; Do we have non whitespace chars after `point'? (thread-first (buffer-substring (point) (point-max)) (string-trim) (string-empty-p) (not)) (let ((thing (read (current-buffer)))) (cond ((eq thing '-) (unless (dape--plistp read-config) (user-error "Expecting complete options list before `-'")) (cl-loop with command = (split-string-shell-command (buffer-substring (point) (point-max))) with setvar = "\\`\\([A-Za-z_][A-Za-z0-9_]*\\)=\\(.*\\)\\'" for cell on command for (program . args) = cell when (string-match setvar program) append `(,(intern (concat ":" (match-string 1 program))) ,(match-string 2 program)) into env and do (setq program nil) when (or (and (not program) (not args)) program) do (setq read-config (append (nreverse (append (when program `(:program ,program)) (when args `(:args ,(apply #'vector args))) (when env `(:env ,env)))) read-config)) ;; Stop and eat rest of buffer and return (goto-char (point-max)))) (t (push thing read-config)))))) ;; Balance half baked options list (when (not (dape--plistp read-config)) (pop read-config)) (unless (dape--plistp read-config) (user-error "Bad options format, see `dape-configs'")) (setq read-config (nreverse read-config)) ;; Apply properties from parsed PLIST to `dape-configs' item (cl-loop for (key value) on base-config by 'cddr unless (plist-member read-config key) do (setq read-config (plist-put read-config key value))) (list name read-config)))) (defun dape--config-diff (key post-eval) "Create a diff of config KEY and POST-EVAL config." (let ((base-config (alist-get key dape-configs))) (cl-loop for (key value) on post-eval by 'cddr unless (or (memql key '(modes fn ensure)) ;; Skip meta params (and ;; Does the key exist in `base-config'? (plist-member base-config key) ;; Has value changed (skip functions)? (equal (dape--config-eval-value (plist-get base-config key) 'skip-functions) value))) append (list key value)))) (defun dape--config-to-string (key expanded-config) "Create string from KEY and EXPANDED-CONFIG." (pcase-let* ((diff (dape--config-diff key expanded-config)) ((map :env :program :args) expanded-config) (zap-form-p (and (eq dape-history-add 'shell-like) (or (stringp program) (and (consp env) (keywordp (car env)) (not args)))))) (when zap-form-p (cl-loop for key in '(:program :env :args) do (setq diff (map-delete diff key)))) (concat (when key (format "%s" key)) (when-let* (diff (config-str (prin1-to-string diff))) (format " %s" (substring config-str 1 (1- (length config-str))))) (when zap-form-p (concat " -" (cl-loop for (symbol value) on env by #'cddr for name = (substring (symbol-name symbol) 1) concat (format " %s=%s" (shell-quote-argument name) (shell-quote-argument value))) (cl-loop for arg in (cons program (append args nil)) concat (format " %s" (shell-quote-argument arg)))))))) (defun dape--config-ensure (config &optional signal) "Ensure that CONFIG is executable. If SIGNAL is non-nil raises `user-error' on failure otherwise returns nil." (if-let* ((ensure-fn (plist-get config 'ensure))) (condition-case err (let ((default-directory (or (dape-config-get config 'command-cwd) default-directory))) (or (funcall ensure-fn config) t)) (error (if signal (user-error (error-message-string err)) nil))) t)) (defun dape--config-mode-p (config) "Return non-nil if CONFIG is for current major mode." (let ((modes (plist-get config 'modes))) (or (not modes) (apply #'provided-mode-derived-p major-mode (cl-map 'list 'identity modes)) (when-let* (((not (derived-mode-p 'prog-mode))) (last-hist (car dape-history)) (last-config (cadr (ignore-errors (dape--config-from-string last-hist))))) (cl-some (lambda (mode) (memql mode (plist-get last-config 'modes))) modes))))) (defun dape--config-completion-at-point () "Function for `completion-at-point' fn for `dape--read-config'." (let (key key-end args args-bounds last-p) (save-excursion (goto-char (minibuffer-prompt-end)) (setq key (ignore-errors (read (current-buffer)))) (setq key-end (point)) (ignore-errors (while t (setq last-p (point)) (push (read (current-buffer)) args) (push (cons last-p (point)) args-bounds)))) (setq args (nreverse args) args-bounds (nreverse args-bounds)) (cond ;; Complete key ((<= (point) key-end) (pcase-let ((`(,start . ,end) (or (bounds-of-thing-at-point 'symbol) (cons (point) (point))))) (list start end (mapcar (lambda (suggestion) (format "%s " suggestion)) dape--minibuffer-suggestions)))) ;; Complete args ((and (not (plist-member args '-)) ;; Skip zap/dash notation (alist-get key dape-configs) (or (and (plistp args) (thing-at-point 'whitespace)) (cl-loop with p = (point) for ((start . end) _) on args-bounds by 'cddr when (and (<= start p) (<= p end)) return t finally return nil))) (pcase-let ((`(,start . ,end) (or (bounds-of-thing-at-point 'symbol) (cons (point) (point))))) (list start end (cl-loop with plist = (append (alist-get key dape-configs) '(compile nil)) for (key _) on plist by 'cddr collect (format "%s " key))))) (t (list (point) (point) nil :exclusive 'no))))) (defun dape--read-config () "Read configuration from minibuffer. Completes from suggested conjurations, a configuration is suggested if it's for current `major-mode' and it's available. See `modes' and `ensure' in `dape-configs'." (run-hooks 'dape-read-config-hook) (let* ((suggested-configs (cl-loop for (name . config) in dape-configs when (and (dape--config-mode-p config) (ignore-errors (dape--config-ensure config))) collect (symbol-name name))) (initial-contents (or ;; Take `dape-command' if exist (when dape-command (dape--config-to-string (car dape-command) (cdr dape-command))) ;; Take first valid history item (cl-loop for string in dape-history for (_ config) = (ignore-errors (dape--config-from-string string)) when (and config (dape--config-mode-p config) (ignore-errors (dape--config-ensure config))) return string) ;; Take first suggested config if only one exist (when (and (length= suggested-configs 1) (car suggested-configs)) suggested-configs))) (default-value (when initial-contents (pcase-let ((`(,key ,config) (ignore-errors (dape--config-from-string initial-contents)))) (list (dape--config-to-string key (ignore-errors (dape--config-eval key config 'skip-functions))) (format "%s " key)))))) (setq dape--minibuffer-last-buffer (current-buffer) dape--minibuffer-cache nil) (minibuffer-with-setup-hook (lambda () (setq-local dape--minibuffer-suggestions suggested-configs comint-completion-addsuffix nil resize-mini-windows t max-mini-window-height 0.5 dape--minibuffer-hint-overlay (make-overlay (point) (point)) default-directory (dape-command-cwd) ;; Store origin buffer `dape-configs' value dape-configs (buffer-local-value 'dape-configs dape--minibuffer-last-buffer)) (set-syntax-table emacs-lisp-mode-syntax-table) (add-hook 'completion-at-point-functions #'comint-filename-completion nil t) (add-hook 'completion-at-point-functions #'dape--config-completion-at-point nil t) (add-hook 'after-change-functions #'dape--minibuffer-hint nil t) (dape--minibuffer-hint)) (pcase-let* ((str (let ((history-add-new-input (eq dape-history-add 'input))) (read-from-minibuffer "Run adapter: " initial-contents (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) (define-key map (kbd "C-M-i") #'completion-at-point) (define-key map "\t" #'completion-at-point) ;; This mapping is shadowed by `next-history-element' ;; future history (default-value) (define-key map (kbd "C-c C-k") (lambda () (interactive) (pcase-let* ((str (buffer-substring (minibuffer-prompt-end) (point-max))) (`(,key) (dape--config-from-string str))) (delete-region (minibuffer-prompt-end) (point-max)) (insert (format "%s" key) " ")))) map) nil 'dape-history default-value))) (`(,key ,config) (dape--config-from-string (substring-no-properties str))) (evaled-config (let ((default-directory (dape--guess-root config))) (dape--config-eval key config)))) (unless (eq dape-history-add 'input) (push (dape--config-to-string key evaled-config) dape-history)) evaled-config)))) ;;; Hover (defun dape-hover-function (cb) "Hook function to produce doc strings for `eldoc'. On success calls CB with the doc string. See `eldoc-documentation-functions', for more information." (when-let* ((conn (dape--live-connection 'last t)) ((dape--capable-p conn :supportsEvaluateForHovers)) (symbol (thing-at-point 'symbol)) (name (substring-no-properties symbol)) (id (plist-get (dape--current-stack-frame conn) :id))) (dape--with-request-bind (body error) (dape--evaluate-expression conn id name "hover") (unless error (dape--with-request (dape--variables-recursive conn `(:variables (,body)) '(hover) #'dape--variable-expanded-p) (let ((table (make-gdb-table))) (dape--info-scope-add-variable table (plist-put body :name name) nil '(hover) #'dape--variable-expanded-p 'no-handles) (funcall cb (gdb-table-string table " "))))))) t) (defun dape--add-eldoc-hook () "Add `dape-hover-function' from eldoc hook." (add-hook 'eldoc-documentation-functions #'dape-hover-function nil t)) (defun dape--remove-eldoc-hook () "Remove `dape-hover-function' from eldoc hook." (remove-hook 'eldoc-documentation-functions #'dape-hover-function t)) ;;; Mode line (easy-menu-define dape-menu nil "Menu for `dape-active-mode'." `("Dape" ["Continue" dape-continue :enable (dape--live-connection 'stopped)] ["Next" dape-next :enable (dape--live-connection 'stopped)] ["Step in" dape-step-in :enable (dape--live-connection 'stopped)] ["Step out" dape-step-out :enable (dape--live-connection 'stopped)] ["Pause" dape-pause :enable (not (dape--live-connection 'stopped t))] ["Restart" dape-restart] ["Quit" dape-quit] "--" ["REPL" dape-repl] ["Info buffers" dape-info] ["Memory" dape-memory :enable (dape--capable-p (dape--live-connection 'last) :supportsReadMemoryRequest)] ["Disassemble" dape-disassemble :enable (dape--capable-p (dape--live-connection 'last) :supportsDisassembleRequest)] "--" ["Customize Dape" ,(lambda () (interactive) (customize-group "dape"))])) (defvar dape--update-mode-line-debounce-timer (timer-create) "Debounce context for updating the mode line.") (defun dape--update-state (conn state &optional reason) "Update Dape mode line with STATE symbol for adapter CONN." (setf (dape--state conn) state (dape--state-reason conn) reason) (dape--with-debounce dape--update-mode-line-debounce-timer dape-ui-debounce-time (dape--mode-line-format) (force-mode-line-update t))) (defvar dape--mode-line-format nil "Dape mode line format.") (put 'dape--mode-line-format 'risky-local-variable t) (defun dape--mode-line-format () "Update variable `dape--mode-line-format' format." (let ((conn (or (dape--live-connection 'last t) (car dape--connections)))) (setq dape--mode-line-format `(( :propertize "dape" face font-lock-constant-face mouse-face mode-line-highlight help-echo "Dape: Debug Adapter Protocol for Emacs\n\ mouse-1: Display minor mode menu" keymap ,(let ((map (make-sparse-keymap))) (define-key map [mode-line down-mouse-1] dape-menu) map)) ":" ( :propertize ,(when-let* ((thread-name (plist-get (dape--current-thread conn) :name))) (concat thread-name " ")) face font-lock-constant-face mouse-face mode-line-highlight help-echo "mouse-1: Select thread" keymap ,(let ((map (make-sparse-keymap))) (define-key map [mode-line down-mouse-1] #'dape-select-thread) map)) ( :propertize ,(format "%s" (or (and conn (dape--state conn)) 'unknown)) face font-lock-doc-face) ,@(when-let* (conn (reason (dape--state-reason conn))) `("/" (:propertize ,reason face font-lock-doc-face))) ,@(when-let* (conn (children (cl-loop with root = (dape--root-of conn) for conn in (dape--live-connections) count (and (eq (dape--root-of conn) root) (dape--threads conn)))) ((> children 1))) `(( :propertize ,(format "(%d)" children) face shadow help-echo "Active child connections"))))))) (add-to-list 'global-mode-string `(dape-active-mode ("[" dape--mode-line-format "] "))) ;;; Keymaps (defvar dape-global-map (let ((map (make-sparse-keymap))) (define-key map "d" #'dape) (define-key map "p" #'dape-pause) (define-key map "c" #'dape-continue) (define-key map "n" #'dape-next) (define-key map "s" #'dape-step-in) (define-key map "o" #'dape-step-out) (define-key map "r" #'dape-restart) (define-key map "f" #'dape-restart-frame) (define-key map "u" #'dape-until) (define-key map "i" #'dape-info) (define-key map "R" #'dape-repl) (define-key map "m" #'dape-memory) (define-key map "M" #'dape-disassemble) (define-key map "l" #'dape-breakpoint-log) (define-key map "e" #'dape-breakpoint-expression) (define-key map "h" #'dape-breakpoint-hits) (define-key map "F" #'dape-breakpoint-function) (define-key map "b" #'dape-breakpoint-toggle) (define-key map "B" #'dape-breakpoint-remove-all) (define-key map "t" #'dape-select-thread) (define-key map "T" #'dape-select-session) (define-key map "S" #'dape-select-stack) (define-key map ">" #'dape-stack-select-down) (define-key map "<" #'dape-stack-select-up) (define-key map "x" #'dape-evaluate-expression) (define-key map "w" #'dape-watch-dwim) (define-key map "D" #'dape-disconnect-quit) (define-key map "K" #'dape-kill) (define-key map "q" #'dape-quit) map)) (dolist (cmd '(dape dape-pause dape-continue dape-next dape-step-in dape-step-out dape-restart dape-restart-frame dape-until dape-breakpoint-log dape-breakpoint-expression dape-breakpoint-hits dape-breakpoint-function dape-breakpoint-toggle dape-breakpoint-remove-all dape-stack-select-up dape-stack-select-down dape-select-stack dape-select-thread dape-select-session dape-watch-dwim dape-evaluate-expression dape-info)) (put cmd 'repeat-map 'dape-global-map)) (when dape-key-prefix (global-set-key dape-key-prefix dape-global-map)) ;;; Hooks (defun dape--kill-busy-wait () "Kill all connections and wait until finished." (dolist (conn (copy-sequence dape--connections)) (let (done) (dape--with-request (dape-kill conn) (setf done t)) ;; Busy wait for response at least 2 seconds (cl-loop with max-iterations = 20 for i from 1 to max-iterations until done do (accept-process-output nil 0.1))))) ;; Cleanup conn before bed time (add-hook 'kill-emacs-hook #'dape--kill-busy-wait) (provide 'dape) ;;; dape.el ends here