cider-debug.el (36587B)
1 ;;; cider-debug.el --- CIDER interaction with the cider.debug nREPL middleware -*- lexical-binding: t; -*- 2 3 ;; Copyright © 2015-2023 Bozhidar Batsov, Artur Malabarba and CIDER contributors 4 5 ;; Author: Artur Malabarba <bruce.connor.am@gmail.com> 6 7 ;; This program is free software; you can redistribute it and/or modify 8 ;; it under the terms of the GNU General Public License as published by 9 ;; the Free Software Foundation, either version 3 of the License, or 10 ;; (at your option) any later version. 11 12 ;; This program is distributed in the hope that it will be useful, 13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;; GNU General Public License for more details. 16 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with this program. If not, see <http://www.gnu.org/licenses/>. 19 20 ;;; Commentary: 21 22 ;; Instrument code with `cider-debug-defun-at-point', and when the code is 23 ;; executed cider-debug will kick in. See this function's doc for more 24 ;; information. 25 26 ;;; Code: 27 28 (require 'map) 29 (require 'seq) 30 (require 'subr-x) 31 32 (require 'spinner) 33 34 (require 'cider-browse-ns) 35 (require 'cider-client) 36 (require 'cider-eval) 37 (require 'cider-inspector) 38 (require 'cider-util) 39 (require 'cider-common) 40 (require 'nrepl-client) ; `nrepl--mark-id-completed' 41 (require 'nrepl-dict) 42 43 44 ;;; Customization 45 (defgroup cider-debug nil 46 "Presentation and behavior of the cider debugger." 47 :prefix "cider-debug-" 48 :group 'cider 49 :package-version '(cider . "0.10.0")) 50 51 (defface cider-debug-code-overlay-face 52 '((((class color) (background light)) :background "grey80") 53 (((class color) (background dark)) :background "grey30")) 54 "Face used to mark code being debugged." 55 :package-version '(cider . "0.9.1")) 56 57 (defface cider-debug-prompt-face 58 '((t :underline t :inherit font-lock-builtin-face)) 59 "Face used to highlight keys in the debug prompt." 60 :package-version '(cider . "0.10.0")) 61 62 (defface cider-enlightened-face 63 '((((class color) (background light)) :inherit cider-result-overlay-face 64 :box (:color "darkorange" :line-width -1)) 65 (((class color) (background dark)) :inherit cider-result-overlay-face 66 ;; "#dd0" is a dimmer yellow. 67 :box (:color "#990" :line-width -1))) 68 "Face used to mark enlightened sexps and their return values." 69 :package-version '(cider . "0.11.0")) 70 71 (defface cider-enlightened-local-face 72 '((((class color) (background light)) :weight bold :foreground "darkorange") 73 (((class color) (background dark)) :weight bold :foreground "yellow")) 74 "Face used to mark enlightened locals (not their values)." 75 :package-version '(cider . "0.11.0")) 76 77 (defcustom cider-debug-prompt 'overlay 78 "If and where to show the keys while debugging. 79 If `minibuffer', show it in the minibuffer along with the return value. 80 If `overlay', show it in an overlay above the current function. 81 If t, do both. 82 If nil, don't list available keys at all." 83 :type '(choice (const :tag "Show in minibuffer" minibuffer) 84 (const :tag "Show above function" overlay) 85 (const :tag "Show in both places" t) 86 (const :tag "Don't list keys" nil)) 87 :package-version '(cider . "0.10.0")) 88 89 (defcustom cider-debug-use-overlays t 90 "Whether to highlight debugging information with overlays. 91 Takes the same possible values as `cider-use-overlays', but only applies to 92 values displayed during debugging sessions. 93 To control the overlay that lists possible keys above the current function, 94 configure `cider-debug-prompt' instead." 95 :type '(choice (const :tag "End of line" t) 96 (const :tag "Bottom of screen" nil) 97 (const :tag "Both" both)) 98 :package-version '(cider . "0.9.1")) 99 100 (make-obsolete 'cider-debug-print-length 'cider-debug-print-options "0.20") 101 (make-obsolete 'cider-debug-print-level 'cider-debug-print-options "0.20") 102 (make-obsolete-variable 'cider-debug-print-options 'cider-print-options "0.21") 103 104 105 ;;; Implementation 106 (declare-function cider-browse-ns--combined-vars-with-meta "cider-browse-ns") 107 108 (defun cider-browse-instrumented-defs () 109 "List all instrumented definitions." 110 (interactive) 111 (if-let* ((all (thread-first (cider-nrepl-send-sync-request '("op" "debug-instrumented-defs")) 112 (nrepl-dict-get "list")))) 113 (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer t) 114 (let ((inhibit-read-only t)) 115 (dolist (list all) 116 (let* ((ns (car list)) 117 (ns-vars-with-meta (cider-browse-ns--combined-vars-with-meta ns)) 118 (instrumented-meta (nrepl-dict-filter (lambda (k _) 119 (member k list)) 120 ns-vars-with-meta))) 121 (cider-browse-ns--list (current-buffer) ns 122 instrumented-meta 123 ns))))) 124 (message "No currently instrumented definitions"))) 125 126 (defun cider--debug-response-handler (response) 127 "Handles RESPONSE from the cider.debug middleware." 128 (nrepl-dbind-response response (status id causes) 129 (when (member "enlighten" status) 130 (cider--handle-enlighten response)) 131 (when (or (member "eval-error" status) 132 (member "stack" status)) 133 ;; TODO: Make the error buffer a bit friendlier when we're just printing 134 ;; the stack. 135 (cider--render-stacktrace-causes causes)) 136 (when (member "need-debug-input" status) 137 (cider--handle-debug response)) 138 (when (member "done" status) 139 (nrepl--mark-id-completed id)))) 140 141 (defun cider--debug-init-connection () 142 "Initialize a connection with the cider.debug middleware." 143 (cider-nrepl-send-request 144 (thread-last 145 (map-merge 'list 146 '(("op" "init-debugger")) 147 (cider--nrepl-print-request-map fill-column)) 148 (seq-mapcat #'identity)) 149 #'cider--debug-response-handler)) 150 151 152 ;;; Debugging overlays 153 (defconst cider--fringe-arrow-string 154 #("." 0 1 (display (left-fringe right-triangle))) 155 "Used as an overlay's before-string prop to place a fringe arrow.") 156 157 (defun cider--debug-display-result-overlay (value) 158 "Place an overlay at point displaying VALUE." 159 (when cider-debug-use-overlays 160 ;; This is cosmetic, let's ensure it doesn't break the session no matter what. 161 (ignore-errors 162 ;; Result 163 (cider--make-result-overlay (cider-font-lock-as-clojure value) 164 :where (point-marker) 165 :type 'debug-result 166 'before-string cider--fringe-arrow-string) 167 ;; Code 168 (cider--make-overlay (save-excursion (clojure-backward-logical-sexp 1) (point)) 169 (point) 'debug-code 170 'face 'cider-debug-code-overlay-face 171 ;; Higher priority than `show-paren'. 172 'priority 2000)))) 173 174 175 ;;; Minor mode 176 (defvar-local cider--debug-mode-response nil 177 "Response that triggered current debug session. 178 Set by `cider--turn-on-debug-mode'.") 179 180 (defcustom cider-debug-display-locals nil 181 "If non-nil, local variables are displayed while debugging. 182 Can be toggled at any time with `\\[cider-debug-toggle-locals]'." 183 :type 'boolean 184 :package-version '(cider . "0.10.0")) 185 186 (defcustom cider-debug-prompt-commands 187 '((?c "continue" "continue") 188 (?C "continue-all" nil) 189 (?n "next" "next") 190 (?i "in" "in") 191 (?o "out" "out") 192 (?O "force-out" nil) 193 (?h "here" "here") 194 (?e "eval" "eval") 195 (?p "inspect" "inspect") 196 (?P "inspect-prompt" nil) 197 (?l "locals" "locals") 198 (?j "inject" "inject") 199 (?s "stacktrace" "stacktrace") 200 (?t "trace" "trace") 201 (?q "quit" "quit")) 202 "A list of debugger command specs. 203 204 Specs are in the format (KEY COMMAND-NAME DISPLAY-NAME?) where KEY is a 205 character which is mapped to the command COMMAND-NAME is a valid debug 206 command to be passed to the cider-nrepl middleware DISPLAY-NAME is the 207 string displayed in the debugger overlay 208 209 If DISPLAY-NAME is nil, that command is hidden from the overlay but still 210 callable. The rest of the commands are displayed in the same order as this 211 list." 212 :type '(alist :key-type character 213 :value-type (list 214 (string :tag "command name") 215 (choice (string :tag "display name") nil))) 216 :package-version '(cider . "0.24.0")) 217 218 (defun cider--debug-format-locals-list (locals) 219 "Return a string description of list LOCALS. 220 Each element of LOCALS should be a list of at least two elements." 221 (if locals 222 (let ((left-col-width 223 ;; To right-indent the variable names. 224 (apply #'max (mapcar (lambda (l) (string-width (car l))) locals)))) 225 ;; A format string to build a format string. :-P 226 (mapconcat (lambda (l) (format (format " %%%ds: %%s\n" left-col-width) 227 (propertize (car l) 'face 'font-lock-variable-name-face) 228 (cider-font-lock-as-clojure (cadr l)))) 229 locals "")) 230 "")) 231 232 (defun cider--debug-propertize-prompt-commands () 233 "In-place format the command display names for the `cider-debug-prompt' overlay." 234 (mapc (lambda (spec) 235 (cl-destructuring-bind (char _cmd disp-name) spec 236 (when-let* ((pos (cl-position char disp-name))) 237 (put-text-property pos (1+ pos) 'face 'cider-debug-prompt-face disp-name)))) 238 cider-debug-prompt-commands)) 239 240 (defun cider--debug-prompt (commands) 241 "Return prompt to display for COMMANDS." 242 ;; Force `default' face, otherwise the overlay "inherits" the face of the text 243 ;; after it. 244 (format (propertize "%s\n" 'face 'default) 245 (cl-reduce 246 (lambda (prompt spec) 247 (cl-destructuring-bind (_char cmd disp) spec 248 (if (and disp (cl-find cmd commands :test 'string=)) 249 (concat prompt " " disp) 250 prompt))) 251 cider-debug-prompt-commands 252 :initial-value ""))) 253 254 (defvar-local cider--debug-prompt-overlay nil) 255 256 (defun cider--debug-mode-redisplay () 257 "Display the input prompt to the user." 258 (nrepl-dbind-response cider--debug-mode-response (debug-value input-type locals) 259 ;; input-type is an unsorted collection of command names, 260 ;; as sent by `cider.nrepl.middleware.debug/read-debug-input` 261 (when (or (eq cider-debug-prompt t) 262 (eq cider-debug-prompt 'overlay)) 263 (if (overlayp cider--debug-prompt-overlay) 264 (overlay-put cider--debug-prompt-overlay 265 'before-string (cider--debug-prompt input-type)) 266 (setq cider--debug-prompt-overlay 267 (cider--make-overlay 268 (max (car (cider-defun-at-point 'bounds)) 269 (window-start)) 270 nil 'debug-prompt 271 'before-string (cider--debug-prompt input-type))))) 272 (let* ((value (concat " " cider-eval-result-prefix 273 (cider-font-lock-as-clojure 274 (or debug-value "#unknown#")))) 275 (to-display 276 (concat (when cider-debug-display-locals 277 (cider--debug-format-locals-list locals)) 278 (when (or (eq cider-debug-prompt t) 279 (eq cider-debug-prompt 'minibuffer)) 280 (cider--debug-prompt input-type)) 281 (when (or (not cider-debug-use-overlays) 282 (eq cider-debug-use-overlays 'both)) 283 value)))) 284 (if (> (string-width to-display) 0) 285 (message "%s" to-display) 286 ;; If there's nothing to display in the minibuffer. Just send the value 287 ;; to the Messages buffer. 288 (message "%s" value) 289 (message nil))))) 290 291 (defun cider-debug-toggle-locals () 292 "Toggle display of local variables." 293 (interactive) 294 (setq cider-debug-display-locals (not cider-debug-display-locals)) 295 (cider--debug-mode-redisplay)) 296 297 (defun cider--debug-lexical-eval (key form &optional callback _point) 298 "Eval FORM in the lexical context of debug session given by KEY. 299 Do nothing if CALLBACK is provided. 300 Designed to be used as `cider-interactive-eval-override' and called instead 301 of `cider-interactive-eval' in debug sessions." 302 ;; The debugger uses its own callback, so if the caller is passing a callback 303 ;; we return nil and let `cider-interactive-eval' do its thing. 304 (unless callback 305 (cider-debug-mode-send-reply (format "{:response :eval, :code %s}" form) 306 key) 307 t)) 308 309 (defvar cider--debug-mode-tool-bar-map 310 (let ((tool-bar-map (make-sparse-keymap))) 311 (tool-bar-add-item "right-arrow" #'cider-debug-mode-send-reply :next :label "Next step") 312 (tool-bar-add-item "next-node" #'cider-debug-mode-send-reply :continue :label "Continue") 313 (tool-bar-add-item "jump-to" #'cider-debug-mode-send-reply :out :label "Out of sexp") 314 (tool-bar-add-item "exit" #'cider-debug-mode-send-reply :quit :label "Quit") 315 tool-bar-map)) 316 317 (defvar cider--debug-mode-map 318 (let ((map (make-sparse-keymap))) 319 ;; Bind the `:here` command to both h and H, because it behaves differently 320 ;; if invoked with an uppercase letter. 321 (define-key map "h" #'cider-debug-move-here) 322 (define-key map "H" #'cider-debug-move-here) 323 (define-key map "L" #'cider-debug-toggle-locals) 324 map) 325 "The active keymap during a debugging session.") 326 327 (define-minor-mode cider--debug-mode 328 "Mode active during debug sessions. 329 In order to work properly, this mode must be activated by 330 `cider--turn-on-debug-mode'." 331 :init-value nil :lighter " DEBUG" :keymap '() 332 (if cider--debug-mode 333 (if cider--debug-mode-response 334 (nrepl-dbind-response cider--debug-mode-response (input-type) 335 ;; A debug session is an ongoing eval, but it's annoying to have the 336 ;; spinner spinning while you debug. 337 (when spinner-current (spinner-stop)) 338 (setq-local tool-bar-map cider--debug-mode-tool-bar-map) 339 (add-hook 'kill-buffer-hook #'cider--debug-quit nil 'local) 340 (add-hook 'before-revert-hook #'cider--debug-quit nil 'local) 341 (unless (consp input-type) 342 (error "Activated debug-mode on a message not asking for commands: %s" cider--debug-mode-response)) 343 ;; Integrate with eval commands. 344 (setq cider-interactive-eval-override 345 (apply-partially #'cider--debug-lexical-eval 346 (nrepl-dict-get cider--debug-mode-response "key"))) 347 ;; Map over the key->command alist and set the keymap 348 (mapc 349 (lambda (p) 350 (let ((char (car p))) 351 (unless (= char ?h) ; `here' needs a special command. 352 (define-key cider--debug-mode-map (string char) #'cider-debug-mode-send-reply)) 353 (when (= char ?o) 354 (define-key cider--debug-mode-map (string (upcase ?o)) #'cider-debug-mode-send-reply)))) 355 cider-debug-prompt-commands) 356 (cider--debug-propertize-prompt-commands) 357 ;; Show the prompt. 358 (cider--debug-mode-redisplay) 359 ;; If a sync request is ongoing, the user can't act normally to 360 ;; provide input, so we enter `recursive-edit'. 361 (when nrepl-ongoing-sync-request 362 (recursive-edit))) 363 (cider--debug-mode -1) 364 (if (called-interactively-p 'any) 365 (user-error (substitute-command-keys "Don't call this mode manually, use `\\[universal-argument] \\[cider-eval-defun-at-point]' instead")) 366 (error "Attempt to activate `cider--debug-mode' without setting `cider--debug-mode-response' first"))) 367 (setq cider-interactive-eval-override nil) 368 (setq cider--debug-mode-response nil) 369 ;; We wait a moment before clearing overlays and the read-onlyness, so that 370 ;; cider-nrepl has a chance to send the next message, and so that the user 371 ;; doesn't accidentally hit `n' between two messages (thus editing the code). 372 (when-let* ((proc (unless nrepl-ongoing-sync-request 373 (get-buffer-process (cider-current-repl))))) 374 (accept-process-output proc 1)) 375 (unless cider--debug-mode 376 (setq buffer-read-only nil) 377 (cider--debug-remove-overlays (current-buffer))) 378 (when nrepl-ongoing-sync-request 379 (ignore-errors (exit-recursive-edit))))) 380 381 (defun cider--debug-remove-overlays (&optional buffer) 382 "Remove CIDER debug overlays from BUFFER if variable `cider--debug-mode' is nil." 383 (when (or (not buffer) (buffer-live-p buffer)) 384 (with-current-buffer (or buffer (current-buffer)) 385 (unless cider--debug-mode 386 (kill-local-variable 'tool-bar-map) 387 (remove-overlays nil nil 'category 'debug-result) 388 (remove-overlays nil nil 'category 'debug-code) 389 (setq cider--debug-prompt-overlay nil) 390 (remove-overlays nil nil 'category 'debug-prompt))))) 391 392 (defun cider--debug-set-prompt (value) 393 "Set `cider-debug-prompt' to VALUE, then redisplay." 394 (setq cider-debug-prompt value) 395 (cider--debug-mode-redisplay)) 396 397 (easy-menu-define cider-debug-mode-menu cider--debug-mode-map 398 "Menu for CIDER debug mode." 399 `("CIDER Debugger" 400 ["Next step" (cider-debug-mode-send-reply ":next") :keys "n"] 401 ["Continue" (cider-debug-mode-send-reply ":continue") :keys "c"] 402 ["Continue non-stop" (cider-debug-mode-send-reply ":continue-all") :keys "C"] 403 ["Move out of sexp" (cider-debug-mode-send-reply ":out") :keys "o"] 404 ["Forced move out of sexp" (cider-debug-mode-send-reply ":out" nil true) :keys "O"] 405 ["Move to current position" (cider-debug-mode-send-reply ":here") :keys "h"] 406 ["Quit" (cider-debug-mode-send-reply ":quit") :keys "q"] 407 "--" 408 ["Evaluate in current scope" (cider-debug-mode-send-reply ":eval") :keys "e"] 409 ["Inject value" (cider-debug-mode-send-reply ":inject") :keys "i"] 410 ["Inspect current value" (cider-debug-mode-send-reply ":inspect") :keys "p"] 411 ["Inspect expression" (cider-debug-mode-send-reply ":inspect-prompt") :keys "P"] 412 ["Inspect local variables" (cider-debug-mode-send-reply ":locals") :keys "l"] 413 "--" 414 ("Configure keys prompt" 415 ["Don't show keys" (cider--debug-set-prompt nil) :style toggle :selected (eq cider-debug-prompt nil)] 416 ["Show in minibuffer" (cider--debug-set-prompt 'minibuffer) :style toggle :selected (eq cider-debug-prompt 'minibuffer)] 417 ["Show above function" (cider--debug-set-prompt 'overlay) :style toggle :selected (eq cider-debug-prompt 'overlay)] 418 ["Show in both places" (cider--debug-set-prompt t) :style toggle :selected (eq cider-debug-prompt t)] 419 "--" 420 ["List locals" cider-debug-toggle-locals :style toggle :selected cider-debug-display-locals]) 421 ["Customize" (customize-group 'cider-debug)])) 422 423 (defun cider--uppercase-command-p () 424 "Return non-nil if the last command was uppercase letter." 425 (ignore-errors 426 (let ((case-fold-search nil)) 427 (string-match "[[:upper:]]" (string last-command-event))))) 428 429 (defun cider-debug-mode-send-reply (command &optional key force) 430 "Reply to the message that started current bufer's debugging session. 431 COMMAND is sent as the input option. KEY can be provided to reply to a 432 specific message. If FORCE is non-nil, send a \"force?\" argument in the 433 message." 434 (interactive (list 435 (if (symbolp last-command-event) 436 (symbol-name last-command-event) 437 (ignore-errors 438 (concat ":" (cadr (assoc last-command-event cider-debug-prompt-commands))))) 439 nil 440 (cider--uppercase-command-p))) 441 (when (and (string-prefix-p ":" command) force) 442 (setq command (format "{:response %s :force? true}" command))) 443 (cider-nrepl-send-unhandled-request 444 `("op" "debug-input" 445 "input" ,(or command ":quit") 446 "key" ,(or key (nrepl-dict-get cider--debug-mode-response "key")))) 447 (ignore-errors (cider--debug-mode -1))) 448 449 (defun cider--debug-quit () 450 "Send a :quit reply to the debugger. Used in hooks." 451 (when cider--debug-mode 452 (cider-debug-mode-send-reply ":quit") 453 (message "Quitting debug session"))) 454 455 456 ;;; Movement logic 457 (defconst cider--debug-buffer-format "*cider-debug %s*") 458 459 (defun cider--debug-trim-code (code) 460 "Remove whitespace and reader macros from the start of the CODE. 461 Return trimmed CODE." 462 (replace-regexp-in-string "\\`#[a-z]+[\n\r[:blank:]]*" "" code)) 463 464 (declare-function cider-set-buffer-ns "cider-mode") 465 (defun cider--initialize-debug-buffer (code ns id &optional reason) 466 "Create a new debugging buffer with CODE and namespace NS. 467 ID is the id of the message that instrumented CODE. 468 REASON is a keyword describing why this buffer was necessary." 469 (let ((buffer-name (format cider--debug-buffer-format id))) 470 (if-let* ((buffer (get-buffer buffer-name))) 471 (cider-popup-buffer-display buffer 'select) 472 (with-current-buffer (cider-popup-buffer buffer-name 'select 473 #'clojure-mode 'ancillary) 474 (cider-set-buffer-ns ns) 475 (setq buffer-undo-list nil) 476 (let ((inhibit-read-only t) 477 (buffer-undo-list t)) 478 (erase-buffer) 479 (insert (format "%s" (cider--debug-trim-code code))) 480 (when code 481 (insert "\n\n\n;; We had to create this temporary buffer because we couldn't find the original definition. That probably happened because " 482 reason 483 ".") 484 (fill-paragraph)) 485 (font-lock-ensure) 486 (set-buffer-modified-p nil)))) 487 (switch-to-buffer buffer-name) 488 (goto-char (point-min)))) 489 490 (defun cider--debug-goto-keyval (key) 491 "Find KEY in current sexp or return nil." 492 (when-let* ((limit (ignore-errors (save-excursion (up-list) (point))))) 493 (search-forward-regexp (concat "\\_<" (regexp-quote key) "\\_>") 494 limit 'noerror))) 495 496 (defun cider--debug-skip-ignored-forms () 497 "Skip past all forms ignored with #_ reader macro." 498 ;; Logic taken from `clojure--search-comment-macro-internal' 499 (while (looking-at (concat "[ ,\r\t\n]*" clojure--comment-macro-regexp)) 500 (let ((md (match-data)) 501 (start (match-beginning 1))) 502 (goto-char start) 503 ;; Count how many #_ we got and step by that many sexps 504 (clojure-forward-logical-sexp 505 (count-matches (rx "#_") (elt md 0) (elt md 1)))))) 506 507 (defun cider--debug-move-point (coordinates) 508 "Place point on after the sexp specified by COORDINATES. 509 COORDINATES is a list of integers that specify how to navigate into the 510 sexp that is after point when this function is called. 511 512 As an example, a COORDINATES list of '(1 0 2) means: 513 - enter next sexp then `forward-sexp' once, 514 - enter next sexp, 515 - enter next sexp then `forward-sexp' twice. 516 517 In the following snippet, this takes us to the (* x 2) sexp (point is left 518 at the end of the given sexp). 519 520 (letfn [(twice [x] 521 (* x 2))] 522 (twice 15)) 523 524 In addition to numbers, a coordinate can be a string. This string names the 525 key of a map, and it means \"go to the value associated with this key\"." 526 (condition-case-unless-debug nil 527 ;; Navigate through sexps inside the sexp. 528 (let ((in-syntax-quote nil)) 529 (while coordinates 530 (while (clojure--looking-at-non-logical-sexp) 531 (forward-sexp)) 532 ;; An `@x` is read as (deref x), so we pop coordinates once to account 533 ;; for the extra depth, and move past the @ char. 534 (if (eq ?@ (char-after)) 535 (progn (forward-char 1) 536 (pop coordinates)) 537 (down-list) 538 ;; Are we entering a syntax-quote? 539 (when (looking-back "`\\(#{\\|[{[(]\\)" (line-beginning-position)) 540 ;; If we are, this affects all nested structures until the next `~', 541 ;; so we set this variable for all following steps in the loop. 542 (setq in-syntax-quote t)) 543 (when in-syntax-quote 544 ;; A `(. .) is read as (seq (concat (list .) (list .))). This pops 545 ;; the `seq', since the real coordinates are inside the `concat'. 546 (pop coordinates) 547 ;; Non-list seqs like `[] and `{} are read with 548 ;; an extra (apply vector ...), so pop it too. 549 (unless (eq ?\( (char-before)) 550 (pop coordinates))) 551 ;; #(...) is read as (fn* ([] ...)), so we patch that here. 552 (when (looking-back "#(" (line-beginning-position)) 553 (pop coordinates)) 554 (if coordinates 555 (let ((next (pop coordinates))) 556 (when in-syntax-quote 557 ;; We're inside the `concat' form, but we need to discard the 558 ;; actual `concat' symbol from the coordinate. 559 (setq next (1- next))) 560 ;; String coordinates are map keys. 561 (if (stringp next) 562 (cider--debug-goto-keyval next) 563 (clojure-forward-logical-sexp next) 564 (when in-syntax-quote 565 (clojure-forward-logical-sexp 1) 566 (forward-sexp -1) 567 ;; Here a syntax-quote is ending. 568 (let ((match (when (looking-at "~@?") 569 (match-string 0)))) 570 (when match 571 (setq in-syntax-quote nil)) 572 ;; A `~@' is read as the object itself, so we don't pop 573 ;; anything. 574 (unless (equal "~@" match) 575 ;; Anything else (including a `~') is read as a `list' 576 ;; form inside the `concat', so we need to pop the list 577 ;; from the coordinates. 578 (pop coordinates)))))) 579 ;; If that extra pop was the last coordinate, this represents the 580 ;; entire #(...), so we should move back out. 581 (backward-up-list))) 582 ;; Finally skip past all #_ forms 583 (cider--debug-skip-ignored-forms)) 584 ;; Place point at the end of instrumented sexp. 585 (clojure-forward-logical-sexp 1)) 586 ;; Avoid throwing actual errors, since this happens on every breakpoint. 587 (error (message "Can't find instrumented sexp, did you edit the source?")))) 588 589 (defun cider--debug-position-for-code (code) 590 "Return non-nil if point is roughly before CODE. 591 This might move point one line above." 592 (or (looking-at-p (regexp-quote code)) 593 (let ((trimmed (regexp-quote (cider--debug-trim-code code)))) 594 (or (looking-at-p trimmed) 595 ;; If this is a fake #dbg injected by `C-u 596 ;; C-M-x', then the sexp we want is actually on 597 ;; the line above. 598 (progn (forward-line -1) 599 (looking-at-p trimmed)))))) 600 601 (defun cider--debug-find-source-position (response &optional create-if-needed) 602 "Return a marker of the position after the sexp specified in RESPONSE. 603 This marker might be in a different buffer! If the sexp can't be 604 found (file that contains the code is no longer visited or has been 605 edited), return nil. However, if CREATE-IF-NEEDED is non-nil, a new buffer 606 is created in this situation and the return value is never nil. 607 608 Follow the \"line\" and \"column\" entries in RESPONSE, and check whether 609 the code at point matches the \"code\" entry in RESPONSE. If it doesn't, 610 assume that the code in this file has been edited, and create a temp buffer 611 holding the original code. 612 Either way, navigate inside the code by following the \"coor\" entry which 613 is a coordinate measure in sexps." 614 (nrepl-dbind-response response (code file line column ns original-id coor) 615 (when (or code (and file line column)) 616 ;; This is for restoring current-buffer. 617 (save-excursion 618 (let ((out)) 619 ;; We prefer in-source debugging. 620 (when-let* ((buf (and file line column 621 (ignore-errors 622 (cider--find-buffer-for-file file))))) 623 ;; The logic here makes it hard to use `with-current-buffer'. 624 (with-current-buffer buf 625 ;; This is for restoring point inside buf. 626 (save-excursion 627 ;; Get to the proper line & column in the file 628 (forward-line (- line (line-number-at-pos))) 629 ;; Column numbers in the response start from 1. 630 ;; Convert to Emacs system which starts from 0 631 ;; Inverse of `cider-column-number-at-pos'. 632 (move-to-column (max 0 (1- column))) 633 ;; Check if it worked 634 (when (cider--debug-position-for-code code) 635 ;; Find the desired sexp. 636 (cider--debug-move-point coor) 637 (setq out (point-marker)))))) 638 ;; But we can create a temp buffer if that fails. 639 (or out 640 (when create-if-needed 641 (cider--initialize-debug-buffer 642 code ns original-id 643 (if (and line column) 644 "you edited the code" 645 "your nREPL version is older than 0.2.11")) 646 (save-excursion 647 (cider--debug-move-point coor) 648 (point-marker))))))))) 649 650 (defun cider--handle-debug (response) 651 "Handle debugging notification. 652 RESPONSE is a message received from the nrepl describing the input 653 needed. It is expected to contain at least \"key\", \"input-type\", and 654 \"prompt\", and possibly other entries depending on the input-type." 655 (nrepl-dbind-response response (debug-value key input-type prompt inspect) 656 (condition-case-unless-debug e 657 (progn 658 (pcase input-type 659 ("expression" (cider-debug-mode-send-reply 660 (condition-case nil 661 (cider-read-from-minibuffer 662 (or prompt "Expression: ")) 663 (quit "nil")) 664 key)) 665 ((pred sequencep) 666 (let* ((marker (cider--debug-find-source-position response 'create-if-needed))) 667 (pop-to-buffer (marker-buffer marker)) 668 (goto-char marker)) 669 ;; The overlay code relies on window boundaries, but point could have been 670 ;; moved outside the window by some other code. Redisplay here to ensure the 671 ;; visible window includes point. 672 (redisplay) 673 ;; Remove overlays AFTER redisplaying! Otherwise there's a visible 674 ;; flicker even if we immediately recreate the overlays. 675 (cider--debug-remove-overlays) 676 (when cider-debug-use-overlays 677 (cider--debug-display-result-overlay debug-value)) 678 (setq cider--debug-mode-response response) 679 (cider--debug-mode 1))) 680 (when inspect 681 (setq cider-inspector--current-repl (cider-current-repl)) 682 (cider-inspector--render-value inspect))) 683 ;; If something goes wrong, we send a "quit" or the session hangs. 684 (error (cider-debug-mode-send-reply ":quit" key) 685 (message "Error encountered while handling the debug message: %S" e))))) 686 687 (defun cider--handle-enlighten (response) 688 "Handle an enlighten notification. 689 RESPONSE is a message received from the nrepl describing the value and 690 coordinates of a sexp. Create an overlay after the specified sexp 691 displaying its value." 692 (when-let* ((marker (cider--debug-find-source-position response))) 693 (with-current-buffer (marker-buffer marker) 694 (save-excursion 695 (goto-char marker) 696 (clojure-backward-logical-sexp 1) 697 (nrepl-dbind-response response (debug-value erase-previous) 698 (when erase-previous 699 (remove-overlays (point) marker 'category 'enlighten)) 700 (when debug-value 701 (if (memq (char-before marker) '(?\) ?\] ?})) 702 ;; Enlightening a sexp looks like a regular return value, except 703 ;; for a different border. 704 (cider--make-result-overlay (cider-font-lock-as-clojure debug-value) 705 :where (cons marker marker) 706 :type 'enlighten 707 :prepend-face 'cider-enlightened-face) 708 ;; Enlightening a symbol uses a more abbreviated format. The 709 ;; result face is the same as a regular result, but we also color 710 ;; the symbol with `cider-enlightened-local-face'. 711 (cider--make-result-overlay (cider-font-lock-as-clojure debug-value) 712 :format "%s" 713 :where (cons (point) marker) 714 :type 'enlighten 715 'face 'cider-enlightened-local-face)))))))) 716 717 718 ;;; Move here command 719 ;; This is the inverse of `cider--debug-move-point'. However, that algorithm is 720 ;; complicated, and trying to code its inverse would probably be insane. 721 ;; Instead, we find the coordinate by trial and error. 722 (defun cider--debug-find-coordinates-for-point (target &optional list-so-far) 723 "Return the coordinates list for reaching TARGET. 724 Assumes that the next thing after point is a logical Clojure sexp and that 725 TARGET is inside it. The returned list is suitable for use in 726 `cider--debug-move-point'. LIST-SO-FAR is for internal use." 727 (when (looking-at (rx (or "(" "[" "#{" "{"))) 728 (let ((starting-point (point))) 729 (unwind-protect 730 (let ((x 0)) 731 ;; Keep incrementing the last coordinate until we've moved 732 ;; past TARGET. 733 (while (condition-case nil 734 (progn (goto-char starting-point) 735 (cider--debug-move-point (append list-so-far (list x))) 736 (< (point) target)) 737 ;; Not a valid coordinate. Move back a step and stop here. 738 (scan-error (setq x (1- x)) 739 nil)) 740 (setq x (1+ x))) 741 (setq list-so-far (append list-so-far (list x))) 742 ;; We have moved past TARGET, now determine whether we should 743 ;; stop, or if target is deeper inside the previous sexp. 744 (if (or (= target (point)) 745 (progn (forward-sexp -1) 746 (<= target (point)))) 747 list-so-far 748 (goto-char starting-point) 749 (cider--debug-find-coordinates-for-point target list-so-far))) 750 ;; `unwind-protect' clause. 751 (goto-char starting-point))))) 752 753 (defun cider-debug-move-here (&optional force) 754 "Skip any breakpoints up to point. 755 The boolean value of FORCE will be sent in the reply." 756 (interactive (list (cider--uppercase-command-p))) 757 (unless cider--debug-mode 758 (user-error "`cider-debug-move-here' only makes sense during a debug session")) 759 (let ((here (point))) 760 (nrepl-dbind-response cider--debug-mode-response (line column) 761 (if (and line column (buffer-file-name)) 762 (progn ;; Get to the proper line & column in the file 763 (forward-line (1- (- line (line-number-at-pos)))) 764 (move-to-column column)) 765 (beginning-of-defun)) 766 ;; Is HERE inside the sexp being debugged? 767 (when (or (< here (point)) 768 (save-excursion 769 (forward-sexp 1) 770 (> here (point)))) 771 (user-error "Point is outside the sexp being debugged")) 772 ;; Move forward until start of sexp. 773 (comment-normalize-vars) 774 (comment-forward (point-max)) 775 ;; Find the coordinate and send it. 776 (cider-debug-mode-send-reply 777 (format "{:response :here, :coord %s :force? %s}" 778 (cider--debug-find-coordinates-for-point here) 779 (if force "true" "false")))))) 780 781 782 ;;; User commands 783 ;;;###autoload 784 (defun cider-debug-defun-at-point () 785 "Instrument the \"top-level\" expression at point. 786 If it is a defn, dispatch the instrumented definition. Otherwise, 787 immediately evaluate the instrumented expression. 788 789 While debugged code is being evaluated, the user is taken through the 790 source code and displayed the value of various expressions. At each step, 791 a number of keys will be prompted to the user." 792 (interactive) 793 (cider-eval-defun-at-point 'debug-it)) 794 795 (provide 'cider-debug) 796 ;;; cider-debug.el ends here