cider-stacktrace.el (41694B)
1 ;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*- 2 3 ;; Copyright © 2014-2023 Jeff Valk, Bozhidar Batsov and CIDER contributors 4 5 ;; Author: Jeff Valk <jv@jeffvalk.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 ;; This file is not part of GNU Emacs. 21 22 ;;; Commentary: 23 24 ;; Stacktrace filtering and stack frame source navigation 25 26 ;;; Code: 27 28 (require 'button) 29 (require 'cl-lib) 30 (require 'easymenu) 31 (require 'map) 32 (require 'seq) 33 (require 'subr-x) 34 35 (require 'cider-common) 36 (require 'cider-client) 37 (require 'cider-popup) 38 (require 'cider-util) 39 40 ;; Variables 41 42 (defgroup cider-stacktrace nil 43 "Stacktrace filtering and navigation." 44 :prefix "cider-stacktrace-" 45 :group 'cider) 46 47 (defcustom cider-stacktrace-fill-column t 48 "Fill column for error messages in stacktrace display. 49 If nil, messages will not be wrapped. If truthy but non-numeric, 50 `fill-column' will be used." 51 :type 'list 52 :package-version '(cider . "0.7.0")) 53 54 (defcustom cider-stacktrace-default-filters '(tooling dup) 55 "Frame types to omit from initial stacktrace display." 56 :type 'list 57 :package-version '(cider . "0.6.0")) 58 59 (make-obsolete 'cider-stacktrace-print-length 'cider-stacktrace-print-options "0.20") 60 (make-obsolete 'cider-stacktrace-print-level 'cider-stacktrace-print-options "0.20") 61 (make-obsolete-variable 'cider-stacktrace-print-options 'cider-print-options "0.21") 62 63 (defvar cider-stacktrace-detail-max 2 64 "The maximum detail level for causes.") 65 66 (defvar-local cider-stacktrace-hidden-frame-count 0) 67 (defvar-local cider-stacktrace-filters nil) 68 (defvar-local cider-stacktrace-cause-visibility nil) 69 (defvar-local cider-stacktrace-positive-filters nil) 70 71 (defconst cider-error-buffer "*cider-error*") 72 73 (make-obsolete 'cider-visit-error-buffer 'cider-selector "0.18") 74 75 (defcustom cider-stacktrace-suppressed-errors '() 76 "Errors that won't make the stacktrace buffer 'pop-over' your active window. 77 The error types are represented as strings." 78 :type 'list 79 :package-version '(cider . "0.12.0")) 80 81 ;; Faces 82 83 (defface cider-stacktrace-error-class-face 84 '((t (:inherit font-lock-warning-face))) 85 "Face for exception class names." 86 :package-version '(cider . "0.6.0")) 87 88 (defface cider-stacktrace-error-message-face 89 '((t (:inherit font-lock-doc-face))) 90 "Face for exception messages." 91 :package-version '(cider . "0.7.0")) 92 93 (defface cider-stacktrace-filter-active-face 94 '((t (:inherit button :underline t :weight normal))) 95 "Face for filter buttons representing frames currently visible." 96 :package-version '(cider . "0.6.0")) 97 98 (defface cider-stacktrace-filter-inactive-face 99 '((t (:inherit button :underline nil :weight normal))) 100 "Face for filter buttons representing frames currently filtered out." 101 :package-version '(cider . "0.6.0")) 102 103 (defface cider-stacktrace-face 104 '((t (:inherit default))) 105 "Face for stack frame text." 106 :package-version '(cider . "0.6.0")) 107 108 (defface cider-stacktrace-ns-face 109 '((t (:inherit font-lock-comment-face))) 110 "Face for stack frame namespace name." 111 :package-version '(cider . "0.6.0")) 112 113 (defface cider-stacktrace-fn-face 114 '((t (:inherit default :weight bold))) 115 "Face for stack frame function name." 116 :package-version '(cider . "0.6.0")) 117 118 (defface cider-stacktrace-promoted-button-face 119 '((((type graphic)) 120 :box (:line-width 3 :style released-button) 121 :inherit error) 122 (t :inverse-video t)) 123 "A button with this face represents a promoted (non-suppressed) error type." 124 :package-version '(cider . "0.12.0")) 125 126 (defface cider-stacktrace-suppressed-button-face 127 '((((type graphic)) 128 :box (:line-width 3 :style pressed-button) 129 :inherit widget-inactive) 130 (t :inverse-video t)) 131 "A button with this face represents a suppressed error type." 132 :package-version '(cider . "0.12.0")) 133 134 ;; Colors & Theme Support 135 136 (defvar cider-stacktrace-frames-background-color 137 (cider-scale-background-color) 138 "Background color for stacktrace frames.") 139 140 (advice-add 'enable-theme :after #'cider--stacktrace-adapt-to-theme) 141 (advice-add 'disable-theme :after #'cider--stacktrace-adapt-to-theme) 142 (defun cider--stacktrace-adapt-to-theme (&rest _) 143 "When theme is changed, update `cider-stacktrace-frames-background-color'." 144 (setq cider-stacktrace-frames-background-color 145 (cider-scale-background-color))) 146 147 148 ;; Mode & key bindings 149 150 (defvar cider-stacktrace-mode-map 151 (let ((map (make-sparse-keymap))) 152 (define-key map (kbd "M-p") #'cider-stacktrace-previous-cause) 153 (define-key map (kbd "M-n") #'cider-stacktrace-next-cause) 154 (define-key map (kbd "M-.") #'cider-stacktrace-jump) 155 (define-key map "q" #'cider-popup-buffer-quit-function) 156 (define-key map "j" #'cider-stacktrace-toggle-java) 157 (define-key map "c" #'cider-stacktrace-toggle-clj) 158 (define-key map "r" #'cider-stacktrace-toggle-repl) 159 (define-key map "t" #'cider-stacktrace-toggle-tooling) 160 (define-key map "d" #'cider-stacktrace-toggle-duplicates) 161 (define-key map "p" #'cider-stacktrace-show-only-project) 162 (define-key map "a" #'cider-stacktrace-toggle-all) 163 (define-key map "1" #'cider-stacktrace-cycle-cause-1) 164 (define-key map "2" #'cider-stacktrace-cycle-cause-2) 165 (define-key map "3" #'cider-stacktrace-cycle-cause-3) 166 (define-key map "4" #'cider-stacktrace-cycle-cause-4) 167 (define-key map "5" #'cider-stacktrace-cycle-cause-5) 168 (define-key map "0" #'cider-stacktrace-cycle-all-causes) 169 (define-key map (kbd "TAB") #'cider-stacktrace-cycle-current-cause) 170 (define-key map [backtab] #'cider-stacktrace-cycle-all-causes) 171 (easy-menu-define cider-stacktrace-mode-menu map 172 "Menu for CIDER's stacktrace mode" 173 '("Stacktrace" 174 ["Previous cause" cider-stacktrace-previous-cause] 175 ["Next cause" cider-stacktrace-next-cause] 176 "--" 177 ["Jump to frame source" cider-stacktrace-jump] 178 "--" 179 ["Cycle current cause detail" cider-stacktrace-cycle-current-cause] 180 ["Cycle cause #1 detail" cider-stacktrace-cycle-cause-1] 181 ["Cycle cause #2 detail" cider-stacktrace-cycle-cause-2] 182 ["Cycle cause #3 detail" cider-stacktrace-cycle-cause-3] 183 ["Cycle cause #4 detail" cider-stacktrace-cycle-cause-4] 184 ["Cycle cause #5 detail" cider-stacktrace-cycle-cause-5] 185 ["Cycle all cause detail" cider-stacktrace-cycle-all-causes] 186 "--" 187 ["Show/hide Java frames" cider-stacktrace-toggle-java] 188 ["Show/hide Clojure frames" cider-stacktrace-toggle-clj] 189 ["Show/hide REPL frames" cider-stacktrace-toggle-repl] 190 ["Show/hide tooling frames" cider-stacktrace-toggle-tooling] 191 ["Show/hide duplicate frames" cider-stacktrace-toggle-duplicates] 192 ["Toggle only project frames" cider-stacktrace-show-only-project] 193 ["Show/hide all frames" cider-stacktrace-toggle-all])) 194 map)) 195 196 (define-derived-mode cider-stacktrace-mode special-mode "Stacktrace" 197 "Major mode for filtering and navigating CIDER stacktraces. 198 199 \\{cider-stacktrace-mode-map}" 200 (when cider-special-mode-truncate-lines 201 (setq-local truncate-lines t)) 202 (setq-local sesman-system 'CIDER) 203 (setq-local electric-indent-chars nil) 204 (setq-local cider-stacktrace-hidden-frame-count 0) 205 (setq-local cider-stacktrace-filters cider-stacktrace-default-filters) 206 (setq-local cider-stacktrace-cause-visibility (make-vector 10 0)) 207 (buffer-disable-undo)) 208 209 210 ;; Stacktrace filtering 211 212 (defvar cider-stacktrace--all-negative-filters 213 '(clj tooling dup java repl) 214 "Filters that remove stackframes.") 215 216 (defvar cider-stacktrace--all-positive-filters 217 '(project all) 218 "Filters that ensure stackframes are shown.") 219 220 (defun cider-stacktrace--face-for-filter (filter neg-filters pos-filters) 221 "Return whether we should mark the FILTER is active or not. 222 223 NEG-FILTERS and POS-FILTERS are lists of filters to check FILTER's type. 224 225 NEG-FILTERS dictate which frames should be hidden while POS-FILTERS can 226 override this and ensure that those frames are shown." 227 (cond ((member filter cider-stacktrace--all-negative-filters) 228 (if (member filter neg-filters) 229 'cider-stacktrace-filter-active-face 230 'cider-stacktrace-filter-inactive-face)) 231 ((member filter cider-stacktrace--all-positive-filters) 232 (if (member filter pos-filters) 233 'cider-stacktrace-filter-active-face 234 'cider-stacktrace-filter-inactive-face)))) 235 236 (defun cider-stacktrace-indicate-filters (filters pos-filters) 237 "Update enabled state of filter buttons. 238 239 Find buttons with a 'filter property; if filter is a member of FILTERS, or 240 if filter is nil ('show all') and the argument list is non-nil, fontify the 241 button as disabled. Upon finding text with a 'hidden-count property, stop 242 searching and update the hidden count text. POS-FILTERS is the list of 243 positive filters to always include." 244 (with-current-buffer cider-error-buffer 245 (save-excursion 246 (goto-char (point-min)) 247 (let ((inhibit-read-only t)) 248 ;; Toggle buttons 249 (while (not (or (get-text-property (point) 'hidden-count) (eobp))) 250 (let ((button (button-at (point)))) 251 (when button 252 (let* ((filter (button-get button 'filter)) 253 (face (cider-stacktrace--face-for-filter filter 254 filters 255 pos-filters))) 256 (button-put button 'face face))) 257 (goto-char (or (next-property-change (point)) 258 (point-max))))) 259 ;; Update hidden count 260 (when (and (get-text-property (point) 'hidden-count) 261 (re-search-forward "[0-9]+" (line-end-position) t)) 262 (replace-match 263 (number-to-string cider-stacktrace-hidden-frame-count))))))) 264 265 (defun cider-stacktrace-frame-p () 266 "Indicate if the text at point is a stack frame." 267 (get-text-property (point) 'cider-stacktrace-frame)) 268 269 (defun cider-stacktrace-collapsed-p () 270 "Indicate if the stackframe was collapsed." 271 (get-text-property (point) 'collapsed)) 272 273 (defun cider-stacktrace--should-hide-p (neg-filters pos-filters flags) 274 "Decide whether a stackframe should be hidden or not. 275 NEG-FILTERS dictate which frames should be hidden while POS-FILTERS can 276 override this and ensure that those frames are shown. 277 Argument FLAGS are the flags set on the stackframe, ie: clj dup, etc." 278 (let ((neg (seq-intersection neg-filters flags)) 279 (pos (seq-intersection pos-filters flags)) 280 (all (memq 'all pos-filters))) 281 (cond (all nil) ;; if all filter is on then we should not hide 282 ((and pos neg) nil) ;; if hidden and "resurrected" we should not hide 283 (pos nil) 284 (neg t) 285 (t nil)))) 286 287 (defun cider-stacktrace--apply-filters (neg-filters pos-filters) 288 "Set visibility on stack frames. 289 Should be called by `cider-stacktrace-apply-filters' which has the logic of 290 how to interpret the combinations of the positive and negative filters. 291 For instance, the presence of the positive filter `project' requires all of 292 the other negative filters to be applied so that only project frames are 293 shown. NEG-FILTERS are the tags that should be hidden. POS-FILTERS are 294 the tags that must be shown." 295 (with-current-buffer cider-error-buffer 296 (save-excursion 297 (goto-char (point-min)) 298 (let ((inhibit-read-only t) 299 (hidden 0)) 300 (while (not (eobp)) 301 (when (and (cider-stacktrace-frame-p) 302 (not (cider-stacktrace-collapsed-p))) 303 (let* ((flags (get-text-property (point) 'flags)) 304 (hide (cider-stacktrace--should-hide-p neg-filters 305 pos-filters 306 flags))) 307 (when hide (cl-incf hidden)) 308 (put-text-property (point) (line-beginning-position 2) 309 'invisible hide))) 310 (forward-line 1)) 311 (setq cider-stacktrace-hidden-frame-count hidden))) 312 (cider-stacktrace-indicate-filters neg-filters pos-filters))) 313 314 (defun cider-stacktrace-apply-filters (filters) 315 "Takes a single list of filters and applies them. 316 Update `cider-stacktrace-hidden-frame-count' and indicate 317 filters applied. Currently collapsed stacktraces are ignored, and do not 318 contribute to the hidden count. FILTERS is the list of filters to be 319 applied, positive and negative all together. This function defines how 320 those choices interact and separates them into positive and negative 321 filters for the resulting machinery." 322 (let ((neg-filters (seq-intersection filters cider-stacktrace--all-negative-filters)) 323 (pos-filters (seq-intersection filters cider-stacktrace--all-positive-filters))) 324 ;; project and all are mutually exclusive. when both are present we check to 325 ;; see the most recent one (as cons onto the list would put it) and use that 326 ;; interaction. 327 (cond 328 ((memq 'all (memq 'project pos-filters)) ;; project is most recent 329 (cider-stacktrace--apply-filters cider-stacktrace--all-negative-filters '(project))) 330 ((memq 'project (memq 'all pos-filters)) ;; all is most recent 331 (cider-stacktrace--apply-filters nil '(all))) 332 ((memq 'all pos-filters) (cider-stacktrace--apply-filters nil '(all))) 333 ((memq 'project pos-filters) (cider-stacktrace--apply-filters cider-stacktrace--all-negative-filters 334 pos-filters)) 335 (t (cider-stacktrace--apply-filters neg-filters pos-filters))))) 336 337 (defun cider-stacktrace-apply-cause-visibility () 338 "Apply `cider-stacktrace-cause-visibility' to causes and reapply filters." 339 (with-current-buffer cider-error-buffer 340 (save-excursion 341 (goto-char (point-min)) 342 (cl-flet ((next-detail (end) 343 (when-let* ((pos (next-single-property-change (point) 'detail))) 344 (when (< pos end) 345 (goto-char pos))))) 346 (let ((inhibit-read-only t)) 347 ;; For each cause... 348 (while (cider-stacktrace-next-cause) 349 (let* ((num (get-text-property (point) 'cause)) 350 (level (elt cider-stacktrace-cause-visibility num)) 351 (cause-end (cadr (cider-property-bounds 'cause)))) 352 ;; For each detail level within the cause, set visibility. 353 (while (next-detail cause-end) 354 (let* ((detail (get-text-property (point) 'detail)) 355 (detail-end (cadr (cider-property-bounds 'detail))) 356 (hide (if (> detail level) t nil))) 357 (add-text-properties (point) detail-end 358 (list 'invisible hide 359 'collapsed hide)))))))) 360 (cider-stacktrace-apply-filters cider-stacktrace-filters)))) 361 362 ;;; Internal/Middleware error suppression 363 364 (defun cider-stacktrace-some-suppressed-errors-p (error-types) 365 "Return intersection of ERROR-TYPES and CIDER-STACKTRACE-SUPPRESSED-ERRORS. 366 I.e, Return non-nil if the seq ERROR-TYPES shares any elements with 367 `cider-stacktrace-suppressed-errors'. This means that even a 368 'well-behaved' (ie, promoted) error type will be 'guilty by association' if 369 grouped with a suppressed error type." 370 (seq-intersection error-types cider-stacktrace-suppressed-errors)) 371 372 (defun cider-stacktrace-suppress-error (error-type) 373 "Destructively add ERROR-TYPE to the `cider-stacktrace-suppressed-errors' set." 374 (setq cider-stacktrace-suppressed-errors 375 (cl-adjoin error-type cider-stacktrace-suppressed-errors :test 'equal))) 376 377 (defun cider-stacktrace-promote-error (error-type) 378 "Destructively remove ERROR-TYPE from `cider-stacktrace-suppressed-errors'." 379 (setq cider-stacktrace-suppressed-errors 380 (remove error-type cider-stacktrace-suppressed-errors))) 381 382 (defun cider-stacktrace-suppressed-error-p (error-type) 383 "Return non-nil if ERROR-TYPE is in `cider-stacktrace-suppressed-errors'." 384 (member error-type cider-stacktrace-suppressed-errors)) 385 386 ;; Interactive functions 387 388 (defun cider-stacktrace-previous-cause () 389 "Move point to the previous exception cause, if one exists." 390 (interactive) 391 (with-current-buffer cider-error-buffer 392 (when-let* ((pos (previous-single-property-change (point) 'cause))) 393 (goto-char pos)))) 394 395 (defun cider-stacktrace-next-cause () 396 "Move point to the next exception cause, if one exists." 397 (interactive) 398 (with-current-buffer cider-error-buffer 399 (when-let* ((pos (next-single-property-change (point) 'cause))) 400 (goto-char pos)))) 401 402 (defun cider-stacktrace-cycle-cause (num &optional level) 403 "Update element NUM of `cider-stacktrace-cause-visibility'. 404 If LEVEL is specified, it is used, otherwise its current value is incremented. 405 When it reaches 3, it wraps to 0." 406 (let ((level (or level (1+ (elt cider-stacktrace-cause-visibility num))))) 407 (aset cider-stacktrace-cause-visibility num (mod level 3)) 408 (cider-stacktrace-apply-cause-visibility))) 409 410 (defun cider-stacktrace-cycle-all-causes () 411 "Cycle the visibility of all exception causes." 412 (interactive) 413 (with-current-buffer cider-error-buffer 414 (save-excursion 415 ;; Find nearest cause. 416 (unless (get-text-property (point) 'cause) 417 (cider-stacktrace-next-cause) 418 (unless (get-text-property (point) 'cause) 419 (cider-stacktrace-previous-cause))) 420 ;; Cycle its level, and apply that to all causes. 421 (let* ((num (get-text-property (point) 'cause)) 422 (level (1+ (elt cider-stacktrace-cause-visibility num)))) 423 (setq-local cider-stacktrace-cause-visibility 424 (make-vector 10 (mod level 3))) 425 (cider-stacktrace-apply-cause-visibility))))) 426 427 (defun cider-stacktrace-cycle-current-cause () 428 "Cycle the visibility of current exception at point, if any." 429 (interactive) 430 (with-current-buffer cider-error-buffer 431 (when-let* ((num (get-text-property (point) 'cause))) 432 (cider-stacktrace-cycle-cause num)))) 433 434 (defun cider-stacktrace-cycle-cause-1 () 435 "Cycle the visibility of exception cause #1." 436 (interactive) 437 (cider-stacktrace-cycle-cause 1)) 438 439 (defun cider-stacktrace-cycle-cause-2 () 440 "Cycle the visibility of exception cause #2." 441 (interactive) 442 (cider-stacktrace-cycle-cause 2)) 443 444 (defun cider-stacktrace-cycle-cause-3 () 445 "Cycle the visibility of exception cause #3." 446 (interactive) 447 (cider-stacktrace-cycle-cause 3)) 448 449 (defun cider-stacktrace-cycle-cause-4 () 450 "Cycle the visibility of exception cause #4." 451 (interactive) 452 (cider-stacktrace-cycle-cause 4)) 453 454 (defun cider-stacktrace-cycle-cause-5 () 455 "Cycle the visibility of exception cause #5." 456 (interactive) 457 (cider-stacktrace-cycle-cause 5)) 458 459 (defun cider-stacktrace-toggle (flag) 460 "Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters." 461 (cider-stacktrace-apply-filters 462 (setq cider-stacktrace-filters 463 (if (memq flag cider-stacktrace-filters) 464 (remq flag cider-stacktrace-filters) 465 (cons flag cider-stacktrace-filters))))) 466 467 (defun cider-stacktrace-toggle-all () 468 "Toggle `all' in filter list." 469 (interactive) 470 (cider-stacktrace-toggle 'all)) 471 472 (defun cider-stacktrace-show-only-project () 473 "Display only the stackframes from the project." 474 (interactive) 475 (cider-stacktrace-toggle 'project)) 476 477 (defun cider-stacktrace-toggle-java () 478 "Toggle display of Java stack frames." 479 (interactive) 480 (cider-stacktrace-toggle 'java)) 481 482 (defun cider-stacktrace-toggle-clj () 483 "Toggle display of Clojure stack frames." 484 (interactive) 485 (cider-stacktrace-toggle 'clj)) 486 487 (defun cider-stacktrace-toggle-repl () 488 "Toggle display of REPL stack frames." 489 (interactive) 490 (cider-stacktrace-toggle 'repl)) 491 492 (defun cider-stacktrace-toggle-tooling () 493 "Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)." 494 (interactive) 495 (cider-stacktrace-toggle 'tooling)) 496 497 (defun cider-stacktrace-toggle-duplicates () 498 "Toggle display of stack frames that are duplicates of their descendents." 499 (interactive) 500 (cider-stacktrace-toggle 'dup)) 501 502 ;; Text button functions 503 504 (defun cider-stacktrace-filter (button) 505 "Apply filter(s) indicated by the BUTTON." 506 (with-temp-message "Filters may also be toggled with the keyboard." 507 (let ((flag (button-get button 'filter))) 508 (cond ((member flag cider-stacktrace--all-negative-filters) 509 (cider-stacktrace-toggle flag)) 510 ((member flag cider-stacktrace--all-positive-filters) 511 (cider-stacktrace-show-only-project)) 512 (t (cider-stacktrace-toggle-all)))) 513 (sit-for 5))) 514 515 (defun cider-stacktrace-toggle-suppression (button) 516 "Toggle stacktrace pop-over/pop-under behavior for the `error-type' in BUTTON. 517 Achieved by destructively manipulating `cider-stacktrace-suppressed-errors'." 518 (with-current-buffer cider-error-buffer 519 (let ((inhibit-read-only t) 520 (suppressed (button-get button 'suppressed)) 521 (error-type (button-get button 'error-type))) 522 (if suppressed 523 (progn 524 (cider-stacktrace-promote-error error-type) 525 (button-put button 'face 'cider-stacktrace-promoted-button-face) 526 (button-put button 'help-echo "Click to suppress these stacktraces.")) 527 (cider-stacktrace-suppress-error error-type) 528 (button-put button 'face 'cider-stacktrace-suppressed-button-face) 529 (button-put button 'help-echo "Click to promote these stacktraces.")) 530 (button-put button 'suppressed (not suppressed))))) 531 532 (defun cider-stacktrace-navigate (button) 533 "Navigate to the stack frame source represented by the BUTTON." 534 (let* ((var (button-get button 'var)) 535 (class (button-get button 'class)) 536 (method (button-get button 'method)) 537 (info (or (and var (cider-var-info var)) 538 (and class method (cider-member-info class method)) 539 (nrepl-dict))) 540 ;; Stacktrace returns more accurate line numbers, but if the function's 541 ;; line was unreliable, then so is the stacktrace by the same amount. 542 ;; Set `line-shift' to the number of lines from the beginning of defn. 543 (line-shift (- (or (button-get button 'line) 0) 544 (or (nrepl-dict-get info "line") 1))) 545 (file (or 546 (nrepl-dict-get info "file") 547 (button-get button 'file))) 548 ;; give priority to `info` files as `info` returns full paths. 549 (info (nrepl-dict-put info "file" file))) 550 (cider--jump-to-loc-from-info info t) 551 (forward-line line-shift) 552 (back-to-indentation))) 553 554 (declare-function cider-find-var "cider-find") 555 556 (defun cider-stacktrace-jump (&optional arg) 557 "Find definition for stack frame at point, if available. 558 The prefix ARG and `cider-prompt-for-symbol' decide whether to 559 prompt and whether to use a new window. Similar to `cider-find-var'." 560 (interactive "P") 561 (let ((button (button-at (point)))) 562 (if (and button (button-get button 'line)) 563 (cider-stacktrace-navigate button) 564 (cider-find-var arg)))) 565 566 567 ;; Rendering 568 (defvar cider-use-tooltips) 569 (defun cider-stacktrace-tooltip (tooltip) 570 "Return TOOLTIP if `cider-use-tooltips' is set to true, nil otherwise." 571 (when cider-use-tooltips tooltip)) 572 573 (defun cider-stacktrace-emit-indented (text &optional indent fill fontify) 574 "Insert TEXT, and optionally FILL and FONTIFY as clojure the entire block. 575 INDENT is a string to insert before each line. When INDENT is nil, first 576 line is not indented and INDENT defaults to a white-spaced string with 577 length given by `current-column'." 578 (let ((text (if fontify 579 (cider-font-lock-as-clojure text) 580 text)) 581 (do-first indent) 582 (indent (or indent (make-string (current-column) ? ))) 583 (beg (point))) 584 (insert text) 585 (goto-char beg) 586 (when do-first 587 (insert indent)) 588 (forward-line) 589 (while (not (eobp)) 590 (insert indent) 591 (forward-line)) 592 (when (and fill cider-stacktrace-fill-column) 593 (when (and (numberp cider-stacktrace-fill-column)) 594 (setq-local fill-column cider-stacktrace-fill-column)) 595 (setq-local fill-prefix indent) 596 (fill-region beg (point))))) 597 598 (defun cider-stacktrace-render-filters (buffer special-filters filters) 599 "Emit into BUFFER toggle buttons for each of the FILTERS. 600 SPECIAL-FILTERS are filters that show stack certain stack frames, hiding 601 others." 602 (with-current-buffer buffer 603 (insert " Show: ") 604 (dolist (filter special-filters) 605 (insert-text-button (car filter) 606 'filter (cadr filter) 607 'follow-link t 608 'action #'cider-stacktrace-filter 609 'help-echo (cider-stacktrace-tooltip 610 (format "Toggle %s stack frames" 611 (car filter)))) 612 (insert " ")) 613 (insert "\n") 614 (insert " Hide: ") 615 (dolist (filter filters) 616 (insert-text-button (car filter) 617 'filter (cadr filter) 618 'follow-link t 619 'action #'cider-stacktrace-filter 620 'help-echo (cider-stacktrace-tooltip 621 (format "Toggle %s stack frames" 622 (car filter)))) 623 (insert " ")) 624 625 (let ((hidden "(0 frames hidden)")) 626 (put-text-property 0 (length hidden) 'hidden-count t hidden) 627 (insert " " hidden "\n")))) 628 629 (defun cider-stacktrace-render-suppression-toggle (buffer error-types) 630 "Emit toggle buttons for each of the ERROR-TYPES leading this stacktrace BUFFER." 631 (with-current-buffer buffer 632 (when error-types 633 (insert " This is an unexpected CIDER middleware error.\n Please submit a bug report via `") 634 (insert-text-button "M-x cider-report-bug" 635 'follow-link t 636 'action (lambda (_button) (cider-report-bug)) 637 'help-echo (cider-stacktrace-tooltip 638 "Report bug to the CIDER team.")) 639 (insert "`.\n\n") 640 (insert "\ 641 If these stacktraces are occurring frequently, consider using the 642 button(s) below to suppress these types of errors for the duration of 643 your current CIDER session. The stacktrace buffer will still be 644 generated, but it will \"pop under\" your current buffer instead of 645 \"popping over\". The button toggles this behavior.\n\n ") 646 (dolist (error-type error-types) 647 (let ((suppressed (cider-stacktrace-suppressed-error-p error-type))) 648 (insert-text-button (format "%s %s" (if suppressed "Promote" "Suppress") error-type) 649 'follow-link t 650 'error-type error-type 651 'action #'cider-stacktrace-toggle-suppression 652 'suppressed suppressed 653 'face (if suppressed 654 'cider-stacktrace-suppressed-button-face 655 'cider-stacktrace-promoted-button-face) 656 'help-echo (cider-stacktrace-tooltip 657 (format "Click to %s these stacktraces." 658 (if suppressed "promote" "suppress"))))) 659 (insert " "))))) 660 661 (defun cider-stacktrace-render-frame (buffer frame) 662 "Emit into BUFFER function call site info for the stack FRAME. 663 This associates text properties to enable filtering and source navigation." 664 (with-current-buffer buffer 665 (if (null frame) ;; Probably caused by OmitStackTraceInFastThrow 666 (let ((url "https://docs.cider.mx/cider/troubleshooting.html#empty-java-stacktraces")) 667 (insert " No stacktrace available!\n Please see ") 668 (insert-text-button url 669 'url url 670 'follow-link t 671 'action (lambda (x) (browse-url (button-get x 'url))))) 672 (nrepl-dbind-response frame (file line flags class method name var ns fn) 673 (when (or class file fn method ns name) 674 (let ((flags (mapcar #'intern flags))) ; strings -> symbols 675 (insert-text-button (format "%26s:%5d %s/%s" 676 (if (member 'repl flags) "REPL" file) (or line -1) 677 (if (member 'clj flags) ns class) 678 (if (member 'clj flags) fn method)) 679 'var var 'class class 'method method 680 'name name 'file file 'line line 681 'flags flags 'follow-link t 682 'action #'cider-stacktrace-navigate 683 'help-echo (cider-stacktrace-tooltip 684 "View source at this location") 685 'font-lock-face 'cider-stacktrace-face 686 'type 'cider-plain-button) 687 (save-excursion 688 (let ((p4 (point)) 689 (p1 (search-backward " ")) 690 (p2 (search-forward "/")) 691 (p3 (search-forward-regexp "[^/$]+"))) 692 (put-text-property p1 p4 'font-lock-face 'cider-stacktrace-ns-face) 693 (put-text-property p2 p3 'font-lock-face 'cider-stacktrace-fn-face) 694 (put-text-property (line-beginning-position) (line-end-position) 695 'cider-stacktrace-frame t))) 696 (insert "\n"))))))) 697 698 (defun cider-stacktrace-render-compile-error (buffer cause) 699 "Emit into BUFFER the compile error CAUSE, and enable jumping to it." 700 (with-current-buffer buffer 701 (nrepl-dbind-response cause (file path line column) 702 (let ((indent " ") 703 (message-face 'cider-stacktrace-error-message-face)) 704 (insert indent) 705 (insert (propertize "Error compiling " 'font-lock-face message-face)) 706 (insert-text-button path 'compile-error t 707 'file file 'line line 'column column 'follow-link t 708 'action (lambda (_button) 709 (cider-jump-to (cider-find-file file) 710 (cons line column))) 711 'help-echo (cider-stacktrace-tooltip 712 "Jump to the line that caused the error")) 713 (insert (propertize (format " at (%d:%d)" line column) 714 'font-lock-face message-face)))))) 715 716 (defun cider-stacktrace--toggle-visibility (id) 717 "Toggle visibility of the region with ID invisibility prop. 718 ID can also be a button, in which case button's property :id is used 719 instead. This function can be used directly in button actions." 720 (let ((id (if (or (numberp id) (symbolp id)) 721 ;; There is no proper way to identify buttons. Assuming that 722 ;; id's can be either numbers or symbols. 723 id 724 (button-get id :id)))) 725 (if (and (consp buffer-invisibility-spec) 726 (assoc id buffer-invisibility-spec)) 727 (remove-from-invisibility-spec (cons id t)) 728 (add-to-invisibility-spec (cons id t))))) 729 730 (defun cider-stacktrace--insert-named-group (indent name &rest vals) 731 "Insert named group with the ability to toggle visibility. 732 NAME is a string naming the group. VALS are strings to be inserted after 733 the NAME. The whole group is prefixed by string INDENT." 734 (let* ((str (and vals (replace-regexp-in-string "\n+\\'" "" (apply #'concat vals)))) 735 (id (and str 736 (string-match "\n" str) 737 (cl-gensym name)))) 738 (insert indent) 739 (if id 740 (let* ((beg-link (string-match "[^ :]" name)) 741 (end-link (string-match "[ :]" name (1+ beg-link)))) 742 (insert (substring name 0 beg-link)) 743 (insert-text-button (substring name beg-link end-link) 744 :id id 745 'face '((:weight bold) (:underline t)) 746 'follow-link t 747 'help-echo "Toggle visibility" 748 'action #'cider-stacktrace--toggle-visibility) 749 (insert (substring name end-link))) 750 (insert (propertize name 'face '((:weight bold))))) 751 (let ((pos (point))) 752 (when str 753 (cider-stacktrace-emit-indented (concat str "\n") nil nil t) 754 (when id 755 (remove-from-invisibility-spec (cons id t)) 756 (let ((hide-beg (save-excursion (goto-char pos) (point-at-eol))) 757 (hide-end (1- (point-at-bol)))) 758 (overlay-put (make-overlay hide-beg hide-end) 'invisible id))))))) 759 760 (defun cider-stacktrace--emit-spec-problems (spec-data indent) 761 "Emit SPEC-DATA indented with INDENT." 762 (nrepl-dbind-response spec-data (spec value problems) 763 (insert "\n") 764 (cider-stacktrace--insert-named-group indent " Spec: " spec) 765 (cider-stacktrace--insert-named-group indent " Value: " value) 766 (insert "\n") 767 (cider-stacktrace--insert-named-group indent "Problems: \n") 768 (let ((indent2 (concat indent " "))) 769 (dolist (prob problems) 770 (nrepl-dbind-response prob (in val predicate reason spec at extra) 771 (insert "\n") 772 (when (not (string= val value)) 773 (cider-stacktrace--insert-named-group indent2 " val: " val)) 774 (when in 775 (cider-stacktrace--insert-named-group indent2 " in: " in)) 776 (cider-stacktrace--insert-named-group indent2 "failed: " predicate) 777 (when spec 778 (cider-stacktrace--insert-named-group indent2 " spec: " spec)) 779 (when at 780 (cider-stacktrace--insert-named-group indent2 " at: " at)) 781 (when reason 782 (cider-stacktrace--insert-named-group indent2 "reason: " reason)) 783 (when extra 784 (cider-stacktrace--insert-named-group indent2 "extras: \n") 785 (cider-stacktrace-emit-indented extra (concat indent2 " ") nil t))))))) 786 787 (defun cider-stacktrace-render-cause (buffer cause num note) 788 "Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE." 789 (with-current-buffer buffer 790 (nrepl-dbind-response cause (class message data spec stacktrace) 791 (let ((indent " ") 792 (class-face 'cider-stacktrace-error-class-face) 793 (message-face 'cider-stacktrace-error-message-face)) 794 (cider-propertize-region `(cause ,num) 795 ;; Detail level 0: exception class 796 (cider-propertize-region '(detail 0) 797 (insert (format "%d. " num) 798 (propertize note 'font-lock-face 'font-lock-comment-face) " " 799 (propertize class 'font-lock-face class-face) 800 "\n")) 801 ;; Detail level 1: message + ex-data 802 (cider-propertize-region '(detail 1) 803 (if (equal class "clojure.lang.Compiler$CompilerException") 804 (cider-stacktrace-render-compile-error buffer cause) 805 (cider-stacktrace-emit-indented 806 (propertize (or message "(No message)") 807 'font-lock-face message-face) 808 indent t)) 809 (insert "\n") 810 (when spec 811 (cider-stacktrace--emit-spec-problems spec (concat indent " "))) 812 (when data 813 (cider-stacktrace-emit-indented data indent nil t))) 814 ;; Detail level 2: stacktrace 815 (cider-propertize-region '(detail 2) 816 (insert "\n") 817 (let ((beg (point)) 818 (bg `(:background ,cider-stacktrace-frames-background-color :extend t))) 819 (dolist (frame stacktrace) 820 (cider-stacktrace-render-frame buffer frame)) 821 (overlay-put (make-overlay beg (point)) 'font-lock-face bg))) 822 ;; Add line break between causes, even when collapsed. 823 (cider-propertize-region '(detail 0) 824 (insert "\n"))))))) 825 826 (defun cider-stacktrace-initialize (causes) 827 "Set and apply CAUSES initial visibility, filters, and cursor position." 828 (nrepl-dbind-response (car causes) (class) 829 (let ((compile-error-p (equal class "clojure.lang.Compiler$CompilerException"))) 830 ;; Partially display outermost cause if it's a compiler exception (the 831 ;; description reports reader location of the error). 832 (when compile-error-p 833 (cider-stacktrace-cycle-cause (length causes) 1)) 834 ;; Fully display innermost cause. This also applies visibility/filters. 835 (cider-stacktrace-cycle-cause 1 cider-stacktrace-detail-max) 836 ;; Move point (DWIM) to the compile error location if present, or to the 837 ;; first stacktrace frame in displayed cause otherwise. If the error 838 ;; buffer is visible in a window, ensure that window is selected while moving 839 ;; point, so as to move both the buffer's and the window's point. 840 (with-selected-window (or (get-buffer-window cider-error-buffer) 841 (selected-window)) 842 (with-current-buffer cider-error-buffer 843 (goto-char (point-min)) 844 (if compile-error-p 845 (goto-char (next-single-property-change (point) 'compile-error)) 846 (progn 847 (while (cider-stacktrace-next-cause)) 848 (when-let (position (next-single-property-change (point) 'flags)) 849 (goto-char position))))))))) 850 851 (defun cider-stacktrace-render (buffer causes &optional error-types) 852 "Emit into BUFFER useful stacktrace information for the CAUSES. 853 Takes an optional ERROR-TYPES list which will render a 'suppression' toggle 854 that alters the pop-over/pop-under behavorior of the stacktrace buffers 855 created by these types of errors. The suppressed errors set can be customized 856 through the `cider-stacktrace-suppressed-errors' variable." 857 (with-current-buffer buffer 858 (let ((inhibit-read-only t)) 859 (erase-buffer) 860 (insert "\n") 861 ;; Stacktrace filters 862 (cider-stacktrace-render-filters 863 buffer 864 `(("Project-Only" project) ("All" all)) 865 `(("Clojure" clj) ("Java" java) ("REPL" repl) 866 ("Tooling" tooling) ("Duplicates" dup))) 867 (insert "\n") 868 ;; Option to suppress internal/middleware errors 869 (when error-types 870 (cider-stacktrace-render-suppression-toggle buffer error-types) 871 (insert "\n\n")) 872 ;; Stacktrace exceptions & frames 873 (let ((num (length causes))) 874 (dolist (cause causes) 875 (let ((note (if (= num (length causes)) "Unhandled" "Caused by"))) 876 (cider-stacktrace-render-cause buffer cause num note) 877 (setq num (1- num)))))) 878 (cider-stacktrace-initialize causes) 879 (font-lock-refresh-defaults))) 880 881 (defun cider-stacktrace--analyze-stacktrace-op (stacktrace) 882 "Return the Cider NREPL op to analyze STACKTRACE." 883 (list "op" "analyze-stacktrace" "stacktrace" stacktrace)) 884 885 (defun cider-stacktrace--stacktrace-request (stacktrace) 886 "Return the Cider NREPL request to analyze STACKTRACE." 887 (thread-last 888 (map-merge 'list 889 (list (cider-stacktrace--analyze-stacktrace-op stacktrace)) 890 (cider--nrepl-print-request-map fill-column)) 891 (seq-mapcat #'identity))) 892 893 (defun cider-stacktrace--analyze-render (causes) 894 "Render the CAUSES of the stacktrace analysis result." 895 (let ((buffer (get-buffer-create cider-error-buffer))) 896 (with-current-buffer buffer 897 (cider-stacktrace-mode) 898 (cider-stacktrace-render buffer (reverse causes)) 899 (display-buffer buffer cider-jump-to-pop-to-buffer-actions)))) 900 901 (defun cider-stacktrace-analyze-string (stacktrace) 902 "Analyze the STACKTRACE string and show the result." 903 (when (stringp stacktrace) 904 (set-text-properties 0 (length stacktrace) nil stacktrace)) 905 (let (causes) 906 (cider-nrepl-send-request 907 (cider-stacktrace--stacktrace-request stacktrace) 908 (lambda (response) 909 (setq causes (nrepl-dbind-response response (class status) 910 (cond (class (cons response causes)) 911 ((and (member "done" status) causes) 912 (cider-stacktrace--analyze-render causes))))))))) 913 914 (defun cider-stacktrace-analyze-at-point () 915 "Analyze the stacktrace at point." 916 (interactive) 917 (cond ((thing-at-point 'sentence) 918 (cider-stacktrace-analyze-string (thing-at-point 'sentence))) 919 ((thing-at-point 'paragraph) 920 (cider-stacktrace-analyze-string (thing-at-point 'paragraph))) 921 (t (cider-stacktrace-analyze-in-region (region-beginning) (region-end))))) 922 923 (defun cider-stacktrace-analyze-in-region (beg end) 924 "Analyze the stacktrace in the region between BEG and END." 925 (interactive (list (region-beginning) (region-end))) 926 (let ((stacktrace (buffer-substring beg end))) 927 (cider-stacktrace-analyze-string stacktrace))) 928 929 (provide 'cider-stacktrace) 930 931 ;;; cider-stacktrace.el ends here