about summary refs log blame commit diff
path: root/configs/shared/emacs/.emacs.d/elpa/cider-20180719.542/cider-stacktrace.el
blob: 5daed06cc8fccdfd6335e5e212c813a6edbaab0e (plain) (tree)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
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