sly-trace-dialog.el (30123B)
1 ;;; -*- coding: utf-8; lexical-binding: t -*- 2 ;;; 3 ;;; sly-trace-dialog.el -- a navigable dialog of inspectable trace entries 4 ;;; 5 ;;; TODO: implement better wrap interface for sbcl method, labels and such 6 ;;; TODO: backtrace printing is very slow 7 ;;; 8 (require 'sly) 9 (require 'sly-parse "lib/sly-parse") 10 (require 'cl-lib) 11 12 (define-sly-contrib sly-trace-dialog 13 "Provide an interactive trace dialog buffer for managing and 14 inspecting details of traced functions. Invoke this dialog with C-c T." 15 (:authors "João Távora <joaotavora@gmail.com>") 16 (:license "GPL") 17 (:slynk-dependencies slynk/trace-dialog) 18 (:on-load (add-hook 'sly-mode-hook 'sly-trace-dialog-shortcut-mode) 19 (define-key sly-selector-map (kbd "T") 'sly-trace-dialog)) 20 (:on-unload (remove-hook 'sly-mode-hook 'sly-trace-dialogn-shortcut-mode))) 21 22 23 ;;;; Variables 24 ;;; 25 (defvar sly-trace-dialog-flash t 26 "Non-nil means flash the updated region of the SLY Trace Dialog. ") 27 28 (defvar sly-trace-dialog--specs-overlay nil) 29 30 (defvar sly-trace-dialog--progress-overlay nil) 31 32 (defvar sly-trace-dialog--tree-overlay nil) 33 34 (defvar sly-trace-dialog--collapse-chars (cons "-" "+")) 35 36 37 ;;;; Local trace entry model 38 (defvar sly-trace-dialog--traces nil) 39 40 (cl-defstruct (sly-trace-dialog--trace 41 (:constructor sly-trace-dialog--make-trace)) 42 id 43 parent 44 spec 45 args 46 retlist 47 depth 48 beg 49 end 50 collapse-button-marker 51 summary-beg 52 children-end 53 collapsed-p) 54 55 (defun sly-trace-dialog--find-trace (id) 56 (gethash id sly-trace-dialog--traces)) 57 58 59 ;;;; Modes and mode maps 60 ;;; 61 (defvar sly-trace-dialog-mode-map 62 (let ((map (make-sparse-keymap))) 63 (define-key map (kbd "G") 'sly-trace-dialog-fetch-traces) 64 (define-key map (kbd "C-k") 'sly-trace-dialog-clear-fetched-traces) 65 (define-key map (kbd "g") 'sly-trace-dialog-fetch-status) 66 67 (define-key map (kbd "q") 'quit-window) 68 69 (set-keymap-parent map button-buffer-map) 70 map)) 71 72 (define-derived-mode sly-trace-dialog-mode fundamental-mode 73 "SLY Trace Dialog" "Mode for controlling SLY's Trace Dialog" 74 (set-syntax-table lisp-mode-syntax-table) 75 (read-only-mode 1) 76 (sly-mode 1) 77 (add-to-list (make-local-variable 'sly-trace-dialog-after-toggle-hook) 78 'sly-trace-dialog-fetch-status)) 79 80 (defvar sly-trace-dialog-shortcut-mode-map 81 (let ((map (make-sparse-keymap))) 82 (define-key map (kbd "C-c T") 'sly-trace-dialog) 83 (define-key map (kbd "C-c C-t") 'sly-trace-dialog-toggle-trace) 84 (define-key map (kbd "C-c M-t") 85 (if (featurep 'sly-fancy-trace) 86 'sly-toggle-fancy-trace 87 'sly-toggle-trace-fdefinition)) 88 map)) 89 90 (define-minor-mode sly-trace-dialog-shortcut-mode 91 "Add keybindings for accessing SLY's Trace Dialog.") 92 93 (easy-menu-define sly-trace-dialog--shortcut-menu nil 94 "Menu setting traces from anywhere in SLY." 95 (let* ((in-dialog '(eq major-mode 'sly-trace-dialog-mode)) 96 (_dialog-live `(and ,in-dialog 97 (memq sly-buffer-connection sly-net-processes))) 98 (connected '(sly-connected-p))) 99 `("Trace" 100 ["Toggle trace.." sly-trace-dialog-toggle-trace ,connected] 101 ["Untrace all" sly-trace-dialog-untrace-all ,connected] 102 ["Trace complex spec" sly-trace-dialog-toggle-complex-trace ,connected] 103 ["Open Trace dialog" sly-trace-dialog (and ,connected (not ,in-dialog))] 104 "--" 105 [ "Regular lisp trace..." sly-toggle-fancy-trace ,connected]))) 106 107 (easy-menu-add-item sly-menu nil sly-trace-dialog--shortcut-menu "Documentation") 108 109 (easy-menu-define sly-trace-dialog--menu sly-trace-dialog-mode-map 110 "Menu for SLY's Trace Dialog" 111 (let* ((in-dialog '(eq major-mode 'sly-trace-dialog-mode)) 112 (dialog-live `(and ,in-dialog 113 (memq sly-buffer-connection sly-net-processes)))) 114 `("SLY-Trace" 115 [ "Refresh traces and progress" sly-trace-dialog-fetch-status 116 ,dialog-live] 117 [ "Fetch next batch" sly-trace-dialog-fetch-traces ,dialog-live] 118 [ "Clear all fetched traces" sly-trace-dialog-clear-fetched-traces 119 ,dialog-live] 120 [ "Toggle details" sly-trace-dialog-hide-details-mode ,in-dialog] 121 [ "Toggle autofollow" sly-trace-dialog-autofollow-mode ,in-dialog]))) 122 123 (define-minor-mode sly-trace-dialog-hide-details-mode 124 "Hide details in `sly-trace-dialog-mode'" 125 nil " Brief" 126 :group 'sly-trace-dialog 127 (unless (derived-mode-p 'sly-trace-dialog-mode) 128 (error "Not a SLY Trace Dialog buffer")) 129 (sly-trace-dialog--set-hide-details-mode)) 130 131 (define-minor-mode sly-trace-dialog-autofollow-mode 132 "Automatically inspect trace entries from `sly-trace-dialog-mode'" 133 nil " Autofollow" 134 :group 'sly-trace-dialog 135 (unless (derived-mode-p 'sly-trace-dialog-mode) 136 (error "Not a SLY Trace Dialog buffer"))) 137 138 139 ;;;; Helper functions 140 ;;; 141 (defmacro sly-trace-dialog--insert-and-overlay (string overlay) 142 `(save-restriction 143 (let ((inhibit-read-only t)) 144 (narrow-to-region (point) (point)) 145 (insert ,string "\n") 146 (set (make-local-variable ',overlay) 147 (let ((overlay (make-overlay (point-min) 148 (point-max) 149 (current-buffer) 150 nil 151 t))) 152 (move-overlay overlay (overlay-start overlay) 153 (1- (overlay-end overlay))) 154 overlay))))) 155 156 (defun sly-trace-dialog--buffer-name () 157 (sly-buffer-name :traces :connection (sly-current-connection))) 158 159 (defun sly-trace-dialog--live-dialog (&optional buffer-or-name) 160 (let ((buffer-or-name (or buffer-or-name 161 (sly-trace-dialog--buffer-name)))) 162 (and (buffer-live-p (get-buffer buffer-or-name)) 163 (with-current-buffer buffer-or-name 164 (memq sly-buffer-connection sly-net-processes)) 165 buffer-or-name))) 166 167 (defun sly-trace-dialog--ensure-buffer () 168 (let ((name (sly-trace-dialog--buffer-name))) 169 (or (sly-trace-dialog--live-dialog name) 170 (let ((connection (sly-current-connection))) 171 (with-current-buffer (get-buffer-create name) 172 (let ((inhibit-read-only t)) 173 (erase-buffer)) 174 (sly-trace-dialog-mode) 175 (save-excursion 176 (buffer-disable-undo) 177 (sly-trace-dialog--insert-and-overlay 178 "[waiting for the traced specs to be available]" 179 sly-trace-dialog--specs-overlay) 180 (sly-trace-dialog--insert-and-overlay 181 "[waiting for some info on trace download progress ]" 182 sly-trace-dialog--progress-overlay) 183 (sly-trace-dialog--insert-and-overlay 184 "[waiting for the actual traces to be available]" 185 sly-trace-dialog--tree-overlay) 186 (current-buffer)) 187 (setq sly-buffer-connection connection) 188 (current-buffer)))))) 189 190 (defun sly-trace-dialog--set-collapsed (collapsed-p trace button) 191 (save-excursion 192 (setf (sly-trace-dialog--trace-collapsed-p trace) collapsed-p) 193 (sly-trace-dialog--go-replace-char-at 194 button 195 (if collapsed-p 196 (cdr sly-trace-dialog--collapse-chars) 197 (car sly-trace-dialog--collapse-chars))) 198 (sly-trace-dialog--hide-unhide 199 (sly-trace-dialog--trace-summary-beg trace) 200 (sly-trace-dialog--trace-end trace) 201 (if collapsed-p 1 -1)) 202 (sly-trace-dialog--hide-unhide 203 (sly-trace-dialog--trace-end trace) 204 (sly-trace-dialog--trace-children-end trace) 205 (if collapsed-p 1 -1)))) 206 207 (defun sly-trace-dialog--hide-unhide (start-pos end-pos delta) 208 (cl-loop with inhibit-read-only = t 209 for pos = start-pos then next 210 for next = (next-single-property-change 211 pos 212 'sly-trace-dialog--hidden-level 213 nil 214 end-pos) 215 for hidden-level = (+ (or (get-text-property 216 pos 217 'sly-trace-dialog--hidden-level) 218 0) 219 delta) 220 do (add-text-properties pos next 221 (list 'sly-trace-dialog--hidden-level 222 hidden-level 223 'invisible 224 (cl-plusp hidden-level))) 225 while (< next end-pos))) 226 227 (defun sly-trace-dialog--set-hide-details-mode () 228 (cl-loop for trace being the hash-values of sly-trace-dialog--traces 229 do (sly-trace-dialog--hide-unhide 230 (sly-trace-dialog--trace-summary-beg trace) 231 (sly-trace-dialog--trace-end trace) 232 (if sly-trace-dialog-hide-details-mode 1 -1)))) 233 234 (defun sly-trace-dialog--format (fmt-string &rest args) 235 (let* ((string (apply #'format fmt-string args)) 236 (indent (make-string (max 2 237 (- 50 (length string))) ? ))) 238 (format "%s%s" string indent))) 239 240 (defun sly-trace-dialog--call-maintaining-properties (pos fn) 241 (save-excursion 242 (goto-char pos) 243 (let* ((saved-props (text-properties-at pos)) 244 (saved-point (point)) 245 (inhibit-read-only t) 246 (inhibit-point-motion-hooks t)) 247 (funcall fn) 248 (add-text-properties saved-point (point) saved-props) 249 (if (markerp pos) (set-marker pos saved-point))))) 250 251 (cl-defmacro sly-trace-dialog--maintaining-properties (pos 252 &body body) 253 (declare (indent 1)) 254 `(sly-trace-dialog--call-maintaining-properties ,pos #'(lambda () ,@body))) 255 256 (defun sly-trace-dialog--go-replace-char-at (pos char) 257 (sly-trace-dialog--maintaining-properties pos 258 (delete-char 1) 259 (insert char))) 260 261 262 ;;;; Handlers for the *trace-dialog* buffer 263 ;;; 264 (defun sly-trace-dialog--open-specs (traced-specs) 265 (let ((make-report-spec-fn-fn 266 (lambda (&optional form) 267 (lambda (_button) 268 (sly-eval-async 269 `(cl:progn 270 ,form 271 (slynk-trace-dialog:report-specs)) 272 #'(lambda (results) 273 (sly-trace-dialog--open-specs results))))))) 274 (sly-refreshing 275 (:overlay sly-trace-dialog--specs-overlay 276 :recover-point-p t) 277 (insert 278 (sly-trace-dialog--format "Traced specs (%s)" (length traced-specs)) 279 (sly-make-action-button "[refresh]" 280 (funcall make-report-spec-fn-fn)) 281 "\n" (make-string 50 ? ) 282 (sly-make-action-button 283 "[untrace all]" 284 (funcall make-report-spec-fn-fn `(slynk-trace-dialog:dialog-untrace-all))) 285 "\n\n") 286 (cl-loop for (spec-pretty . spec) in traced-specs 287 do (insert 288 " " 289 (sly-make-action-button 290 "[untrace]" 291 (funcall make-report-spec-fn-fn 292 `(slynk-trace-dialog:dialog-untrace ',spec))) 293 (format " %s" spec-pretty) 294 "\n"))))) 295 296 (defvar sly-trace-dialog--fetch-key nil) 297 298 (defvar sly-trace-dialog--stop-fetching nil) 299 300 (defun sly-trace-dialog--update-progress (total &optional show-stop-p remaining-p) 301 ;; `remaining-p' indicates `total' is the number of remaining traces. 302 (sly-refreshing 303 (:overlay sly-trace-dialog--progress-overlay 304 :recover-point-p t) 305 (let* ((done (hash-table-count sly-trace-dialog--traces)) 306 (total (if remaining-p (+ done total) total))) 307 (insert 308 (sly-trace-dialog--format "Trace collection status (%d/%s)" 309 done 310 (or total "0")) 311 (sly-make-action-button "[refresh]" 312 #'(lambda (_button) 313 (sly-trace-dialog-fetch-progress)))) 314 315 (when (and total (cl-plusp (- total done))) 316 (insert "\n" (make-string 50 ? ) 317 (sly-make-action-button 318 "[fetch next batch]" 319 #'(lambda (_button) 320 (sly-trace-dialog-fetch-traces nil))) 321 "\n" (make-string 50 ? ) 322 (sly-make-action-button 323 "[fetch all]" 324 #'(lambda (_button) 325 (sly-trace-dialog-fetch-traces t))))) 326 (when total 327 (insert "\n" (make-string 50 ? ) 328 (sly-make-action-button 329 "[clear]" 330 #'(lambda (_button) 331 (sly-trace-dialog-clear-fetched-traces))))) 332 (when show-stop-p 333 (insert "\n" (make-string 50 ? ) 334 (sly-make-action-button 335 "[stop]" 336 #'(lambda (_button) 337 (setq sly-trace-dialog--stop-fetching t))))) 338 (insert "\n\n")))) 339 340 341 ;;;; Rendering traces 342 ;;; 343 344 (define-button-type 'sly-trace-dialog-part :supertype 'sly-part 345 'sly-button-inspect 346 #'(lambda (trace-id part-id type) 347 (sly-eval-for-inspector 348 `(slynk-trace-dialog:inspect-trace-part ,trace-id ,part-id ,type) 349 :inspector-name (sly-maybe-read-inspector-name))) 350 'sly-button-pretty-print 351 #'(lambda (trace-id part-id type) 352 (sly-eval-describe 353 `(slynk-trace-dialog:pprint-trace-part ,trace-id ,part-id ,type))) 354 'sly-button-describe 355 #'(lambda (trace-id part-id type) 356 (sly-eval-describe 357 `(slynk-trace-dialog:describe-trace-part ,trace-id ,part-id ,type)))) 358 359 (defun sly-trace-dialog-part-button (part-id part-text trace-id type) 360 (sly--make-text-button part-text nil 361 :type 'sly-trace-dialog-part 362 'part-args (list trace-id part-id type) 363 'part-label (format "%s %s" 364 (capitalize 365 (substring (symbol-name type) 1)) 366 part-id))) 367 368 (define-button-type 'sly-trace-dialog-spec :supertype 'sly-part 369 'action 'sly-button-show-source 370 'sly-button-inspect 371 #'(lambda (trace-id _spec) 372 (sly-eval-for-inspector `(slynk-trace-dialog:inspect-trace ,trace-id) 373 :inspector-name "trace-entries")) 374 'sly-button-show-source 375 #'(lambda (trace-id _spec) 376 (sly-eval-async 377 `(slynk-trace-dialog:trace-location ,trace-id) 378 #'(lambda (location) 379 (sly--display-source-location location 'noerror)))) 380 'point-entered 381 #'(lambda (before after) 382 (let ((button (sly-button-at after nil 'no-error))) 383 (when (and (not (sly-button-at before nil 'no-error)) 384 button 385 sly-trace-dialog-autofollow-mode) 386 ;; we can't quite `push-button' here, because 387 ;; of the need for `save-selected-window' 388 ;; 389 (let ((id (button-get button 'trace-id))) 390 (sly-eval-for-inspector 391 `(slynk-trace-dialog:inspect-trace ,id) 392 :inspector-name "trace-entries" 393 :save-selected-window t)))))) 394 395 (defun sly-trace-dialog-spec-button (label trace &rest props) 396 (let ((id (sly-trace-dialog--trace-id trace))) 397 (apply #'sly--make-text-button label nil 398 :type 'sly-trace-dialog-spec 399 'trace-id id 400 'part-args (list id 401 (cdr (sly-trace-dialog--trace-spec trace))) 402 'part-label (format "Trace entry: %s" id) 403 props))) 404 405 (defun sly-trace-dialog--draw-tree-lines (start offset direction) 406 (save-excursion 407 (let ((inhibit-point-motion-hooks t)) 408 (goto-char start) 409 (cl-loop with replace-set = (if (eq direction 'down) 410 '(? ) 411 '(? ?`)) 412 for line-beginning = (line-beginning-position 413 (if (eq direction 'down) 414 2 0)) 415 for pos = (+ line-beginning offset) 416 while (and (< (point-min) line-beginning) 417 (< line-beginning (point-max)) 418 (memq (char-after pos) replace-set)) 419 do 420 (sly-trace-dialog--go-replace-char-at pos "|") 421 (goto-char pos))))) 422 423 (defun sly-trace-dialog--make-indent (depth suffix) 424 (concat (make-string (* 3 (max 0 (1- depth))) ? ) 425 (if (cl-plusp depth) suffix))) 426 427 (defun sly-trace-dialog--make-collapse-button (trace) 428 (sly-make-action-button (if (sly-trace-dialog--trace-collapsed-p trace) 429 (cdr sly-trace-dialog--collapse-chars) 430 (car sly-trace-dialog--collapse-chars)) 431 #'(lambda (button) 432 (sly-trace-dialog--set-collapsed 433 (not (sly-trace-dialog--trace-collapsed-p 434 trace)) 435 trace 436 button)))) 437 438 (defun sly-trace-dialog--insert-trace (trace) 439 (let* ((id (sly-trace-dialog--trace-id trace)) 440 (parent (sly-trace-dialog--trace-parent trace)) 441 (has-children-p (sly-trace-dialog--trace-children-end trace)) 442 (indent-spec (sly-trace-dialog--make-indent 443 (sly-trace-dialog--trace-depth trace) 444 "`--")) 445 (indent-summary (sly-trace-dialog--make-indent 446 (sly-trace-dialog--trace-depth trace) 447 " ")) 448 (id-string 449 (sly-trace-dialog-spec-button 450 (format "%4s" id) trace 'skip t 'action 'sly-button-inspect)) 451 (spec-button (sly-trace-dialog-spec-button 452 (format "%s" (car (sly-trace-dialog--trace-spec trace))) 453 trace)) 454 (summary (cl-loop for (type objects marker) in 455 `((:arg ,(sly-trace-dialog--trace-args trace) 456 " > ") 457 (:retval ,(sly-trace-dialog--trace-retlist trace) 458 " < ")) 459 concat (cl-loop for object in objects 460 concat " " 461 concat indent-summary 462 concat marker 463 concat (sly-trace-dialog-part-button 464 (cl-first object) 465 (cl-second object) 466 id 467 type) 468 concat "\n")))) 469 (puthash id trace sly-trace-dialog--traces) 470 ;; insert and propertize the text 471 ;; 472 (setf (sly-trace-dialog--trace-beg trace) (point-marker)) 473 (insert id-string " ") 474 (insert indent-spec) 475 (if has-children-p 476 (insert (sly-trace-dialog--make-collapse-button trace)) 477 (setf (sly-trace-dialog--trace-collapse-button-marker trace) 478 (point-marker)) 479 (insert "-")) 480 (insert " " spec-button "\n") 481 (setf (sly-trace-dialog--trace-summary-beg trace) (point-marker)) 482 (insert summary) 483 (setf (sly-trace-dialog--trace-end trace) (point-marker)) 484 (set-marker-insertion-type (sly-trace-dialog--trace-beg trace) t) 485 486 ;; respect brief mode and collapsed state 487 ;; 488 (cl-loop for condition in (list sly-trace-dialog-hide-details-mode 489 (sly-trace-dialog--trace-collapsed-p trace)) 490 when condition 491 do (sly-trace-dialog--hide-unhide 492 (sly-trace-dialog--trace-summary-beg 493 trace) 494 (sly-trace-dialog--trace-end trace) 495 1)) 496 (cl-loop for tr = trace then parent 497 for parent = (sly-trace-dialog--trace-parent tr) 498 while parent 499 when (sly-trace-dialog--trace-collapsed-p parent) 500 do (sly-trace-dialog--hide-unhide 501 (sly-trace-dialog--trace-beg trace) 502 (sly-trace-dialog--trace-end trace) 503 (+ 1 504 (or (get-text-property (sly-trace-dialog--trace-beg parent) 505 'sly-trace-dialog--hidden-level) 506 0))) 507 (cl-return)) 508 ;; maybe add the collapse-button to the parent in case it didn't 509 ;; have one already 510 ;; 511 (when (and parent 512 (sly-trace-dialog--trace-collapse-button-marker parent)) 513 (sly-trace-dialog--maintaining-properties 514 (sly-trace-dialog--trace-collapse-button-marker parent) 515 (delete-char 1) 516 (insert (sly-trace-dialog--make-collapse-button parent)) 517 (setf (sly-trace-dialog--trace-collapse-button-marker parent) 518 nil))) 519 ;; draw the tree lines 520 ;; 521 (when parent 522 (sly-trace-dialog--draw-tree-lines (sly-trace-dialog--trace-beg trace) 523 (+ 2 (length indent-spec)) 524 'up)) 525 (when has-children-p 526 (sly-trace-dialog--draw-tree-lines (sly-trace-dialog--trace-beg trace) 527 (+ 5 (length indent-spec)) 528 'down)) 529 ;; set the "children-end" slot 530 ;; 531 (unless (sly-trace-dialog--trace-children-end trace) 532 (cl-loop for parent = trace 533 then (sly-trace-dialog--trace-parent parent) 534 while parent 535 do 536 (setf (sly-trace-dialog--trace-children-end parent) 537 (sly-trace-dialog--trace-end trace)))))) 538 539 (defun sly-trace-dialog--render-trace (trace) 540 ;; Render the trace entry in the appropriate place. 541 ;; 542 ;; A trace becomes a few lines of slightly propertized text in the 543 ;; buffer, inserted by `sly-trace-dialog--insert-trace', bound by 544 ;; point markers that we use here. 545 ;; 546 ;; The new trace might be replacing an existing one, or otherwise 547 ;; must be placed under its existing parent which might or might not 548 ;; be the last entry inserted. 549 ;; 550 (let ((existing (sly-trace-dialog--find-trace 551 (sly-trace-dialog--trace-id trace))) 552 (parent (sly-trace-dialog--trace-parent trace))) 553 (cond (existing 554 ;; Other traces might already reference `existing' and with 555 ;; need to maintain that eqness. Best way to do that is 556 ;; destructively modify `existing' with the new retlist... 557 ;; 558 (setf (sly-trace-dialog--trace-retlist existing) 559 (sly-trace-dialog--trace-retlist trace)) 560 ;; Now, before deleting and re-inserting `existing' at an 561 ;; arbitrary point in the tree, note that it's 562 ;; "children-end" marker is already non-nil, and informs us 563 ;; about its parenthood status. We want to 1. leave it 564 ;; alone if it's already a parent, or 2. set it to nil if 565 ;; it's a leaf, thus forcing the needed update of the 566 ;; parents' "children-end" marker. 567 ;; 568 (when (= (sly-trace-dialog--trace-children-end existing) 569 (sly-trace-dialog--trace-end existing)) 570 (setf (sly-trace-dialog--trace-children-end existing) nil)) 571 (delete-region (sly-trace-dialog--trace-beg existing) 572 (sly-trace-dialog--trace-end existing)) 573 (goto-char (sly-trace-dialog--trace-end existing)) 574 ;; Remember to set `trace' to be `existing' 575 ;; 576 (setq trace existing)) 577 (parent 578 (goto-char (1+ (sly-trace-dialog--trace-children-end parent)))) 579 (;; top level trace 580 t 581 (goto-char (point-max)))) 582 (goto-char (line-beginning-position)) 583 (sly-trace-dialog--insert-trace trace))) 584 585 (defun sly-trace-dialog--update-tree (tuples) 586 (save-excursion 587 (sly-refreshing 588 (:overlay sly-trace-dialog--tree-overlay 589 :dont-erase t) 590 (cl-loop for tuple in tuples 591 for parent = (sly-trace-dialog--find-trace (cl-second tuple)) 592 for trace = (sly-trace-dialog--make-trace 593 :id (cl-first tuple) 594 :parent parent 595 :spec (cl-third tuple) 596 :args (cl-fourth tuple) 597 :retlist (cl-fifth tuple) 598 :depth (if parent 599 (1+ (sly-trace-dialog--trace-depth 600 parent)) 601 0)) 602 do (sly-trace-dialog--render-trace trace))))) 603 604 (defun sly-trace-dialog--clear-local-tree () 605 (set (make-local-variable 'sly-trace-dialog--fetch-key) 606 (cl-gensym "sly-trace-dialog-fetch-key-")) 607 (set (make-local-variable 'sly-trace-dialog--traces) 608 (make-hash-table)) 609 (sly-refreshing 610 (:overlay sly-trace-dialog--tree-overlay)) 611 (sly-trace-dialog--update-progress nil)) 612 613 (defun sly-trace-dialog--on-new-results (results &optional recurse) 614 (cl-destructuring-bind (tuples remaining reply-key) 615 results 616 (cond ((and sly-trace-dialog--fetch-key 617 (string= (symbol-name sly-trace-dialog--fetch-key) 618 (symbol-name reply-key))) 619 (sly-trace-dialog--update-tree tuples) 620 (sly-trace-dialog--update-progress 621 remaining 622 (and recurse 623 (cl-plusp remaining)) 624 t) 625 (when (and recurse 626 (not (prog1 sly-trace-dialog--stop-fetching 627 (setq sly-trace-dialog--stop-fetching nil))) 628 (cl-plusp remaining)) 629 (sly-eval-async `(slynk-trace-dialog:report-partial-tree 630 ',reply-key) 631 #'(lambda (results) (sly-trace-dialog--on-new-results 632 results 633 recurse)))))))) 634 635 636 ;;;; Interactive functions 637 ;;; 638 (defun sly-trace-dialog-fetch-specs () 639 "Refresh just list of traced specs." 640 (interactive) 641 (sly-eval-async `(slynk-trace-dialog:report-specs) 642 #'sly-trace-dialog--open-specs)) 643 644 (defun sly-trace-dialog-fetch-progress () 645 (interactive) 646 (sly-eval-async 647 '(slynk-trace-dialog:report-total) 648 #'(lambda (total) 649 (sly-trace-dialog--update-progress 650 total)))) 651 652 (defun sly-trace-dialog-fetch-status () 653 "Refresh just the status part of the SLY Trace Dialog" 654 (interactive) 655 (sly-trace-dialog-fetch-specs) 656 (sly-trace-dialog-fetch-progress)) 657 658 (defun sly-trace-dialog-clear-fetched-traces (&optional interactive) 659 "Clear local and remote traces collected so far" 660 (interactive "p") 661 (when (or (not interactive) 662 (y-or-n-p "Clear all collected and fetched traces?")) 663 (sly-eval-async 664 '(slynk-trace-dialog:clear-trace-tree) 665 #'(lambda (_ignored) 666 (sly-trace-dialog--clear-local-tree))))) 667 668 (defun sly-trace-dialog-fetch-traces (&optional recurse) 669 (interactive "P") 670 (setq sly-trace-dialog--stop-fetching nil) 671 (sly-eval-async `(slynk-trace-dialog:report-partial-tree 672 ',sly-trace-dialog--fetch-key) 673 #'(lambda (results) (sly-trace-dialog--on-new-results results 674 recurse)))) 675 676 (defvar sly-trace-dialog-after-toggle-hook nil 677 "Hooks run after toggling a dialog-trace") 678 679 (defun sly-trace-dialog-toggle-trace (&optional using-context-p) 680 "Toggle the dialog-trace of the spec at point. 681 682 When USING-CONTEXT-P, attempt to decipher lambdas. methods and 683 other complicated function specs." 684 (interactive "P") 685 ;; Notice the use of "spec strings" here as opposed to the 686 ;; proper cons specs we use on the slynk side. 687 ;; 688 ;; Notice the conditional use of `sly-trace-query' found in 689 ;; slynk-fancy-trace.el 690 ;; 691 (let* ((spec-string (if using-context-p 692 (sly-extract-context) 693 (sly-symbol-at-point))) 694 (spec-string (if (fboundp 'sly-trace-query) 695 (sly-trace-query spec-string) 696 spec-string))) 697 (sly-message "%s" (sly-eval `(slynk-trace-dialog:dialog-toggle-trace 698 (slynk::from-string ,spec-string)))) 699 (run-hooks 'sly-trace-dialog-after-toggle-hook))) 700 701 (defun sly-trace-dialog-untrace-all () 702 "Untrace all specs traced for the Trace Dialog." 703 (interactive) 704 (sly-eval-async `(slynk-trace-dialog:dialog-untrace-all) 705 #'(lambda (results) 706 (sly-message "%s dialog specs and %s regular specs untraced" 707 (cdr results) (car results) ))) 708 (run-hooks 'sly-trace-dialog-after-toggle-hook)) 709 710 (defun sly-trace-dialog--update-existing-dialog () 711 (let ((existing (sly-trace-dialog--live-dialog))) 712 (when existing 713 (with-current-buffer existing 714 (sly-trace-dialog-fetch-status))))) 715 716 (add-hook 'sly-trace-dialog-after-toggle-hook 717 'sly-trace-dialog--update-existing-dialog) 718 719 (defun sly-trace-dialog-toggle-complex-trace () 720 "Toggle the dialog-trace of the complex spec at point. 721 722 See `sly-trace-dialog-toggle-trace'." 723 (interactive) 724 (sly-trace-dialog-toggle-trace t)) 725 726 (defun sly-trace-dialog (&optional clear-and-fetch) 727 "Show trace dialog and refresh trace collection status. 728 729 With optional CLEAR-AND-FETCH prefix arg, clear the current tree 730 and fetch a first batch of traces." 731 (interactive "P") 732 (with-current-buffer 733 ;; FIXME: refactor with `sly-with-popup-buffer' 734 (pop-to-buffer 735 (sly-trace-dialog--ensure-buffer) 736 `(display-buffer-reuse-window . ((inhibit-same-window . t)))) 737 (sly-trace-dialog-fetch-status) 738 (when (or clear-and-fetch 739 (null sly-trace-dialog--fetch-key)) 740 (sly-trace-dialog--clear-local-tree)) 741 (when clear-and-fetch 742 (sly-trace-dialog-fetch-traces nil)))) 743 744 (provide 'sly-trace-dialog)