slynk-fancy-inspector.lisp (44630B)
1 ;;; slynk-fancy-inspector.lisp --- Fancy inspector for CLOS objects 2 ;; 3 ;; Author: Marco Baringer <mb@bese.it> and others 4 ;; License: Public Domain 5 ;; 6 7 (in-package :slynk) 8 9 (defmethod emacs-inspect ((symbol symbol)) 10 (let ((package (symbol-package symbol))) 11 (multiple-value-bind (_symbol status) 12 (and package (find-symbol (string symbol) package)) 13 (declare (ignore _symbol)) 14 (append 15 (label-value-line "Its name is" (symbol-name symbol)) 16 ;; 17 ;; Value 18 (cond ((boundp symbol) 19 (append 20 (label-value-line (if (constantp symbol) 21 "It is a constant of value" 22 "It is a global variable bound to") 23 (symbol-value symbol) :newline nil) 24 ;; unbinding constants might be not a good idea, but 25 ;; implementations usually provide a restart. 26 `(" " (:action "[unbind]" 27 ,(lambda () (makunbound symbol)))) 28 '((:newline)))) 29 (t '("It is unbound." (:newline)))) 30 (docstring-ispec "Documentation" symbol 'variable) 31 (multiple-value-bind (expansion definedp) (macroexpand symbol) 32 (if definedp 33 (label-value-line "It is a symbol macro with expansion" 34 expansion))) 35 ;; 36 ;; Function 37 (if (fboundp symbol) 38 (append (if (macro-function symbol) 39 `("It a macro with macro-function: " 40 (:value ,(macro-function symbol))) 41 `("It is a function: " 42 (:value ,(symbol-function symbol)))) 43 `(" " (:action "[unbind]" 44 ,(lambda () (fmakunbound symbol)))) 45 `((:newline))) 46 `("It has no function value." (:newline))) 47 (docstring-ispec "Function documentation" symbol 'function) 48 (when (compiler-macro-function symbol) 49 (append 50 (label-value-line "It also names the compiler macro" 51 (compiler-macro-function symbol) :newline nil) 52 `(" " (:action "[remove]" 53 ,(lambda () 54 (setf (compiler-macro-function symbol) nil))) 55 (:newline)))) 56 (docstring-ispec "Compiler macro documentation" 57 symbol 'compiler-macro) 58 ;; 59 ;; Package 60 (if package 61 `("It is " ,(string-downcase (string status)) 62 " to the package: " 63 (:value ,package ,(package-name package)) 64 ,@(if (eq :internal status) 65 `(" " 66 (:action "[export]" 67 ,(lambda () (export symbol package))))) 68 " " 69 (:action "[unintern]" 70 ,(lambda () (unintern symbol package))) 71 (:newline)) 72 '("It is a non-interned symbol." (:newline))) 73 ;; 74 ;; Plist 75 (label-value-line "Property list" (symbol-plist symbol)) 76 ;; 77 ;; Class 78 (if (find-class symbol nil) 79 `("It names the class " 80 (:value ,(find-class symbol) ,(string symbol)) 81 " " 82 (:action "[remove]" 83 ,(lambda () (setf (find-class symbol) nil))) 84 (:newline))) 85 ;; 86 ;; More package 87 (if (find-package symbol) 88 (label-value-line "It names the package" (find-package symbol))) 89 (inspect-type-specifier symbol))))) 90 91 #-sbcl 92 (defun inspect-type-specifier (symbol) 93 (declare (ignore symbol))) 94 95 #+sbcl 96 (defun inspect-type-specifier (symbol) 97 (let* ((kind (sb-int:info :type :kind symbol)) 98 (fun (case kind 99 (:defined 100 (or (sb-int:info :type :expander symbol) t)) 101 (:primitive 102 (or #.(if (slynk-sbcl::sbcl-version>= 1 3 1) 103 '(let ((x (sb-int:info :type :expander symbol))) 104 (if (consp x) 105 (car x) 106 x)) 107 '(sb-int:info :type :translator symbol)) 108 t))))) 109 (when fun 110 (append 111 (list 112 (format nil "It names a ~@[primitive~* ~]type-specifier." 113 (eq kind :primitive)) 114 '(:newline)) 115 (docstring-ispec "Type-specifier documentation" symbol 'type) 116 (unless (eq t fun) 117 (let ((arglist (arglist fun))) 118 (append 119 `("Type-specifier lambda-list: " 120 ;; Could use ~:s, but inspector-princ does a bit more, 121 ;; and not all NILs in the arglist should be printed that way. 122 ,(if arglist 123 (inspector-princ arglist) 124 "()") 125 (:newline)) 126 (multiple-value-bind (expansion ok) 127 (handler-case (sb-ext:typexpand-1 symbol) 128 (error () (values nil nil))) 129 (when ok 130 (list "Type-specifier expansion: " 131 (princ-to-string expansion))))))))))) 132 133 (defun docstring-ispec (label object kind) 134 "Return a inspector spec if OBJECT has a docstring of kind KIND." 135 (let ((docstring (documentation object kind))) 136 (cond ((not docstring) nil) 137 ((< (+ (length label) (length docstring)) 138 75) 139 (list label ": " docstring '(:newline))) 140 (t 141 (list label ":" '(:newline) " " docstring '(:newline)))))) 142 143 (unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil) 144 (defmethod emacs-inspect ((f function)) 145 (inspect-function f))) 146 147 (defun inspect-function (f) 148 (append 149 (label-value-line "Name" (function-name f)) 150 `("Its argument list is: " 151 ,(inspector-princ (arglist f)) (:newline)) 152 (docstring-ispec "Documentation" f t) 153 (if (function-lambda-expression f) 154 (label-value-line "Lambda Expression" 155 (function-lambda-expression f))))) 156 157 (defun method-specializers-for-inspect (method) 158 "Return a \"pretty\" list of the method's specializers. Normal 159 specializers are replaced by the name of the class, eql 160 specializers are replaced by `(eql ,object)." 161 (mapcar (lambda (spec) 162 (typecase spec 163 (slynk-mop:eql-specializer 164 `(eql ,(slynk-mop:eql-specializer-object spec))) 165 #-sbcl 166 (t 167 (slynk-mop:class-name spec)) 168 #+sbcl 169 (t 170 ;; SBCL has extended specializers 171 (let ((gf (sb-mop:method-generic-function method))) 172 (cond (gf 173 (sb-pcl:unparse-specializer-using-class gf spec)) 174 ((typep spec 'class) 175 (class-name spec)) 176 (t 177 spec)))))) 178 (slynk-mop:method-specializers method))) 179 180 (defun method-for-inspect-value (method) 181 "Returns a \"pretty\" list describing METHOD. The first element 182 of the list is the name of generic-function method is 183 specialiazed on, the second element is the method qualifiers, 184 the rest of the list is the method's specialiazers (as per 185 method-specializers-for-inspect)." 186 (append (list (slynk-mop:generic-function-name 187 (slynk-mop:method-generic-function method))) 188 (slynk-mop:method-qualifiers method) 189 (method-specializers-for-inspect method))) 190 191 (defmethod emacs-inspect ((object standard-object)) 192 (let ((class (class-of object))) 193 `("Class: " (:value ,class) (:newline) 194 ,@(all-slots-for-inspector object)))) 195 196 (defvar *gf-method-getter* 'methods-by-applicability 197 "This function is called to get the methods of a generic function. 198 The default returns the method sorted by applicability. 199 See `methods-by-applicability'.") 200 201 (defun specializer< (specializer1 specializer2) 202 "Return true if SPECIALIZER1 is more specific than SPECIALIZER2." 203 (let ((s1 specializer1) (s2 specializer2) ) 204 (cond ((typep s1 'slynk-mop:eql-specializer) 205 (not (typep s2 'slynk-mop:eql-specializer))) 206 ((typep s1 'class) 207 (flet ((cpl (class) 208 (and (slynk-mop:class-finalized-p class) 209 (slynk-mop:class-precedence-list class)))) 210 (member s2 (cpl s1))))))) 211 212 (defun methods-by-applicability (gf) 213 "Return methods ordered by most specific argument types. 214 215 `method-specializer<' is used for sorting." 216 ;; FIXME: argument-precedence-order and qualifiers are ignored. 217 (labels ((method< (meth1 meth2) 218 (loop for s1 in (slynk-mop:method-specializers meth1) 219 for s2 in (slynk-mop:method-specializers meth2) 220 do (cond ((specializer< s2 s1) (return nil)) 221 ((specializer< s1 s2) (return t)))))) 222 (stable-sort (copy-seq (slynk-mop:generic-function-methods gf)) 223 #'method<))) 224 225 (defun abbrev-doc (doc &optional (maxlen 80)) 226 "Return the first sentence of DOC, but not more than MAXLAN characters." 227 (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen))) 228 maxlen 229 (length doc)))) 230 231 (defstruct (inspector-checklist (:conc-name checklist.) 232 (:constructor %make-checklist (buttons))) 233 (buttons nil :type (or null simple-vector)) 234 (count 0)) 235 236 (defun make-checklist (n) 237 (%make-checklist (make-array n :initial-element nil))) 238 239 (defun reinitialize-checklist (checklist) 240 ;; Along this counter the buttons are created, so we have to 241 ;; initialize it to 0 everytime the inspector page is redisplayed. 242 (setf (checklist.count checklist) 0) 243 checklist) 244 245 (defun make-checklist-button (checklist) 246 (let ((buttons (checklist.buttons checklist)) 247 (i (checklist.count checklist))) 248 (incf (checklist.count checklist)) 249 `(:action ,(if (svref buttons i) 250 "[X]" 251 "[ ]") 252 ,#'(lambda () 253 (setf (svref buttons i) (not (svref buttons i)))) 254 :refreshp t))) 255 256 (defmacro do-checklist ((idx checklist) &body body) 257 "Iterate over all set buttons in CHECKLIST." 258 (let ((buttons (gensym "buttons"))) 259 `(let ((,buttons (checklist.buttons ,checklist))) 260 (dotimes (,idx (length ,buttons)) 261 (when (svref ,buttons ,idx) 262 ,@body))))) 263 264 (defun box (thing) (cons :box thing)) 265 (defun ref (box) 266 (assert (eq (car box) :box)) 267 (cdr box)) 268 (defun (setf ref) (value box) 269 (assert (eq (car box) :box)) 270 (setf (cdr box) value)) 271 272 (defvar *inspector-slots-default-order* :alphabetically 273 "Accepted values: :alphabetically and :unsorted") 274 275 (defvar *inspector-slots-default-grouping* :all 276 "Accepted values: :inheritance and :all") 277 278 (defgeneric all-slots-for-inspector (object)) 279 280 (defmethod all-slots-for-inspector ((object standard-object)) 281 (let* ((class (class-of object)) 282 (direct-slots (slynk-mop:class-direct-slots class)) 283 (effective-slots (slynk-mop:class-slots class)) 284 (longest-slot-name-length 285 (loop for slot :in effective-slots 286 maximize (length (symbol-name 287 (slynk-mop:slot-definition-name slot))))) 288 (checklist 289 (reinitialize-checklist 290 (ensure-istate-metadata object :checklist 291 (make-checklist (length effective-slots))))) 292 (grouping-kind 293 ;; We box the value so we can re-set it. 294 (ensure-istate-metadata object :grouping-kind 295 (box *inspector-slots-default-grouping*))) 296 (sort-order 297 (ensure-istate-metadata object :sort-order 298 (box *inspector-slots-default-order*))) 299 (sort-predicate (ecase (ref sort-order) 300 (:alphabetically #'string<) 301 (:unsorted (constantly nil)))) 302 (sorted-slots (sort (copy-seq effective-slots) 303 sort-predicate 304 :key #'slynk-mop:slot-definition-name)) 305 (effective-slots 306 (ecase (ref grouping-kind) 307 (:all sorted-slots) 308 (:inheritance (stable-sort-by-inheritance sorted-slots 309 class sort-predicate))))) 310 `("--------------------" 311 (:newline) 312 " Group slots by inheritance " 313 (:action ,(ecase (ref grouping-kind) 314 (:all "[ ]") 315 (:inheritance "[X]")) 316 ,(lambda () 317 ;; We have to do this as the order of slots will 318 ;; be sorted differently. 319 (fill (checklist.buttons checklist) nil) 320 (setf (ref grouping-kind) 321 (ecase (ref grouping-kind) 322 (:all :inheritance) 323 (:inheritance :all)))) 324 :refreshp t) 325 (:newline) 326 " Sort slots alphabetically " 327 (:action ,(ecase (ref sort-order) 328 (:unsorted "[ ]") 329 (:alphabetically "[X]")) 330 ,(lambda () 331 (fill (checklist.buttons checklist) nil) 332 (setf (ref sort-order) 333 (ecase (ref sort-order) 334 (:unsorted :alphabetically) 335 (:alphabetically :unsorted)))) 336 :refreshp t) 337 (:newline) 338 ,@ (case (ref grouping-kind) 339 (:all 340 `((:newline) 341 "All Slots:" 342 (:newline) 343 ,@(make-slot-listing checklist object class 344 effective-slots direct-slots 345 longest-slot-name-length))) 346 (:inheritance 347 (list-all-slots-by-inheritance checklist object class 348 effective-slots direct-slots 349 longest-slot-name-length))) 350 (:newline) 351 (:action "[set value]" 352 ,(lambda () 353 (do-checklist (idx checklist) 354 (query-and-set-slot class object 355 (nth idx effective-slots)))) 356 :refreshp t) 357 " " 358 (:action "[make unbound]" 359 ,(lambda () 360 (do-checklist (idx checklist) 361 (slynk-mop:slot-makunbound-using-class 362 class object (nth idx effective-slots)))) 363 :refreshp t) 364 (:newline)))) 365 366 (defun list-all-slots-by-inheritance (checklist object class effective-slots 367 direct-slots longest-slot-name-length) 368 (flet ((slot-home-class (slot) 369 (slot-home-class-using-class slot class))) 370 (let ((current-slots '())) 371 (append 372 (loop for slot in effective-slots 373 for previous-home-class = (slot-home-class slot) then home-class 374 for home-class = previous-home-class then (slot-home-class slot) 375 if (eq home-class previous-home-class) 376 do (push slot current-slots) 377 else 378 collect '(:newline) 379 and collect (format nil "~A:" (class-name previous-home-class)) 380 and collect '(:newline) 381 and append (make-slot-listing checklist object class 382 (nreverse current-slots) 383 direct-slots 384 longest-slot-name-length) 385 and do (setf current-slots (list slot))) 386 (and current-slots 387 `((:newline) 388 ,(format nil "~A:" 389 (class-name (slot-home-class-using-class 390 (car current-slots) class))) 391 (:newline) 392 ,@(make-slot-listing checklist object class 393 (nreverse current-slots) direct-slots 394 longest-slot-name-length))))))) 395 396 (defun make-slot-listing (checklist object class effective-slots direct-slots 397 longest-slot-name-length) 398 (flet ((padding-for (slot-name) 399 (make-string (- longest-slot-name-length (length slot-name)) 400 :initial-element #\Space))) 401 (loop 402 for effective-slot :in effective-slots 403 for direct-slot = (find (slynk-mop:slot-definition-name effective-slot) 404 direct-slots 405 :key #'slynk-mop:slot-definition-name) 406 for slot-name = (inspector-princ 407 (slynk-mop:slot-definition-name effective-slot)) 408 collect (make-checklist-button checklist) 409 collect " " 410 collect `(:value ,(if direct-slot 411 (list direct-slot effective-slot) 412 effective-slot) 413 ,slot-name) 414 collect (padding-for slot-name) 415 collect " = " 416 collect (slot-value-for-inspector class object effective-slot) 417 collect '(:newline)))) 418 419 (defgeneric slot-value-for-inspector (class object slot) 420 (:method (class object slot) 421 (let ((boundp (slynk-mop:slot-boundp-using-class class object slot))) 422 (if boundp 423 `(:value ,(slynk-mop:slot-value-using-class class object slot)) 424 "#<unbound>")))) 425 426 (defun slot-home-class-using-class (slot class) 427 (let ((slot-name (slynk-mop:slot-definition-name slot))) 428 (loop for class in (reverse (slynk-mop:class-precedence-list class)) 429 thereis (and (member slot-name (slynk-mop:class-direct-slots class) 430 :key #'slynk-mop:slot-definition-name 431 :test #'eq) 432 class)))) 433 434 (defun stable-sort-by-inheritance (slots class predicate) 435 (stable-sort slots predicate 436 :key #'(lambda (s) 437 (class-name (slot-home-class-using-class s class))))) 438 439 (defun query-and-set-slot (class object slot) 440 (let* ((slot-name (slynk-mop:slot-definition-name slot)) 441 (value-string (read-from-minibuffer-in-emacs 442 (format nil "Set slot ~S to (evaluated) : " 443 slot-name)))) 444 (when (and value-string (not (string= value-string ""))) 445 (with-simple-restart (abort "Abort setting slot ~S" slot-name) 446 (setf (slynk-mop:slot-value-using-class class object slot) 447 (eval (read-from-string value-string))))))) 448 449 450 (defmethod emacs-inspect ((gf standard-generic-function)) 451 (flet ((lv (label value) (label-value-line label value))) 452 (append 453 (lv "Name" (slynk-mop:generic-function-name gf)) 454 (lv "Arguments" (slynk-mop:generic-function-lambda-list gf)) 455 (docstring-ispec "Documentation" gf t) 456 (lv "Method class" (slynk-mop:generic-function-method-class gf)) 457 (lv "Method combination" 458 (slynk-mop:generic-function-method-combination gf)) 459 `("Methods: " (:newline)) 460 (loop for method in (funcall *gf-method-getter* gf) append 461 `((:value ,method ,(inspector-princ 462 ;; drop the name of the GF 463 (cdr (method-for-inspect-value method)))) 464 " " 465 (:action "[remove method]" 466 ,(let ((m method)) ; LOOP reassigns method 467 (lambda () 468 (remove-method gf m)))) 469 (:newline))) 470 `((:newline)) 471 (all-slots-for-inspector gf)))) 472 473 (defmethod emacs-inspect ((method standard-method)) 474 `(,@(if (slynk-mop:method-generic-function method) 475 `("Method defined on the generic function " 476 (:value ,(slynk-mop:method-generic-function method) 477 ,(inspector-princ 478 (slynk-mop:generic-function-name 479 (slynk-mop:method-generic-function method))))) 480 '("Method without a generic function")) 481 (:newline) 482 ,@(docstring-ispec "Documentation" method t) 483 "Lambda List: " (:value ,(slynk-mop:method-lambda-list method)) 484 (:newline) 485 "Specializers: " (:value ,(slynk-mop:method-specializers method) 486 ,(inspector-princ 487 (method-specializers-for-inspect method))) 488 (:newline) 489 "Qualifiers: " (:value ,(slynk-mop:method-qualifiers method)) 490 (:newline) 491 "Method function: " (:value ,(slynk-mop:method-function method)) 492 (:newline) 493 ,@(all-slots-for-inspector method))) 494 495 (defun specializer-direct-methods (class) 496 (sort (copy-seq (slynk-mop:specializer-direct-methods class)) 497 #'string< 498 :key 499 (lambda (x) 500 (symbol-name 501 (let ((name (slynk-mop::generic-function-name 502 (slynk-mop::method-generic-function x)))) 503 (if (symbolp name) 504 name 505 (second name))))))) 506 507 (defmethod emacs-inspect ((class standard-class)) 508 `("Name: " 509 (:value ,(class-name class)) 510 (:newline) 511 "Super classes: " 512 ,@(common-seperated-spec (slynk-mop:class-direct-superclasses class)) 513 (:newline) 514 "Direct Slots: " 515 ,@(common-seperated-spec 516 (slynk-mop:class-direct-slots class) 517 (lambda (slot) 518 `(:value ,slot ,(inspector-princ 519 (slynk-mop:slot-definition-name slot))))) 520 (:newline) 521 "Effective Slots: " 522 ,@(if (slynk-mop:class-finalized-p class) 523 (common-seperated-spec 524 (slynk-mop:class-slots class) 525 (lambda (slot) 526 `(:value ,slot ,(inspector-princ 527 (slynk-mop:slot-definition-name slot))))) 528 `("#<N/A (class not finalized)> " 529 (:action "[finalize]" 530 ,(lambda () (slynk-mop:finalize-inheritance class))))) 531 (:newline) 532 ,@(let ((doc (documentation class t))) 533 (when doc 534 `("Documentation:" (:newline) ,(inspector-princ doc) (:newline)))) 535 "Sub classes: " 536 ,@(common-seperated-spec (slynk-mop:class-direct-subclasses class) 537 (lambda (sub) 538 `(:value ,sub 539 ,(inspector-princ (class-name sub))))) 540 (:newline) 541 "Precedence List: " 542 ,@(if (slynk-mop:class-finalized-p class) 543 (common-seperated-spec 544 (slynk-mop:class-precedence-list class) 545 (lambda (class) 546 `(:value ,class ,(inspector-princ (class-name class))))) 547 '("#<N/A (class not finalized)>")) 548 (:newline) 549 ,@(when (slynk-mop:specializer-direct-methods class) 550 `("It is used as a direct specializer in the following methods:" 551 (:newline) 552 ,@(loop 553 for method in (specializer-direct-methods class) 554 collect " " 555 collect `(:value ,method 556 ,(inspector-princ 557 (method-for-inspect-value method))) 558 collect '(:newline) 559 if (documentation method t) 560 collect " Documentation: " and 561 collect (abbrev-doc (documentation method t)) and 562 collect '(:newline)))) 563 "Prototype: " ,(if (slynk-mop:class-finalized-p class) 564 `(:value ,(slynk-mop:class-prototype class)) 565 '"#<N/A (class not finalized)>") 566 (:newline) 567 ,@(all-slots-for-inspector class))) 568 569 (defmethod emacs-inspect ((slot slynk-mop:standard-slot-definition)) 570 `("Name: " 571 (:value ,(slynk-mop:slot-definition-name slot)) 572 (:newline) 573 ,@(when (slynk-mop:slot-definition-documentation slot) 574 `("Documentation:" (:newline) 575 (:value ,(slynk-mop:slot-definition-documentation 576 slot)) 577 (:newline))) 578 "Init args: " 579 (:value ,(slynk-mop:slot-definition-initargs slot)) 580 (:newline) 581 "Init form: " 582 ,(if (slynk-mop:slot-definition-initfunction slot) 583 `(:value ,(slynk-mop:slot-definition-initform slot)) 584 "#<unspecified>") 585 (:newline) 586 "Init function: " 587 (:value ,(slynk-mop:slot-definition-initfunction slot)) 588 (:newline) 589 ,@(all-slots-for-inspector slot))) 590 591 592 ;; Wrapper structure over the list of symbols of a package that should 593 ;; be displayed with their respective classification flags. This is 594 ;; because we need a unique type to dispatch on in EMACS-INSPECT. 595 ;; Used by the Inspector for packages. 596 (defstruct (%package-symbols-container 597 (:conc-name %container.) 598 (:constructor %%make-package-symbols-container)) 599 title ;; A string; the title of the inspector page in Emacs. 600 description ;; A list of renderable objects; used as description. 601 symbols ;; A list of symbols. Supposed to be sorted alphabetically. 602 grouping-kind) ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING 603 604 605 (defun %make-package-symbols-container (&key title description symbols) 606 (%%make-package-symbols-container :title title :description description 607 :symbols symbols :grouping-kind :symbol)) 608 609 (defun symbol-classification-string (symbol) 610 "Return a string in the form -f-c---- where each letter stands for 611 boundp fboundp generic-function class macro special-operator package" 612 (let ((letters "bfgctmsp") 613 (result (copy-seq "--------"))) 614 (flet ((flip (letter) 615 (setf (char result (position letter letters)) 616 letter))) 617 (when (boundp symbol) (flip #\b)) 618 (when (fboundp symbol) 619 (flip #\f) 620 (when (typep (ignore-errors (fdefinition symbol)) 621 'generic-function) 622 (flip #\g))) 623 (when (type-specifier-p symbol) (flip #\t)) 624 (when (find-class symbol nil) (flip #\c) ) 625 (when (macro-function symbol) (flip #\m)) 626 (when (special-operator-p symbol) (flip #\s)) 627 (when (find-package symbol) (flip #\p)) 628 result))) 629 630 (defgeneric make-symbols-listing (grouping-kind symbols)) 631 632 (defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols) 633 "Returns an object renderable by Emacs' inspector side that 634 alphabetically lists all the symbols in SYMBOLS together with a 635 concise string representation of what each symbol 636 represents (see SYMBOL-CLASSIFICATION-STRING)" 637 (let ((max-length (loop for s in symbols 638 maximizing (length (symbol-name s)))) 639 (distance 10)) ; empty distance between name and classification 640 (flet ((string-representations (symbol) 641 (let* ((name (symbol-name symbol)) 642 (length (length name)) 643 (padding (- max-length length))) 644 (values 645 (concatenate 'string 646 name 647 (make-string (+ padding distance) 648 :initial-element #\Space)) 649 (symbol-classification-string symbol))))) 650 `("" ; 8 is (length "Symbols:") 651 "Symbols:" ,(make-string (+ -8 max-length distance) 652 :initial-element #\Space) 653 "Flags:" 654 (:newline) 655 ,(concatenate 'string ; underlining dashes 656 (make-string (+ max-length distance -1) 657 :initial-element #\-) 658 " " 659 (symbol-classification-string '#:foo)) 660 (:newline) 661 ,@(loop for symbol in symbols appending 662 (multiple-value-bind (symbol-string classification-string) 663 (string-representations symbol) 664 `((:value ,symbol ,symbol-string) ,classification-string 665 (:newline) 666 ))))))) 667 668 (defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols) 669 "For each possible classification (cf. CLASSIFY-SYMBOL), group 670 all the symbols in SYMBOLS to all of their respective 671 classifications. (If a symbol is, for instance, boundp and a 672 generic-function, it'll appear both below the BOUNDP group and 673 the GENERIC-FUNCTION group.) As macros and special-operators are 674 specified to be FBOUNDP, there is no general FBOUNDP group, 675 instead there are the three explicit FUNCTION, MACRO and 676 SPECIAL-OPERATOR groups." 677 (let ((table (make-hash-table :test #'eq)) 678 (+default-classification+ :misc)) 679 (flet ((normalize-classifications (classifications) 680 (cond ((null classifications) `(,+default-classification+)) 681 ;; Convert an :FBOUNDP in CLASSIFICATIONS to 682 ;; :FUNCTION if possible. 683 ((and (member :fboundp classifications) 684 (not (member :macro classifications)) 685 (not (member :special-operator classifications))) 686 (substitute :function :fboundp classifications)) 687 (t (remove :fboundp classifications))))) 688 (loop for symbol in symbols do 689 (loop for classification in 690 (normalize-classifications (classify-symbol symbol)) 691 ;; SYMBOLS are supposed to be sorted alphabetically; 692 ;; this property is preserved here except for reversing. 693 do (push symbol (gethash classification table))))) 694 (let* ((classifications (loop for k being each hash-key in table 695 collect k)) 696 (classifications (sort classifications 697 ;; Sort alphabetically, except 698 ;; +DEFAULT-CLASSIFICATION+ which 699 ;; sort to the end. 700 (lambda (a b) 701 (cond ((eql a +default-classification+) 702 nil) 703 ((eql b +default-classification+) 704 t) 705 (t (string< a b))))))) 706 (loop for classification in classifications 707 for symbols = (gethash classification table) 708 appending`(,(symbol-name classification) 709 (:newline) 710 ,(make-string 64 :initial-element #\-) 711 (:newline) 712 ,@(mapcan (lambda (symbol) 713 `((:value ,symbol ,(symbol-name symbol)) 714 (:newline))) 715 ;; restore alphabetic order. 716 (nreverse symbols)) 717 (:newline)))))) 718 719 (defmethod emacs-inspect ((%container %package-symbols-container)) 720 (with-struct (%container. title description symbols grouping-kind) %container 721 `(,title (:newline) (:newline) 722 ,@description 723 (:newline) 724 " " ,(ecase grouping-kind 725 (:symbol 726 `(:action "[Group by classification]" 727 ,(lambda () 728 (setf grouping-kind :classification)) 729 :refreshp t)) 730 (:classification 731 `(:action "[Group by symbol]" 732 ,(lambda () (setf grouping-kind :symbol)) 733 :refreshp t))) 734 (:newline) (:newline) 735 ,@(make-symbols-listing grouping-kind symbols)))) 736 737 (defun display-link (type symbols length &key title description) 738 (if (null symbols) 739 (format nil "0 ~A symbols." type) 740 `(:value ,(%make-package-symbols-container :title title 741 :description description 742 :symbols symbols) 743 ,(format nil "~D ~A symbol~P." length type length)))) 744 745 (defmacro do-symbols* ((var &optional (package '*package*) result-form) 746 &body body) 747 "Just like do-symbols, but makes sure a symbol is visited only once." 748 (let ((seen-ht (gensym "SEEN-HT"))) 749 `(let ((,seen-ht (make-hash-table :test #'eq))) 750 (do-symbols (,var ,package ,result-form) 751 (unless (gethash ,var ,seen-ht) 752 (setf (gethash ,var ,seen-ht) t) 753 (tagbody ,@body)))))) 754 755 (defmethod emacs-inspect ((package package)) 756 (let ((package-name (package-name package)) 757 (package-nicknames (package-nicknames package)) 758 (package-use-list (package-use-list package)) 759 (package-used-by-list (package-used-by-list package)) 760 (shadowed-symbols (package-shadowing-symbols package)) 761 (present-symbols '()) (present-symbols-length 0) 762 (internal-symbols '()) (internal-symbols-length 0) 763 (inherited-symbols '()) (inherited-symbols-length 0) 764 (external-symbols '()) (external-symbols-length 0)) 765 766 (do-symbols* (sym package) 767 (let ((status (symbol-status sym package))) 768 (when (eq status :inherited) 769 (push sym inherited-symbols) (incf inherited-symbols-length) 770 (go :continue)) 771 (push sym present-symbols) (incf present-symbols-length) 772 (cond ((eq status :internal) 773 (push sym internal-symbols) (incf internal-symbols-length)) 774 (t 775 (push sym external-symbols) (incf external-symbols-length)))) 776 :continue) 777 778 (setf package-nicknames (sort (copy-list package-nicknames) 779 #'string<) 780 package-use-list (sort (copy-list package-use-list) 781 #'string< :key #'package-name) 782 package-used-by-list (sort (copy-list package-used-by-list) 783 #'string< :key #'package-name) 784 shadowed-symbols (sort (copy-list shadowed-symbols) 785 #'string<)) 786 ;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18. 787 (setf present-symbols (sort present-symbols #'string<) 788 internal-symbols (sort internal-symbols #'string<) 789 external-symbols (sort external-symbols #'string<) 790 inherited-symbols (sort inherited-symbols #'string<)) 791 `("" ;; dummy to preserve indentation. 792 "Name: " (:value ,package-name) (:newline) 793 794 "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline) 795 796 ,@(when (documentation package t) 797 `("Documentation:" (:newline) 798 ,(documentation package t) (:newline))) 799 800 "Use list: " ,@(common-seperated-spec 801 package-use-list 802 (lambda (package) 803 `(:value ,package ,(package-name package)))) 804 (:newline) 805 806 "Used by list: " ,@(common-seperated-spec 807 package-used-by-list 808 (lambda (package) 809 `(:value ,package ,(package-name package)))) 810 (:newline) 811 812 ,(display-link "present" present-symbols present-symbols-length 813 :title 814 (format nil "All present symbols of package \"~A\"" 815 package-name) 816 :description 817 '("A symbol is considered present in a package if it's" 818 (:newline) 819 "\"accessible in that package directly, rather than" 820 (:newline) 821 "being inherited from another package.\"" 822 (:newline) 823 "(CLHS glossary entry for `present')" 824 (:newline))) 825 826 (:newline) 827 ,(display-link "external" external-symbols external-symbols-length 828 :title 829 (format nil "All external symbols of package \"~A\"" 830 package-name) 831 :description 832 '("A symbol is considered external of a package if it's" 833 (:newline) 834 "\"part of the `external interface' to the package and" 835 (:newline) 836 "[is] inherited by any other package that uses the" 837 (:newline) 838 "package.\" (CLHS glossary entry of `external')" 839 (:newline))) 840 (:newline) 841 ,(display-link "internal" internal-symbols internal-symbols-length 842 :title 843 (format nil "All internal symbols of package \"~A\"" 844 package-name) 845 :description 846 '("A symbol is considered internal of a package if it's" 847 (:newline) 848 "present and not external---that is if the package is" 849 (:newline) 850 "the home package of the symbol, or if the symbol has" 851 (:newline) 852 "been explicitly imported into the package." 853 (:newline) 854 (:newline) 855 "Notice that inherited symbols will thus not be listed," 856 (:newline) 857 "which deliberately deviates from the CLHS glossary" 858 (:newline) 859 "entry of `internal' because it's assumed to be more" 860 (:newline) 861 "useful this way." 862 (:newline))) 863 (:newline) 864 ,(display-link "inherited" inherited-symbols inherited-symbols-length 865 :title 866 (format nil "All inherited symbols of package \"~A\"" 867 package-name) 868 :description 869 '("A symbol is considered inherited in a package if it" 870 (:newline) 871 "was made accessible via USE-PACKAGE." 872 (:newline))) 873 (:newline) 874 ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols) 875 :title 876 (format nil "All shadowed symbols of package \"~A\"" 877 package-name) 878 :description nil)))) 879 880 881 (defmethod emacs-inspect ((pathname pathname)) 882 `(,(if (wild-pathname-p pathname) 883 "A wild pathname." 884 "A pathname.") 885 (:newline) 886 ,@(label-value-line* 887 ("Namestring" (namestring pathname)) 888 ("Host" (pathname-host pathname)) 889 ("Device" (pathname-device pathname)) 890 ("Directory" (pathname-directory pathname)) 891 ("Name" (pathname-name pathname)) 892 ("Type" (pathname-type pathname)) 893 ("Version" (pathname-version pathname))) 894 ,@ (unless (or (wild-pathname-p pathname) 895 (not (probe-file pathname))) 896 (label-value-line "Truename" (truename pathname))))) 897 898 (defmethod emacs-inspect ((pathname logical-pathname)) 899 (append 900 (label-value-line* 901 ("Namestring" (namestring pathname)) 902 ("Physical pathname: " (translate-logical-pathname pathname))) 903 `("Host: " 904 (:value ,(pathname-host pathname)) 905 " (" 906 (:value ,(logical-pathname-translations 907 (pathname-host pathname))) 908 " other translations)" 909 (:newline)) 910 (label-value-line* 911 ("Directory" (pathname-directory pathname)) 912 ("Name" (pathname-name pathname)) 913 ("Type" (pathname-type pathname)) 914 ("Version" (pathname-version pathname)) 915 ("Truename" (if (not (wild-pathname-p pathname)) 916 (probe-file pathname)))))) 917 918 (defmethod emacs-inspect ((n number)) 919 `("Value: " ,(princ-to-string n))) 920 921 (defun format-iso8601-time (time-value &optional include-timezone-p) 922 "Formats a universal time TIME-VALUE in ISO 8601 format, with 923 the time zone included if INCLUDE-TIMEZONE-P is non-NIL" 924 ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html 925 ;; Thanks, Nikolai Sandved and Thomas Russ! 926 (flet ((format-iso8601-timezone (zone) 927 (if (zerop zone) 928 "Z" 929 (multiple-value-bind (h m) (truncate (abs zone) 1.0) 930 ;; Tricky. Sign of time zone is reversed in ISO 8601 931 ;; relative to Common Lisp convention! 932 (format nil "~:[+~;-~]~2,'0D:~2,'0D" 933 (> zone 0) h (round (* 60 m))))))) 934 (multiple-value-bind (second minute hour day month year dow dst zone) 935 (decode-universal-time time-value) 936 (declare (ignore dow)) 937 (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" 938 year month day hour minute second 939 include-timezone-p (format-iso8601-timezone (if dst 940 (+ zone 1) 941 zone)))))) 942 943 (defmethod emacs-inspect ((i integer)) 944 (append 945 `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]" 946 i i i i (ignore-errors (coerce i 'float))) 947 (:newline)) 948 (when (< -1 i char-code-limit) 949 (label-value-line "Code-char" (code-char i))) 950 (label-value-line "Integer-length" (integer-length i)) 951 (ignore-errors 952 (label-value-line "Universal-time" (format-iso8601-time i t))))) 953 954 (defmethod emacs-inspect ((c complex)) 955 (label-value-line* 956 ("Real part" (realpart c)) 957 ("Imaginary part" (imagpart c)))) 958 959 (defmethod emacs-inspect ((r ratio)) 960 (label-value-line* 961 ("Numerator" (numerator r)) 962 ("Denominator" (denominator r)) 963 ("As float" (float r)))) 964 965 (defmethod emacs-inspect ((f float)) 966 (cond 967 ((float-nan-p f) 968 ;; try NaN first because the next tests may perform operations 969 ;; that are undefined for NaNs. 970 (list "Not a Number.")) 971 ((not (float-infinity-p f)) 972 (multiple-value-bind (significand exponent sign) (decode-float f) 973 (append 974 `("Scientific: " ,(format nil "~E" f) (:newline) 975 "Decoded: " 976 (:value ,sign) " * " 977 (:value ,significand) " * " 978 (:value ,(float-radix f)) "^" 979 (:value ,exponent) (:newline)) 980 (label-value-line "Digits" (float-digits f)) 981 (label-value-line "Precision" (float-precision f))))) 982 ((> f 0) 983 (list "Positive infinity.")) 984 ((< f 0) 985 (list "Negative infinity.")))) 986 987 (defun make-pathname-ispec (pathname position) 988 `("Pathname: " 989 (:value ,pathname) 990 (:newline) " " 991 ,@(when position 992 `((:action "[visit file and show current position]" 993 ,(lambda () 994 (ed-in-emacs `(,pathname :position ,position :bytep t))) 995 :refreshp nil) 996 (:newline))))) 997 998 (defun make-file-stream-ispec (stream) 999 ;; SBCL's socket stream are file-stream but are not associated to 1000 ;; any pathname. 1001 (let ((pathname (ignore-errors (pathname stream)))) 1002 (when pathname 1003 (make-pathname-ispec pathname (and (open-stream-p stream) 1004 (file-position stream)))))) 1005 1006 (defmethod emacs-inspect ((stream file-stream)) 1007 (multiple-value-bind (content) 1008 (call-next-method) 1009 (append (make-file-stream-ispec stream) content))) 1010 1011 (defmethod emacs-inspect ((condition stream-error)) 1012 (multiple-value-bind (content) 1013 (call-next-method) 1014 (let ((stream (stream-error-stream condition))) 1015 (append (when (typep stream 'file-stream) 1016 (make-file-stream-ispec stream)) 1017 content)))) 1018 1019 (defun common-seperated-spec (list &optional (callback (lambda (v) 1020 `(:value ,v)))) 1021 (butlast 1022 (loop 1023 for i in list 1024 collect (funcall callback i) 1025 collect ", "))) 1026 1027 (defun inspector-princ (list) 1028 "Like princ-to-string, but don't rewrite (function foo) as #'foo. 1029 Do NOT pass circular lists to this function." 1030 (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) 1031 (set-pprint-dispatch '(cons (member function)) nil) 1032 (princ-to-string list))) 1033 1034 (provide :slynk/fancy-inspector)