837 lines
34 KiB
EmacsLisp
837 lines
34 KiB
EmacsLisp
;;; -*- coding: utf-8; lexical-binding: t -*-
|
||
;;;
|
||
;;; slime-trace-dialog.el -- a navigable dialog of inspectable trace entries
|
||
;;;
|
||
;;; TODO: implement better wrap interface for sbcl method, labels and such
|
||
;;; TODO: backtrace printing is very slow
|
||
;;;
|
||
(require 'slime)
|
||
(require 'slime-parse)
|
||
(require 'slime-repl)
|
||
(require 'cl-lib)
|
||
|
||
(define-slime-contrib slime-trace-dialog
|
||
"Provide an interfactive trace dialog buffer for managing and
|
||
inspecting details of traced functions. Invoke this dialog with C-c T."
|
||
(:authors "João Távora <joaotavora@gmail.com>")
|
||
(:license "GPL")
|
||
(:swank-dependencies swank-trace-dialog)
|
||
(:on-load (add-hook 'slime-mode-hook 'slime-trace-dialog-enable)
|
||
(add-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable))
|
||
(:on-unload (remove-hook 'slime-mode-hook 'slime-trace-dialog-enable)
|
||
(remove-hook 'slime-repl-mode-hook 'slime-trace-dialog-enable)))
|
||
|
||
|
||
;;;; Variables
|
||
;;;
|
||
(defvar slime-trace-dialog-flash t
|
||
"Non-nil means flash the updated region of the SLIME Trace Dialog. ")
|
||
|
||
(defvar slime-trace-dialog--specs-overlay nil)
|
||
|
||
(defvar slime-trace-dialog--progress-overlay nil)
|
||
|
||
(defvar slime-trace-dialog--tree-overlay nil)
|
||
|
||
(defvar slime-trace-dialog--collapse-chars (cons "-" "+"))
|
||
|
||
|
||
;;;; Local trace entry model
|
||
(defvar slime-trace-dialog--traces nil)
|
||
|
||
(cl-defstruct (slime-trace-dialog--trace
|
||
(:constructor slime-trace-dialog--make-trace))
|
||
id
|
||
parent
|
||
spec
|
||
args
|
||
retlist
|
||
depth
|
||
beg
|
||
end
|
||
collapse-button-marker
|
||
summary-beg
|
||
children-end
|
||
collapsed-p)
|
||
|
||
(defun slime-trace-dialog--find-trace (id)
|
||
(gethash id slime-trace-dialog--traces))
|
||
|
||
|
||
;;;; Modes and mode maps
|
||
;;;
|
||
(defvar slime-trace-dialog-mode-map
|
||
(let ((map (make-sparse-keymap))
|
||
(remaps '((slime-inspector-operate-on-point . nil)
|
||
(slime-inspector-operate-on-click . nil)
|
||
(slime-inspector-reinspect
|
||
. slime-trace-dialog-fetch-status)
|
||
(slime-inspector-next-inspectable-object
|
||
. slime-trace-dialog-next-button)
|
||
(slime-inspector-previous-inspectable-object
|
||
. slime-trace-dialog-prev-button))))
|
||
(set-keymap-parent map slime-inspector-mode-map)
|
||
(cl-loop for (old . new) in remaps
|
||
do (substitute-key-definition old new map))
|
||
(set-keymap-parent map slime-parent-map)
|
||
(define-key map (kbd "G") 'slime-trace-dialog-fetch-traces)
|
||
(define-key map (kbd "C-k") 'slime-trace-dialog-clear-fetched-traces)
|
||
(define-key map (kbd "g") 'slime-trace-dialog-fetch-status)
|
||
(define-key map (kbd "M-RET") 'slime-trace-dialog-copy-down-to-repl)
|
||
(define-key map (kbd "q") 'quit-window)
|
||
map))
|
||
|
||
(define-derived-mode slime-trace-dialog-mode fundamental-mode
|
||
"SLIME Trace Dialog" "Mode for controlling SLIME's Trace Dialog"
|
||
(set-syntax-table lisp-mode-syntax-table)
|
||
(read-only-mode 1)
|
||
(add-to-list (make-local-variable 'slime-trace-dialog-after-toggle-hook)
|
||
'slime-trace-dialog-fetch-status))
|
||
|
||
(define-derived-mode slime-trace-dialog--detail-mode slime-inspector-mode
|
||
"SLIME Trace Detail"
|
||
"Mode for viewing a particular trace from SLIME's Trace Dialog")
|
||
|
||
(setq slime-trace-dialog--detail-mode-map
|
||
(let ((map (make-sparse-keymap))
|
||
(remaps '((slime-inspector-next-inspectable-object
|
||
. slime-trace-dialog-next-button)
|
||
(slime-inspector-previous-inspectable-object
|
||
. slime-trace-dialog-prev-button))))
|
||
(set-keymap-parent map slime-trace-dialog-mode-map)
|
||
(cl-loop for (old . new) in remaps
|
||
do (substitute-key-definition old new map))
|
||
map))
|
||
|
||
(defvar slime-trace-dialog-minor-mode-map
|
||
(let ((map (make-sparse-keymap)))
|
||
(define-key map (kbd "C-c T") 'slime-trace-dialog)
|
||
(define-key map (kbd "C-c M-t") 'slime-trace-dialog-toggle-trace)
|
||
map))
|
||
|
||
(define-minor-mode slime-trace-dialog-minor-mode
|
||
"Add keybindings for accessing SLIME's Trace Dialog.")
|
||
|
||
(defun slime-trace-dialog-enable ()
|
||
(slime-trace-dialog-minor-mode 1))
|
||
|
||
(easy-menu-define slime-trace-dialog--menubar (list slime-trace-dialog-minor-mode-map
|
||
slime-trace-dialog-mode-map)
|
||
"A menu for accessing some features of SLIME's Trace Dialog"
|
||
(let* ((in-dialog '(eq major-mode 'slime-trace-dialog-mode))
|
||
(dialog-live `(and ,in-dialog
|
||
(memq slime-buffer-connection slime-net-processes)))
|
||
(connected '(slime-connected-p)))
|
||
`("Trace"
|
||
["Toggle trace" slime-trace-dialog-toggle-trace ,connected]
|
||
["Trace complex spec" slime-trace-dialog-toggle-complex-trace ,connected]
|
||
["Open Trace dialog" slime-trace-dialog (and ,connected (not ,in-dialog))]
|
||
"--"
|
||
[ "Refresh traces and progress" slime-trace-dialog-fetch-status ,dialog-live]
|
||
[ "Fetch next batch" slime-trace-dialog-fetch-traces ,dialog-live]
|
||
[ "Clear all fetched traces" slime-trace-dialog-clear-fetched-traces ,dialog-live]
|
||
[ "Toggle details" slime-trace-dialog-hide-details-mode ,in-dialog]
|
||
[ "Toggle autofollow" slime-trace-dialog-autofollow-mode ,in-dialog])))
|
||
|
||
(define-minor-mode slime-trace-dialog-hide-details-mode
|
||
"Hide details in `slime-trace-dialog-mode'"
|
||
nil " Brief"
|
||
:group 'slime-trace-dialog
|
||
(unless (derived-mode-p 'slime-trace-dialog-mode)
|
||
(error "Not a SLIME Trace Dialog buffer"))
|
||
(slime-trace-dialog--set-hide-details-mode))
|
||
|
||
(define-minor-mode slime-trace-dialog-autofollow-mode
|
||
"Automatically open buffers with trace details from `slime-trace-dialog-mode'"
|
||
nil " Autofollow"
|
||
:group 'slime-trace-dialog
|
||
(unless (derived-mode-p 'slime-trace-dialog-mode)
|
||
(error "Not a SLIME Trace Dialog buffer")))
|
||
|
||
|
||
;;;; Helper functions
|
||
;;;
|
||
(defun slime-trace-dialog--call-refreshing (buffer
|
||
overlay
|
||
dont-erase
|
||
recover-point-p
|
||
fn)
|
||
(with-current-buffer buffer
|
||
(let ((inhibit-point-motion-hooks t)
|
||
(inhibit-read-only t)
|
||
(saved (point)))
|
||
(save-restriction
|
||
(when overlay
|
||
(narrow-to-region (overlay-start overlay)
|
||
(overlay-end overlay)))
|
||
(unwind-protect
|
||
(if dont-erase
|
||
(goto-char (point-max))
|
||
(delete-region (point-min) (point-max)))
|
||
(funcall fn)
|
||
(when recover-point-p
|
||
(goto-char saved)))
|
||
(when slime-trace-dialog-flash
|
||
(slime-flash-region (point-min) (point-max)))))
|
||
buffer))
|
||
|
||
(cl-defmacro slime-trace-dialog--refresh ((&key
|
||
overlay
|
||
dont-erase
|
||
recover-point-p
|
||
buffer)
|
||
&rest body)
|
||
(declare (indent 1)
|
||
(debug (sexp &rest form)))
|
||
`(slime-trace-dialog--call-refreshing ,(or buffer
|
||
`(current-buffer))
|
||
,overlay
|
||
,dont-erase
|
||
,recover-point-p
|
||
#'(lambda () ,@body)))
|
||
|
||
(defmacro slime-trace-dialog--insert-and-overlay (string overlay)
|
||
`(save-restriction
|
||
(let ((inhibit-read-only t))
|
||
(narrow-to-region (point) (point))
|
||
(insert ,string "\n")
|
||
(set (make-local-variable ',overlay)
|
||
(let ((overlay (make-overlay (point-min)
|
||
(point-max)
|
||
(current-buffer)
|
||
nil
|
||
t)))
|
||
(move-overlay overlay (overlay-start overlay)
|
||
(1- (overlay-end overlay)))
|
||
;; (overlay-put overlay 'face '(:background "darkslategrey"))
|
||
overlay)))))
|
||
|
||
(defun slime-trace-dialog--buffer-name ()
|
||
(format "*traces for %s*"
|
||
(slime-connection-name slime-default-connection)))
|
||
|
||
(defun slime-trace-dialog--live-dialog (&optional buffer-or-name)
|
||
(let ((buffer-or-name (or buffer-or-name
|
||
(slime-trace-dialog--buffer-name))))
|
||
(and (buffer-live-p (get-buffer buffer-or-name))
|
||
(with-current-buffer buffer-or-name
|
||
(memq slime-buffer-connection slime-net-processes))
|
||
buffer-or-name)))
|
||
|
||
(defun slime-trace-dialog--ensure-buffer ()
|
||
(let ((name (slime-trace-dialog--buffer-name)))
|
||
(or (slime-trace-dialog--live-dialog name)
|
||
(with-current-buffer (get-buffer-create name)
|
||
(let ((inhibit-read-only t))
|
||
(erase-buffer))
|
||
(slime-trace-dialog-mode)
|
||
(save-excursion
|
||
(buffer-disable-undo)
|
||
(slime-trace-dialog--insert-and-overlay
|
||
"[waiting for the traced specs to be available]"
|
||
slime-trace-dialog--specs-overlay)
|
||
(slime-trace-dialog--insert-and-overlay
|
||
"[waiting for some info on trace download progress ]"
|
||
slime-trace-dialog--progress-overlay)
|
||
(slime-trace-dialog--insert-and-overlay
|
||
"[waiting for the actual traces to be available]"
|
||
slime-trace-dialog--tree-overlay)
|
||
(current-buffer))
|
||
(setq slime-buffer-connection slime-default-connection)
|
||
(current-buffer)))))
|
||
|
||
(defun slime-trace-dialog--make-autofollow-fn (id)
|
||
(let ((requested nil))
|
||
#'(lambda (_before after)
|
||
(let ((inhibit-point-motion-hooks t)
|
||
(id-after (get-text-property after 'slime-trace-dialog--id)))
|
||
(when (and (= after (point))
|
||
slime-trace-dialog-autofollow-mode
|
||
id-after
|
||
(= id-after id)
|
||
(not requested))
|
||
(setq requested t)
|
||
(slime-eval-async `(swank-trace-dialog:report-trace-detail
|
||
,id-after)
|
||
#'(lambda (detail)
|
||
(setq requested nil)
|
||
(when detail
|
||
(let ((inhibit-point-motion-hooks t))
|
||
(slime-trace-dialog--open-detail detail
|
||
'no-pop))))))))))
|
||
|
||
(defun slime-trace-dialog--set-collapsed (collapsed-p trace button)
|
||
(save-excursion
|
||
(setf (slime-trace-dialog--trace-collapsed-p trace) collapsed-p)
|
||
(slime-trace-dialog--go-replace-char-at
|
||
button
|
||
(if collapsed-p
|
||
(cdr slime-trace-dialog--collapse-chars)
|
||
(car slime-trace-dialog--collapse-chars)))
|
||
(slime-trace-dialog--hide-unhide
|
||
(slime-trace-dialog--trace-summary-beg trace)
|
||
(slime-trace-dialog--trace-end trace)
|
||
(if collapsed-p 1 -1))
|
||
(slime-trace-dialog--hide-unhide
|
||
(slime-trace-dialog--trace-end trace)
|
||
(slime-trace-dialog--trace-children-end trace)
|
||
(if collapsed-p 1 -1))))
|
||
|
||
(defun slime-trace-dialog--hide-unhide (start-pos end-pos delta)
|
||
(cl-loop with inhibit-read-only = t
|
||
for pos = start-pos then next
|
||
for next = (next-single-property-change
|
||
pos
|
||
'slime-trace-dialog--hidden-level
|
||
nil
|
||
end-pos)
|
||
for hidden-level = (+ (or (get-text-property
|
||
pos
|
||
'slime-trace-dialog--hidden-level)
|
||
0)
|
||
delta)
|
||
do (add-text-properties pos next
|
||
(list 'slime-trace-dialog--hidden-level
|
||
hidden-level
|
||
'invisible
|
||
(cl-plusp hidden-level)))
|
||
while (< next end-pos)))
|
||
|
||
(defun slime-trace-dialog--set-hide-details-mode ()
|
||
(cl-loop for trace being the hash-values of slime-trace-dialog--traces
|
||
do (slime-trace-dialog--hide-unhide
|
||
(slime-trace-dialog--trace-summary-beg trace)
|
||
(slime-trace-dialog--trace-end trace)
|
||
(if slime-trace-dialog-hide-details-mode 1 -1))))
|
||
|
||
(defun slime-trace-dialog--format-part (part-id part-text trace-id type)
|
||
(slime-trace-dialog--button
|
||
(format "%s" part-text)
|
||
#'(lambda (_button)
|
||
(slime-eval-async
|
||
`(swank-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type)
|
||
#'slime-open-inspector))
|
||
'mouse-face 'highlight
|
||
'slime-trace-dialog--part-id part-id
|
||
'slime-trace-dialog--type type
|
||
'face 'slime-inspector-value-face))
|
||
|
||
(defun slime-trace-dialog--format-trace-entry (id external)
|
||
(slime-trace-dialog--button
|
||
(format "%s" external)
|
||
#'(lambda (_button)
|
||
(slime-eval-async
|
||
`(swank::inspect-object (swank-trace-dialog::find-trace ,id))
|
||
#'slime-open-inspector))
|
||
'face 'slime-inspector-value-face))
|
||
|
||
(defun slime-trace-dialog--format (fmt-string &rest args)
|
||
(let* ((string (apply #'format fmt-string args))
|
||
(indent (make-string (max 2
|
||
(- 50 (length string))) ? )))
|
||
(format "%s%s" string indent)))
|
||
|
||
(defun slime-trace-dialog--button (title lambda &rest props)
|
||
(let ((string (format "%s" title)))
|
||
(apply #'make-text-button string nil
|
||
'action #'(lambda (button)
|
||
(funcall lambda button))
|
||
'mouse-face 'highlight
|
||
'face 'slime-inspector-action-face
|
||
props)
|
||
string))
|
||
|
||
(defun slime-trace-dialog--call-maintaining-properties (pos fn)
|
||
(save-excursion
|
||
(goto-char pos)
|
||
(let* ((saved-props (text-properties-at pos))
|
||
(saved-point (point))
|
||
(inhibit-read-only t)
|
||
(inhibit-point-motion-hooks t))
|
||
(funcall fn)
|
||
(add-text-properties saved-point (point) saved-props)
|
||
(if (markerp pos) (set-marker pos saved-point)))))
|
||
|
||
(cl-defmacro slime-trace-dialog--maintaining-properties (pos
|
||
&body body)
|
||
(declare (indent 1))
|
||
`(slime-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body)))
|
||
|
||
(defun slime-trace-dialog--go-replace-char-at (pos char)
|
||
(slime-trace-dialog--maintaining-properties pos
|
||
(delete-char 1)
|
||
(insert char)))
|
||
|
||
|
||
;;;; Handlers for the *trace-dialog* and *trace-detail* buffers
|
||
;;;
|
||
(defun slime-trace-dialog--open-specs (traced-specs)
|
||
(cl-labels ((make-report-spec-fn
|
||
(&optional form)
|
||
#'(lambda (_button)
|
||
(slime-eval-async
|
||
`(cl:progn
|
||
,form
|
||
(swank-trace-dialog:report-specs))
|
||
#'(lambda (results)
|
||
(slime-trace-dialog--open-specs results))))))
|
||
(slime-trace-dialog--refresh
|
||
(:overlay slime-trace-dialog--specs-overlay
|
||
:recover-point-p t)
|
||
(insert
|
||
(slime-trace-dialog--format "Traced specs (%s)" (length traced-specs))
|
||
(slime-trace-dialog--button "[refresh]"
|
||
(make-report-spec-fn))
|
||
"\n" (make-string 50 ? )
|
||
(slime-trace-dialog--button
|
||
"[untrace all]"
|
||
(make-report-spec-fn `(swank-trace-dialog:dialog-untrace-all)))
|
||
"\n\n")
|
||
(cl-loop for spec in traced-specs
|
||
do (insert
|
||
" "
|
||
(slime-trace-dialog--button
|
||
"[untrace]"
|
||
(make-report-spec-fn
|
||
`(swank-trace-dialog:dialog-untrace ',spec)))
|
||
(format " %s" spec)
|
||
"\n")))))
|
||
|
||
(defvar slime-trace-dialog--fetch-key nil)
|
||
|
||
(defvar slime-trace-dialog--stop-fetching nil)
|
||
|
||
(defun slime-trace-dialog--update-progress (total &optional show-stop-p remaining-p)
|
||
;; `remaining-p' indicates `total' is the number of remaining traces.
|
||
(slime-trace-dialog--refresh
|
||
(:overlay slime-trace-dialog--progress-overlay
|
||
:recover-point-p t)
|
||
(let* ((done (hash-table-count slime-trace-dialog--traces))
|
||
(total (if remaining-p (+ done total) total)))
|
||
(insert
|
||
(slime-trace-dialog--format "Trace collection status (%d/%s)"
|
||
done
|
||
(or total "0"))
|
||
(slime-trace-dialog--button "[refresh]"
|
||
#'(lambda (_button)
|
||
(slime-trace-dialog-fetch-progress))))
|
||
|
||
(when (and total (cl-plusp (- total done)))
|
||
(insert "\n" (make-string 50 ? )
|
||
(slime-trace-dialog--button
|
||
"[fetch next batch]"
|
||
#'(lambda (_button)
|
||
(slime-trace-dialog-fetch-traces nil)))
|
||
"\n" (make-string 50 ? )
|
||
(slime-trace-dialog--button
|
||
"[fetch all]"
|
||
#'(lambda (_button)
|
||
(slime-trace-dialog-fetch-traces t)))))
|
||
(when total
|
||
(insert "\n" (make-string 50 ? )
|
||
(slime-trace-dialog--button
|
||
"[clear]"
|
||
#'(lambda (_button)
|
||
(slime-trace-dialog-clear-fetched-traces)))))
|
||
(when show-stop-p
|
||
(insert "\n" (make-string 50 ? )
|
||
(slime-trace-dialog--button
|
||
"[stop]"
|
||
#'(lambda (_button)
|
||
(setq slime-trace-dialog--stop-fetching t)))))
|
||
(insert "\n\n"))))
|
||
|
||
(defun slime-trace-dialog--open-detail (trace-tuple &optional no-pop)
|
||
(slime-with-popup-buffer ("*trace-detail*" :select (not no-pop)
|
||
:mode 'slime-trace-dialog--detail-mode)
|
||
(cl-destructuring-bind (id _parent-id _spec args retlist backtrace external)
|
||
trace-tuple
|
||
(let ((headline (slime-trace-dialog--format-trace-entry id external)))
|
||
(setq headline (format "%s\n%s\n"
|
||
headline
|
||
(make-string (length headline) ?-)))
|
||
(insert headline))
|
||
(cl-loop for (type objects label)
|
||
in `((:arg ,args "Called with args:")
|
||
(:retval ,retlist "Returned values:"))
|
||
do (insert (format "\n%s\n" label))
|
||
(insert (cl-loop for object in objects
|
||
for i from 0
|
||
concat (format " %s: %s\n" i
|
||
(slime-trace-dialog--format-part
|
||
(cl-first object)
|
||
(cl-second object)
|
||
id
|
||
type)))))
|
||
(when backtrace
|
||
(insert "\nBacktrace:\n"
|
||
(cl-loop for (i spec) in backtrace
|
||
concat (format " %s: %s\n" i spec)))))))
|
||
|
||
|
||
;;;; Rendering traces
|
||
;;;
|
||
(defun slime-trace-dialog--draw-tree-lines (start offset direction)
|
||
(save-excursion
|
||
(let ((inhibit-point-motion-hooks t))
|
||
(goto-char start)
|
||
(cl-loop with replace-set = (if (eq direction 'down)
|
||
'(? )
|
||
'(? ?`))
|
||
for line-beginning = (line-beginning-position
|
||
(if (eq direction 'down)
|
||
2 0))
|
||
for pos = (+ line-beginning offset)
|
||
while (and (< (point-min) line-beginning)
|
||
(< line-beginning (point-max))
|
||
(memq (char-after pos) replace-set))
|
||
do
|
||
(slime-trace-dialog--go-replace-char-at pos "|")
|
||
(goto-char pos)))))
|
||
|
||
(defun slime-trace-dialog--make-indent (depth suffix)
|
||
(concat (make-string (* 3 (max 0 (1- depth))) ? )
|
||
(if (cl-plusp depth) suffix)))
|
||
|
||
(defun slime-trace-dialog--make-collapse-button (trace)
|
||
(slime-trace-dialog--button (if (slime-trace-dialog--trace-collapsed-p trace)
|
||
(cdr slime-trace-dialog--collapse-chars)
|
||
(car slime-trace-dialog--collapse-chars))
|
||
#'(lambda (button)
|
||
(slime-trace-dialog--set-collapsed
|
||
(not (slime-trace-dialog--trace-collapsed-p
|
||
trace))
|
||
trace
|
||
button))))
|
||
|
||
|
||
(defun slime-trace-dialog--insert-trace (trace)
|
||
(let* ((id (slime-trace-dialog--trace-id trace))
|
||
(parent (slime-trace-dialog--trace-parent trace))
|
||
(has-children-p (slime-trace-dialog--trace-children-end trace))
|
||
(indent-spec (slime-trace-dialog--make-indent
|
||
(slime-trace-dialog--trace-depth trace)
|
||
"`--"))
|
||
(indent-summary (slime-trace-dialog--make-indent
|
||
(slime-trace-dialog--trace-depth trace)
|
||
" "))
|
||
(autofollow-fn (slime-trace-dialog--make-autofollow-fn id))
|
||
(id-string (slime-trace-dialog--button
|
||
(format "%4s" id)
|
||
#'(lambda (_button)
|
||
(slime-eval-async
|
||
`(swank-trace-dialog:report-trace-detail
|
||
,id)
|
||
#'slime-trace-dialog--open-detail))))
|
||
(spec (slime-trace-dialog--trace-spec trace))
|
||
(summary (cl-loop for (type objects marker) in
|
||
`((:arg ,(slime-trace-dialog--trace-args trace)
|
||
" > ")
|
||
(:retval ,(slime-trace-dialog--trace-retlist trace)
|
||
" < "))
|
||
concat (cl-loop for object in objects
|
||
concat " "
|
||
concat indent-summary
|
||
concat marker
|
||
concat (slime-trace-dialog--format-part
|
||
(cl-first object)
|
||
(cl-second object)
|
||
id
|
||
type)
|
||
concat "\n"))))
|
||
(puthash id trace slime-trace-dialog--traces)
|
||
;; insert and propertize the text
|
||
;;
|
||
(setf (slime-trace-dialog--trace-beg trace) (point-marker))
|
||
(insert id-string " ")
|
||
(insert indent-spec)
|
||
(if has-children-p
|
||
(insert (slime-trace-dialog--make-collapse-button trace))
|
||
(setf (slime-trace-dialog--trace-collapse-button-marker trace)
|
||
(point-marker))
|
||
(insert "-"))
|
||
(insert (format " %s\n" spec))
|
||
(setf (slime-trace-dialog--trace-summary-beg trace) (point-marker))
|
||
(insert summary)
|
||
(setf (slime-trace-dialog--trace-end trace) (point-marker))
|
||
(set-marker-insertion-type (slime-trace-dialog--trace-beg trace) t)
|
||
|
||
(add-text-properties (slime-trace-dialog--trace-beg trace)
|
||
(slime-trace-dialog--trace-end trace)
|
||
(list 'slime-trace-dialog--id id
|
||
'point-entered autofollow-fn
|
||
'point-left autofollow-fn))
|
||
;; respect brief mode and collapsed state
|
||
;;
|
||
(cl-loop for condition in (list slime-trace-dialog-hide-details-mode
|
||
(slime-trace-dialog--trace-collapsed-p trace))
|
||
when condition
|
||
do (slime-trace-dialog--hide-unhide
|
||
(slime-trace-dialog--trace-summary-beg
|
||
trace)
|
||
(slime-trace-dialog--trace-end trace)
|
||
1))
|
||
(cl-loop for tr = trace then parent
|
||
for parent = (slime-trace-dialog--trace-parent tr)
|
||
while parent
|
||
when (slime-trace-dialog--trace-collapsed-p parent)
|
||
do (slime-trace-dialog--hide-unhide
|
||
(slime-trace-dialog--trace-beg trace)
|
||
(slime-trace-dialog--trace-end trace)
|
||
(+ 1
|
||
(or (get-text-property (slime-trace-dialog--trace-beg parent)
|
||
'slime-trace-dialog--hidden-level)
|
||
0)))
|
||
(cl-return))
|
||
;; maybe add the collapse-button to the parent in case it didn't
|
||
;; have one already
|
||
;;
|
||
(when (and parent
|
||
(slime-trace-dialog--trace-collapse-button-marker parent))
|
||
(slime-trace-dialog--maintaining-properties
|
||
(slime-trace-dialog--trace-collapse-button-marker parent)
|
||
(delete-char 1)
|
||
(insert (slime-trace-dialog--make-collapse-button parent))
|
||
(setf (slime-trace-dialog--trace-collapse-button-marker parent)
|
||
nil)))
|
||
;; draw the tree lines
|
||
;;
|
||
(when parent
|
||
(slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace)
|
||
(+ 2 (length indent-spec))
|
||
'up))
|
||
(when has-children-p
|
||
(slime-trace-dialog--draw-tree-lines (slime-trace-dialog--trace-beg trace)
|
||
(+ 5 (length indent-spec))
|
||
'down))
|
||
;; set the "children-end" slot
|
||
;;
|
||
(unless (slime-trace-dialog--trace-children-end trace)
|
||
(cl-loop for parent = trace
|
||
then (slime-trace-dialog--trace-parent parent)
|
||
while parent
|
||
do
|
||
(setf (slime-trace-dialog--trace-children-end parent)
|
||
(slime-trace-dialog--trace-end trace))))))
|
||
|
||
(defun slime-trace-dialog--render-trace (trace)
|
||
;; Render the trace entry in the appropriate place.
|
||
;;
|
||
;; A trace becomes a few lines of slightly propertized text in the
|
||
;; buffer, inserted by `slime-trace-dialog--insert-trace', bound by
|
||
;; point markers that we use here.
|
||
;;
|
||
;; The new trace might be replacing an existing one, or otherwise
|
||
;; must be placed under its existing parent which might or might not
|
||
;; be the last entry inserted.
|
||
;;
|
||
(let ((existing (slime-trace-dialog--find-trace
|
||
(slime-trace-dialog--trace-id trace)))
|
||
(parent (slime-trace-dialog--trace-parent trace)))
|
||
(cond (existing
|
||
;; Other traces might already reference `existing' and with
|
||
;; need to maintain that eqness. Best way to do that is
|
||
;; destructively modify `existing' with the new retlist...
|
||
;;
|
||
(setf (slime-trace-dialog--trace-retlist existing)
|
||
(slime-trace-dialog--trace-retlist trace))
|
||
;; Now, before deleting and re-inserting `existing' at an
|
||
;; arbitrary point in the tree, note that it's
|
||
;; "children-end" marker is already non-nil, and informs us
|
||
;; about its parenthood status. We want to 1. leave it
|
||
;; alone if it's already a parent, or 2. set it to nil if
|
||
;; it's a leaf, thus forcing the needed update of the
|
||
;; parents' "children-end" marker.
|
||
;;
|
||
(when (= (slime-trace-dialog--trace-children-end existing)
|
||
(slime-trace-dialog--trace-end existing))
|
||
(setf (slime-trace-dialog--trace-children-end existing) nil))
|
||
(delete-region (slime-trace-dialog--trace-beg existing)
|
||
(slime-trace-dialog--trace-end existing))
|
||
(goto-char (slime-trace-dialog--trace-end existing))
|
||
;; Remember to set `trace' to be `existing'
|
||
;;
|
||
(setq trace existing))
|
||
(parent
|
||
(goto-char (1+ (slime-trace-dialog--trace-children-end parent))))
|
||
(;; top level trace
|
||
t
|
||
(goto-char (point-max))))
|
||
(goto-char (line-beginning-position))
|
||
(slime-trace-dialog--insert-trace trace)))
|
||
|
||
(defun slime-trace-dialog--update-tree (tuples)
|
||
(save-excursion
|
||
(slime-trace-dialog--refresh
|
||
(:overlay slime-trace-dialog--tree-overlay
|
||
:dont-erase t)
|
||
(cl-loop for tuple in tuples
|
||
for parent = (slime-trace-dialog--find-trace (cl-second tuple))
|
||
for trace = (slime-trace-dialog--make-trace
|
||
:id (cl-first tuple)
|
||
:parent parent
|
||
:spec (cl-third tuple)
|
||
:args (cl-fourth tuple)
|
||
:retlist (cl-fifth tuple)
|
||
:depth (if parent
|
||
(1+ (slime-trace-dialog--trace-depth
|
||
parent))
|
||
0))
|
||
do (slime-trace-dialog--render-trace trace)))))
|
||
|
||
(defun slime-trace-dialog--clear-local-tree ()
|
||
(set (make-local-variable 'slime-trace-dialog--fetch-key)
|
||
(cl-gensym "slime-trace-dialog-fetch-key-"))
|
||
(set (make-local-variable 'slime-trace-dialog--traces)
|
||
(make-hash-table))
|
||
(slime-trace-dialog--refresh
|
||
(:overlay slime-trace-dialog--tree-overlay))
|
||
(slime-trace-dialog--update-progress nil))
|
||
|
||
(defun slime-trace-dialog--on-new-results (results &optional recurse)
|
||
(cl-destructuring-bind (tuples remaining reply-key)
|
||
results
|
||
(cond ((and slime-trace-dialog--fetch-key
|
||
(string= (symbol-name slime-trace-dialog--fetch-key)
|
||
(symbol-name reply-key)))
|
||
(slime-trace-dialog--update-tree tuples)
|
||
(slime-trace-dialog--update-progress
|
||
remaining
|
||
(and recurse
|
||
(cl-plusp remaining))
|
||
t)
|
||
(when (and recurse
|
||
(not (prog1 slime-trace-dialog--stop-fetching
|
||
(setq slime-trace-dialog--stop-fetching nil)))
|
||
(cl-plusp remaining))
|
||
(slime-eval-async `(swank-trace-dialog:report-partial-tree
|
||
',reply-key)
|
||
#'(lambda (results) (slime-trace-dialog--on-new-results
|
||
results
|
||
recurse))))))))
|
||
|
||
|
||
;;;; Interactive functions
|
||
;;;
|
||
(defun slime-trace-dialog-fetch-specs ()
|
||
"Refresh just list of traced specs."
|
||
(interactive)
|
||
(slime-eval-async `(swank-trace-dialog:report-specs)
|
||
#'slime-trace-dialog--open-specs))
|
||
|
||
(defun slime-trace-dialog-fetch-progress ()
|
||
(interactive)
|
||
(slime-eval-async
|
||
'(swank-trace-dialog:report-total)
|
||
#'(lambda (total)
|
||
(slime-trace-dialog--update-progress
|
||
total))))
|
||
|
||
(defun slime-trace-dialog-fetch-status ()
|
||
"Refresh just the status part of the SLIME Trace Dialog"
|
||
(interactive)
|
||
(slime-trace-dialog-fetch-specs)
|
||
(slime-trace-dialog-fetch-progress))
|
||
|
||
(defun slime-trace-dialog-clear-fetched-traces (&optional interactive)
|
||
"Clear local and remote traces collected so far"
|
||
(interactive "p")
|
||
(when (or (not interactive)
|
||
(y-or-n-p "Clear all collected and fetched traces?"))
|
||
(slime-eval-async
|
||
'(swank-trace-dialog:clear-trace-tree)
|
||
#'(lambda (_ignored)
|
||
(slime-trace-dialog--clear-local-tree)))))
|
||
|
||
(defun slime-trace-dialog-fetch-traces (&optional recurse)
|
||
(interactive "P")
|
||
(setq slime-trace-dialog--stop-fetching nil)
|
||
(slime-eval-async `(swank-trace-dialog:report-partial-tree
|
||
',slime-trace-dialog--fetch-key)
|
||
#'(lambda (results) (slime-trace-dialog--on-new-results results
|
||
recurse))))
|
||
|
||
(defun slime-trace-dialog-next-button (&optional goback)
|
||
(interactive)
|
||
(let ((finder (if goback
|
||
#'previous-single-property-change
|
||
#'next-single-property-change)))
|
||
(cl-loop for pos = (funcall finder (point) 'action)
|
||
while pos
|
||
do (goto-char pos)
|
||
until (get-text-property pos 'action))))
|
||
|
||
(defun slime-trace-dialog-prev-button ()
|
||
(interactive)
|
||
(slime-trace-dialog-next-button 'goback))
|
||
|
||
(defvar slime-trace-dialog-after-toggle-hook nil
|
||
"Hooks run after toggling a dialog-trace")
|
||
|
||
(defun slime-trace-dialog-toggle-trace (&optional using-context-p)
|
||
"Toggle the dialog-trace of the spec at point.
|
||
|
||
When USING-CONTEXT-P, attempt to decipher lambdas. methods and
|
||
other complicated function specs."
|
||
(interactive "P")
|
||
;; Notice the use of "spec strings" here as opposed to the
|
||
;; proper cons specs we use on the swank side.
|
||
;;
|
||
;; Notice the conditional use of `slime-trace-query' found in
|
||
;; swank-fancy-trace.el
|
||
;;
|
||
(let* ((spec-string (if using-context-p
|
||
(slime-extract-context)
|
||
(slime-symbol-at-point)))
|
||
(spec-string (if (fboundp 'slime-trace-query)
|
||
(slime-trace-query spec-string)
|
||
spec-string)))
|
||
(message "%s" (slime-eval `(swank-trace-dialog:dialog-toggle-trace
|
||
(swank::from-string ,spec-string))))
|
||
(run-hooks 'slime-trace-dialog-after-toggle-hook)))
|
||
|
||
(defun slime-trace-dialog--update-existing-dialog ()
|
||
(let ((existing (slime-trace-dialog--live-dialog)))
|
||
(when existing
|
||
(with-current-buffer existing
|
||
(slime-trace-dialog-fetch-status)))))
|
||
|
||
(add-hook 'slime-trace-dialog-after-toggle-hook
|
||
'slime-trace-dialog--update-existing-dialog)
|
||
|
||
(defun slime-trace-dialog-toggle-complex-trace ()
|
||
"Toggle the dialog-trace of the complex spec at point.
|
||
|
||
See `slime-trace-dialog-toggle-trace'."
|
||
(interactive)
|
||
(slime-trace-dialog-toggle-trace t))
|
||
|
||
(defun slime-trace-dialog (&optional clear-and-fetch)
|
||
"Show trace dialog and refresh trace collection status.
|
||
|
||
With optional CLEAR-AND-FETCH prefix arg, clear the current tree
|
||
and fetch a first batch of traces."
|
||
(interactive "P")
|
||
(with-current-buffer
|
||
(pop-to-buffer (slime-trace-dialog--ensure-buffer))
|
||
(slime-trace-dialog-fetch-status)
|
||
(when (or clear-and-fetch
|
||
(null slime-trace-dialog--fetch-key))
|
||
(slime-trace-dialog--clear-local-tree))
|
||
(when clear-and-fetch
|
||
(slime-trace-dialog-fetch-traces nil))))
|
||
|
||
(defun slime-trace-dialog-copy-down-to-repl (id part-id type)
|
||
"Eval the Trace Dialog entry under point in the REPL (to set *)"
|
||
(interactive (cl-loop for prop in '(slime-trace-dialog--id
|
||
slime-trace-dialog--part-id
|
||
slime-trace-dialog--type)
|
||
collect (get-text-property (point) prop)))
|
||
(unless (and id part-id type) (error "No trace part at point %s" (point)))
|
||
(slime-repl-send-string
|
||
(format "%s" `(nth-value 0
|
||
(swank-trace-dialog::find-trace-part
|
||
,id ,part-id ,type))))
|
||
(slime-repl))
|
||
|
||
(provide 'slime-trace-dialog)
|