From e4a485f5a1ae1609b5e148d78f004c21754671ca Mon Sep 17 00:00:00 2001 From: Max Amundsen Date: Tue, 30 Dec 2025 10:38:00 -0500 Subject: [PATCH] add debugging, fix c-t menu --- .config/Code/User/settings.json | 1 - .emacs.d/init.el | 217 +- .emacs.d/lisp/dape.el | 5858 +++++++++++++++++++++++++++++++ .emacs.d/themes/acme-theme.el | 512 +++ 4 files changed, 6536 insertions(+), 52 deletions(-) create mode 100644 .emacs.d/lisp/dape.el create mode 100644 .emacs.d/themes/acme-theme.el diff --git a/.config/Code/User/settings.json b/.config/Code/User/settings.json index 7b92397..062ce3c 100644 --- a/.config/Code/User/settings.json +++ b/.config/Code/User/settings.json @@ -199,7 +199,6 @@ "workbench.editor.empty.hint": "hidden", "chat.agent.enabled": false, "chat.disableAIFeatures": true, - "workbench.colorTheme": "Default Light+", "workbench.preferredDarkColorTheme": "Visual Studio Dark", "workbench.preferredLightColorTheme": "Visual Studio Light" } \ No newline at end of file diff --git a/.emacs.d/init.el b/.emacs.d/init.el index e48f3a4..7fa5c18 100755 --- a/.emacs.d/init.el +++ b/.emacs.d/init.el @@ -38,6 +38,9 @@ ;; Search (require 'xah-find) +;; Debugging +(require 'dape) + ;;; ============================================================================ ;;; MODE ASSOCIATIONS ;;; ============================================================================ @@ -99,38 +102,84 @@ (advice-add 'y-or-n-p :around #'my-auto-confirm-modified-buffer) (defun my-lsp-find-workspace-symbol () - "Interactively search for symbols in workspace using LSP." + "Interactively search for symbols in workspace using LSP. +Start typing to search - LSP provides fuzzy matching." (interactive) (if (eglot-managed-p) (let* ((server (eglot-current-server)) (root (project-root (project-current))) - (query (read-string "Symbol query: ")) - (resp (jsonrpc-request server :workspace/symbol `(:query ,query))) - (items (append resp nil)) - (candidates - (delq nil - (mapcar (lambda (item) - (condition-case nil - (let* ((name (plist-get item :name)) - (loc (plist-get item :location)) - (uri (plist-get loc :uri)) - (range (plist-get loc :range)) - (start (plist-get range :start)) - (line (1+ (plist-get start :line))) - (file (eglot-uri-to-path uri)) - (rel-path (file-relative-name file root))) - (propertize (format "%s %s:%d" name rel-path line) - 'file file - 'line line)) - (error nil))) - items))) - (candidate (completing-read "Symbol: " candidates nil t))) - (when (and candidate (get-text-property 0 'file candidate)) - (find-file (get-text-property 0 'file candidate)) + (all-candidates '()) + (completion-styles '(orderless basic)) + (completion-ignore-case t) + (collection + (lambda (string pred action) + (when (and (> (length string) 0) (not (eq action 'metadata))) + (let* ((resp (jsonrpc-request server :workspace/symbol `(:query ,string))) + (items (append resp nil))) + (dolist (item items) + (condition-case nil + (let* ((name (plist-get item :name)) + (loc (plist-get item :location)) + (uri (plist-get loc :uri)) + (range (plist-get loc :range)) + (start (plist-get range :start)) + (line (plist-get start :line)) + (char (plist-get start :character)) + (file (eglot-uri-to-path uri)) + (rel-path (file-relative-name file root)) + (display (format "%s %s:%d" name rel-path (1+ line)))) + (unless (seq-find (lambda (c) (string= (car c) display)) all-candidates) + (push (list display file line char) all-candidates))) + (error nil))))) + ;; Sort by symbol name length (shorter first) + (let ((strings (mapcar #'car + (sort (copy-sequence all-candidates) + (lambda (a b) + (< (length (car (split-string (car a) " "))) + (length (car (split-string (car b) " "))))))))) + (complete-with-action action strings string pred)))) + (selection (completing-read "Symbol (type to search): " collection nil t))) + (when-let ((match (seq-find (lambda (c) (string= (car c) selection)) all-candidates))) + (find-file (nth 1 match)) (goto-char (point-min)) - (forward-line (1- (get-text-property 0 'line candidate))))) + (forward-line (nth 2 match)) + (forward-char (or (nth 3 match) 0)))) (call-interactively 'xref-find-apropos))) +;;; ============================================================================ +;;; DAPE (DEBUGGING) +;;; ============================================================================ + +;; Go debugging with dlv (requires: go install github.com/go-delve/delve/cmd/dlv@latest) +;; Use M-x dape or F5 to start debugging, select "dlv" configuration + +;; Show inlay hints for variable values while debugging +(setq dape-inlay-hints t) + +;; Save buffers before starting debug session +(add-hook 'dape-start-hook (lambda () (save-some-buffers t t))) + +;; Kill debug session before quitting Emacs +(add-hook 'kill-emacs-hook + (lambda () + (ignore-errors (dape-quit)) + ;; Also kill any lingering dlv processes + (dolist (proc (process-list)) + (when (and (process-live-p proc) + (string-match-p "\\(dape\\|dlv\\)" (process-name proc))) + (ignore-errors + (let ((pid (process-id proc))) + (when pid (my-kill-process-tree pid))) + (delete-process proc)))))) + +(defun my-dape-start-or-continue () + "Start debugging or continue if already in a debug session. +If stopped at a breakpoint, continue. Otherwise start a new debug session." + (interactive) + (if-let ((conn (dape--live-connection 'stopped t))) + (dape-continue conn) + (call-interactively #'dape))) + ;;; ============================================================================ ;;; FLYMAKE & DIAGNOSTICS ;;; ============================================================================ @@ -258,6 +307,7 @@ (global-auto-revert-mode t) (global-so-long-mode 1) (global-hl-line-mode -1) +(setq enable-local-variables :all) ; trust .dir-locals.el files ;; display (setq-default truncate-lines 1) @@ -275,7 +325,6 @@ (setq-default require-final-newline t) (setq ediff-split-window-function 'split-window-horizontally) (setq dired-dnd-protocol-alist nil) -(setq custom-file "~/.emacs.d/custom.el") ;; mouse - disable right-click context menu (global-set-key [mouse-3] 'ignore) @@ -317,20 +366,19 @@ (progn (set-window-buffer window buffer) window) - (let ((new-window (display-buffer-at-bottom buffer alist))) - (when new-window - (with-selected-window new-window - (set-window-parameter new-window 'window-height 0.25))) - new-window)))) + (display-buffer-in-side-window buffer + '((side . bottom) + (slot . 1) + (window-height . 0.25)))))) (add-to-list 'display-buffer-alist - '("\\*compilation\\*" (my-display-in-bottom-panel) (window-height . 0.25))) + '("\\*compilation\\*" (my-display-in-bottom-panel) (side . bottom) (slot . 1) (window-height . 0.25))) (add-to-list 'display-buffer-alist - '("\\*xref\\*" (my-display-in-bottom-panel) (window-height . 0.25))) + '("\\*xref\\*" (my-display-in-bottom-panel) (side . bottom) (slot . 1) (window-height . 0.25))) (add-to-list 'display-buffer-alist - '("\\*Flymake diagnostics.*\\*" (my-display-in-bottom-panel) (window-height . 0.25))) + '("\\*Flymake diagnostics.*\\*" (my-display-in-bottom-panel) (side . bottom) (slot . 1) (window-height . 0.25))) (add-to-list 'display-buffer-alist - '("\\*grep\\*" (my-display-in-bottom-panel) (window-height . 0.25))) + '("\\*grep\\*" (my-display-in-bottom-panel) (side . bottom) (slot . 1) (window-height . 0.25))) (defun my-bottom-panel-toggle () "Toggle the bottom panel. Close if visible, open if hidden." @@ -433,7 +481,7 @@ (global-set-key (kbd "C-") 'next-multiframe-window) (global-set-key (kbd "C-1") 'my-select-left-pane) (global-set-key (kbd "C-2") 'my-select-right-pane) -(global-set-key (kbd "") 'toggle-frame-maximized) +(global-set-key (kbd "M-") 'toggle-frame-maximized) ;; --- Selection & Editing --- (global-set-key (kbd "C-a") 'mark-whole-buffer) @@ -454,7 +502,7 @@ (global-set-key (kbd "") 'move-end-of-line) (global-set-key (kbd "M-p") 'backward-paragraph) (global-set-key (kbd "M-n") 'forward-paragraph) -(global-set-key [f8] 'goto-line) +(global-set-key (kbd "C-S-g") 'goto-line) (when (eq system-type 'darwin) (global-set-key (kbd "C-") 'my-smart-home) (global-set-key (kbd "C-") 'move-end-of-line)) @@ -472,7 +520,8 @@ ;; --- Code Navigation (xref/LSP) --- (global-set-key (kbd "") 'my-xref-find-definitions-same-pane) -(global-set-key (kbd "C-") 'xref-find-references) +(global-set-key (kbd "C-") 'my-xref-find-definitions-right-pane) +(global-set-key (kbd "C-S-") 'xref-find-references) (global-set-key (kbd "C-{") 'xref-go-back) (global-set-key (kbd "C-}") 'xref-go-forward) (global-set-key (kbd "") 'xref-go-back) @@ -488,8 +537,21 @@ ;; --- Compilation & Build --- (global-set-key (kbd "") 'my-bottom-panel-toggle) -(global-set-key (kbd "") 'my-compile-last) -(global-set-key (kbd "") 'my-compile-custom) +(global-set-key (kbd "") 'next-error) +(global-set-key (kbd "S-") 'previous-error) +(global-set-key (kbd "C-b") 'my-compile-last) +(global-set-key (kbd "C-S-b") 'my-compile-custom) + +;; --- Debugging (dape, VS Code-style) --- +(global-set-key (kbd "") 'my-dape-start-or-continue) +(global-set-key (kbd "S-") 'dape-quit) +(global-set-key (kbd "C-S-") 'dape-restart) +(global-set-key (kbd "") 'dape-breakpoint-toggle) +(global-set-key (kbd "") 'dape-next) +(global-set-key (kbd "") 'dape-step-in) +(global-set-key (kbd "S-") 'dape-step-out) +(global-set-key (kbd "S-") 'dape-breakpoint-remove-all) +(global-set-key (kbd "C-") 'dape-continue) ;; --- External Tools --- (global-set-key (kbd "") 'my-file-manager-command) @@ -499,10 +561,6 @@ (global-set-key (kbd "") 'project-switch-project) (global-set-key (kbd "C-S-p") 'execute-extended-command) -;; --- Bookmarks --- -(global-set-key (kbd "") 'bookmark-jump) -(global-set-key (kbd "") 'bookmark-set) - ;; --- Themes --- (global-set-key (kbd "") 'my-select-theme) @@ -531,11 +589,14 @@ (global-set-key (kbd "M-") 'my-delete-word) (global-set-key (kbd "C-") 'my-backward-delete-word) +;; --- Macros --- +(global-set-key (kbd "C-S-r") 'my-toggle-macro-recording) +(global-set-key (kbd "C-M-r") 'my-call-macro) + ;; --- Misc --- -(global-set-key (kbd "C-e") 'my-copy-path-with-line) +(global-set-key (kbd "C-e") 'my-select-inside-parens) +(global-set-key (kbd "C-y") 'my-copy-path-with-line) (global-set-key (kbd "C-!") 'my-insert-shell-command-output) -(global-set-key (kbd "C-") 'my-toggle-macro-recording) -(global-set-key (kbd "") 'my-call-macro) ;; --- Minibuffer Keybindings --- (define-key minibuffer-local-filename-completion-map (kbd "C-2") 'my-find-file-right-pane) @@ -598,11 +659,12 @@ (move-beginning-of-line 1)))) (defun my-get-top-windows () - "Get windows in the top portion of the frame (not bottom compilation)." + "Get windows in the top portion of the frame (not bottom compilation or dape)." (let ((windows '())) (walk-windows (lambda (w) - (when (window-at-side-p w 'top) + (when (and (window-at-side-p w 'top) + (not (string-prefix-p "*dape-" (buffer-name (window-buffer w))))) (push w windows)))) (sort windows (lambda (a b) (< (car (window-edges a)) (car (window-edges b))))))) @@ -638,6 +700,22 @@ Falls back to dumb-jump if xref fails." (dumb-jump-go))) (error (dumb-jump-go)))))) +(defun my-xref-find-definitions-right-pane () + "Find definition and show it in a new pane split to the right. +Falls back to dumb-jump if xref fails." + (interactive) + (let ((identifier (thing-at-point 'symbol t))) + (if (null identifier) + (message "No symbol at point") + (split-window-right) + (other-window 1) + (condition-case nil + (let ((xrefs (xref-backend-definitions (xref-find-backend) identifier))) + (if xrefs + (xref-find-definitions identifier) + (dumb-jump-go))) + (error (dumb-jump-go)))))) + (defun my-xref-find-definitions-at-click (event) "Find definition of the symbol clicked on." (interactive "e") @@ -867,6 +945,20 @@ Respects search settings: regexp, whole-word, case-sensitivity." (set-mark (point)) (forward-line 1))) +(defun my-select-inside-parens () + "Select the contents inside the nearest enclosing parentheses, brackets, or braces." + (interactive) + (let ((start nil) (end nil)) + (save-excursion + (ignore-errors + (up-list -1 t t) ; go backward, escape strings, no syntax crossing + (setq start (1+ (point))) + (forward-sexp 1) + (setq end (1- (point))))) + (when (and start end) + (goto-char start) + (set-mark end)))) + (defun my-toggle-comment () "Toggle comment on line or region without moving point." (interactive) @@ -1002,6 +1094,7 @@ Does not copy to kill ring." (defun my-compile-custom () "Run a custom compile command in the project root." (interactive) + (save-some-buffers t t) (let* ((default-directory (project-root (project-current t))) (saved (my-compile-get-saved-command)) (cmd (read-string "Command: " saved))) @@ -1011,6 +1104,7 @@ Does not copy to kill ring." (defun my-compile-last () "Run last compile command, or prompt for one if none has been run." (interactive) + (save-some-buffers t t) (let* ((default-directory (project-root (project-current t))) (cmd (my-compile-get-saved-command))) (if cmd @@ -1228,9 +1322,9 @@ Does not copy to kill ring." (if defining-kbd-macro (progn (kmacro-end-macro nil) - (message "Macro recorded. Press F4 to replay.")) + (message "Macro recorded. Press C-M-r to replay.")) (kmacro-start-macro nil) - (message "Recording macro... Press C- to stop."))) + (message "Recording macro... Press C-S-r to stop."))) (defun my-call-macro () "Call last macro. If region is active, run macro N times where N is number of selected lines. @@ -1280,6 +1374,27 @@ Use in `isearch-mode-end-hook'." ;; (set-face-attribute 'default nil :font "Consolas-15") +;; Disable current theme before loading to prevent stacking on config reload +(when my-current-theme + (disable-theme my-current-theme)) +(setq my-current-theme 'bedroom) (load-theme 'bedroom t) +;;; ============================================================================ +;;; CUSTOM +;;; ============================================================================ + +(custom-set-variables + ;; custom-set-variables was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + '(safe-local-variable-directories '("/Users/mta/projects/cdrateline.com_2.0/"))) +(custom-set-faces + ;; custom-set-faces was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + ) + ;;; init.el ends here diff --git a/.emacs.d/lisp/dape.el b/.emacs.d/lisp/dape.el new file mode 100644 index 0000000..0549750 --- /dev/null +++ b/.emacs.d/lisp/dape.el @@ -0,0 +1,5858 @@ +;;; dape.el --- Debug Adapter Protocol for Emacs -*- lexical-binding: t -*- + +;; Copyright (C) 2023-2025 Free Software Foundation, Inc. + +;; Author: Daniel Pettersson +;; Maintainer: Daniel Pettersson +;; Created: 2023 +;; License: GPL-3.0-or-later +;; Version: 0.25.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")) + ,@(let ((codelldb + `( ensure dape-ensure-command + command-cwd dape-command-cwd + command ,(file-name-concat dape-adapter-dir + "codelldb" + "extension" + "adapter" + "codelldb") + port :autoport + :type "lldb" + :request "launch" + :cwd ".")) + (common `(:args [] :stopOnEntry nil))) + `((codelldb-cc + modes (c-mode c-ts-mode c++-mode c++-ts-mode) + command-args ("--port" :autoport) + ,@codelldb + :program "a.out" + ,@common) + (codelldb-rust + modes (rust-mode rust-ts-mode) + command-args ("--port" :autoport + "--settings" "{\"sourceLanguages\":[\"rust\"]}") + ,@codelldb + :program (file-name-concat "target" "debug" + (car (last (file-name-split + (directory-file-name (dape-cwd)))))) + ,@common))) + (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) + (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." + :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.") + + +;;; 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'.") + +;; FIXME `dape--source-buffers' should be moved into connection as +;; source references are not globally scoped. +(defvar dape--source-buffers nil + "Plist of sources reference to buffer.") +(defvar dape--breakpoints nil + "List of `dape--breakpoint's.") +(defvar dape--exceptions nil + "List of available exceptions as plists.") +(defvar dape--watched nil + "List of watched expressions.") +(defvar dape--data-breakpoints nil + "List of data breakpoints.") +(defvar dape--connection nil + "Debug adapter connection.") +(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--connection))) + (;; 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 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." + (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." + (if-let* ((command-cwd (plist-get config 'command-cwd)) + ((stringp command-cwd))) + command-cwd + (dape-command-cwd))) + +(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--connection) + (config + (and conn + ;; If child connection check parent + (or (when-let* ((parent (dape--parent conn))) + (dape--config parent)) + (dape--config 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 (not (and skip-process-buffers + (get-buffer-process buffer))) + (when-let* ((name (buffer-name buffer))) + (string-match-p "\\*dape-.+\\*\\(<[0-9]+>\\)?$" name))) + 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* ((buffer (get-buffer "*dape-shell*"))) + (dape--display-buffer buffer)) + (when-let* ((buffer (get-buffer "*dape-repl*")) + (window (get-buffer-window buffer))) + (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 (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))))))) + (live-connections-1 dape--connection))) + +(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.")) + :documentation + "Represents a DAP debugger. Wraps a process for DAP communication.") + +(cl-defstruct (dape--breakpoint (:constructor dape--breakpoint-make)) + "Breakpoint object storing location and state." + location type value disabled hits verified id) + +(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) "")))) + (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--breakpoint-type breakpoint) + ('log + (if (dape--capable-p conn :supportsLogPoints) + (plist-put plist :logMessage + (dape--breakpoint-value breakpoint)) + (dape--warn "Adapter does not support `dape-breakpoint-log'"))) + ('expression + (if (dape--capable-p conn :supportsConditionalBreakpoints) + (plist-put plist :condition + (dape--breakpoint-value breakpoint)) + (dape--warn + "Adapter does not support `dape-breakpoint-expression'"))) + ('hits + (if (dape--capable-p conn :supportsHitConditionalBreakpoints) + (plist-put plist :hitCondition + (dape--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 (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 + for (reference buffer) on dape--source-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. +The exceptions are derived from `dape--exceptions'. +See `dape-request' for expected CB signature." + (if (not dape--exceptions) + (dape--request-continue cb) + (dape-request + conn :setExceptionBreakpoints + `(:filters + ,(cl-map 'vector + (lambda (exception) + (plist-get exception :filter)) + (seq-filter (lambda (exception) + (plist-get exception :enabled)) + dape--exceptions))) + cb))) + +(defun dape--configure-exceptions (conn &optional cb) + "Configure exception breakpoints for adapter CONN. +The exceptions are derived from `dape--exceptions'. +See `dape-request' for expected CB signature." + (setq dape--exceptions + (cl-map + 'list + (lambda (exception) + (if-let* ((stored-exception + (cl-find (plist-get exception :filter) + dape--exceptions + :key (lambda (ex) (plist-get ex :filter)) + :test #'equal))) + ;; Exception is known, store old value + (plist-put exception :enabled + (plist-get stored-exception :enabled)) + ;; New exception use default + (plist-put exception :enabled + (eq (plist-get exception :default) t)))) + (plist-get (dape--capabilities conn) :exceptionBreakpointFilters))) + (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 + (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." + (if (dape--capable-p conn :supportsDataBreakpoints) + (dape--with-request-bind + ((&key breakpoints &allow-other-keys) error) + (dape-request conn :setDataBreakpoints + (list + :breakpoints + (cl-loop + for plist in dape--data-breakpoints + collect (list :dataId (plist-get plist :dataId) + :accessType (plist-get plist :accessType)) + into breakpoints + finally return (apply #'vector breakpoints)))) + (when error + (message "Failed to setup data breakpoints: %s" error)) + (cl-loop + for req-breakpoint in dape--data-breakpoints + for res-breakpoint across (or breakpoints []) + if (eq (plist-get res-breakpoint :verified) t) + collect req-breakpoint into verfied-breakpoints else + collect req-breakpoint into unverfied-breakpoints + finally do + (when unverfied-breakpoints + (dape--warn "Failed setting data breakpoints for %s" + (mapconcat (lambda (plist) (plist-get plist :name)) + unverfied-breakpoints ", "))) + ;; FIXME Should not remove unverified-breakpoints as they + ;; might be verified by another live connection. + (setq dape--data-breakpoints verfied-breakpoints)) + (dape--request-continue cb error)) + (setq dape--data-breakpoints nil) + (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)) + (buffer (get-buffer-create "*dape-shell*"))) + (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-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 + (with-slots (hits) breakpoint + (setf hits (1+ (or hits 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 by 'cddr + when (buffer-live-p buffer) + do (kill-buffer buffer)) + (setq dape--source-buffers 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 default-directory)) + (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) + ;; 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) + (let ((stderr-buffer + (with-current-buffer (get-buffer-create " *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)))) + (setq 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 (get-buffer-create "*dape-connection stderr*") + :file-handler t)) + (when dape-debug + (dape--message "Adapter started with %S" + (mapconcat #'identity command " ")))))) + (dape-connection + :name "dape-connection" + :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 + (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))) + ;; Run hooks and update mode line + (dape-active-mode -1) + (force-mode-line-update t))) + :request-dispatcher #'dape-handle-request + :notification-dispatcher #'dape-handle-event + :process process))) + + +;;; 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 (dape--thread-id-object conn)) + (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) + (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--connection (dape (dape--config dape--connection))) + (;; 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-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 cb 'with-disconnect) + (jsonrpc-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)))) + (jsonrpc-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)) + (jsonrpc-shutdown conn) + (dape--kill-buffers))) + +(defun dape-quit (&optional conn) + "Terminate session and kill all Dape buffers. +CONN is inferred for interactive invocations." + (interactive (list (dape--live-connection 'parent t))) + (dape--kill-buffers 'skip-process-buffers) + (if (not conn) + (dape--kill-buffers) + (let (;; Use a lower timeout, if trying to kill an to kill an + ;; unresponsive adapter 10s is an long time to wait. + (dape-request-timeout 3)) + (dape--with-request (dape-kill conn) + (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--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--breakpoint-type))) + (dape--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--breakpoint-type))) + (dape--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-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 ((sources (mapcar #'dape--breakpoint-source dape--breakpoints))) + (dolist (breakpoint dape--breakpoints) + (dape--breakpoint-remove breakpoint 'skip-notify)) + (apply #'dape--breakpoint-notify-changes sources))) + +(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--live-connections) 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 (list (dape--read-config))) + (dape--with-request (dape-kill (dape--live-connection 'parent t)) + (dape--config-ensure config t) + ;; Hooks need to be run before any REPL messaging but after we + ;; have tried ensured that config is executable. + (run-hooks 'dape-start-hook) + (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))) + (setq dape--connection (dape--create-connection config)) + (dape--start-debugging dape--connection)))) + + +;;; 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 (plist-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* ((overlay (dape--breakpoint-location breakpoint)) + ((overlayp overlay))) + (overlay-buffer overlay))) + +(defun dape--breakpoint-file-name (breakpoint) + "Return file name for BREAKPOINT." + (let ((location (dape--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." + (let ((location (dape--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 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--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--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--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 breakpoints have buffers." + (cl-loop for breakpoint in dape--breakpoints + 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 + 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 breakpoints at current point." + (cl-loop with current-line = (line-number-at-pos (point)) + for breakpoint in dape--breakpoints + when (and (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 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--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 (dape--breakpoint-make :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--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--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--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 breakpoint from buffer and notify all adapters. +If SKIP-NOTIFY is non-nil, do not notify adapter about removal." + (setq dape--breakpoints (delq breakpoint dape--breakpoints)) + (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." + (with-slots (id verified type value disabled) breakpoint + (unless disabled + ;; Update `dape--breakpoint' data + (setf id (plist-put id conn (plist-get update :id)) + verified (plist-put verified 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--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 (dape--breakpoint-make :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--breakpoint-type breakpoint) + ,(dape--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 (name reference content mime-type) + "Make source buffer from REFERENCE. +Created from NAME, MIME-TYPE, REFERENCE and CONTENT." + (let ((buffer (generate-new-buffer (format "*dape-source %s*" name)))) + (setq dape--source-buffers + (plist-put dape--source-buffers 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 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 (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'." + (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 + truncate-lines 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 'mode-line) + (dape--info-header name mode index "mouse-1: select" + 'mode-line-highlight + 'mode-line-inactive)) + " ")))))) + + +;;; 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." + (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--exception) + (dape-info-breakpoints-mode) + "Toggle exception or goto breakpoint at current line." + (cond (dape--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 + (plist-put dape--exception :enabled + (not (plist-get dape--exception :enabled))) + (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--data-breakpoint) + (dape-info-breakpoints-mode) + "Delete breakpoint at current line." + (cond (dape--breakpoint + (dape--breakpoint-remove dape--breakpoint)) + (dape--data-breakpoint + (setq dape--data-breakpoints + (delq dape--data-breakpoint + dape--data-breakpoints)) + (when-let* ((conn (dape--live-connection 'stopped t))) + (dape--with-request (dape--set-data-breakpoints conn))))) + (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--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) + +(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 plist in dape--data-breakpoints do + (gdb-table-add-row + table + (list + y "Data " + (format "%s %s %s" + (propertize (plist-get plist :name) + 'font-lock-face + 'font-lock-variable-name-face) + (plist-get plist :accessType) + (when-let* ((data-id (plist-get plist :dataId))) + (format "(%s)" data-id)))) + `(dape--data-breakpoint ,plist))) + (cl-loop for breakpoint in dape--breakpoints + for line = (dape--breakpoint-line breakpoint) + for verified-plist = (dape--breakpoint-verified breakpoint) + for 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)) + do + (gdb-table-add-row + table + (list + (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)) + (pcase (dape--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))))) + (cl-loop for exception in dape--exceptions do + (gdb-table-add-row + table + `(,(if (plist-get exception :enabled) y n) + "Excep" + ,(format "%s" (plist-get exception :label))) + `( dape--exception ,exception + mouse-face highlight + help-echo "mouse-2, RET: toggle exception"))) + (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) + truncate-lines nil + 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--live-connections) + 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) + 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) + dape--connection)) + (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) + dape--connection)) + (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 (list :name name + :dataId dataId + :accessType (completing-read + (format "Breakpoint type for `%s': " name) + (append accessTypes nil) nil t)) + dape--data-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) "")) + (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* ((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)) + ((< 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--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 (dape--breakpoint-disabled breakpoint) + (eq (dape--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 + (eq (dape--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))))) + (when dape-minibuffer-hint + (overlay-put dape--minibuffer-hint-overlay + 'after-string + (concat + (when 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))) + +(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 + (condition-case _ + ;; Try to eval function, signal on minibuffer + (let ((enable-recursive-minibuffers (not skip-interactive))) + (if (functionp value) + (funcall-interactively value) + (eval value t))) + (error value)))) + ;; 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' 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) + "Evaluate config with KEY and OPTIONS." + (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))))) + +(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))) + (let ((default-directory + (if-let* ((command-cwd (plist-get config 'command-cwd))) + (dape--config-eval-value command-cwd) + default-directory))) + (condition-case err + (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) + (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) + (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))) + (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 (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) + dape--connection))) + (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* ((reason (and conn (dape--state-reason conn)))) + `("/" (:propertize ,reason face font-lock-doc-face))) + ,@(when-let* ((conns (dape--live-connections)) + (nof-conns + (length (cl-remove-if-not #'dape--threads conns))) + ((> nof-conns 1))) + `(( :propertize ,(format "(%s)" nof-conns) + 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 "b" #'dape-breakpoint-toggle) + (define-key map "B" #'dape-breakpoint-remove-all) + (define-key map "t" #'dape-select-thread) + (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 "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-toggle + dape-breakpoint-remove-all + dape-stack-select-up + dape-stack-select-down + dape-select-stack + dape-select-thread + dape-watch-dwim + dape-evaluate-expression)) + (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 connection and wait until finished." + (let (done) + (dape--with-request (dape-kill dape--connection) + (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 diff --git a/.emacs.d/themes/acme-theme.el b/.emacs.d/themes/acme-theme.el new file mode 100644 index 0000000..b83c8ae --- /dev/null +++ b/.emacs.d/themes/acme-theme.el @@ -0,0 +1,512 @@ +;;; acme-theme.el --- A color theme based on Acme & Sam from Plan 9 -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Ian Yi-En Pan + +;; Author: Ian Y.E. Pan +;; URL: https://github.com/ianpan870102/acme-emacs-theme +;; Version: 1.0.0 + +;; 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: +;; A color theme for Emacs based on Acme & Sam from Plan 9 + +;;; Credits: +;; This theme was modified from John Louis Del Rosario's plan9-theme.el + +;;; Code: + +(defgroup acme-theme nil + "Options for acme theme." + :group 'faces) + +(defcustom acme-theme-black-fg nil + "If non-nil, foreground will be pure black instead of the default dark grey." + :group 'acme-theme + :type 'boolean) + +(deftheme acme "A color theme based on Acme & Sam") + +;;; Color palette + +(let ((class '((class color) (min-colors 89))) + (bg "#FFFFE8") ; default bg + (bg-alt "#EFEFD8") + (bg-dark "#E5E5D0") + (fg (if acme-theme-black-fg "#000000" "#444444")) ; default fg + (fg-alt "#B8B09A") + (fg-dark "#988D6D") + (fg-light "#CCCCB7") + (highlight "#E8EB98") + (highlight-alt "#E8EBC8") + + ;; Standardized palette + (acme-cyan "#007777") + (acme-cyan-light "#A8EFEB") + (acme-red "#880000") + (acme-red-light "#F8E8E8") + (acme-yellow "#888838") + (acme-yellow-light "#F8FCE8") + (acme-green "#005500") + (acme-green-alt "#006600") + (acme-green-light "#E8FCE8") + (acme-blue "#1054AF") + (acme-blue-light "#E1FAFF") + (acme-purple "#555599") + (acme-purple-light "#FFEAFF")) + +;;; Theme Faces + (custom-theme-set-faces + 'acme + +;;;; Built-in + +;;;;; basic coloring + `(button ((t (:underline t)))) + `(link ((t (:foreground "#0066cc":weight normal)))) + `(highlight ((t (:inherit link :underline t)))) ; link hover + `(link-visited ((t (:foreground ,acme-purple :underline t :weight normal)))) + `(default ((t (:foreground ,fg :background ,bg)))) + `(cursor ((t (:foreground ,bg :background ,fg)))) + `(escape-glyph ((t (:foreground ,acme-cyan-light :bold nil)))) + `(fringe ((t (:foreground ,fg :background ,bg)))) + `(line-number ((t (:foreground ,fg :background ,bg-alt)))) + `(line-number-current-line ((t (:foreground ,fg :background ,bg-alt)))) + `(header-line ((t (:foreground ,fg :background ,acme-blue-light :box t)))) + `(success ((t (:foreground ,acme-green :weight normal)))) + `(warning ((t (:foreground ,acme-red :weight normal)))) + `(error ((t (:foreground ,acme-red :bold t)))) + +;;;;; compilation + `(compilation-column-face ((t (:foreground ,acme-yellow :background ,acme-yellow-light)))) + `(compilation-column-number ((t (:foreground ,acme-yellow :background ,acme-yellow-light)))) + `(compilation-error-face ((t (:foreground ,acme-red :weight normal :underline t)))) + `(compilation-face ((t (:foreground ,fg)))) + `(compilation-info-face ((t (:foreground ,acme-blue)))) + `(compilation-info ((t (:foreground ,acme-blue :underline t)))) + `(compilation-line-face ((t (:foreground ,acme-purple)))) + `(compilation-line-number ((t (:foreground ,acme-yellow :background ,acme-yellow-light)))) + `(compilation-message-face ((t (:foreground ,acme-blue)))) + `(compilation-warning-face ((t (:foreground ,acme-yellow :weight normal :underline t)))) + `(compilation-mode-line-exit ((t (:foreground ,acme-cyan :weight normal)))) + `(compilation-mode-line-fail ((t (:foreground ,acme-red :weight normal)))) + `(compilation-mode-line-run ((t (:foreground ,acme-purple :weight normal)))) + +;;;;; grep + `(grep-context-face ((t (:foreground ,fg-alt)))) + `(grep-error-face ((t (:foreground ,acme-red :weight normal :underline t)))) + `(grep-hit-face ((t (:foreground ,acme-purple :weight normal)))) + `(grep-match-face ((t (:foreground ,acme-cyan :weight normal)))) + `(match ((t (:background ,acme-cyan :foreground ,acme-cyan-light)))) + +;;;;; ag + `(ag-hit-face ((t (:foreground ,acme-green :weight normal)))) + `(ag-match-face ((t (:foreground ,acme-cyan :background ,acme-cyan-light :weight normal)))) + +;;;;; isearch + `(isearch ((t (:foreground ,fg :weight normal :background ,acme-cyan-light)))) + `(isearch-fail ((t (:foreground ,fg :weight normal :background ,acme-red)))) + `(lazy-highlight ((t (:foreground ,fg :weight normal :background ,acme-blue-light)))) + + `(menu ((t (:foreground ,bg :background ,fg)))) + `(minibuffer-prompt ((t (:foreground ,fg :weight normal)))) + `(region ((,class (:foreground ,fg :background ,highlight :extend nil)))) + `(secondary-selection ((t (:background ,acme-green-light)))) + `(trailing-whitespace ((t (:background ,acme-red-light)))) + `(vertical-border ((t (:foreground ,acme-cyan)))) + +;;;;; font lock + `(font-lock-builtin-face ((t (:foreground ,fg :weight normal)))) + `(font-lock-function-name-face ((t (:foreground ,fg :weight normal)))) + `(font-lock-string-face ((t (:foreground ,acme-red)))) + `(font-lock-keyword-face ((t (:foreground ,acme-blue :weight bold)))) ; if, else, for, while, return... + `(font-lock-type-face ((t (:foreground ,fg :weight bold)))) ; int, float, string, void... + `(font-lock-constant-face ((t (:foreground ,fg :weight bold)))) ; NULL, nullptr, true, false... + `(font-lock-variable-name-face ((t (:foreground ,fg :weight normal)))) + `(font-lock-comment-face ((t (:foreground ,acme-green :italic nil)))) + `(font-lock-comment-delimiter-face ((t (:foreground ,acme-green :italic nil)))) + `(font-lock-doc-face ((t (:foreground ,acme-yellow :italic nil)))) + `(font-lock-negation-char-face ((t (:foreground ,acme-red :weight normal)))) + `(font-lock-preprocessor-face ((t (:foreground ,acme-red :weight normal)))) + `(font-lock-regexp-grouping-construct ((t (:foreground ,acme-purple :weight normal)))) + `(font-lock-regexp-grouping-backslash ((t (:foreground ,acme-purple :weight normal)))) + `(font-lock-warning-face ((t (:foreground ,acme-red :weight normal)))) + +;;;;; table + `(table-cell ((t (:background ,bg-alt)))) + +;;;;; ledger + `(ledger-font-directive-face ((t (:foreground ,acme-cyan)))) + `(ledger-font-periodic-xact-face ((t (:inherit ledger-font-directive-face)))) + `(ledger-font-posting-account-face ((t (:foreground ,acme-blue)))) + `(ledger-font-posting-amount-face ((t (:foreground ,acme-red)))) + `(ledger-font-posting-date-face ((t (:foreground ,acme-red :weight normal)))) + `(ledger-font-payee-uncleared-face ((t (:foreground ,acme-purple)))) + `(ledger-font-payee-cleared-face ((t (:foreground ,fg)))) + `(ledger-font-payee-pending-face ((t (:foreground ,acme-yellow)))) + `(ledger-font-xact-highlight-face ((t (:background ,bg-alt)))) + +;;;; Third-party + + +;;;;; anzu + `(anzu-mode-line ((t (:foreground ,acme-yellow :background ,acme-yellow-light :weight normal)))) + +;;;;; clojure-mode + `(clojure-interop-method-face ((t (:inherit font-lock-function-name-face)))) + +;;;;; clojure-test-mode + `(clojure-test-failure-face ((t (:foreground ,acme-red :weight normal :underline t)))) + `(clojure-test-error-face ((t (:foreground ,acme-red :weight normal :underline t)))) + `(clojure-test-success-face ((t (:foreground ,acme-green :weight normal :underline t)))) + +;;;;; diff + `(diff-added ((,class (:foreground ,fg :background ,acme-green-light)) + (t (:foreground ,fg :background ,acme-green-light)))) + `(diff-changed ((t (:foreground ,acme-yellow)))) + `(diff-context ((t (:foreground ,fg)))) + `(diff-removed ((,class (:foreground ,fg :background ,acme-red-light)) + (t (:foreground ,fg :background ,acme-red-light)))) + `(diff-refine-added ((t :inherit diff-added :background ,acme-green-light :weight bold :underline t))) + `(diff-refine-change ((t :inherit diff-changed :weight normal))) + `(diff-refine-removed ((t :inherit diff-removed :background ,acme-red-light :weight bold :underline t))) + `(diff-header ((,class (:foreground ,fg :weight normal)) + (t (:foreground ,acme-purple-light :weight normal)))) + `(diff-file-header ((,class (:foreground ,fg :background ,acme-cyan-light :weight normal)) + (t (:foreground ,fg :background ,acme-cyan-light :weight normal)))) + `(diff-hunk-header ((,class (:foreground ,acme-green :weight normal)) + (t (:foreground ,acme-green :weight normal)))) +;;;;; dired/dired+/dired-subtree + `(dired-directory ((t (:foreground ,acme-blue :weight bold)))) + `(diredp-display-msg ((t (:foreground ,acme-blue)))) + `(diredp-compressed-file-suffix ((t (:foreground ,acme-purple)))) + `(diredp-date-time ((t (:foreground ,acme-green)))) + `(diredp-deletion ((t (:foreground ,acme-red)))) + `(diredp-deletion-file-name ((t (:foreground ,acme-red)))) + `(diredp-dir-heading ((t (:foreground ,acme-blue :background ,acme-blue-light :weight bold)))) + `(diredp-dir-priv ((t (:foreground ,acme-blue)))) + `(diredp-exec-priv ((t (:foreground ,acme-yellow)))) + `(diredp-executable-tag ((t (:foreground ,acme-yellow)))) + `(diredp-file-name ((t (:foreground ,fg)))) + `(diredp-file-suffix ((t (:foreground ,acme-yellow)))) + `(diredp-flag-mark ((t (:foreground ,acme-cyan)))) + `(diredp-flag-mark-line ((t (:foreground ,acme-cyan)))) + `(diredp-ignored-file-name ((t (:foreground ,fg-light)))) + `(diredp-link-priv ((t (:foreground ,acme-purple)))) + `(diredp-mode-line-flagged ((t (:foreground ,acme-yellow)))) + `(diredp-mode-line-marked ((t (:foreground ,acme-yellow)))) + `(diredp-no-priv ((t (:foreground ,fg)))) + `(diredp-number ((t (:foreground ,acme-blue)))) + `(diredp-other-priv ((t (:foreground ,fg)))) + `(diredp-rare-priv ((t (:foreground ,fg)))) + `(diredp-read-priv ((t (:foreground ,fg)))) + `(diredp-symlink ((t (:foreground ,fg :background ,acme-blue-light)))) + `(diredp-write-priv ((t (:foreground ,fg)))) + `(diredp-dir-name ((t (:foreground ,acme-blue :weight bold)))) + `(dired-subtree-depth-1-face ((t (:background ,bg)))) + `(dired-subtree-depth-2-face ((t (:background ,bg)))) + `(dired-subtree-depth-3-face ((t (:background ,bg)))) + +;;;;; elfeed + `(elfeed-search-date-face ((t (:foreground ,acme-blue)))) + `(elfeed-search-title-face ((t (:foreground ,fg)))) + `(elfeed-search-unread-title-face ((t (:foreground ,fg)))) + `(elfeed-search-feed-face ((t (:foreground ,acme-green)))) + `(elfeed-search-tag-face ((t (:foreground ,acme-red)))) + `(elfeed-search-unread-count-face ((t (:foreground ,fg)))) + +;;;;; erc + `(erc-default-face ((t (:foreground ,fg)))) + `(erc-header-line ((t (:inherit header-line)))) + `(erc-action-face ((t (:inherit erc-default-face)))) + `(erc-bold-face ((t (:inherit erc-default-face :weight normal)))) + `(erc-underline-face ((t (:underline t)))) + `(erc-error-face ((t (:inherit font-lock-warning-face)))) + `(erc-prompt-face ((t (:foreground ,acme-green :background ,acme-green-light :weight normal)))) + `(erc-timestamp-face ((t (:foreground ,acme-green :background ,acme-green-light)))) + `(erc-direct-msg-face ((t (:inherit erc-default)))) + `(erc-notice-face ((t (:foreground ,fg-light)))) + `(erc-highlight-face ((t (:background ,highlight)))) + `(erc-input-face ((t (:foreground ,fg :background ,bg-alt)))) + `(erc-current-nick-face ((t (:foreground ,fg :background ,acme-cyan-light :weight normal + :box (:line-width 1 :style released-button))))) + `(erc-nick-default-face ((t (:weight normal :background ,bg-alt)))) + `(erc-my-nick-face ((t (:foreground ,fg :background ,acme-cyan-light :weight normal + :box (:line-width 1 :style released-button))))) + `(erc-nick-msg-face ((t (:inherit erc-default)))) + `(erc-fool-face ((t (:inherit erc-default)))) + `(erc-pal-face ((t (:foreground ,acme-purple :weight normal)))) + `(erc-dangerous-host-face ((t (:inherit font-lock-warning-face)))) + `(erc-keyword-face ((t (:foreground ,acme-yellow :weight normal)))) + + ;;;;; evil + `(evil-search-highlight-persist-highlight-face ((t (:inherit lazy-highlight)))) + +;;;;; flx + `(flx-highlight-face ((t (:foreground ,acme-yellow :background ,acme-green-light + :weight normal :underline t)))) + +;;;;; company + `(company-tooltip ((t (:background ,acme-blue-light)))) + `(company-tooltip-selection ((t (:background ,acme-cyan-light)))) + `(company-tooltip-common ((t (:foreground ,acme-blue :bold t)))) + `(company-tooltip-annotation ((t (:foreground ,acme-yellow :italic t)))) ; parameter hints etc. + `(company-scrollbar-fg ((t (:background ,acme-cyan)))) + `(company-scrollbar-bg ((t (:background ,acme-cyan-light)))) + `(company-preview-common ((t (:foreground ,fg :background ,acme-cyan-light)))) + +;;;;; highlight-symbol + `(highlight-symbol-face ((t (:background ,bg-alt)))) + +;;;;; highlight-numbers + `(highlight-numbers-number ((t (:foreground ,acme-blue)))) + +;;;;; highlight-operators + `(highlight-operators-face ((t (:foreground ,fg)))) + +;;;;; hl-todo + `(hl-todo ((t (:inverse-video t)))) + +;;;;; hl-line-mode + `(hl-line ((,class (:background ,bg-alt)))) + +;;;;; hl-sexp + `(hl-sexp-face ((,class (:background ,bg-alt)))) + +;;;;; ido-mode + `(ido-first-match ((t (:foreground ,fg :weight normal)))) + `(ido-only-match ((t (:foreground ,fg :weight normal)))) + `(ido-subdir ((t (:foreground ,acme-blue)))) + `(ido-indicator ((t (:foreground ,acme-yellow)))) + +;;;;; ido-vertical + `(ido-vertical-first-match-face ((t (:foreground ,fg :background ,acme-cyan-light :weight normal)))) + `(ido-vertical-only-match-face ((t (:foreground ,acme-red :background ,acme-red-light :weight normal)))) + `(ido-vertical-match-face ((t (:foreground ,fg :background ,acme-green-light + :weight normal :underline t)))) + +;;;;; indent-guide + `(indent-guide-face ((t (:foreground ,highlight)))) + +;;;;; ivy + `(ivy-current-match ((t (:background ,acme-blue-light :underline t :extend t)))) + `(ivy-minibuffer-match-face-1 ((t (:background ,bg-alt)))) + `(ivy-minibuffer-match-face-2 ((t (:background ,acme-cyan-light)))) + `(ivy-minibuffer-match-face-3 ((t (:background ,acme-purple-light)))) + `(ivy-minibuffer-match-face-3 ((t (:background ,acme-blue-light)))) + +;;;;; js2-mode + `(js2-warning ((t (:underline ,acme-yellow)))) + `(js2-error ((t (:foreground ,acme-red :weight normal)))) + `(js2-jsdoc-tag ((t (:foreground ,acme-purple)))) + `(js2-jsdoc-type ((t (:foreground ,acme-blue)))) + `(js2-jsdoc-value ((t (:foreground ,acme-cyan)))) + `(js2-function-param ((t (:foreground ,fg)))) + `(js2-external-variable ((t (:foreground ,acme-cyan)))) + +;;;;; linum-mode + `(linum ((t (:foreground ,fg-light)))) + +;;;;; lsp-mode + `(lsp-face-highlight-textual ((t (:background ,bg-dark)))) + `(lsp-face-highlight-read ((t (:background ,acme-purple-light)))) + `(lsp-face-highlight-write ((t (:background ,acme-green-light)))) + +;;;;; magit + `(magit-section-heading ((t (:foreground ,acme-cyan :background ,acme-blue-light + :weight normal :underline t)))) + `(magit-section-highlight ((t (:background ,bg-alt)))) + `(magit-section-heading-selection ((t (:background ,highlight)))) + `(magit-filename ((t (:foreground ,fg)))) + `(magit-hash ((t (:foreground ,acme-yellow :weight normal)))) + `(magit-tag ((t (:foreground ,acme-purple :weight normal)))) + `(magit-refname ((t (:foreground ,acme-purple :weight normal)))) + `(magit-head ((t (:foreground ,acme-green :weight normal)))) + `(magit-branch-local ((t (:foreground ,acme-blue :background ,acme-blue-light + :weight normal)))) + `(magit-branch-remote ((t (:foreground ,acme-green :background ,acme-green-light + :weight normal)))) + `(magit-branch-current ((t (:foreground ,acme-cyan :background ,acme-cyan-light + :weight normal + :box (:line-width 1 :color ,acme-cyan))))) + `(magit-diff-file-heading ((t (:foreground ,fg :weight normal)))) + `(magit-diff-file-heading-highlight ((t (:background ,bg-alt)))) + `(magit-diff-file-heading-selection ((t (:foreground ,acme-red :background ,highlight)))) + `(magit-diff-hunk-heading ((t (:foreground ,acme-blue :background ,acme-blue-light :weight normal :underline t)))) + `(magit-diff-hunk-heading-highlight ((t (:background ,acme-cyan-light)))) + `(magit-diff-added ((t (:foreground ,acme-green :background ,acme-green-light)))) + `(magit-diff-removed ((t (:foreground ,acme-red :background ,acme-red-light)))) + `(magit-diff-context ((t (:foreground ,fg-dark :background nil)))) + `(magit-diff-added-highlight ((t (:foreground ,acme-green :background ,acme-green-light)))) + `(magit-diff-removed-highlight ((t (:foreground ,acme-red :background ,acme-red-light)))) + `(magit-diff-context-highlight ((t (:foreground ,fg-dark :background ,bg-alt)))) + `(magit-diffstat-added ((t (:foreground ,acme-green :background ,acme-green-light :weight normal)))) + `(magit-diffstat-removed ((t (:foreground ,acme-red :background ,acme-red-light :weight normal)))) + `(magit-log-author ((t (:foreground ,acme-blue :weight normal)))) + `(magit-log-date ((t (:foreground ,acme-purple :weight normal)))) + `(magit-log-graph ((t (:foreground ,acme-red :weight normal)))) + `(magit-blame-heading ((t (:foreground ,fg-dark :background ,bg-alt)))) + +;;;;; paren-face + `(parenthesis ((t (:foreground "#CCCCB7")))) + +;;;;; project-explorer + `(pe/file-face ((t (:foreground ,fg)))) + `(pe/directory-face ((t (:foreground ,acme-blue :weight normal)))) + +;;;;; rainbow-delimiters + `(rainbow-delimiters-depth-1-face ((t (:foreground ,acme-green)))) + `(rainbow-delimiters-depth-2-face ((t (:foreground ,acme-blue)))) + `(rainbow-delimiters-depth-3-face ((t (:foreground ,acme-red)))) + +;;;;; show-paren + `(show-paren-mismatch ((t (:foreground ,acme-yellow :background ,acme-red :weight normal)))) + `(show-paren-match ((t (:foreground ,fg :background ,acme-cyan-light :weight normal)))) + +;;;;; mode-line/sml-mode-line + `(mode-line ((,class (:foreground ,fg :background ,acme-blue-light :box t)))) + `(mode-line-inactive ((t (:foreground ,fg :background ,bg-dark :box t)))) + `(mode-line-buffer-id ((t (:foreground ,fg :weight bold)))) ; associated buffer/file name + `(sml/global ((t (:foreground ,fg)))) + `(sml/modes ((t (:foreground ,acme-green :background ,acme-green-light)))) + `(sml/filename ((t (:foreground ,acme-red)))) + `(sml/folder ((t (:foreground ,fg)))) + `(sml/prefix ((t (:foreground ,fg)))) + `(sml/read-only ((t (:foreground ,fg)))) + `(sml/modified ((t (:foreground ,acme-red :weight normal)))) + `(sml/outside-modified ((t (:background ,acme-red :foreground ,acme-red-light :weight normal)))) + `(sml/line-number ((t (:foreground ,fg :weight normal)))) + `(sml/col-number ((t (:foreground ,fg :weight normal)))) + `(sml/vc ((t (:foreground ,fg :weight normal)))) + `(sml/vc-edited ((t (:foreground ,acme-red :weight normal)))) + `(sml/git ((t (:foreground ,fg :weight normal)))) + +;;;;; sh + `(sh-heredoc-face ((t (:foreground ,acme-purple)))) + +;;;;; web-mode + `(web-mode-builtin-face ((t (:inherit ,font-lock-builtin-face)))) + `(web-mode-comment-face ((t (:inherit ,font-lock-comment-face)))) + `(web-mode-constant-face ((t (:inherit ,font-lock-constant-face)))) + `(web-mode-doctype-face ((t (:inherit ,font-lock-comment-face)))) + `(web-mode-folded-face ((t (:underline t)))) + `(web-mode-function-name-face ((t (:foreground ,fg :weight normal)))) + `(web-mode-html-attr-name-face ((t (:foreground ,fg)))) + `(web-mode-html-attr-value-face ((t (:inherit ,font-lock-string-face)))) + `(web-mode-html-tag-face ((t (:foreground ,acme-blue)))) + `(web-mode-keyword-face ((t (:inherit ,font-lock-keyword-face)))) + `(web-mode-preprocessor-face ((t (:inherit ,font-lock-preprocessor-face)))) + `(web-mode-string-face ((t (:inherit ,font-lock-string-face)))) + `(web-mode-type-face ((t (:inherit ,font-lock-type-face)))) + `(web-mode-variable-name-face ((t (:inherit ,font-lock-variable-name-face)))) + `(web-mode-server-background-face ((t (:background ,acme-green-light)))) + `(web-mode-server-comment-face ((t (:inherit web-mode-comment-face)))) + `(web-mode-server-string-face ((t (:foreground ,acme-red)))) + `(web-mode-symbol-face ((t (:inherit font-lock-constant-face)))) + `(web-mode-warning-face ((t (:inherit font-lock-warning-face)))) + `(web-mode-whitespaces-face ((t (:background ,acme-red-light)))) + `(web-mode-block-face ((t (:background ,acme-green-light)))) + `(web-mode-current-element-highlight-face ((t (:foreground ,fg :background ,acme-blue-light)))) + `(web-mode-json-key-face ((,class (:inherit font-lock-string-face)))) + `(web-mode-json-context-face ((,class (:inherit font-lock-string-face :bold t)))) + +;;;;; which-func-mode + `(which-func ((t (:foreground ,acme-purple :background ,acme-purple-light)))) + +;;;;; yascroll + `(yascroll:thumb-text-area ((t (:background ,highlight)))) + `(yascroll:thumb-fringe ((t (:background ,bg :foreground ,bg + :box (:line-width 1 :style released-button))))) + +;;;;; Org + `(org-level-1 ((t (:background ,acme-blue-light :foreground ,acme-blue :weight bold :overline t)))) + `(org-level-2 ((t (:background ,acme-blue-light :foreground ,acme-cyan :weight bold :overline t)))) + `(org-level-3 ((t (:background ,acme-blue-light :foreground ,acme-blue :weight bold :overline t)))) + `(org-level-4 ((t (:background ,acme-blue-light :foreground ,acme-cyan)))) + `(org-level-5 ((t (:background ,acme-blue-light :foreground ,acme-blue)))) + `(org-level-6 ((t (:background ,acme-blue-light :foreground ,acme-cyan)))) + `(org-level-7 ((t (:background ,acme-blue-light :foreground ,acme-blue)))) + `(org-level-8 ((t (:background ,acme-blue-light :foreground ,acme-cyan)))) + `(org-document-title ((t (:height 1.2 :foreground ,acme-blue :weight bold :underline t)))) ; #TITLE + `(org-meta-line ((t (:foreground ,acme-green)))) + `(org-document-info ((t (:foreground ,acme-cyan :weight normal)))) + `(org-document-info-keyword ((t (:foreground ,acme-cyan)))) + `(org-todo ((t (:foreground ,acme-yellow :background ,bg-alt :weight normal :box (:line-width 1 :style released-button))))) + `(org-done ((t (:foreground ,acme-green :background ,acme-green-light :weight normal :box (:style released-button))))) + `(org-date ((t (:foreground ,acme-purple)))) + `(org-table ((t (:foreground ,acme-purple)))) + `(org-formula ((t (:foreground ,acme-blue :background ,bg-alt)))) + `(org-code ((t (:foreground ,acme-red :background ,bg-alt)))) + `(org-verbatim ((t (:foreground ,fg :background ,bg-alt :underline t)))) + `(org-special-keyword ((t (:foreground ,acme-cyan)))) + `(org-agenda-date ((t (:foreground ,acme-cyan)))) + `(org-agenda-structure ((t (:foreground ,acme-purple)))) + `(org-block ((t (:foreground ,fg :background ,bg-alt :extend t)))) + `(org-block-background ((t (:background ,bg-alt :extend t)))) + `(org-block-begin-line ((t (:foreground ,fg-alt :background ,bg-dark :italic t :extend t)))) + `(org-block-end-line ((t (:foreground ,fg-alt :background ,bg-dark :italic t :extend t)))) + +;;;;; origami + `(origami-fold-replacement-face ((t (:foreground ,acme-red :background ,acme-red-light + :box (:line-width -1))))) + +;;;;; git-gutter + `(git-gutter:added ((t (:background ,acme-green-alt :foreground ,acme-green-alt :weight normal)))) + `(git-gutter:deleted ((t (:background ,acme-red :foreground ,acme-red :weight normal)))) + `(git-gutter:modified ((t (:background ,acme-yellow :foreground ,acme-yellow :weight normal)))) + `(git-gutter-fr:added ((t (:background ,acme-green-alt :foreground ,acme-green-alt :weight normal)))) + `(git-gutter-fr:deleted ((t (:background ,acme-red :foreground ,acme-red :weight normal)))) + `(git-gutter-fr:modified ((t (:background ,acme-yellow :foreground ,acme-yellow :weight normal)))) + +;;;;; diff-hl + `(diff-hl-insert ((t (:background ,acme-green-alt :foreground ,acme-green-alt)))) + `(diff-hl-delete ((t (:background ,acme-red :foreground ,acme-red)))) + `(diff-hl-change ((t (:background ,acme-yellow :foreground ,acme-yellow)))) + +;;;;; mu4e, mail + `(mu4e-header-highlight-face ((t (:background ,highlight)))) + `(mu4e-unread-face ((t (:foreground ,acme-blue :weight normal)))) + `(mu4e-flagged-face ((t (:foreground ,acme-red :background ,acme-red-light :weight normal)))) + `(mu4e-compose-separator-face ((t (:foreground ,acme-green)))) + `(mu4e-header-value-face ((t (:foreground ,fg)))) + `(message-header-name ((t (:foreground ,acme-purple :weight normal)))) + `(message-header-to ((t (:foreground ,acme-blue)))) + `(message-header-subject ((t (:foreground ,acme-blue)))) + `(message-header-other ((t (:foreground ,acme-blue)))) + `(message-cited-text ((t (:inherit font-lock-comment-face)))) + +;;;;; term-mode (vterm too) + `(term ((,class (:foreground ,fg :background ,bg)))) + `(term-color-black ((,class (:foreground ,fg :background ,fg)))) + `(term-color-blue ((,class (:foreground ,acme-blue :background ,acme-blue)))) + `(term-color-red ((,class (:foreground ,acme-red :background ,acme-red)))) + `(term-color-green ((,class (:foreground ,acme-green :background ,acme-green)))) + `(term-color-yellow ((,class (:foreground ,acme-yellow :background ,acme-yellow)))) + `(term-color-magenta ((,class (:foreground ,acme-purple :background ,acme-purple)))) + `(term-color-cyan ((,class (:foreground ,acme-cyan :background ,acme-cyan)))) + `(term-color-white ((,class (:foreground ,fg :background ,fg)))) + +;;;;; fill-column-indicator + `(fci-rule-color ((t (:foreground ,highlight-alt)))) + `(fill-column-indicator ((t (:foreground ,highlight-alt)))))) + +;;;###autoload +(when (and (boundp 'custom-theme-load-path) load-file-name) + (add-to-list 'custom-theme-load-path + (file-name-as-directory (file-name-directory load-file-name)))) + +(provide-theme 'acme) +(provide 'acme-theme) + +;;; acme-theme.el ends here