diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/cider-20180908.1925/cider-stacktrace.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/cider-20180908.1925/cider-stacktrace.el | 910 |
1 files changed, 0 insertions, 910 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/cider-20180908.1925/cider-stacktrace.el b/configs/shared/emacs/.emacs.d/elpa/cider-20180908.1925/cider-stacktrace.el deleted file mode 100644 index 321d4bbdeb0b..000000000000 --- a/configs/shared/emacs/.emacs.d/elpa/cider-20180908.1925/cider-stacktrace.el +++ /dev/null @@ -1,910 +0,0 @@ -;;; 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 -(defvar cider-use-tooltips) -(defun cider-stacktrace-tooltip (tooltip) - "Return TOOLTIP if `cider-use-tooltips' is set to true, nil otherwise." - (when cider-use-tooltips tooltip)) - -(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 (cider-stacktrace-tooltip - (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 (cider-stacktrace-tooltip - (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 (cider-stacktrace-tooltip - "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 (cider-stacktrace-tooltip - (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 (cider-stacktrace-tooltip - "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))) - 'help-echo (cider-stacktrace-tooltip - "Jump to the line that caused the error")) - (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 |