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