about summary refs log tree commit diff
path: root/configs/shared/emacs/.emacs.d/elpa/cider-20180719.542/cider-stacktrace.el
diff options
context:
space:
mode:
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/cider-20180719.542/cider-stacktrace.el')
-rw-r--r--configs/shared/emacs/.emacs.d/elpa/cider-20180719.542/cider-stacktrace.el899
1 files changed, 899 insertions, 0 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/cider-20180719.542/cider-stacktrace.el b/configs/shared/emacs/.emacs.d/elpa/cider-20180719.542/cider-stacktrace.el
new file mode 100644
index 000000000000..5daed06cc8fc
--- /dev/null
+++ b/configs/shared/emacs/.emacs.d/elpa/cider-20180719.542/cider-stacktrace.el
@@ -0,0 +1,899 @@
+;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*-
+
+;; Copyright © 2014-2018 Jeff Valk, Bozhidar Batsov and CIDER contributors
+
+;; Author: Jeff Valk <jv@jeffvalk.com>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; Stacktrace filtering and stack frame source navigation
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'cider-popup)
+(require 'button)
+(require 'easymenu)
+(require 'cider-common)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-client)
+(require 'cider-util)
+
+(require 'seq)
+
+;; Variables
+
+(defgroup cider-stacktrace nil
+  "Stacktrace filtering and navigation."
+  :prefix "cider-stacktrace-"
+  :group 'cider)
+
+(defcustom cider-stacktrace-fill-column t
+  "Fill column for error messages in stacktrace display.
+If nil, messages will not be wrapped.  If truthy but non-numeric,
+`fill-column' will be used."
+  :type 'list
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.7.0"))
+
+(defcustom cider-stacktrace-default-filters '(tooling dup)
+  "Frame types to omit from initial stacktrace display."
+  :type 'list
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.6.0"))
+
+(defcustom cider-stacktrace-print-length 50
+  "Set the maximum length of sequences in displayed cause data.
+
+This sets the value of Clojure's `*print-length*` when pretty printing the
+`ex-data` map for exception causes in the stacktrace that are instances of
+`IExceptionInfo`.
+
+Be advised that setting this to `nil` will cause the attempted printing of
+infinite data structures."
+  :type '(choice integer (const nil))
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.9.0"))
+
+(defcustom cider-stacktrace-print-level 50
+  "Set the maximum level of nesting in displayed cause data.
+
+This sets the value of Clojure's `*print-level*` when pretty printing the
+`ex-data` map for exception causes in the stacktrace that are instances of
+`IExceptionInfo`.
+
+Be advised that setting this to `nil` will cause the attempted printing of
+cyclical data structures."
+  :type '(choice integer (const nil))
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.8.0"))
+
+(defvar cider-stacktrace-detail-max 2
+  "The maximum detail level for causes.")
+
+(defvar-local cider-stacktrace-hidden-frame-count 0)
+(defvar-local cider-stacktrace-filters nil)
+(defvar-local cider-stacktrace-cause-visibility nil)
+(defvar-local cider-stacktrace-positive-filters nil)
+
+(defconst cider-error-buffer "*cider-error*")
+
+(make-obsolete 'cider-visit-error-buffer 'cider-selector "0.18")
+
+(defcustom cider-stacktrace-suppressed-errors '()
+  "Errors that won't make the stacktrace buffer 'pop-over' your active window.
+The error types are represented as strings."
+  :type 'list
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.12.0"))
+
+;; Faces
+
+(defface cider-stacktrace-error-class-face
+  '((t (:inherit font-lock-warning-face)))
+  "Face for exception class names"
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-error-message-face
+  '((t (:inherit font-lock-doc-face)))
+  "Face for exception messages"
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.7.0"))
+
+(defface cider-stacktrace-filter-active-face
+  '((t (:inherit button :underline t :weight normal)))
+  "Face for filter buttons representing frames currently visible"
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-filter-inactive-face
+  '((t (:inherit button :underline nil :weight normal)))
+  "Face for filter buttons representing frames currently filtered out"
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-face
+  '((t (:inherit default)))
+  "Face for stack frame text"
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-ns-face
+  '((t (:inherit font-lock-comment-face)))
+  "Face for stack frame namespace name"
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-fn-face
+  '((t (:inherit default :weight bold)))
+  "Face for stack frame function name"
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.6.0"))
+
+(defface cider-stacktrace-promoted-button-face
+  '((((type graphic))
+     :box (:line-width 3 :style released-button)
+     :inherit error)
+    (t :inverse-video t))
+  "A button with this face represents a promoted (non-suppressed) error type."
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.12.0"))
+
+(defface cider-stacktrace-suppressed-button-face
+  '((((type graphic))
+     :box (:line-width 3 :style pressed-button)
+     :inherit widget-inactive)
+    (t :inverse-video t))
+  "A button with this face represents a suppressed error type."
+  :group 'cider-stacktrace
+  :package-version '(cider . "0.12.0"))
+
+;; Colors & Theme Support
+
+(defvar cider-stacktrace-frames-background-color
+  (cider-scale-background-color)
+  "Background color for stacktrace frames.")
+
+(defadvice enable-theme (after cider-stacktrace-adapt-to-theme activate)
+  "When theme is changed, update `cider-stacktrace-frames-background-color'."
+  (setq cider-stacktrace-frames-background-color (cider-scale-background-color)))
+
+
+(defadvice disable-theme (after cider-stacktrace-adapt-to-theme activate)
+  "When theme is disabled, update `cider-stacktrace-frames-background-color'."
+  (setq cider-stacktrace-frames-background-color (cider-scale-background-color)))
+
+
+;; Mode & key bindings
+
+(defvar cider-stacktrace-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map (kbd "M-p") #'cider-stacktrace-previous-cause)
+    (define-key map (kbd "M-n") #'cider-stacktrace-next-cause)
+    (define-key map (kbd "M-.") #'cider-stacktrace-jump)
+    (define-key map "q" #'cider-popup-buffer-quit-function)
+    (define-key map "j" #'cider-stacktrace-toggle-java)
+    (define-key map "c" #'cider-stacktrace-toggle-clj)
+    (define-key map "r" #'cider-stacktrace-toggle-repl)
+    (define-key map "t" #'cider-stacktrace-toggle-tooling)
+    (define-key map "d" #'cider-stacktrace-toggle-duplicates)
+    (define-key map "p" #'cider-stacktrace-show-only-project)
+    (define-key map "a" #'cider-stacktrace-toggle-all)
+    (define-key map "1" #'cider-stacktrace-cycle-cause-1)
+    (define-key map "2" #'cider-stacktrace-cycle-cause-2)
+    (define-key map "3" #'cider-stacktrace-cycle-cause-3)
+    (define-key map "4" #'cider-stacktrace-cycle-cause-4)
+    (define-key map "5" #'cider-stacktrace-cycle-cause-5)
+    (define-key map "0" #'cider-stacktrace-cycle-all-causes)
+    (define-key map (kbd "TAB") #'cider-stacktrace-cycle-current-cause)
+    (define-key map [backtab] #'cider-stacktrace-cycle-all-causes)
+    (easy-menu-define cider-stacktrace-mode-menu map
+      "Menu for CIDER's stacktrace mode"
+      '("Stacktrace"
+        ["Previous cause" cider-stacktrace-previous-cause]
+        ["Next cause" cider-stacktrace-next-cause]
+        "--"
+        ["Jump to frame source" cider-stacktrace-jump]
+        "--"
+        ["Cycle current cause detail" cider-stacktrace-cycle-current-cause]
+        ["Cycle cause #1 detail" cider-stacktrace-cycle-cause-1]
+        ["Cycle cause #2 detail" cider-stacktrace-cycle-cause-2]
+        ["Cycle cause #3 detail" cider-stacktrace-cycle-cause-3]
+        ["Cycle cause #4 detail" cider-stacktrace-cycle-cause-4]
+        ["Cycle cause #5 detail" cider-stacktrace-cycle-cause-5]
+        ["Cycle all cause detail" cider-stacktrace-cycle-all-causes]
+        "--"
+        ["Show/hide Java frames" cider-stacktrace-toggle-java]
+        ["Show/hide Clojure frames" cider-stacktrace-toggle-clj]
+        ["Show/hide REPL frames" cider-stacktrace-toggle-repl]
+        ["Show/hide tooling frames" cider-stacktrace-toggle-tooling]
+        ["Show/hide duplicate frames" cider-stacktrace-toggle-duplicates]
+        ["Toggle only project frames" cider-stacktrace-show-only-project]
+        ["Show/hide all frames" cider-stacktrace-toggle-all]))
+    map))
+
+(define-derived-mode cider-stacktrace-mode special-mode "Stacktrace"
+  "Major mode for filtering and navigating CIDER stacktraces.
+
+\\{cider-stacktrace-mode-map}"
+  (when cider-special-mode-truncate-lines
+    (setq-local truncate-lines t))
+  (setq-local sesman-system 'CIDER)
+  (setq-local electric-indent-chars nil)
+  (setq-local cider-stacktrace-hidden-frame-count 0)
+  (setq-local cider-stacktrace-filters cider-stacktrace-default-filters)
+  (setq-local cider-stacktrace-cause-visibility (make-vector 10 0)))
+
+
+;; Stacktrace filtering
+
+(defvar cider-stacktrace--all-negative-filters
+  '(clj tooling dup java repl)
+  "Filters that remove stackframes.")
+
+(defvar cider-stacktrace--all-positive-filters
+  '(project all)
+  "Filters that ensure stackframes are shown.")
+
+(defun cider-stacktrace--face-for-filter (filter neg-filters pos-filters)
+  "Return whether we should mark the FILTER is active or not.
+
+NEG-FILTERS and POS-FILTERS are lists of filters to check FILTER's type.
+
+NEG-FILTERS dictate which frames should be hidden while POS-FILTERS can
+override this and ensure that those frames are shown."
+  (cond ((member filter cider-stacktrace--all-negative-filters)
+         (if (member filter neg-filters)
+             'cider-stacktrace-filter-active-face
+           'cider-stacktrace-filter-inactive-face))
+        ((member filter cider-stacktrace--all-positive-filters)
+         (if (member filter pos-filters)
+             'cider-stacktrace-filter-active-face
+           'cider-stacktrace-filter-inactive-face))))
+
+(defun cider-stacktrace-indicate-filters (filters pos-filters)
+  "Update enabled state of filter buttons.
+
+Find buttons with a 'filter property; if filter is a member of FILTERS, or
+if filter is nil ('show all') and the argument list is non-nil, fontify the
+button as disabled.  Upon finding text with a 'hidden-count property, stop
+searching and update the hidden count text.  POS-FILTERS is the list of
+positive filters to always include."
+  (with-current-buffer cider-error-buffer
+    (save-excursion
+      (goto-char (point-min))
+      (let ((inhibit-read-only t))
+        ;; Toggle buttons
+        (while (not (or (get-text-property (point) 'hidden-count) (eobp)))
+          (let ((button (button-at (point))))
+            (when button
+              (let* ((filter (button-get button 'filter))
+                     (face (cider-stacktrace--face-for-filter filter
+                                                              filters
+                                                              pos-filters)))
+                (button-put button 'face face)))
+            (goto-char (or (next-property-change (point))
+                           (point-max)))))
+        ;; Update hidden count
+        (when (and (get-text-property (point) 'hidden-count)
+                   (re-search-forward "[0-9]+" (line-end-position) t))
+          (replace-match
+           (number-to-string cider-stacktrace-hidden-frame-count)))))))
+
+(defun cider-stacktrace-frame-p ()
+  "Indicate if the text at point is a stack frame."
+  (get-text-property (point) 'cider-stacktrace-frame))
+
+(defun cider-stacktrace-collapsed-p ()
+  "Indicate if the stackframe was collapsed."
+  (get-text-property (point) 'collapsed))
+
+(defun cider-stacktrace--should-hide-p (neg-filters pos-filters flags)
+  "Decide whether a stackframe should be hidden or not.
+NEG-FILTERS dictate which frames should be hidden while POS-FILTERS can
+override this and ensure that those frames are shown.
+Argument FLAGS are the flags set on the stackframe, ie: clj dup, etc."
+  (let ((neg (seq-intersection neg-filters flags))
+        (pos (seq-intersection pos-filters flags))
+        (all (memq 'all pos-filters)))
+    (cond (all nil) ;; if all filter is on then we should not hide
+          ((and pos neg) nil) ;; if hidden and "resurrected" we should not hide
+          (pos nil)
+          (neg t)
+          (t nil))))
+
+(defun cider-stacktrace--apply-filters (neg-filters pos-filters)
+  "Set visibility on stack frames.
+Should be called by `cider-stacktrace-apply-filters' which has the logic of
+how to interpret the combinations of the positive and negative filters.
+For instance, the presence of the positive filter `project' requires all of
+the other negative filters to be applied so that only project frames are
+shown.  NEG-FILTERS are the tags that should be hidden.  POS-FILTERS are
+the tags that must be shown."
+  (with-current-buffer cider-error-buffer
+    (save-excursion
+      (goto-char (point-min))
+      (let ((inhibit-read-only t)
+            (hidden 0))
+        (while (not (eobp))
+          (when (and (cider-stacktrace-frame-p)
+                     (not (cider-stacktrace-collapsed-p)))
+            (let* ((flags (get-text-property (point) 'flags))
+                   (hide (cider-stacktrace--should-hide-p neg-filters
+                                                          pos-filters
+                                                          flags)))
+              (when hide (cl-incf hidden))
+              (put-text-property (point) (line-beginning-position 2)
+                                 'invisible hide)))
+          (forward-line 1))
+        (setq cider-stacktrace-hidden-frame-count hidden)))
+    (cider-stacktrace-indicate-filters neg-filters pos-filters)))
+
+(defun cider-stacktrace-apply-filters (filters)
+  "Takes a single list of filters and applies them.
+Update `cider-stacktrace-hidden-frame-count' and indicate
+filters applied.  Currently collapsed stacktraces are ignored, and do not
+contribute to the hidden count.  FILTERS is the list of filters to be
+applied, positive and negative all together.  This function defines how
+those choices interact and separates them into positive and negative
+filters for the resulting machinery."
+  (let ((neg-filters (seq-intersection filters cider-stacktrace--all-negative-filters))
+        (pos-filters (seq-intersection filters cider-stacktrace--all-positive-filters)))
+    ;; project and all are mutually exclusive. when both are present we check to
+    ;; see the most recent one (as cons onto the list would put it) and use that
+    ;; interaction.
+    (cond
+     ((memq 'all (memq 'project pos-filters)) ;; project is most recent
+      (cider-stacktrace--apply-filters cider-stacktrace--all-negative-filters '(project)))
+     ((memq 'project (memq 'all pos-filters)) ;; all is most recent
+      (cider-stacktrace--apply-filters nil '(all)))
+     ((memq 'all pos-filters) (cider-stacktrace--apply-filters nil '(all)))
+     ((memq 'project pos-filters) (cider-stacktrace--apply-filters cider-stacktrace--all-negative-filters
+                                                                   pos-filters))
+     (t (cider-stacktrace--apply-filters neg-filters pos-filters)))))
+
+(defun cider-stacktrace-apply-cause-visibility ()
+  "Apply `cider-stacktrace-cause-visibility' to causes and reapply filters."
+  (with-current-buffer cider-error-buffer
+    (save-excursion
+      (goto-char (point-min))
+      (cl-flet ((next-detail (end)
+                             (when-let* ((pos (next-single-property-change (point) 'detail)))
+                               (when (< pos end)
+                                 (goto-char pos)))))
+        (let ((inhibit-read-only t))
+          ;; For each cause...
+          (while (cider-stacktrace-next-cause)
+            (let* ((num   (get-text-property (point) 'cause))
+                   (level (elt cider-stacktrace-cause-visibility num))
+                   (cause-end (cadr (cider-property-bounds 'cause))))
+              ;; For each detail level within the cause, set visibility.
+              (while (next-detail cause-end)
+                (let* ((detail (get-text-property (point) 'detail))
+                       (detail-end (cadr (cider-property-bounds 'detail)))
+                       (hide (if (> detail level) t nil)))
+                  (add-text-properties (point) detail-end
+                                       (list 'invisible hide
+                                             'collapsed hide))))))))
+      (cider-stacktrace-apply-filters cider-stacktrace-filters))))
+
+;;; Internal/Middleware error suppression
+
+(defun cider-stacktrace-some-suppressed-errors-p (error-types)
+  "Return intersection of ERROR-TYPES and CIDER-STACKTRACE-SUPPRESSED-ERRORS.
+I.e, Return non-nil if the seq ERROR-TYPES shares any elements with
+`cider-stacktrace-suppressed-errors'.  This means that even a
+'well-behaved' (ie, promoted) error type will be 'guilty by association' if
+grouped with a suppressed error type."
+  (seq-intersection error-types cider-stacktrace-suppressed-errors))
+
+(defun cider-stacktrace-suppress-error (error-type)
+  "Destructively add element ERROR-TYPE to the `cider-stacktrace-suppressed-errors' set."
+  (setq cider-stacktrace-suppressed-errors
+        (cl-adjoin error-type cider-stacktrace-suppressed-errors :test 'equal)))
+
+(defun cider-stacktrace-promote-error (error-type)
+  "Destructively remove element ERROR-TYPE from the `cider-stacktrace-suppressed-errors' set."
+  (setq cider-stacktrace-suppressed-errors
+        (remove error-type cider-stacktrace-suppressed-errors)))
+
+(defun cider-stacktrace-suppressed-error-p (error-type)
+  "Return non-nil if element ERROR-TYPE is a member of the `cider-stacktrace-suppressed-errors' set."
+  (member error-type cider-stacktrace-suppressed-errors))
+
+;; Interactive functions
+
+(defun cider-stacktrace-previous-cause ()
+  "Move point to the previous exception cause, if one exists."
+  (interactive)
+  (with-current-buffer cider-error-buffer
+    (when-let* ((pos (previous-single-property-change (point) 'cause)))
+      (goto-char pos))))
+
+(defun cider-stacktrace-next-cause ()
+  "Move point to the next exception cause, if one exists."
+  (interactive)
+  (with-current-buffer cider-error-buffer
+    (when-let* ((pos (next-single-property-change (point) 'cause)))
+      (goto-char pos))))
+
+(defun cider-stacktrace-cycle-cause (num &optional level)
+  "Update element NUM of `cider-stacktrace-cause-visibility'.
+If LEVEL is specified, it is useed, otherwise its current value is incremented.
+When it reaches 3, it wraps to 0."
+  (let ((level (or level (1+ (elt cider-stacktrace-cause-visibility num)))))
+    (aset cider-stacktrace-cause-visibility num (mod level 3))
+    (cider-stacktrace-apply-cause-visibility)))
+
+(defun cider-stacktrace-cycle-all-causes ()
+  "Cycle the visibility of all exception causes."
+  (interactive)
+  (with-current-buffer cider-error-buffer
+    (save-excursion
+      ;; Find nearest cause.
+      (unless (get-text-property (point) 'cause)
+        (cider-stacktrace-next-cause)
+        (unless (get-text-property (point) 'cause)
+          (cider-stacktrace-previous-cause)))
+      ;; Cycle its level, and apply that to all causes.
+      (let* ((num (get-text-property (point) 'cause))
+             (level (1+ (elt cider-stacktrace-cause-visibility num))))
+        (setq-local cider-stacktrace-cause-visibility
+                    (make-vector 10 (mod level 3)))
+        (cider-stacktrace-apply-cause-visibility)))))
+
+(defun cider-stacktrace-cycle-current-cause ()
+  "Cycle the visibility of current exception at point, if any."
+  (interactive)
+  (with-current-buffer cider-error-buffer
+    (when-let* ((num (get-text-property (point) 'cause)))
+      (cider-stacktrace-cycle-cause num))))
+
+(defun cider-stacktrace-cycle-cause-1 ()
+  "Cycle the visibility of exception cause #1."
+  (interactive)
+  (cider-stacktrace-cycle-cause 1))
+
+(defun cider-stacktrace-cycle-cause-2 ()
+  "Cycle the visibility of exception cause #2."
+  (interactive)
+  (cider-stacktrace-cycle-cause 2))
+
+(defun cider-stacktrace-cycle-cause-3 ()
+  "Cycle the visibility of exception cause #3."
+  (interactive)
+  (cider-stacktrace-cycle-cause 3))
+
+(defun cider-stacktrace-cycle-cause-4 ()
+  "Cycle the visibility of exception cause #4."
+  (interactive)
+  (cider-stacktrace-cycle-cause 4))
+
+(defun cider-stacktrace-cycle-cause-5 ()
+  "Cycle the visibility of exception cause #5."
+  (interactive)
+  (cider-stacktrace-cycle-cause 5))
+
+(defun cider-stacktrace-toggle (flag)
+  "Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters."
+  (cider-stacktrace-apply-filters
+   (setq cider-stacktrace-filters
+         (if (memq flag cider-stacktrace-filters)
+             (remq flag cider-stacktrace-filters)
+           (cons flag cider-stacktrace-filters)))))
+
+(defun cider-stacktrace-toggle-all ()
+  "Toggle `all' in filter list."
+  (interactive)
+  (cider-stacktrace-toggle 'all))
+
+(defun cider-stacktrace-show-only-project ()
+  "Display only the stackframes from the project."
+  (interactive)
+  (cider-stacktrace-toggle 'project))
+
+(defun cider-stacktrace-toggle-java ()
+  "Toggle display of Java stack frames."
+  (interactive)
+  (cider-stacktrace-toggle 'java))
+
+(defun cider-stacktrace-toggle-clj ()
+  "Toggle display of Clojure stack frames."
+  (interactive)
+  (cider-stacktrace-toggle 'clj))
+
+(defun cider-stacktrace-toggle-repl ()
+  "Toggle display of REPL stack frames."
+  (interactive)
+  (cider-stacktrace-toggle 'repl))
+
+(defun cider-stacktrace-toggle-tooling ()
+  "Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)."
+  (interactive)
+  (cider-stacktrace-toggle 'tooling))
+
+(defun cider-stacktrace-toggle-duplicates ()
+  "Toggle display of stack frames that are duplicates of their descendents."
+  (interactive)
+  (cider-stacktrace-toggle 'dup))
+
+;; Text button functions
+
+(defun cider-stacktrace-filter (button)
+  "Apply filter(s) indicated by the BUTTON."
+  (with-temp-message "Filters may also be toggled with the keyboard."
+    (let ((flag (button-get button 'filter)))
+      (cond ((member flag cider-stacktrace--all-negative-filters)
+             (cider-stacktrace-toggle flag))
+            ((member flag cider-stacktrace--all-positive-filters)
+             (cider-stacktrace-show-only-project))
+            (t (cider-stacktrace-toggle-all))))
+    (sit-for 5)))
+
+(defun cider-stacktrace-toggle-suppression (button)
+  "Toggle stacktrace pop-over/pop-under behavior for the `error-type' in BUTTON.
+Achieved by destructively manipulating the `cider-stacktrace-suppressed-errors' set."
+  (with-current-buffer cider-error-buffer
+    (let ((inhibit-read-only t)
+          (suppressed (button-get button 'suppressed))
+          (error-type (button-get button 'error-type)))
+      (if suppressed
+          (progn
+            (cider-stacktrace-promote-error error-type)
+            (button-put button 'face 'cider-stacktrace-promoted-button-face)
+            (button-put button 'help-echo "Click to suppress these stacktraces."))
+        (cider-stacktrace-suppress-error error-type)
+        (button-put button 'face 'cider-stacktrace-suppressed-button-face)
+        (button-put button 'help-echo "Click to promote these stacktraces."))
+      (button-put button 'suppressed (not suppressed)))))
+
+(defun cider-stacktrace-navigate (button)
+  "Navigate to the stack frame source represented by the BUTTON."
+  (let* ((var (button-get button 'var))
+         (class (button-get button 'class))
+         (method (button-get button 'method))
+         (info (or (and var (cider-var-info var))
+                   (and class method (cider-member-info class method))
+                   (nrepl-dict)))
+         ;; Stacktrace returns more accurate line numbers, but if the function's
+         ;; line was unreliable, then so is the stacktrace by the same amount.
+         ;; Set `line-shift' to the number of lines from the beginning of defn.
+         (line-shift (- (or (button-get button 'line) 0)
+                        (or (nrepl-dict-get info "line") 1)))
+         (file (or
+                (and (null var) (cider-resolve-java-class class))
+                (nrepl-dict-get info "file")
+                (button-get button 'file)))
+         ;; give priority to `info` files as `info` returns full paths.
+         (info (nrepl-dict-put info "file" file)))
+    (cider--jump-to-loc-from-info info t)
+    (forward-line line-shift)
+    (back-to-indentation)))
+
+(declare-function cider-find-var "cider-find")
+
+(defun cider-stacktrace-jump (&optional arg)
+  "Find definition for stack frame at point, if available.
+The prefix ARG and `cider-prompt-for-symbol' decide whether to
+prompt and whether to use a new window.  Similar to `cider-find-var'."
+  (interactive "P")
+  (let ((button (button-at (point))))
+    (if (and button (button-get button 'line))
+        (cider-stacktrace-navigate button)
+      (cider-find-var arg))))
+
+
+;; Rendering
+
+(defun cider-stacktrace-emit-indented (text &optional indent fill fontify)
+  "Insert TEXT, and optionally FILL and FONTIFY as clojure the entire block.
+INDENT is a string to insert before each line.  When INDENT is nil, first
+line is not indented and INDENT defaults to a white-spaced string with
+length given by `current-column'."
+  (let ((text (if fontify
+                  (cider-font-lock-as-clojure text)
+                text))
+        (do-first indent)
+        (indent (or indent (make-string (current-column) ? )))
+        (beg (point)))
+    (insert text)
+    (goto-char beg)
+    (when do-first
+      (insert indent))
+    (forward-line)
+    (while (not (eobp))
+      (insert indent)
+      (forward-line))
+    (when (and fill cider-stacktrace-fill-column)
+      (when (and (numberp cider-stacktrace-fill-column))
+        (setq-local fill-column cider-stacktrace-fill-column))
+      (setq-local fill-prefix indent)
+      (fill-region beg (point)))))
+
+(defun cider-stacktrace-render-filters (buffer special-filters filters)
+  "Emit into BUFFER toggle buttons for each of the FILTERS.
+SPECIAL-FILTERS are filters that show stack certain stack frames, hiding
+others."
+  (with-current-buffer buffer
+    (insert "  Show: ")
+    (dolist (filter special-filters)
+      (insert-text-button (car filter)
+                          'filter (cadr filter)
+                          'follow-link t
+                          'action 'cider-stacktrace-filter
+                          'help-echo (format "Toggle %s stack frames"
+                                             (car filter)))
+      (insert " "))
+    (insert "\n")
+    (insert "  Hide: ")
+    (dolist (filter filters)
+      (insert-text-button (car filter)
+                          'filter (cadr filter)
+                          'follow-link t
+                          'action 'cider-stacktrace-filter
+                          'help-echo (format "Toggle %s stack frames"
+                                             (car filter)))
+      (insert " "))
+
+    (let ((hidden "(0 frames hidden)"))
+      (put-text-property 0 (length hidden) 'hidden-count t hidden)
+      (insert " " hidden "\n"))))
+
+(defun cider-stacktrace-render-suppression-toggle (buffer error-types)
+  "Emit into BUFFER toggle buttons for each of the ERROR-TYPES leading this stacktrace buffer."
+  (with-current-buffer buffer
+    (when error-types
+      (insert "  This is an unexpected CIDER middleware error.\n  Please submit a bug report via `")
+      (insert-text-button "M-x cider-report-bug"
+                          'follow-link t
+                          'action (lambda (_button) (cider-report-bug))
+                          'help-echo "Report bug to the CIDER team.")
+      (insert "`.\n\n")
+      (insert "\
+  If these stacktraces are occuring frequently, consider using the
+  button(s) below to suppress these types of errors for the duration of
+  your current CIDER session. The stacktrace buffer will still be
+  generated, but it will \"pop under\" your current buffer instead of
+  \"popping over\". The button toggles this behavior.\n\n ")
+      (dolist (error-type error-types)
+        (let ((suppressed (cider-stacktrace-suppressed-error-p error-type)))
+          (insert-text-button (format "%s %s" (if suppressed "Promote" "Suppress") error-type)
+                              'follow-link t
+                              'error-type error-type
+                              'action 'cider-stacktrace-toggle-suppression
+                              'suppressed suppressed
+                              'face (if suppressed
+                                        'cider-stacktrace-suppressed-button-face
+                                      'cider-stacktrace-promoted-button-face)
+                              'help-echo (format "Click to %s these stacktraces."
+                                                 (if suppressed "promote" "suppress"))))
+        (insert " ")))))
+
+(defun cider-stacktrace-render-frame (buffer frame)
+  "Emit into BUFFER function call site info for the stack FRAME.
+This associates text properties to enable filtering and source navigation."
+  (with-current-buffer buffer
+    (nrepl-dbind-response frame (file line flags class method name var ns fn)
+      (let ((flags (mapcar 'intern flags))) ; strings -> symbols
+        (insert-text-button (format "%26s:%5d  %s/%s"
+                                    (if (member 'repl flags) "REPL" file) line
+                                    (if (member 'clj flags) ns class)
+                                    (if (member 'clj flags) fn method))
+                            'var var 'class class 'method method
+                            'name name 'file file 'line line
+                            'flags flags 'follow-link t
+                            'action 'cider-stacktrace-navigate
+                            'help-echo "View source at this location"
+                            'font-lock-face 'cider-stacktrace-face
+                            'type 'cider-plain-button)
+        (save-excursion
+          (let ((p4 (point))
+                (p1 (search-backward " "))
+                (p2 (search-forward "/"))
+                (p3 (search-forward-regexp "[^/$]+")))
+            (put-text-property p1 p4 'font-lock-face 'cider-stacktrace-ns-face)
+            (put-text-property p2 p3 'font-lock-face 'cider-stacktrace-fn-face)
+            (put-text-property (line-beginning-position) (line-end-position)
+                               'cider-stacktrace-frame t)))
+        (insert "\n")))))
+
+(defun cider-stacktrace-render-compile-error (buffer cause)
+  "Emit into BUFFER the compile error CAUSE, and enable jumping to it."
+  (with-current-buffer buffer
+    (nrepl-dbind-response cause (file path line column)
+      (let ((indent "   ")
+            (message-face 'cider-stacktrace-error-message-face))
+        (insert indent)
+        (insert (propertize "Error compiling " 'font-lock-face  message-face))
+        (insert-text-button path 'compile-error t
+                            'file file 'line line 'column column 'follow-link t
+                            'action (lambda (_button)
+                                      (cider-jump-to (cider-find-file file)
+                                                     (cons line column))))
+        (insert (propertize (format " at (%d:%d)" line column)
+                            'font-lock-face message-face))))))
+
+(defun cider-stacktrace--toggle-visibility (id)
+  "Toggle visibility of the region with ID invisibility prop.
+ID can also be a button, in which case button's property :id is used
+instead.  This function can be used directly in button actions."
+  (let ((id (if (or (numberp id) (symbolp id))
+                ;; There is no proper way to identify buttons. Assuming that
+                ;; id's can be either numbers or symbols.
+                id
+              (button-get id :id))))
+    (if (and (consp buffer-invisibility-spec)
+             (assoc id buffer-invisibility-spec))
+        (remove-from-invisibility-spec (cons id t))
+      (add-to-invisibility-spec (cons id t)))))
+
+(defun cider-stacktrace--insert-named-group (indent name &rest vals)
+  "Insert named group with the ability to toggle visibility.
+NAME is a string naming the group.  VALS are strings to be inserted after
+the NAME.  The whole group is prefixed by string INDENT."
+  (let* ((str (and vals (replace-regexp-in-string "\n+\\'" "" (apply #'concat vals))))
+         (id (and str
+                  (string-match "\n" str)
+                  (cl-gensym name))))
+    (insert indent)
+    (if id
+        (let* ((beg-link (string-match "[^ :]" name))
+               (end-link (string-match "[ :]" name (1+ beg-link))))
+          (insert (substring name 0 beg-link))
+          (insert-text-button (substring name beg-link end-link)
+                              :id id
+                              'face '((:weight bold) (:underline t))
+                              'follow-link t
+                              'help-echo "Toggle visibility"
+                              'action #'cider-stacktrace--toggle-visibility)
+          (insert (substring name end-link)))
+      (insert (propertize name 'face '((:weight bold)))))
+    (let ((pos (point)))
+      (when str
+        (cider-stacktrace-emit-indented (concat str "\n") nil nil t)
+        (when id
+          (remove-from-invisibility-spec (cons id t))
+          (let ((hide-beg (save-excursion (goto-char pos) (point-at-eol)))
+                (hide-end (1- (point-at-bol))))
+            (overlay-put (make-overlay hide-beg hide-end) 'invisible id)))))))
+
+(defun cider-stacktrace--emit-spec-problems (spec-data indent)
+  "Emit SPEC-DATA indented with INDENT."
+  (nrepl-dbind-response spec-data (spec value problems)
+    (insert "\n")
+    (cider-stacktrace--insert-named-group indent "    Spec: " spec)
+    (cider-stacktrace--insert-named-group indent "   Value: " value)
+    (insert "\n")
+    (cider-stacktrace--insert-named-group indent "Problems: \n")
+    (let ((indent2 (concat indent "    ")))
+      (dolist (prob problems)
+        (nrepl-dbind-response prob (in val predicate reason spec at extra)
+          (insert "\n")
+          (when (not (string= val value))
+            (cider-stacktrace--insert-named-group indent2 "   val: " val))
+          (when in
+            (cider-stacktrace--insert-named-group indent2 "    in: " in))
+          (cider-stacktrace--insert-named-group indent2   "failed: " predicate)
+          (when spec
+            (cider-stacktrace--insert-named-group indent2 "  spec: " spec))
+          (when at
+            (cider-stacktrace--insert-named-group indent2 "    at: " at))
+          (when reason
+            (cider-stacktrace--insert-named-group indent2 "reason: " reason))
+          (when extra
+            (cider-stacktrace--insert-named-group indent2 "extras: \n")
+            (cider-stacktrace-emit-indented extra (concat indent2 "  ") nil t)))))))
+
+(defun cider-stacktrace-render-cause (buffer cause num note)
+  "Emit into BUFFER the CAUSE NUM, exception class, message, data, and NOTE."
+  (with-current-buffer buffer
+    (nrepl-dbind-response cause (class message data spec stacktrace)
+      (let ((indent "   ")
+            (class-face 'cider-stacktrace-error-class-face)
+            (message-face 'cider-stacktrace-error-message-face))
+        (cider-propertize-region `(cause ,num)
+          ;; Detail level 0: exception class
+          (cider-propertize-region '(detail 0)
+            (insert (format "%d. " num)
+                    (propertize note 'font-lock-face 'font-lock-comment-face) " "
+                    (propertize class 'font-lock-face class-face)
+                    "\n"))
+          ;; Detail level 1: message + ex-data
+          (cider-propertize-region '(detail 1)
+            (if (equal class "clojure.lang.Compiler$CompilerException")
+                (cider-stacktrace-render-compile-error buffer cause)
+              (cider-stacktrace-emit-indented
+               (propertize (or message "(No message)")
+                           'font-lock-face  message-face)
+               indent t))
+            (insert "\n")
+            (when spec
+              (cider-stacktrace--emit-spec-problems spec (concat indent "  ")))
+            (when data
+              (cider-stacktrace-emit-indented data indent nil t)))
+          ;; Detail level 2: stacktrace
+          (cider-propertize-region '(detail 2)
+            (insert "\n")
+            (let ((beg (point))
+                  (bg `(:background ,cider-stacktrace-frames-background-color)))
+              (dolist (frame stacktrace)
+                (cider-stacktrace-render-frame buffer frame))
+              (overlay-put (make-overlay beg (point)) 'font-lock-face bg)))
+          ;; Add line break between causes, even when collapsed.
+          (cider-propertize-region '(detail 0)
+            (insert "\n")))))))
+
+(defun cider-stacktrace-initialize (causes)
+  "Set and apply CAUSES initial visibility, filters, and cursor position."
+  (nrepl-dbind-response (car causes) (class)
+    (let ((compile-error-p (equal class "clojure.lang.Compiler$CompilerException")))
+      ;; Partially display outermost cause if it's a compiler exception (the
+      ;; description reports reader location of the error).
+      (when compile-error-p
+        (cider-stacktrace-cycle-cause (length causes) 1))
+      ;; Fully display innermost cause. This also applies visibility/filters.
+      (cider-stacktrace-cycle-cause 1 cider-stacktrace-detail-max)
+      ;; Move point (DWIM) to the compile error location if present, or to the
+      ;; first stacktrace frame in displayed cause otherwise. If the error
+      ;; buffer is visible in a window, ensure that window is selected while moving
+      ;; point, so as to move both the buffer's and the window's point.
+      (with-selected-window (or (get-buffer-window cider-error-buffer)
+                                (selected-window))
+        (with-current-buffer cider-error-buffer
+          (goto-char (point-min))
+          (if compile-error-p
+              (goto-char (next-single-property-change (point) 'compile-error))
+            (progn
+              (while (cider-stacktrace-next-cause))
+              (goto-char (next-single-property-change (point) 'flags)))))))))
+
+(defun cider-stacktrace-render (buffer causes &optional error-types)
+  "Emit into BUFFER useful stacktrace information for the CAUSES.
+Takes an optional ERROR-TYPES list which will render a 'suppression' toggle
+that alters the pop-over/pop-under behavorior of the stacktrace buffers
+created by these types of errors.  The suppressed errors set can be customized
+through the `cider-stacktrace-suppressed-errors' variable."
+  (with-current-buffer buffer
+    (let ((inhibit-read-only t))
+      (erase-buffer)
+      (insert "\n")
+      ;; Stacktrace filters
+      (cider-stacktrace-render-filters
+       buffer
+       `(("Project-Only" project) ("All" all))
+       `(("Clojure" clj) ("Java" java) ("REPL" repl)
+         ("Tooling" tooling) ("Duplicates" dup)))
+      (insert "\n")
+      ;; Option to suppress internal/middleware errors
+      (when error-types
+        (cider-stacktrace-render-suppression-toggle buffer error-types)
+        (insert "\n\n"))
+      ;; Stacktrace exceptions & frames
+      (let ((num (length causes)))
+        (dolist (cause causes)
+          (let ((note (if (= num (length causes)) "Unhandled" "Caused by")))
+            (cider-stacktrace-render-cause buffer cause num note)
+            (setq num (1- num))))))
+    (cider-stacktrace-initialize causes)
+    (font-lock-refresh-defaults)))
+
+(provide 'cider-stacktrace)
+
+;;; cider-stacktrace.el ends here