Klimi's new dotfiles with stow.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

889 lines
39 KiB

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