You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
837 lines
34 KiB
837 lines
34 KiB
;;; -*- 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)
|