sly-stickers.el (57460B)
1 ;;; sly-stickers.el --- Live-code annotations for SLY -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2014 João Távora 4 5 ;; Author: João Távora <joaotavora@gmail.com> 6 ;; Keywords: convenience, languages, lisp, tools 7 8 ;; This program is free software; you can redistribute it and/or modify 9 ;; it under the terms of the GNU General Public License as published by 10 ;; the Free Software Foundation, either version 3 of the License, or 11 ;; (at your option) any later version. 12 13 ;; This program is distributed in the hope that it will be useful, 14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 ;; GNU General Public License for more details. 17 18 ;; You should have received a copy of the GNU General Public License 19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>. 20 21 ;;; Commentary: 22 ;;; 23 ;;; There is much in this library that would merit comment. Just some points: 24 ;;; 25 ;;; * Stickers are just overlays that exist on the Emacs side. A lot 26 ;;; of the code is managing overlay nesting levels so that faces 27 ;;; are chosen suitably for making sticker inside stickers 28 ;;; visually recognizable. 29 ;;; 30 ;;; The main entry-point here is the interactive command 31 ;;; `sly-sticker-dwim', which places and removes stickers. 32 ;;; 33 ;;; Stickers are also indexed by an integer and placed in a 34 ;;; connection-global hash-table, `sly-stickers--stickers'. It can 35 ;;; be connection-global because the same sticker with the same id 36 ;;; might eventually be sent, multiple times, to many 37 ;;; connections. It's the Slynk side that has to be able to tell 38 ;;; whence the stickers comes from (this is not done currently). 39 ;;; 40 ;;; * The gist of stickers is instrumenting top-level forms. This is 41 ;;; done by hooking onto `sly-compile-region-function'. Two separate 42 ;;; compilations are performed: one for the uninstrumented form and 43 ;;; another for the intrumented form. This is so that warnings and 44 ;;; compilations errors that are due to stickers exclusively can be 45 ;;; sorted out. If the second compilation fails, the stickers dont 46 ;;; "stick", i.e. they are not armed. 47 ;;; 48 ;;; * File compilation is also hooked onto via 49 ;;; `sly-compilation-finished-hook'. The idea here is to first 50 ;;; compile the whole file, then traverse any top-level forms that 51 ;;; contain stickers and instrument those. 52 ;;; 53 ;;; * On the emacs-side, the sticker overlays are very ephemeral 54 ;;; objects. They are not persistently saved in any way. Deleting or 55 ;;; modifying text inside them automatically deletes them. 56 ;;; 57 ;;; The slynk side eventually must be told to let go of deleted 58 ;;; stickers. Before this happens these stickers are known as 59 ;;; zombies. Reaping happens on almost every SLY -> Slynk call. 60 ;;; Killing the buffer they live in doesn't automatically delete 61 ;;; them, but reaping eventually happens anyway via 62 ;;; `sly-stickers--sticker-by-id'. 63 ;;; 64 ;;; Before a zombie sticker is reaped, some code may still be 65 ;;; running that adds recordings to these stickers, and some of 66 ;;; these recordings make it to the Emacs side. The user can ignore 67 ;;; them in `sly-stickers-replay', being notified that a deleted 68 ;;; sticker is being referenced. 69 ;;; 70 ;;; This need to communicate dead stickers to Slynk is only here 71 ;;; because using weak-hash-tables is impractical for stickers 72 ;;; indexed by integers. Perhaps this could be fixed if the 73 ;;; instrumented forms could reference sticker objects directly. 74 ;;; 75 ;;; * To see the results of sticker-instrumented code, there are the 76 ;;; interactive commands `sly-stickers-replay' and 77 ;;; `sly-stickers-fetch'. If "breaking stickers" is enabled, the 78 ;;; debugger is also invoked before a sticker is reached and after a 79 ;;; sticker returns (if it returns). Auxiliary data-structures like 80 ;;; `sly-stickers--recording' are used here. 81 ;;; 82 ;;; * `sly-stickers--replay-state' and `sly-stickers--replay-map' are 83 ;;; great big hacks just for handling the `sly-stickers-replay' 84 ;;; interactive loop. Should look into recursive minibuffers or 85 ;;; something more akin to `ediff', for example. 86 ;;; 87 ;;; Code: 88 89 90 (require 'sly) 91 (require 'sly-parse "lib/sly-parse") 92 (require 'sly-buttons "lib/sly-buttons") 93 94 (eval-when-compile 95 (when (version< emacs-version "26") 96 ;; Using `cl-defstruct' needs `cl' on older Emacsen. See issue 97 ;; https://github.com/joaotavora/sly/issues/54 98 (require 'cl))) 99 100 (require 'cl-lib) 101 (require 'hi-lock) ; for the faces 102 (require 'color) 103 (require 'pulse) ; pulse-momentary-highlight-overlay 104 105 (define-sly-contrib sly-stickers 106 "Mark expressions in source buffers and annotate return values." 107 (:authors "João Távora <joaotavora@gmail.com>") 108 (:license "GPL") 109 (:slynk-dependencies slynk/stickers) 110 (:on-load (add-hook 'sly-editing-mode-hook 'sly-stickers-mode) 111 (add-hook 'sly-mode-hook 'sly-stickers-shortcut-mode) 112 (setq sly-compile-region-function 113 'sly-stickers-compile-region-aware-of-stickers) 114 (add-hook 'sly-compilation-finished-hook 115 'sly-stickers-after-buffer-compilation t) 116 (add-hook 'sly-db-extras-hooks 'sly-stickers--handle-break)) 117 (:on-unload (remove-hook 'sly-editing-mode-hook 'sly-stickers-mode) 118 (remove-hook 'sly-mode-hook 'sly-stickers-shortcut-mode) 119 (setq sly-compile-region-function 'sly-compile-region-as-string) 120 (remove-hook 'sly-compilation-finished-hook 121 'sly-stickers-after-buffer-compilation) 122 (remove-hook 'sly-db-extras-hooks 'sly-stickers--handle-break))) 123 124 125 126 ;;;; Bookeeping for local stickers 127 ;;;; 128 (defvar sly-stickers--counter 0) 129 130 (defvar sly-stickers--stickers (make-hash-table)) 131 132 (defvar sly-stickers--zombie-sticker-ids nil 133 "Sticker ids that might exist in Slynk but no longer in Emacs.") 134 135 (defun sly-stickers--zombies () sly-stickers--zombie-sticker-ids) 136 137 (defun sly-stickers--reset-zombies () (setq sly-stickers--zombie-sticker-ids nil)) 138 139 140 141 ;;;; Sticker display and UI logic 142 ;;;; 143 (defgroup sly-stickers nil 144 "Mark expressions in source buffers and annotate return values." 145 :prefix "sly-stickers-" 146 :group 'sly) 147 148 (when nil 149 (cl-loop for sym in '(sly-stickers-placed-face 150 sly-stickers-armed-face 151 sly-stickers-empty-face 152 sly-stickers-recordings-face 153 sly-stickers-exited-non-locally-face) 154 do 155 (put sym 'face-defface-spec nil))) 156 157 (defface sly-stickers-placed-face 158 '((((background dark)) (:background "light grey" :foreground "black")) 159 (t (:background "light grey"))) 160 "Face for sticker just set") 161 162 (defface sly-stickers-armed-face 163 '((t (:strike-through nil :inherit hi-blue))) 164 "Face for stickers that have been armed") 165 166 (defface sly-stickers-recordings-face 167 '((t (:strike-through nil :inherit hi-green))) 168 "Face for stickers that have new recordings") 169 170 (defface sly-stickers-empty-face 171 '((t (:strike-through nil :inherit hi-pink))) 172 "Face for stickers that have no recordings.") 173 174 (defface sly-stickers-exited-non-locally-face 175 '((t (:strike-through t :inherit sly-stickers-empty-face))) 176 "Face for stickers that have exited non-locally.") 177 178 (defvar sly-stickers-mode-map 179 (let ((map (make-sparse-keymap))) 180 (define-key map (kbd "C-c C-s C-s") 'sly-stickers-dwim) 181 (define-key map (kbd "C-c C-s C-d") 'sly-stickers-clear-defun-stickers) 182 (define-key map (kbd "C-c C-s C-k") 'sly-stickers-clear-buffer-stickers) 183 map)) 184 185 (defvar sly-stickers-shortcut-mode-map 186 (let ((map (make-sparse-keymap))) 187 (define-key map (kbd "C-c C-s S") 'sly-stickers-fetch) 188 (define-key map (kbd "C-c C-s F") 'sly-stickers-forget) 189 (define-key map (kbd "C-c C-s C-r") 'sly-stickers-replay) 190 map)) 191 192 (define-minor-mode sly-stickers-mode 193 "Mark expression in source buffers and annotate return values.") 194 195 (define-minor-mode sly-stickers-shortcut-mode 196 "Shortcuts for navigating sticker recordings.") 197 198 (defvar sly-stickers--sticker-map 199 (let ((map (make-sparse-keymap))) 200 (define-key map (kbd "M-RET") 'sly-mrepl-copy-part-to-repl) 201 (define-key map [down-mouse-3] 'sly-button-popup-part-menu) 202 (define-key map [mouse-3] 'sly-button-popup-part-menu) 203 map)) 204 205 (define-button-type 'sly-stickers-sticker :supertype 'sly-part 206 'sly-button-inspect 'sly-stickers--inspect-recording 207 'sly-button-echo 'sly-stickers--echo-sticker 208 'keymap sly-stickers--sticker-map) 209 210 (defun sly-stickers--set-tooltip (sticker &optional info) 211 (let* ((help-base (button-get sticker 'sly-stickers--base-help-echo)) 212 (text (if info 213 (concat "[sly] Sticker:" info "\n" help-base) 214 help-base))) 215 (button-put sticker 'help-echo text) 216 (button-put sticker 'sly-stickers--info info))) 217 218 (defun sly-stickers--echo-sticker (sticker &rest more) 219 (cl-assert (null more) "Apparently two stickers at exact same location") 220 (sly-message (button-get sticker 'sly-stickers--info)) 221 (sly-button-flash sticker)) 222 223 (defcustom sly-stickers-max-nested-stickers 4 224 "The maximum expected level expected of sticker nesting. 225 If you nest more than this number of stickers inside other 226 stickers, the overlay face will be very dark, and probably 227 render the underlying text unreadable." 228 :type :integer) 229 230 (defvar sly-stickers-color-face-attribute :background 231 "Color-capable attribute of sticker faces that represents nesting.") 232 233 (gv-define-setter sly-stickers--level (level sticker) 234 `(prog1 235 (setf (sly-button--level ,sticker) ,level) 236 (when (button-get ,sticker 'sly-stickers--base-face) 237 (sly-stickers--set-face ,sticker)))) 238 239 (defun sly-stickers--level (sticker) (sly-button--level sticker)) 240 241 (defun sly-stickers--guess-face-color (face) 242 (face-attribute-specified-or 243 (face-attribute face sly-stickers-color-face-attribute nil t) 244 nil)) 245 246 (defun sly-stickers--set-face (sticker &optional face) 247 (let* ((face (or face 248 (button-get sticker 'sly-stickers--base-face))) 249 (guessed-color (sly-stickers--guess-face-color face))) 250 (button-put sticker 'sly-stickers--base-face face) 251 (unless guessed-color 252 (sly-error "sorry, can't guess color for face %s for sticker %s")) 253 (button-put sticker 'face 254 `(:inherit ,face 255 ,sly-stickers-color-face-attribute 256 ,(color-darken-name 257 guessed-color 258 (* 25 259 (/ (sly-stickers--level sticker) 260 sly-stickers-max-nested-stickers 261 1.0))))))) 262 263 (defun sly-stickers--stickers-in (beg end) 264 (sly-button--overlays-in beg end 'sly-stickers--sticker-id)) 265 (defun sly-stickers--stickers-at (pos) 266 (sly-button--overlays-at pos 'sly-stickers--sticker-id)) 267 (defun sly-stickers--stickers-between (beg end) 268 (sly-button--overlays-between beg end 'sly-stickers--sticker-id)) 269 (defun sly-stickers--stickers-exactly-at (beg end) 270 (sly-button--overlays-exactly-at beg end 'sly-stickers--sticker-id)) 271 272 273 (defun sly-stickers--sticker (from to) 274 "Place a new sticker from FROM to TO" 275 (let* ((intersecting (sly-stickers--stickers-in from to)) 276 (contained (sly-stickers--stickers-between from to)) 277 (not-contained (cl-set-difference intersecting contained)) 278 (containers nil)) 279 (unless (cl-every #'(lambda (e) 280 (and (< (button-start e) from) 281 (> (button-end e) to))) 282 not-contained) 283 (sly-error "Cannot place a sticker that partially overlaps other stickers")) 284 (when (sly-stickers--stickers-exactly-at from to) 285 (sly-error "There is already a sticker at those very coordinates")) 286 ;; by now we know that other intersecting, non-contained stickers 287 ;; are our containers. 288 ;; 289 (setq containers not-contained) 290 (let* ((label "Brand new sticker") 291 (sticker 292 ;;; FIXME: We aren't using sly--make-text-button here 293 ;;; because it doesn't allow overlay button s 294 (make-button from to :type 'sly-stickers-sticker 295 'sly-connection (sly-current-connection) 296 'part-args (list -1 nil) 297 'part-label label 298 'sly-button-search-id (sly-button-next-search-id) 299 'modification-hooks '(sly-stickers--sticker-modified) 300 'sly-stickers-id (cl-incf sly-stickers--counter) 301 'sly-stickers--base-help-echo 302 "mouse-3: Context menu"))) 303 ;; choose a suitable level for ourselves and increase the 304 ;; level of those contained by us 305 ;; 306 (setf (sly-stickers--level sticker) 307 (1+ (cl-reduce #'max containers 308 :key #'sly-stickers--level 309 :initial-value -1))) 310 (mapc (lambda (s) (cl-incf (sly-stickers--level s))) contained) 311 ;; finally, set face 312 ;; 313 (sly-stickers--set-tooltip sticker label) 314 (sly-stickers--set-face sticker 'sly-stickers-placed-face) 315 sticker))) 316 317 (defun sly-stickers--sticker-id (sticker) 318 (button-get sticker 'sly-stickers-id)) 319 320 (defun sly-stickers--arm-sticker (sticker) 321 (let* ((id (sly-stickers--sticker-id sticker)) 322 (label (format "Sticker %d is armed" id))) 323 (button-put sticker 'part-args (list id nil)) 324 (button-put sticker 'part-label label) 325 (button-put sticker 'sly-stickers--last-known-recording nil) 326 (sly-stickers--set-tooltip sticker label) 327 (sly-stickers--set-face sticker 'sly-stickers-armed-face) 328 (puthash id sticker sly-stickers--stickers))) 329 330 (defun sly-stickers--disarm-sticker (sticker) 331 (let* ((id (sly-stickers--sticker-id sticker)) 332 (label (format "Sticker %d failed to stick" id))) 333 (button-put sticker 'part-args (list -1 nil)) 334 (button-put sticker 'part-label label) 335 (sly-stickers--set-tooltip sticker label) 336 (sly-stickers--set-face sticker 'sly-stickers-placed-face))) 337 338 (define-button-type 'sly-stickers--recording-part :supertype 'sly-part 339 'sly-button-inspect 340 'sly-stickers--inspect-recording 341 ;; 'sly-button-pretty-print 342 ;; #'(lambda (id) ...) 343 ;; 'sly-button-describe 344 ;; #'(lambda (id) ...) 345 ;; 'sly-button-show-source 346 ;; #'(lambda (id) ...) 347 ) 348 349 (defun sly-stickers--recording-part (label sticker-id recording vindex 350 &rest props) 351 (apply #'sly--make-text-button 352 label nil 353 :type 'sly-stickers--recording-part 354 'part-args (list sticker-id recording vindex) 355 'part-label "Recorded value" 356 props)) 357 358 (cl-defun sly-stickers--describe-recording-values (recording &key 359 (indent 0) 360 (prefix "=> ")) 361 (cl-flet ((indent (str) 362 (concat (make-string indent ? )str)) 363 (prefix (str) 364 (concat prefix str))) 365 (let ((descs (sly-stickers--recording-value-descriptions recording))) 366 (cond ((sly-stickers--recording-exited-non-locally-p recording) 367 (indent (propertize "exited non locally" 'face 'sly-action-face))) 368 ((null descs) 369 (indent (propertize "no values" 'face 'sly-action-face))) 370 (t 371 (cl-loop for (value-desc . rest) on descs 372 for vindex from 0 373 concat 374 (indent (prefix 375 (sly-stickers--recording-part 376 value-desc 377 (sly-stickers--recording-sticker-id recording) 378 recording 379 vindex))) 380 when rest 381 concat "\n")))))) 382 383 (defconst sly-stickers--newline "\n" 384 "Work around bug #63, actually Emacs bug #21839. 385 \"25.0.50; can't use newlines in defaults in cl functions\"") 386 387 (cl-defun sly-stickers--pretty-describe-recording 388 (recording &key (separator sly-stickers--newline)) 389 (let* ((recording-sticker-id (sly-stickers--recording-sticker-id recording)) 390 (sticker (gethash recording-sticker-id 391 sly-stickers--stickers)) 392 (nvalues (length (sly-stickers--recording-value-descriptions recording)))) 393 (format "%s%s:%s%s" 394 (if sticker 395 (format "Sticker %s on line %s of %s" 396 (sly-stickers--sticker-id sticker) 397 (with-current-buffer (overlay-buffer sticker) 398 (line-number-at-pos (overlay-start sticker))) 399 (overlay-buffer sticker)) 400 (format "Deleted or unknown sticker %s" 401 recording-sticker-id)) 402 (if (cl-plusp nvalues) 403 (format " returned %s values" nvalues) "") 404 separator 405 (sly-stickers--describe-recording-values recording 406 :indent 2)))) 407 408 (defun sly-stickers--populate-sticker (sticker recording) 409 (let* ((id (sly-stickers--sticker-id sticker)) 410 (total (sly-stickers--recording-sticker-total recording))) 411 (cond ((cl-plusp total) 412 (button-put sticker 'part-label 413 (format "Sticker %d has %d recordings" id total)) 414 (unless (sly-stickers--recording-void-p recording) 415 (button-put sticker 'sly-stickers--last-known-recording recording) 416 (button-put sticker 'part-args (list id recording)) 417 (sly-stickers--set-tooltip 418 sticker 419 (format "Newest of %s sticker recordings:\n%s" 420 total 421 (sly-stickers--describe-recording-values recording :prefix ""))) 422 (sly-stickers--set-face 423 sticker 424 (if (sly-stickers--recording-exited-non-locally-p recording) 425 'sly-stickers-exited-non-locally-face 426 'sly-stickers-recordings-face)))) 427 (t 428 (let ((last-known-recording 429 (button-get sticker 'sly-stickers--last-known-recording))) 430 (button-put sticker 'part-label 431 (format "Sticker %d has no recordings" id)) 432 (when last-known-recording 433 (sly-stickers--set-tooltip 434 sticker 435 (format "No new recordings. Last known:\n%s" 436 (sly-stickers--describe-recording-values 437 last-known-recording)))) 438 (sly-stickers--set-tooltip sticker "No new recordings") 439 (sly-stickers--set-face sticker 'sly-stickers-empty-face)))))) 440 441 (defun sly-stickers--sticker-substickers (sticker) 442 (let* ((retval 443 (remove sticker 444 (sly-stickers--stickers-between (button-start sticker) 445 (button-end sticker)))) 446 ;; To verify an important invariant, and warn (don't crash) 447 ;; 448 (exactly-at 449 (sly-stickers--stickers-exactly-at (button-start sticker) 450 (button-end sticker)))) 451 (cond 452 ((remove sticker exactly-at) 453 (sly-warning "Something's fishy. More than one sticker at same position") 454 (cl-set-difference retval exactly-at)) 455 (t 456 retval)))) 457 458 (defun sly-stickers--briefly-describe-sticker (sticker) 459 (let ((beg (button-start sticker)) 460 (end (button-end sticker))) 461 (if (< (- end beg) 20) 462 (format "sticker around %s" (buffer-substring-no-properties beg end)) 463 (cl-labels ((word (point direction) 464 (apply #'buffer-substring-no-properties 465 (sort (list 466 point 467 (save-excursion (goto-char point) 468 (forward-word direction) 469 (point))) 470 #'<)))) 471 (format "sticker from \"%s...\" to \"...%s\"" 472 (word beg 1) 473 (word end -1)))))) 474 475 (defun sly-stickers--delete (sticker) 476 "Ensure that sticker is deleted." 477 ;; Delete the overlay and take care of levels for contained and 478 ;; containers, but note that a sticker might have no buffer anymore 479 ;; if that buffer was killed, for example... 480 ;; 481 (when (and (overlay-buffer sticker) 482 (buffer-live-p (overlay-buffer sticker))) 483 (mapc (lambda (s) (cl-decf (sly-stickers--level s))) 484 (sly-stickers--sticker-substickers sticker)) 485 (delete-overlay sticker)) 486 ;; We also want to deregister it from the hashtable in case it's 487 ;; there (it's not there if it has never been armed) 488 ;; 489 (let ((id (sly-stickers--sticker-id sticker))) 490 (when (gethash (sly-stickers--sticker-id sticker) 491 sly-stickers--stickers) 492 (remhash id sly-stickers--stickers) 493 (add-to-list 'sly-stickers--zombie-sticker-ids id)))) 494 495 (defun sly-stickers--sticker-modified (sticker _after? beg end 496 &optional _pre-change-len) 497 (unless (save-excursion 498 (goto-char beg) 499 (skip-chars-forward "\t\n\s") 500 (>= (point) end)) 501 (let ((inhibit-modification-hooks t)) 502 (sly-message "Deleting %s" 503 (sly-stickers--briefly-describe-sticker sticker)) 504 (sly-stickers--delete sticker)))) 505 506 (defun sly-stickers-next-sticker (&optional n) 507 (interactive "p") 508 (sly-button-search n 'sly-stickers--sticker-id)) 509 510 (defun sly-stickers-prev-sticker (&optional n) 511 (interactive "p") 512 (sly-button-search (- n) 'sly-stickers--sticker-id)) 513 514 (put 'sly-stickers-next-sticker 'sly-button-navigation-command t) 515 (put 'sly-stickers-prev-sticker 'sly-button-navigation-command t) 516 517 (defun sly-stickers-clear-defun-stickers () 518 "Clear all stickers in the current top-level form." 519 (interactive) 520 (let* ((region (sly-region-for-defun-at-point))) 521 (sly-stickers-clear-region-stickers (car region) (cadr region)))) 522 523 (defun sly-stickers-clear-buffer-stickers () 524 "Clear all the stickers in the current buffer." 525 (interactive) 526 (sly-stickers-clear-region-stickers (point-min) (point-max))) 527 528 (defun sly-stickers-clear-region-stickers (&optional from to) 529 "Clear all the stickers between FROM and TO." 530 (interactive "r") 531 (let* ((from (or from (region-beginning))) 532 (to (or to (region-end))) 533 (stickers (sly-stickers--stickers-in from to))) 534 (cond (stickers 535 (mapc #'sly-stickers--delete stickers) 536 (sly-message "%s stickers cleared" (length stickers))) 537 (t 538 (sly-message "no stickers to clear"))))) 539 540 (defun sly-stickers-delete-sticker-at-point (&optional point) 541 "Delete the topmost sticker at point." 542 (interactive "d") 543 (let ((stickers (sly-stickers--stickers-at (or point (point))))) 544 (cond 545 (stickers 546 (sly-stickers--delete (car stickers)) 547 (if (cdr stickers) 548 (sly-message "Deleted topmost sticker (%d remain at point)" 549 (length (cdr stickers))) 550 (sly-message "Deleted sticker %s" 551 (sly-stickers--briefly-describe-sticker (car stickers))))) 552 (t 553 (sly-user-error "No stickers at point"))))) 554 555 (defun sly-stickers-maybe-add-sticker (&optional point) 556 "Add of remove a sticker at POINT. 557 If point is currently at a sticker boundary, delete that sticker, 558 otherwise, add a sticker to the sexp at point." 559 (interactive "d") 560 (save-excursion 561 (goto-char (or point (point))) 562 (let* ((bounds (sly-bounds-of-sexp-at-point)) 563 (beg (car bounds)) 564 (end (cdr bounds)) 565 (matching (and bounds 566 (sly-stickers--stickers-exactly-at beg end)))) 567 (cond 568 ((not bounds) 569 (sly-message "Nothing here to place sticker on, apparently")) 570 (matching 571 (sly-stickers--delete (car matching)) 572 (sly-message "Deleted sticker")) 573 (t 574 (let ((sticker (sly-stickers--sticker beg end))) 575 (sly-message "Added %s" 576 (sly-stickers--briefly-describe-sticker sticker)))))))) 577 578 (defun sly-stickers-dwim (prefix) 579 "Set or remove stickers at point. 580 Set a sticker for the current sexp at point, or delete it if it 581 already exists. 582 583 If the region is active set a sticker in the current region. 584 585 With interactive prefix arg PREFIX always delete stickers. 586 587 - One C-u means delete the current top-level form's stickers. 588 - Two C-u's means delete the current buffer's stickers" 589 (interactive "p") 590 (cond 591 ((= prefix 4) 592 (if (region-active-p) 593 (sly-stickers-clear-region-stickers) 594 (sly-stickers-clear-defun-stickers))) 595 ((>= prefix 16) 596 (sly-stickers-clear-buffer-stickers)) 597 ((region-active-p) 598 (sly-stickers--sticker (region-beginning) (region-end)) 599 (deactivate-mark t)) 600 ((not (sly-inside-string-or-comment-p)) 601 (sly-stickers-maybe-add-sticker)) 602 (t 603 (sly-message "No point placing stickers in string literals or comments")))) 604 605 (defun sly-stickers--sticker-by-id (sticker-id) 606 "Return the sticker for STICKER-ID, or return NIL. 607 Perform some housecleaning tasks for stickers that have been 608 properly deleted or brutally killed with the buffer they were in." 609 (let* ((sticker (gethash sticker-id sly-stickers--stickers))) 610 (cond ((and sticker (overlay-buffer sticker) 611 (buffer-live-p (overlay-buffer sticker))) 612 sticker) 613 (sticker 614 ;; `sticker-id' references a sticker that hasn't been 615 ;; deleted but whose overlay can't be found. One reason for 616 ;; this is that the buffer it existed in was killed. So 617 ;; delete it now and mark it a zombie. 618 (sly-stickers--delete sticker) 619 nil) 620 (t 621 ;; The sticker isn't in the `sly-stickers--stickers' hash 622 ;; table, so it has probably already been marked zombie, 623 ;; and possibly already deleted. We're probably just seeing 624 ;; it because recording playback and breaking stickers may 625 ;; not filtering these out by user option. 626 ;; 627 ;; To be on the safe side, add the id to the table anyway, 628 ;; so it'll get killed on the Slynk side on the next 629 ;; request. 630 ;; 631 (add-to-list 'sly-stickers--zombie-sticker-ids sticker-id) 632 nil)))) 633 634 (defvar sly-stickers--flashing-sticker nil 635 "The sticker currently being flashed.") 636 637 (cl-defun sly-stickers--find-and-flash (sticker-id &key (otherwise nil)) 638 "Find and flash the sticker referenced by STICKER-ID. 639 otherwise call OTHERWISE with a single argument, a string stating 640 the reason why the sticker couldn't be found" 641 (let ((sticker (sly-stickers--sticker-by-id sticker-id))) 642 (cond (sticker 643 (let ((buffer (overlay-buffer sticker))) 644 (when buffer 645 (with-current-buffer buffer 646 (let* ((window (display-buffer buffer t))) 647 (when window 648 (with-selected-window window 649 (push-mark nil t) 650 (goto-char (overlay-start sticker)) 651 (sly-recenter (point)) 652 (setq sly-stickers--flashing-sticker sticker) 653 (pulse-momentary-highlight-overlay sticker 'highlight) 654 (run-with-timer 655 2 nil 656 (lambda () 657 (when (eq sly-stickers--flashing-sticker sticker) 658 (pulse-momentary-highlight-overlay 659 sticker 'highlight))))))))))) 660 (otherwise 661 (funcall otherwise "Can't find sticker (probably deleted!)"))))) 662 663 ;; Work around an Emacs bug, probably won't be needed in Emacs 27.1 664 (advice-add 'pulse-momentary-unhighlight 665 :before (lambda (&rest _args) 666 (let ((o pulse-momentary-overlay)) 667 (when (and o (overlay-get o 'sly-stickers-id)) 668 (overlay-put o 'priority nil)))) 669 '((name . fix-pulse-momentary-unhighlight-bug))) 670 671 672 ;;;; Recordings 673 ;;;; 674 (cl-defstruct (sly-stickers--recording 675 (:constructor sly-stickers--make-recording-1) 676 (:conc-name sly-stickers--recording-) 677 (:copier sly-stickers--copy-recording)) 678 (sticker-id nil) 679 (sticker-total nil) 680 (id nil) 681 (value-descriptions nil) 682 (exited-non-locally-p nil) 683 (sly-connection nil)) 684 685 (defun sly-stickers--recording-void-p (recording) 686 (not (sly-stickers--recording-id recording))) 687 688 (defun sly-stickers--make-recording (description) 689 "Make a `sly-stickers--recording' from DESCRIPTION. 690 A DESCRIPTION is how the Lisp side describes a sticker and 691 usually its most recent recording. If it doesn't, a recording 692 veryfying `sly-stickers--recording-void-p' is created." 693 (cl-destructuring-bind (sticker-id sticker-total . recording-description) 694 description 695 (let ((recording (sly-stickers--make-recording-1 696 :sticker-id sticker-id 697 :sticker-total sticker-total 698 :sly-connection (sly-current-connection)))) 699 (when recording-description 700 (cl-destructuring-bind (recording-id _recording-ctime 701 value-descriptions 702 exited-non-locally-p) 703 recording-description 704 (setf 705 (sly-stickers--recording-id recording) 706 recording-id 707 (sly-stickers--recording-value-descriptions recording) 708 value-descriptions 709 (sly-stickers--recording-exited-non-locally-p recording) 710 exited-non-locally-p))) 711 recording))) 712 713 714 ;;;; Replaying sticker recordings 715 ;;;; 716 (defvar sly-stickers--replay-help nil) 717 718 (defvar sly-stickers--replay-mode-map 719 (let ((map (make-sparse-keymap))) 720 (cl-flet 721 ((def 722 (key binding &optional desc) 723 (define-key map (kbd key) binding) 724 (setf 725 (cl-getf sly-stickers--replay-help binding) 726 (cons (cons key (car (cl-getf sly-stickers--replay-help binding))) 727 (or desc 728 (cdr (cl-getf sly-stickers--replay-help binding))))))) 729 (def "n" 'sly-stickers-replay-next 730 "Scan recordings forward") 731 (def "SPC" 'sly-stickers-replay-next) 732 (def "N" 'sly-stickers-replay-next-for-sticker 733 "Scan recordings forward for this sticker") 734 (def "DEL" 'sly-stickers-replay-prev 735 "Scan recordings backward") 736 (def "p" 'sly-stickers-replay-prev) 737 (def "P" 'sly-stickers-replay-prev-for-sticker 738 "Scan recordings backward for this sticker") 739 (def "j" 'sly-stickers-replay-jump 740 "Jump to a recording") 741 (def ">" 'sly-stickers-replay-jump-to-end 742 "Go to last recording") 743 (def "<" 'sly-stickers-replay-jump-to-beginning 744 "Go to first recording") 745 (def "h" 'sly-stickers-replay-toggle-help 746 "Toggle help") 747 (def "v" 'sly-stickers-replay-pop-to-current-sticker 748 "Pop to current sticker") 749 (def "V" 'sly-stickers-replay-toggle-pop-to-stickers 750 "Toggle popping to stickers") 751 (def "q" 'quit-window 752 "Quit") 753 (def "x" 'sly-stickers-replay-toggle-ignore-sticker 754 "Toggle ignoring a sticker") 755 (def "z" 'sly-stickers-replay-toggle-ignore-zombies 756 "Toggle ignoring deleted stickers") 757 (def "R" 'sly-stickers-replay-reset-ignore-list 758 "Reset ignore list") 759 (def "F" 'sly-stickers-forget 760 "Forget about sticker recordings") 761 (def "g" 'sly-stickers-replay-refresh 762 "Refresh current recording") 763 map))) 764 765 (define-derived-mode sly-stickers--replay-mode fundamental-mode 766 "SLY Stickers Replay" "Mode for controlling sticker replay sessions Dialog" 767 (set-syntax-table lisp-mode-syntax-table) 768 (read-only-mode 1) 769 (sly-mode 1) 770 (add-hook 'post-command-hook 771 'sly-stickers--replay-postch t t)) 772 773 (defun sly-stickers--replay-postch () 774 (let ((win (get-buffer-window (current-buffer)))) 775 (when (and win 776 (window-live-p win)) 777 (ignore-errors 778 (set-window-text-height win (line-number-at-pos (point-max))))))) 779 780 (defvar sly-stickers--replay-expanded-help nil) 781 782 (defun sly-stickers-replay-toggle-help () 783 (interactive) 784 (set (make-local-variable 'sly-stickers--replay-expanded-help) 785 (not sly-stickers--replay-expanded-help)) 786 (sly-stickers--replay-refresh-1)) 787 788 (sly-def-connection-var sly-stickers--replay-data nil 789 "Data structure for information related to recordings") 790 791 (defvar sly-stickers--replay-key nil 792 "A symbol identifying a particular replaying session in the 793 Slynk server.") 794 795 (defvar sly-stickers--replay-pop-to-stickers t) 796 797 (defun sly-stickers--replay-refresh-1 () 798 "Insert a description of the current recording into the current 799 buffer" 800 (cl-assert (eq major-mode 'sly-stickers--replay-mode) 801 nil 802 "%s must be run in a stickers replay buffer" 803 this-command) 804 (cl-labels 805 ((paragraph () (if sly-stickers--replay-expanded-help "\n\n" "\n")) 806 (describe-ignored-stickers 807 () 808 (let ((ignored-ids (cl-getf (sly-stickers--replay-data) 809 :ignored-ids)) 810 (ignore-zombies-p (cl-getf (sly-stickers--replay-data) 811 :ignore-zombies-p))) 812 (if (or ignored-ids ignore-zombies-p) 813 (format "%s%s%s" 814 (paragraph) 815 (if ignore-zombies-p 816 "Skipping recordings of deleted stickers. " "") 817 (if ignored-ids 818 (format "Skipping recordings of sticker%s %s." 819 (if (cl-rest ignored-ids) "s" "") 820 (concat (mapconcat #'pp-to-string 821 (butlast ignored-ids) 822 ", ") 823 (and (cl-rest ignored-ids) " and ") 824 (pp-to-string 825 (car (last ignored-ids))))) 826 "")) 827 ""))) 828 (describe-help 829 () 830 (format "%s%s" 831 (paragraph) 832 (if sly-stickers--replay-expanded-help 833 (substitute-command-keys "\\{sly-stickers--replay-mode-map}") 834 "n => next, p => previous, x => ignore, h => help, q => quit"))) 835 (describe-number-of-recordings 836 (new-total) 837 (let* ((old-total (cl-getf (sly-stickers--replay-data) :old-total)) 838 (diff (and old-total (- new-total old-total)))) 839 (format "%s total recordings%s" 840 new-total 841 (cond ((and diff 842 (cl-plusp diff)) 843 (propertize (format ", %s new in the meantime" 844 diff) 845 'face 'bold)) 846 (t 847 ""))))) 848 (describe-playhead 849 (recording) 850 (let ((new-total (cl-getf (sly-stickers--replay-data) :total)) 851 (index (cl-getf (sly-stickers--replay-data) :index))) 852 (cond 853 ((and new-total 854 recording) 855 (format "Playhead at recording %s of %s" 856 (ignore-errors (1+ index)) 857 (describe-number-of-recordings new-total))) 858 (new-total 859 (format "Playhead detached (ignoring too many stickers?) on %s" 860 (describe-number-of-recordings new-total))) 861 (recording 862 (substitute-command-keys 863 "Playhead confused (perhaps hit \\[sly-stickers-replay-refresh])")) 864 (t 865 (format 866 "No recordings! Perhaps you need to run some sticker-aware code first")))))) 867 (sly-refreshing () 868 (let ((rec (cl-getf (sly-stickers--replay-data) :recording))) 869 (insert (describe-playhead rec) (paragraph)) 870 (when rec 871 (insert (sly-stickers--pretty-describe-recording 872 rec 873 :separator (paragraph))))) 874 (insert (describe-ignored-stickers)) 875 (insert (describe-help))))) 876 877 (defun sly-stickers-replay () 878 "Start interactive replaying of known sticker recordings." 879 (interactive) 880 (let* ((buffer-name (sly-buffer-name :stickers-replay 881 :connection (sly-current-connection))) 882 (existing-buffer (get-buffer buffer-name))) 883 (let ((split-width-threshold nil) 884 (split-height-threshold 0)) 885 (sly-with-popup-buffer (buffer-name 886 :mode 'sly-stickers--replay-mode 887 :select t) 888 (setq existing-buffer standard-output))) 889 (with-current-buffer existing-buffer 890 (setf (cl-getf (sly-stickers--replay-data) :replay-key) 891 (cl-gensym "stickers-replay-")) 892 (let ((old-total (cl-getf (sly-stickers--replay-data) :total)) 893 (new-total (sly-eval '(slynk-stickers:total-recordings)))) 894 (setf (cl-getf (sly-stickers--replay-data) :old-total) old-total) 895 (when (and 896 old-total 897 (cl-plusp old-total) 898 (> new-total old-total) 899 (sly-y-or-n-p 900 "Looks like there are %s new recordings since last replay.\n 901 Forget about old ones before continuing?" (- new-total old-total))) 902 (sly-stickers-forget old-total))) 903 904 (sly-stickers-replay-refresh 0 905 (if existing-buffer nil t) 906 t) 907 (set-window-dedicated-p nil 'soft) 908 (with-current-buffer existing-buffer 909 (sly-stickers--replay-postch))))) 910 911 (defun sly-stickers-replay-refresh (n command &optional interactive) 912 "Refresh the current sticker replay session. 913 N and COMMAND are passed to the Slynk server and instruct what 914 recording to fetch: 915 916 If COMMAND is nil, navigate to Nth next sticker recording, 917 skipping ignored stickers. 918 919 If COMMAND is a number, navigate to the Nth next sticker 920 recording for the sticker with that numeric sticker id. 921 922 If COMMAND is any other value, jump directly to the recording 923 index N. 924 925 Interactively, N is 0 and and COMMAND is nil, meaning that the 926 playhead should stay put and the buffer should be refreshed. 927 928 Non-interactively signal an error if no recording was fetched and 929 INTERACTIVE is the symbol `sly-error'. 930 931 Non-interactively, set the `:recording' slot of 932 `sly-stickers--replay-data' to nil if no recording was fetched." 933 (interactive (list 0 nil t)) 934 (let ((result (sly-eval 935 `(slynk-stickers:search-for-recording 936 ',(cl-getf (sly-stickers--replay-data) :replay-key) 937 ',(cl-getf (sly-stickers--replay-data) :ignored-ids) 938 ',(cl-getf (sly-stickers--replay-data) :ignore-zombies-p) 939 ',(sly-stickers--zombies) 940 ,n 941 ',command)))) 942 ;; presumably, Slynk cleaned up the zombies we passed it. 943 ;; 944 (sly-stickers--reset-zombies) 945 (cond ((car result) 946 (cl-destructuring-bind (total index &rest sticker-description) 947 result 948 (let ((rec (sly-stickers--make-recording sticker-description)) 949 (old-index (cl-getf (sly-stickers--replay-data) :index))) 950 (setf (cl-getf (sly-stickers--replay-data) :index) index 951 (cl-getf (sly-stickers--replay-data) :total) total 952 (cl-getf (sly-stickers--replay-data) :recording) rec) 953 (if old-index 954 (if (cl-plusp n) 955 (if (> old-index index) (sly-message "Rolled over to start")) 956 (if (< old-index index) (sly-message "Rolled over to end")))) 957 ;; Assert that the recording isn't void 958 ;; 959 (when (sly-stickers--recording-void-p rec) 960 (sly-error "Attempt to visit a void recording described by %s" 961 sticker-description)) 962 (when sly-stickers--replay-pop-to-stickers 963 (sly-stickers--find-and-flash 964 (sly-stickers--recording-sticker-id rec)))))) 965 (interactive 966 ;; If we were called interactively and got an error, it's 967 ;; probably because there aren't any recordings, so reset 968 ;; data 969 ;; 970 (setf (sly-stickers--replay-data) nil) 971 (when (eq interactive 'sly-error) 972 (sly-error "%s for %s reported an error: %s" 973 'slynk-stickers:search-for-recording 974 n 975 (cadr result))) 976 (setf (cl-getf (sly-stickers--replay-data) :recording) nil))) 977 (if interactive 978 (sly-stickers--replay-refresh-1) 979 (cl-getf (sly-stickers--replay-data) :recording )))) 980 981 (defun sly-stickers-replay-next (n) 982 "Navigate to Nth next sticker recording, skipping ignored stickers" 983 (interactive "p") 984 (sly-stickers-replay-refresh n nil 'sly-error)) 985 986 (defun sly-stickers-replay-prev (n) 987 "Navigate to Nth prev sticker recording, skipping ignored stickers" 988 (interactive "p") 989 (sly-stickers-replay-refresh (- n) nil 'sly-error)) 990 991 (defun sly-stickers-replay--current-sticker-interactive (prompt) 992 (if current-prefix-arg 993 (read-number (format "[sly] %s " prompt)) 994 (sly-stickers--recording-sticker-id 995 (cl-getf (sly-stickers--replay-data) :recording)))) 996 997 (defun sly-stickers-replay-next-for-sticker (n sticker-id) 998 "Navigate to Nth next sticker recording for STICKER-ID" 999 (interactive (list 1000 (if (numberp current-prefix-arg) 1001 current-prefix-arg 1002 1) 1003 (sly-stickers-replay--current-sticker-interactive 1004 "Which sticker?"))) 1005 (sly-stickers-replay-refresh n sticker-id 'sly-error)) 1006 1007 (defun sly-stickers-replay-prev-for-sticker (n sticker-id) 1008 "Navigate to Nth prev sticker recording for STICKER-ID" 1009 (interactive (list 1010 (- (if (numberp current-prefix-arg) 1011 current-prefix-arg 1012 1)) 1013 (sly-stickers-replay--current-sticker-interactive 1014 "Which sticker?"))) 1015 (sly-stickers-replay-refresh n sticker-id 'sly-error)) 1016 1017 (defun sly-stickers-replay-jump (n) 1018 "Fetch and jump to Nth sticker recording" 1019 (interactive (read-number "[sly] jump to which recording? ")) 1020 (sly-stickers-replay-refresh n 'absolute-p 'sly-error)) 1021 1022 (defun sly-stickers-replay-jump-to-beginning () 1023 "Fetch and jump to the first sticker recording" 1024 (interactive) 1025 (sly-stickers-replay-refresh 0 'absolute-p 'sly-error)) 1026 1027 (defun sly-stickers-replay-jump-to-end () 1028 "Fetch and jump to the last sticker recording" 1029 (interactive) 1030 (sly-stickers-replay-refresh -1 'absolute-p 'sly-error)) 1031 1032 (defun sly-stickers-replay-toggle-ignore-sticker (sticker-id) 1033 "Toggle ignoring recordings of sticker with STICKER-ID" 1034 (interactive (list 1035 (sly-stickers-replay--current-sticker-interactive 1036 "Toggle ignoring which sticker id?"))) 1037 (let* ((ignored (cl-getf (sly-stickers--replay-data) :ignored-ids)) 1038 (ignored-p (memq sticker-id ignored))) 1039 (cond (ignored-p 1040 (setf (cl-getf (sly-stickers--replay-data) :ignored-ids) 1041 (delq sticker-id (cdr ignored))) 1042 (sly-message "No longer ignoring sticker %s" sticker-id)) 1043 (t 1044 (setf (cl-getf (sly-stickers--replay-data) :ignored-ids) 1045 (delete-dups ; stupid but safe 1046 (cons sticker-id ignored))) 1047 (sly-message "Now ignoring sticker %s" sticker-id))) 1048 (sly-stickers-replay-refresh (if ignored-p ; was ignored, now isn't 1049 0 1050 1) 1051 nil 1052 t))) 1053 1054 (defun sly-stickers-replay-toggle-ignore-zombies () 1055 "Toggle ignoring recordings of zombie stickers." 1056 (interactive) 1057 (let ((switch 1058 (setf 1059 (cl-getf (sly-stickers--replay-data) :ignore-zombies-p) 1060 (not (cl-getf (sly-stickers--replay-data) :ignore-zombies-p))))) 1061 (if switch 1062 (sly-message "Now ignoring zombie stickers") 1063 (sly-message "No longer ignoring zombie stickers"))) 1064 (sly-stickers-replay-refresh 0 nil t)) 1065 1066 (defun sly-stickers-replay-pop-to-current-sticker (sticker-id) 1067 "Pop to sticker with STICKER-ID" 1068 (interactive (list 1069 (sly-stickers-replay--current-sticker-interactive 1070 "Pop to which sticker id?"))) 1071 (sly-stickers--find-and-flash sticker-id 1072 :otherwise #'sly-error)) 1073 1074 (defun sly-stickers-replay-toggle-pop-to-stickers () 1075 "Toggle popping to stickers when replaying sticker recordings." 1076 (interactive) 1077 (set (make-local-variable 'sly-stickers--replay-pop-to-stickers) 1078 (not sly-stickers--replay-pop-to-stickers)) 1079 (if sly-stickers--replay-pop-to-stickers 1080 (sly-message "Auto-popping to stickers ON") 1081 (sly-message "Auto-popping to stickers OFF"))) 1082 1083 (defun sly-stickers-replay-reset-ignore-list () 1084 "Reset the sticker ignore specs" 1085 (interactive) 1086 (setf (cl-getf (sly-stickers--replay-data) :ignored-ids) nil) 1087 (sly-stickers-replay-refresh 0 nil t)) 1088 1089 (defun sly-stickers-fetch () 1090 "Fetch recordings from Slynk and update stickers accordingly. 1091 See also `sly-stickers-replay'." 1092 (interactive) 1093 (sly-eval-async `(slynk-stickers:fetch ',(sly-stickers--zombies)) 1094 #'(lambda (result) 1095 (sly-stickers--reset-zombies) 1096 (let ((message 1097 (format "Fetched recordings for %s armed stickers" 1098 (length result)))) 1099 (cl-loop for sticker-description in result 1100 ;; Although we are analysing sticker descriptions 1101 ;; here, recordings are made to pass to 1102 ;; `sly-stickers--sticker-by-id', even if they are 1103 ;; are `sly-stickers--recording-void-p', which is 1104 ;; the case if the sticker has never been 1105 ;; traversed. 1106 ;; 1107 for recording = 1108 (sly-stickers--make-recording sticker-description) 1109 for sticker = 1110 (sly-stickers--sticker-by-id 1111 (sly-stickers--recording-sticker-id recording)) 1112 when sticker 1113 do (sly-stickers--populate-sticker sticker recording)) 1114 (sly-message message))) 1115 "CL_USER")) 1116 1117 (defun sly-stickers-forget (&optional howmany interactive) 1118 "Forget about sticker recordings in the Slynk side. 1119 If HOWMANY is non-nil it must be a number stating how many 1120 recordings to forget about. In this cases Because 0 is an index, 1121 in the `nth' sense, the HOWMANYth recording survives." 1122 (interactive (list (and (numberp current-prefix-arg) 1123 current-prefix-arg) 1124 t)) 1125 (when (or (not interactive) 1126 (sly-y-or-n-p "Really forget about sticker recordings?")) 1127 (sly-eval `(slynk-stickers:forget ',(sly-stickers--zombies) ,howmany)) 1128 (sly-stickers--reset-zombies) 1129 (setf (cl-getf (sly-stickers--replay-data) :rec) nil 1130 (cl-getf (sly-stickers--replay-data) :old-total) nil) 1131 (when interactive 1132 (sly-message "Forgot all about sticker recordings.")) 1133 (when (eq major-mode 'sly-stickers--replay-mode) 1134 (sly-stickers-replay-refresh 0 t t)))) 1135 1136 1137 ;;;; Breaking stickers 1138 (defun sly-stickers--handle-break (extra) 1139 (sly-dcase extra 1140 ((:slynk-after-sticker description) 1141 (let ((sticker-id (cl-first description)) 1142 (recording (sly-stickers--make-recording description))) 1143 (sly-stickers--find-and-flash sticker-id 1144 :otherwise 'sly-message) 1145 (insert 1146 "\n\n" 1147 (sly-stickers--pretty-describe-recording recording 1148 )))) 1149 ((:slynk-before-sticker sticker-id) 1150 (sly-stickers--find-and-flash sticker-id 1151 :otherwise 'sly-message)) 1152 (;; don't do anything if we don't know this "extra" info 1153 t 1154 nil))) 1155 1156 1157 (defun sly-stickers-toggle-break-on-stickers () 1158 (interactive) 1159 (let ((break-p (sly-eval '(slynk-stickers:toggle-break-on-stickers)))) 1160 (sly-message "Breaking on stickers is %s" (if break-p "ON" "OFF")))) 1161 1162 1163 ;;;; Functions for examining recordings 1164 ;;;; 1165 1166 1167 (eval-after-load "sly-mrepl" 1168 `(progn 1169 (button-type-put 'sly-stickers-sticker 1170 'sly-mrepl-copy-part-to-repl 1171 'sly-stickers--copy-recording-to-repl) 1172 (button-type-put 'sly-stickers--recording-part 1173 'sly-mrepl-copy-part-to-repl 1174 'sly-stickers--copy-recording-to-repl))) 1175 1176 1177 ;;; shoosh byte-compiler 1178 (declare-function sly-mrepl--save-and-copy-for-repl nil) 1179 (cl-defun sly-stickers--copy-recording-to-repl 1180 (_sticker-id recording &optional (vindex 0)) 1181 (check-recording recording) 1182 (sly-mrepl--save-and-copy-for-repl 1183 `(slynk-stickers:find-recording-or-lose 1184 ,(sly-stickers--recording-id recording) 1185 ,vindex) 1186 :before (format "Returning values of recording %s of sticker %s" 1187 (sly-stickers--recording-id recording) 1188 (sly-stickers--recording-sticker-id recording)))) 1189 1190 (defun check-recording (recording) 1191 (cond ((null recording) 1192 (sly-error "This sticker doesn't seem to have any recordings")) 1193 ((not (eq (sly-stickers--recording-sly-connection recording) 1194 (sly-current-connection))) 1195 (sly-error "Recording is for a different connection (%s)" 1196 (sly-connection-name 1197 (sly-stickers--recording-sly-connection recording)))))) 1198 1199 (cl-defun sly-stickers--inspect-recording 1200 (_sticker-id recording &optional (vindex 0)) 1201 (check-recording recording) 1202 (sly-eval-for-inspector 1203 `(slynk-stickers:inspect-sticker-recording 1204 ,(sly-stickers--recording-id recording) 1205 ,vindex))) 1206 1207 ;;;; Sticker-aware compilation 1208 ;;;; 1209 1210 (cl-defun sly-stickers--compile-region-aware-of-stickers-1 1211 (start end callback &key sync fallback flash) 1212 "Compile from START to END considering stickers. 1213 After compilation call CALLBACK with the stickers and the 1214 compilation result. If SYNC, use `sly-eval' other wise use 1215 `sly-eval-async'. If FALLBACK, send the uninstrumneted region as 1216 a fallback. If FLASH, flash the compiled region." 1217 (let* ((uninstrumented (buffer-substring-no-properties start end)) 1218 (stickers (sly-stickers--stickers-between start end)) 1219 (original-buffer (current-buffer))) 1220 (cond (stickers 1221 (when flash 1222 (sly-flash-region start end :face 'sly-stickers-armed-face)) 1223 (sly-with-popup-buffer ((sly-buffer-name :stickers :hidden t) 1224 :select :hidden) 1225 (mapc #'delete-overlay (overlays-in (point-min) (point-max))) 1226 (insert uninstrumented) 1227 ;; Use a second set of overlays placed just in the 1228 ;; pre-compilation buffer. We need this to correctly keep 1229 ;; track of the markers because in this buffer we are going 1230 ;; to change actual text 1231 ;; 1232 (cl-loop for sticker in stickers 1233 for overlay = 1234 (make-overlay (- (button-start sticker) (1- start)) 1235 (- (button-end sticker) (1- start))) 1236 do (overlay-put overlay 'sly-stickers--sticker sticker)) 1237 (cl-loop for overlay in (overlays-in (point-min) (point-max)) 1238 for sticker = (overlay-get overlay 'sly-stickers--sticker) 1239 do 1240 (sly-stickers--arm-sticker sticker) 1241 (goto-char (overlay-start overlay)) 1242 (insert (format "(slynk-stickers:record %d " 1243 (sly-stickers--sticker-id sticker))) 1244 (goto-char (overlay-end overlay)) 1245 (insert ")")) 1246 ;; Now send both the instrumented and uninstrumented 1247 ;; string to the Lisp 1248 ;; 1249 (let ((instrumented (buffer-substring-no-properties (point-min) 1250 (point-max))) 1251 (new-ids (mapcar #'sly-stickers--sticker-id stickers))) 1252 (with-current-buffer original-buffer 1253 (let ((form `(slynk-stickers:compile-for-stickers 1254 ',new-ids 1255 ',(sly-stickers--zombies) 1256 ,instrumented 1257 ,(when fallback uninstrumented) 1258 ,(buffer-name) 1259 ',(sly-compilation-position start) 1260 ,(if (buffer-file-name) 1261 (sly-to-lisp-filename (buffer-file-name))) 1262 ',sly-compilation-policy))) 1263 (cond (sync 1264 (funcall callback 1265 stickers 1266 (sly-eval form)) 1267 (sly-stickers--reset-zombies)) 1268 (t (sly-eval-async form 1269 (lambda (result) 1270 (sly-stickers--reset-zombies) 1271 (funcall callback stickers result)))))))))) 1272 (t 1273 (sly-compile-region-as-string start end))))) 1274 1275 (defun sly-stickers-compile-region-aware-of-stickers (start end) 1276 "Compile region from START to END aware of stickers. 1277 Intended to be placed in `sly-compile-region-function'" 1278 (sly-stickers--compile-region-aware-of-stickers-1 1279 start end 1280 (lambda (stickers result-and-stuck-p) 1281 (cl-destructuring-bind (result &optional stuck-p) 1282 result-and-stuck-p 1283 (unless stuck-p 1284 (mapc #'sly-stickers--disarm-sticker stickers)) 1285 (sly-compilation-finished 1286 result 1287 nil 1288 (if stuck-p 1289 (format " (%d stickers armed)" (length stickers)) 1290 " (stickers failed to stick)")))) 1291 :fallback t 1292 :flash t)) 1293 1294 (defun sly-stickers-after-buffer-compilation (success _notes buffer loadp) 1295 "After compilation, compile regions with stickers. 1296 Intented to be placed in `sly-compilation-finished-hook'" 1297 (when (and buffer loadp success) 1298 (save-restriction 1299 (widen) 1300 (let* ((all-stickers (sly-stickers--stickers-between 1301 (point-min) (point-max))) 1302 (regions (cl-loop for sticker in all-stickers 1303 for region = (sly-region-for-defun-at-point 1304 (overlay-start sticker)) 1305 unless (member region regions) 1306 collect region into regions 1307 finally (cl-return regions)))) 1308 (when regions 1309 (cl-loop 1310 with successful 1311 with unsuccessful 1312 for region in regions 1313 do 1314 (sly-stickers--compile-region-aware-of-stickers-1 1315 (car region) (cadr region) 1316 (lambda (stickers result) 1317 (cond (result 1318 (push (cons region stickers) successful)) 1319 (t 1320 (mapc #'sly-stickers--disarm-sticker stickers) 1321 (push (cons region stickers) unsuccessful)))) 1322 :sync t) 1323 finally 1324 (sly-temp-message 1325 3 3 1326 "%s stickers stuck in %s regions, %s disarmed in %s regions" 1327 (cl-reduce #'+ successful :key (lambda (x) (length (cdr x)))) 1328 (length successful) 1329 (cl-reduce #'+ unsuccessful :key (lambda (x) (length (cdr x)))) 1330 (length unsuccessful)))))))) 1331 1332 1333 ;;;; Menu 1334 ;;;; 1335 1336 (easy-menu-define sly-stickers--shortcut-menu nil 1337 "Placing stickers in `lisp-mode' buffers." 1338 (let* ((in-source-file 'sly-stickers-mode) 1339 (connected '(sly-connected-p))) 1340 `("Stickers" 1341 ["Add or remove sticker at point" 1342 sly-stickers-dwim ,in-source-file] 1343 ["Delete stickers from top-level form" 1344 sly-stickers-clear-defun-stickers ,in-source-file] 1345 ["Delete stickers from buffer" 1346 sly-stickers-clear-buffer-stickers ,in-source-file] 1347 "--" 1348 ["Start sticker recording replay" 1349 sly-stickers-replay ,connected] 1350 ["Fetch most recent recordings" 1351 sly-stickers-fetch ,connected] 1352 ["Toggle breaking on stickers" 1353 sly-stickers-toggle-break-on-stickers ,connected]))) 1354 1355 (easy-menu-add-item sly-menu nil sly-stickers--shortcut-menu "Documentation") 1356 1357 (provide 'sly-stickers) 1358 ;;; sly-stickers.el ends here 1359