slynk-stickers.lisp (15894B)
1 (defpackage :slynk-stickers 2 (:use :cl :slynk-api) 3 (:import-from :slynk-backend :slynk-compile-string) 4 (:import-from :slynk :defslyfun :compile-string-for-emacs) 5 (:export #:record 6 #:compile-for-stickers 7 #:kill-stickers 8 #:inspect-sticker 9 #:inspect-sticker-recording 10 #:fetch 11 #:forget 12 #:total-recordings 13 #:find-recording-or-lose 14 #:search-for-recording 15 #:toggle-break-on-stickers 16 #:*break-on-stickers*)) 17 (in-package :slynk-stickers) 18 19 (defvar *next-recording-id* 0) 20 21 (defclass recording () 22 ((id :initform (incf *next-recording-id*) :accessor id-of) 23 (ctime :initform (common-lisp:get-universal-time) :accessor ctime-of) 24 (sticker :initform (error "required") :initarg :sticker :accessor sticker-of) 25 (values :initform (error "required") :initarg :values :accessor values-of) 26 (condition :initarg :condition :accessor condition-of))) 27 28 (defmethod initialize-instance :after ((x recording) &key sticker) 29 (push x (recordings-of sticker)) 30 (vector-push-extend x *recordings*)) 31 32 (defun recording-description-string (recording 33 &optional stream print-first-value) 34 (let ((values (values-of recording)) 35 (condition (condition-of recording))) 36 (cond (condition 37 (format stream "exited non-locally with: ~a" 38 (present-for-emacs condition))) 39 ((eq values 'exited-non-locally) 40 (format stream "exited non-locally")) 41 ((listp values) 42 (if (and print-first-value 43 values) 44 (format stream "~a" (present-for-emacs (car values))) 45 (format stream "~a values" (length values)))) 46 (t 47 (format stream "corrupt recording"))))) 48 49 (defmethod print-object ((r recording) s) 50 (print-unreadable-object (r s :type t) 51 (recording-description-string r s))) 52 53 (defclass sticker () 54 ((id :initform (error "required") :initarg :id :accessor id-of) 55 (hit-count :initform 0 :accessor hit-count-of) 56 (recordings :initform nil :accessor recordings-of) 57 (ignore-spec :initform nil :accessor ignore-spec-of))) 58 59 (defmethod print-object ((sticker sticker) s) 60 (print-unreadable-object (sticker s :type t) 61 (format s "id=~a hit-count=~a" (id-of sticker) (hit-count-of sticker)))) 62 63 (defun exited-non-locally-p (recording) 64 (when (or (condition-of recording) 65 (eq (values-of recording) 'exited-non-locally)) 66 t)) 67 68 69 ;; FIXME: This won't work for multiple connected SLY clients. A 70 ;; channel, or some connection specific structure, is needed for that. 71 ;; 72 (defvar *stickers* (make-hash-table)) 73 (defvar *recordings* (make-array 0 :fill-pointer 0 :adjustable t)) 74 (defvar *visitor* nil) 75 76 (defslyfun compile-for-stickers (new-stickers 77 dead-stickers 78 instrumented-string 79 original-string 80 buffer 81 position 82 filename 83 policy) 84 "Considering NEW-STICKERS, compile INSTRUMENTED-STRING. 85 INSTRUMENTED-STRING is exerpted from BUFFER at POSITION. BUFFER may be 86 associated with FILENAME. DEAD-STICKERS if any, are killed. If 87 compilation succeeds, return a list (NOTES T). 88 89 If ORIGINAL-STRING, if non-nil, is compiled as a fallback if the 90 previous compilation. In this case a list (NOTES NIL) is returned or 91 an error is signalled. 92 93 If ORIGINAL-STRING is not supplied and compilation of 94 INSTRUMENTED-STRING fails, return NIL. 95 96 New stickers for NEW-STICKERS are registered in *STICKERS* and 97 stickers in DEAD-STICKERS are killed. NEW-STICKERS are not necessarily 98 \"new\" in the sense that the ids are not assigned by Slynk, but 99 their ignore-spec is reset nonetheless." 100 ;; Dead stickers are unconditionally removed from *stickers* 101 ;; 102 (kill-stickers dead-stickers) 103 (let ((probe 104 (handler-case 105 (compile-string-for-emacs instrumented-string 106 buffer 107 position 108 filename 109 policy) 110 (error () nil)))) 111 (cond (;; a non-nil and successful compilation result 112 (and probe 113 (third probe)) 114 ;; new objects for NEW-STICKERS are created 115 (loop for id in new-stickers 116 do (setf (gethash id *stickers*) 117 (make-instance 'sticker :id id))) 118 (list probe t)) 119 (original-string 120 (list (compile-string-for-emacs 121 original-string buffer position filename policy) 122 nil))))) 123 124 (defslyfun kill-stickers (ids) 125 (loop for id in ids 126 do (remhash id *stickers*))) 127 128 (define-condition sticker-related-condition (condition) 129 ((sticker :initarg :sticker :initform (error "~S is required" 'sticker) 130 :accessor sticker-of) 131 (debugger-extra-options :initarg :debugger-extra-options 132 :accessor debugger-extra-options-of))) 133 134 (define-condition just-before-sticker (sticker-related-condition) 135 () 136 (:report (lambda (c stream) 137 (with-slots (sticker) c 138 (print-unreadable-object (c stream) 139 (format stream "JUST BEFORE ~a" sticker)))))) 140 141 (define-condition right-after-sticker (sticker-related-condition) 142 ((recording :initarg :recording :accessor recording-of)) 143 (:report (lambda (c stream) 144 (with-slots (sticker recording) c 145 (print-unreadable-object (c stream) 146 (format stream "RIGHT-AFTER ~a (recorded ~a)" 147 sticker 148 recording)))))) 149 150 (defparameter *break-on-stickers* nil 151 "If non-nil, invoke to debugger when evaluating stickered forms. 152 If a list containing :BEFORE, break before evaluating. If a list 153 containing :AFTER, break after evaluating. If t, break before and 154 after.") 155 156 (defslyfun toggle-break-on-stickers () 157 "Toggle the value of *BREAK-ON-STICKERS*" 158 (setq *break-on-stickers* (not *break-on-stickers*))) 159 160 (defun invoke-debugger-for-sticker (sticker condition) 161 (restart-case 162 (let ((*debugger-extra-options* 163 (append (debugger-extra-options-of condition) 164 *debugger-extra-options*))) 165 (invoke-debugger condition)) 166 (continue () :report "OK, continue") 167 (ignore-this-sticker () 168 :report "Stop bothering me about this sticker" 169 :test (lambda (c) 170 (cond ((null c) 171 ;; test functions will often be called without 172 ;; conditions. 173 t) 174 ((typep c 'sticker-related-condition) 175 (and (eq (sticker-of c) sticker) 176 *break-on-stickers*)) 177 (t 178 nil))) 179 (setf (ignore-spec-of sticker) 180 (list :before :after))))) 181 182 (defun break-on-sticker-p (sticker when) 183 (and (or (eq t *break-on-stickers*) 184 (and (listp *break-on-stickers*) 185 (member when *break-on-stickers*))) 186 (not (member when (ignore-spec-of sticker))))) 187 188 (defun call-with-sticker-recording (id fn) 189 (let* ((sticker (gethash id *stickers*)) 190 (mark (gensym)) 191 (retval mark) 192 (last-condition) 193 (recording)) 194 (handler-bind ((condition (lambda (condition) 195 (setq last-condition condition)))) 196 ;; Maybe break before 197 ;; 198 (when sticker 199 (incf (hit-count-of sticker)) 200 (when (break-on-sticker-p sticker :before) 201 (invoke-debugger-for-sticker 202 sticker (make-condition 'just-before-sticker 203 :sticker sticker 204 :debugger-extra-options 205 `((:slynk-before-sticker ,id)))))) 206 ;; Run actual code under the sticker 207 ;; 208 (unwind-protect 209 (values-list (setq retval (multiple-value-list (funcall fn)))) 210 (when sticker 211 ;; Always make a recording... 212 ;; 213 (setq recording 214 (make-instance 'recording 215 :sticker sticker 216 :values (if (eq mark retval) 217 'exited-non-locally 218 retval) 219 :condition (and (eq mark retval) 220 last-condition))) 221 ;; ...and then maybe break after. 222 (when (break-on-sticker-p sticker :after) 223 (invoke-debugger-for-sticker 224 sticker 225 (make-condition 'right-after-sticker 226 :sticker sticker 227 :recording recording 228 :debugger-extra-options 229 `((:slynk-after-sticker 230 ,(describe-sticker-for-emacs 231 sticker recording))))))))))) 232 233 (defmacro record (id &rest body) 234 `(call-with-sticker-recording ,id (lambda () ,@body))) 235 236 (define-setf-expander record (x &environment env) 237 (declare (ignore x env)) 238 (error "Sorry, not allowing ~S for ~S" 'setf 'record)) 239 240 (defun search-for-recording-1 (from &key 241 ignore-p 242 increment) 243 "Return two values: a RECORDING and its position in *RECORDINGS*. 244 Start searching from position FROM, an index in *RECORDINGS* which is 245 successibely increased by INCREMENT before using that to index 246 *RECORDINGS*." 247 (loop for starting-position in `(,from ,(if (plusp increment) 248 -1 249 (length *recordings*))) 250 ;; this funky scheme has something to do with rollover 251 ;; semantics probably 252 ;; 253 for inc in `(,increment ,(if (plusp increment) 1 -1)) 254 for (rec idx) = (loop for cand-idx = (incf starting-position 255 inc) 256 while (< -1 cand-idx (length *recordings*)) 257 for recording = (aref *recordings* cand-idx) 258 for sid = (id-of (sticker-of recording)) 259 unless (funcall ignore-p sid) 260 return (list recording cand-idx)) 261 when rec 262 return (values rec idx))) 263 264 (defun describe-recording-for-emacs (recording) 265 "Describe RECORDING as (ID CTIME VALUE-DESCRIPTIONS EXITED-NON-LOCALLY-P). 266 ID is a number. CTIME is the creation time, given by 267 CL:GET-UNIVERSAL-TIME VALUE-DESCRIPTIONS is a list of 268 strings. EXITED-NON-LOCALLY-P is an integer." 269 (list 270 (id-of recording) 271 (ctime-of recording) 272 (and (listp (values-of recording)) 273 (loop for value in (values-of recording) 274 collect (slynk-api:present-for-emacs value))) 275 (exited-non-locally-p recording))) 276 277 (defun describe-sticker-for-emacs (sticker &optional recording) 278 "Describe STICKER and either its latest recording or RECORDING. 279 Returns a list (ID NRECORDINGS . RECORDING-DESCRIPTION). 280 RECORDING-DESCRIPTION is as given by DESCRIBE-RECORDING-FOR-EMACS." 281 (let* ((recordings (recordings-of sticker)) 282 (recording (or recording 283 (first recordings)))) 284 (list* (id-of sticker) 285 (length recordings) 286 (and recording 287 (describe-recording-for-emacs recording))))) 288 289 (defslyfun total-recordings () 290 "Tell how many recordings in *RECORDINGS*" (length *recordings*)) 291 292 (defslyfun search-for-recording (key ignored-ids ignore-zombies-p dead-stickers index 293 &optional command) 294 "Visit the next recording for the visitor KEY. 295 IGNORED-IDS is a list of sticker IDs to ignore. IGNORE-ZOMBIES-P is 296 non-nil if recordings for dead stickers should also be ignored. 297 298 Kill any stickers in DEAD-STICKERS. 299 300 INDEX is an integer designating a recording to move the playhead 301 to. If COMMAND is nil, INDEX is taken relative to the current 302 playhead and the search jumps over recordings of stickers in 303 IGNORE-SPEC. If it is a number, search for the INDEXth recording 304 of sticker with that ID. Otherwise, jump directly to the INDEXth 305 recording. 306 307 If a recording can be found return a list (LAST-RECORDING-ID 308 ABSOLUTE-INDEX . STICKER-DESCRIPTION). ABSOLUTE-INDEX is the position 309 of recording in the global *RECORDINGS* array. STICKER-DESCRIPTION is 310 as given by DESCRIBE-STICKER-FOR-EMACS. 311 312 Otherwise returns a list (NIL ERROR-DESCRIPTION)" 313 (kill-stickers dead-stickers) 314 (unless (and *visitor* 315 (eq key (car *visitor*))) 316 (setf *visitor* (cons key -1))) 317 (multiple-value-bind (recording absolute-index) 318 (cond 319 ((zerop (length *recordings*)) 320 nil) 321 ((and command 322 (not (numberp command))) 323 (let ((absolute-index (mod index 324 (length *recordings*)))) 325 (values (aref *recordings* absolute-index) 326 absolute-index))) 327 (t 328 (search-for-recording-1 329 (cdr *visitor*) 330 :increment index 331 :ignore-p 332 (if (numberp command) 333 (lambda (sid) 334 (not (= sid command))) 335 (lambda (sid) 336 (or (member sid ignored-ids) 337 (and 338 ignore-zombies-p 339 (not (gethash sid *stickers*))))))))) 340 (cond (recording 341 (setf (cdr *visitor*) absolute-index) 342 (list* (length *recordings*) 343 absolute-index 344 (describe-sticker-for-emacs (sticker-of recording) recording))) 345 (t 346 (list nil "No recording matches that criteria"))))) 347 348 (defslyfun fetch (dead-stickers) 349 "Describe each known sticker to Emacs. 350 As always, take the opportunity to kill DEAD-STICKERS" 351 (kill-stickers dead-stickers) 352 (loop for sticker being the hash-values of *stickers* 353 collect (describe-sticker-for-emacs sticker))) 354 355 (defslyfun forget (dead-stickers &optional howmany) 356 "Forget HOWMANY sticker recordings. 357 Return number of remaining recordings" 358 (kill-stickers dead-stickers) 359 (maphash (lambda (id sticker) 360 (declare (ignore id)) 361 (setf (recordings-of sticker) nil)) 362 *stickers*) 363 (cond ((null howmany) 364 (setf *recordings* (make-array 0 :fill-pointer 0 :adjustable t))) 365 (t 366 (check-type howmany number) 367 (let ((remaining (- (length *recordings*) 368 howmany))) 369 (assert (not (minusp remaining))) 370 (setf *recordings* 371 (make-array remaining 372 :adjustable t 373 :fill-pointer t 374 :initial-contents (subseq *recordings* 375 howmany)))))) 376 (length *recordings*)) 377 378 (defslyfun find-recording-or-lose (recording-id vindex) 379 (let ((recording (find recording-id *recordings* :key #'id-of))) 380 (if vindex 381 (elt (values-of recording) vindex) 382 (values-list (values-of recording))))) 383 384 (defun find-sticker-or-lose (id) 385 (let ((probe (gethash id *stickers* :unknown))) 386 (if (eq probe :unknown) 387 (error "Cannot find sticker ~a" id) 388 probe))) 389 390 (defslyfun inspect-sticker (sticker-id) 391 (let ((sticker (find-sticker-or-lose sticker-id))) 392 (slynk::inspect-object sticker))) 393 394 (defslyfun inspect-sticker-recording (recording-id vindex) 395 (let ((recording (find-recording-or-lose recording-id vindex))) 396 (slynk::inspect-object recording))) 397 398 (provide 'slynk/stickers)