cider-stacktrace.el

;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*-

;; Copyright © 2014-2016 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 '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-prior-filters nil)
(defvar-local cider-stacktrace-cause-visibility nil)

(defconst cider-error-buffer "*cider-error*")
(add-to-list 'cider-ancillary-buffers cider-error-buffer)

(defcustom cider-stacktrace-suppressed-errors '()
  "A set of 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-shown-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-hidden-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-face)
    (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)))


;; 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 "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 [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]
        ["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}"
  (setq buffer-read-only t)
  (when cider-special-mode-truncate-lines
    (setq-local truncate-lines t))
  (setq-local electric-indent-chars nil)
  (setq-local cider-stacktrace-prior-filters 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

(defun cider-stacktrace-indicate-filters (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."
  (with-current-buffer cider-error-buffer
    (save-excursion
      (goto-char (point-min))
      (let ((inhibit-read-only t)
            (get-face (lambda (hide)
                        (if hide
                            'cider-stacktrace-filter-hidden-face
                          'cider-stacktrace-filter-shown-face))))
        ;; 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 (funcall get-face (if filter
                                                 (member filter filters)
                                               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-apply-filters (filters)
  "Set visibility on stack frames using FILTERS.
Update `cider-stacktrace-hidden-frame-count' and indicate filters applied.
Currently collapsed stacktraces are ignored, and do not contribute to the
hidden count."
  (with-current-buffer cider-error-buffer
    (save-excursion
      (goto-char (point-min))
      (let ((inhibit-read-only t)
            (hidden 0))
        (while (not (eobp))
          (unless (get-text-property (point) 'collapsed)
            (let* ((flags (get-text-property (point) 'flags))
                   (hide (if (seq-intersection filters flags) t nil)))
              (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 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', optionally to LEVEL.
If LEVEL is not specified, 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-all ()
  "Reset `cider-stacktrace-filters' if present; otherwise restore prior filters."
  (interactive)
  (when cider-stacktrace-filters
    (setq-local cider-stacktrace-prior-filters
                cider-stacktrace-filters))
  (cider-stacktrace-apply-filters
   (setq cider-stacktrace-filters
         (unless cider-stacktrace-filters      ; when current filters are nil,
           cider-stacktrace-prior-filters))))  ;  reenable prior filter set

(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-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)))
      (if flag
          (cider-stacktrace-toggle flag)
        (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)))
         ;; give priority to `info` files as `info` returns full paths.
         (info (nrepl-dict-put info "file" (or (nrepl-dict-get info "file")
                                               (button-get button 'file)))))
    (cider--jump-to-loc-from-info info t)
    (forward-line line-shift)
    (back-to-indentation)))

(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 indent &optional fill)
  "Insert TEXT, and INDENT and optionally FILL the entire block."
  (let ((beg (point)))
    (insert text)
    (goto-char beg)
    (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 filters)
  "Emit into BUFFER toggle buttons for each of the FILTERS."
  (with-current-buffer buffer
    (insert "  Show: ")
    (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)))
        (insert "\n")))))

(declare-function cider-jump-to "cider-interaction")

(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-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 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 data
              (cider-stacktrace-emit-indented
               (cider-font-lock-as-clojure data) indent nil)))
          ;; 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
       `(("Clojure" clj) ("Java" java) ("REPL" repl)
         ("Tooling" tooling) ("Duplicates" dup) ("All" ,nil)))
      (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