← Back to branch summary

~ubuntu-branches/ubuntu/maverick/slime/maverick

« back to all changes in this revision

Viewing changes to contrib/swank-fancy-inspector.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2007-10-04 09:09:47 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20071004090947-8oy7djtx8no3erxy
Tags: 1:20070927-2
http://bugs.debian.org/445174
Readded tree-widget to the sources. emacs21 on
debian does _not_ have that file. emacs22 and xemacs do.
(Closes: #445174)

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/swank-fancy-inspector.lisp
 
1
;;; swank-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 :swank)
 
8
 
 
9
;; Subclass `backend-inspector' so that backend specific methods are
 
10
;; also considered.
 
11
(defclass fancy-inspector (backend-inspector) ())
 
12
 
 
13
(defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector))
 
14
  (declare (ignore inspector))
 
15
  (let ((package (symbol-package symbol)))
 
16
    (multiple-value-bind (_symbol status) 
 
17
        (and package (find-symbol (string symbol) package))
 
18
      (declare (ignore _symbol))
 
19
      (values 
 
20
       "A symbol."
 
21
       (append
 
22
        (label-value-line "Its name is" (symbol-name symbol))
 
23
        ;;
 
24
        ;; Value 
 
25
        (cond ((boundp symbol)
 
26
               (label-value-line (if (constantp symbol)
 
27
                                     "It is a constant of value"
 
28
                                     "It is a global variable bound to")
 
29
                                 (symbol-value symbol)))
 
30
              (t '("It is unbound." (:newline))))
 
31
        (docstring-ispec "Documentation" symbol 'variable)
 
32
        (multiple-value-bind (expansion definedp) (macroexpand symbol)
 
33
          (if definedp 
 
34
              (label-value-line "It is a symbol macro with expansion" 
 
35
                                expansion)))
 
36
        ;;
 
37
        ;; Function
 
38
        (if (fboundp symbol)
 
39
            (append (if (macro-function symbol)
 
40
                        `("It a macro with macro-function: "
 
41
                          (:value ,(macro-function symbol)))
 
42
                        `("It is a function: " 
 
43
                          (:value ,(symbol-function symbol))))
 
44
                    `(" " (:action "[make funbound]"
 
45
                                   ,(lambda () (fmakunbound symbol))))
 
46
                    `((:newline)))
 
47
            `("It has no function value." (:newline)))
 
48
        (docstring-ispec "Function Documentation" symbol 'function)
 
49
        (if (compiler-macro-function symbol)
 
50
            (label-value-line "It also names the compiler macro"
 
51
                              (compiler-macro-function symbol)))
 
52
        (docstring-ispec "Compiler Macro Documentation" 
 
53
                         symbol 'compiler-macro)
 
54
        ;;
 
55
        ;; Package
 
56
        (if package
 
57
            `("It is " ,(string-downcase (string status)) 
 
58
                       " to the package: "
 
59
                       (:value ,package ,(package-name package))
 
60
                       ,@(if (eq :internal status) 
 
61
                             `(" "
 
62
                               (:action "[export it]"
 
63
                                        ,(lambda () (export symbol package)))))
 
64
                       " "
 
65
                       (:action "[unintern it]"
 
66
                                ,(lambda () (unintern symbol package)))
 
67
                       (:newline))
 
68
            '("It is a non-interned symbol." (:newline)))
 
69
        ;;
 
70
        ;; Plist
 
71
        (label-value-line "Property list" (symbol-plist symbol))
 
72
        ;; 
 
73
        ;; Class
 
74
        (if (find-class symbol nil)
 
75
            `("It names the class " 
 
76
              (:value ,(find-class symbol) ,(string symbol))
 
77
              " "
 
78
              (:action "[remove]"
 
79
                       ,(lambda () (setf (find-class symbol) nil)))
 
80
              (:newline)))
 
81
        ;;
 
82
        ;; More package
 
83
        (if (find-package symbol)
 
84
            (label-value-line "It names the package" (find-package symbol)))
 
85
        )))))
 
86
 
 
87
(defun docstring-ispec (label object kind)
 
88
  "Return a inspector spec if OBJECT has a docstring of of kind KIND."
 
89
  (let ((docstring (documentation object kind)))
 
90
    (cond ((not docstring) nil)
 
91
          ((< (+ (length label) (length docstring))
 
92
              75)
 
93
           (list label ": " docstring '(:newline)))
 
94
          (t 
 
95
           (list label ": " '(:newline) "  " docstring '(:newline))))))
 
96
 
 
97
(defmethod inspect-for-emacs ((f function) (inspector fancy-inspector))
 
98
  (declare (ignore inspector))
 
99
  (values "A function."
 
100
          (append 
 
101
           (label-value-line "Name" (function-name f))
 
102
           `("Its argument list is: " 
 
103
             ,(inspector-princ (arglist f)) (:newline))
 
104
           (docstring-ispec "Documentation" f t)
 
105
           (if (function-lambda-expression f)
 
106
               (label-value-line "Lambda Expression"
 
107
                                 (function-lambda-expression f))))))
 
108
 
 
109
(defun method-specializers-for-inspect (method)
 
110
  "Return a \"pretty\" list of the method's specializers. Normal
 
111
  specializers are replaced by the name of the class, eql
 
112
  specializers are replaced by `(eql ,object)."
 
113
  (mapcar (lambda (spec)
 
114
            (typecase spec
 
115
              (swank-mop:eql-specializer
 
116
               `(eql ,(swank-mop:eql-specializer-object spec)))
 
117
              (t (swank-mop:class-name spec))))
 
118
          (swank-mop:method-specializers method)))
 
119
 
 
120
(defun method-for-inspect-value (method)
 
121
  "Returns a \"pretty\" list describing METHOD. The first element
 
122
  of the list is the name of generic-function method is
 
123
  specialiazed on, the second element is the method qualifiers,
 
124
  the rest of the list is the method's specialiazers (as per
 
125
  method-specializers-for-inspect)."
 
126
  (append (list (swank-mop:generic-function-name
 
127
                 (swank-mop:method-generic-function method)))
 
128
          (swank-mop:method-qualifiers method)
 
129
          (method-specializers-for-inspect method)))
 
130
 
 
131
(defmethod inspect-for-emacs ((object standard-object) 
 
132
                              (inspector fancy-inspector))
 
133
  (let ((class (class-of object)))
 
134
    (values "An object."
 
135
            `("Class: " (:value ,class) (:newline)
 
136
              ,@(all-slots-for-inspector object inspector)))))
 
137
 
 
138
(defvar *gf-method-getter* 'methods-by-applicability
 
139
  "This function is called to get the methods of a generic function.
 
140
The default returns the method sorted by applicability.
 
141
See `methods-by-applicability'.")
 
142
 
 
143
(defun specializer< (specializer1 specializer2)
 
144
  "Return true if SPECIALIZER1 is more specific than SPECIALIZER2."
 
145
  (let ((s1 specializer1) (s2 specializer2) )
 
146
    (cond ((typep s1 'swank-mop:eql-specializer)
 
147
           (not (typep s2 'swank-mop:eql-specializer)))
 
148
          (t
 
149
           (flet ((cpl (class)
 
150
                    (and (swank-mop:class-finalized-p class)
 
151
                         (swank-mop:class-precedence-list class))))
 
152
             (member s2 (cpl s1)))))))
 
153
 
 
154
(defun methods-by-applicability (gf)
 
155
  "Return methods ordered by most specific argument types.
 
156
 
 
157
`method-specializer<' is used for sorting."
 
158
  ;; FIXME: argument-precedence-order and qualifiers are ignored.  
 
159
  (labels ((method< (meth1 meth2)
 
160
             (loop for s1 in (swank-mop:method-specializers meth1)
 
161
                   for s2 in (swank-mop:method-specializers meth2)
 
162
                   do (cond ((specializer< s2 s1) (return nil))
 
163
                            ((specializer< s1 s2) (return t))))))
 
164
    (stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<)))
 
165
 
 
166
(defun abbrev-doc (doc &optional (maxlen 80))
 
167
  "Return the first sentence of DOC, but not more than MAXLAN characters."
 
168
  (subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen)))
 
169
                     maxlen
 
170
                     (length doc))))
 
171
 
 
172
(defgeneric inspect-slot-for-emacs (class object slot)
 
173
  (:method (class object slot)
 
174
           (let ((slot-name (swank-mop:slot-definition-name slot))
 
175
                 (boundp (swank-mop:slot-boundp-using-class class object slot)))
 
176
             `(,@(if boundp
 
177
                     `((:value ,(swank-mop:slot-value-using-class class object slot)))
 
178
                     `("#<unbound>"))
 
179
               " "
 
180
               (:action "[set value]"
 
181
                ,(lambda () (with-simple-restart
 
182
                                (abort "Abort setting slot ~S" slot-name)
 
183
                              (let ((value-string (eval-in-emacs
 
184
                                                   `(condition-case c
 
185
                                                     (slime-read-object
 
186
                                                      ,(format nil "Set slot ~S to (evaluated) : " slot-name))
 
187
                                                     (quit nil)))))
 
188
                                (when (and value-string
 
189
                                           (not (string= value-string "")))
 
190
                                  (setf (swank-mop:slot-value-using-class class object slot)
 
191
                                        (eval (read-from-string value-string))))))))
 
192
               ,@(when boundp
 
193
                   `(" " (:action "[make unbound]"
 
194
                          ,(lambda () (swank-mop:slot-makunbound-using-class class object slot)))))))))
 
195
 
 
196
(defgeneric all-slots-for-inspector (object inspector)
 
197
  (:method ((object standard-object) inspector)
 
198
    (declare (ignore inspector))
 
199
    (append '("--------------------" (:newline)
 
200
              "All Slots:" (:newline))
 
201
            (let* ((class (class-of object))
 
202
                   (direct-slots (swank-mop:class-direct-slots class))
 
203
                   (effective-slots (sort (copy-seq (swank-mop:class-slots class))
 
204
                                          #'string< :key #'swank-mop:slot-definition-name))
 
205
                   (slot-presentations (loop for effective-slot :in effective-slots
 
206
                                             collect (inspect-slot-for-emacs
 
207
                                                      class object effective-slot)))
 
208
                   (longest-slot-name-length
 
209
                    (loop for slot :in effective-slots
 
210
                          maximize (length (symbol-name
 
211
                                            (swank-mop:slot-definition-name slot))))))
 
212
              (loop
 
213
                  for effective-slot :in effective-slots
 
214
                  for slot-presentation :in slot-presentations
 
215
                  for direct-slot = (find (swank-mop:slot-definition-name effective-slot)
 
216
                                          direct-slots :key #'swank-mop:slot-definition-name)
 
217
                  for slot-name = (inspector-princ
 
218
                                   (swank-mop:slot-definition-name effective-slot))
 
219
                  for padding-length = (- longest-slot-name-length
 
220
                                          (length (symbol-name
 
221
                                                   (swank-mop:slot-definition-name
 
222
                                                    effective-slot))))
 
223
                  collect `(:value ,(if direct-slot
 
224
                                        (list direct-slot effective-slot)
 
225
                                        effective-slot)
 
226
                            ,slot-name)
 
227
                  collect (make-array padding-length
 
228
                                      :element-type 'character
 
229
                                      :initial-element #\Space)
 
230
                  collect " = "
 
231
                  append slot-presentation
 
232
                  collect '(:newline))))))
 
233
 
 
234
(defmethod inspect-for-emacs ((gf standard-generic-function) 
 
235
                              (inspector fancy-inspector)) 
 
236
  (flet ((lv (label value) (label-value-line label value)))
 
237
    (values 
 
238
     "A generic function."
 
239
     (append 
 
240
      (lv "Name" (swank-mop:generic-function-name gf))
 
241
      (lv "Arguments" (swank-mop:generic-function-lambda-list gf))
 
242
      (docstring-ispec "Documentation" gf t)
 
243
      (lv "Method class" (swank-mop:generic-function-method-class gf))
 
244
      (lv "Method combination" 
 
245
          (swank-mop:generic-function-method-combination gf))
 
246
      `("Methods: " (:newline))
 
247
      (loop for method in (funcall *gf-method-getter* gf) append
 
248
            `((:value ,method ,(inspector-princ
 
249
                               ;; drop the name of the GF
 
250
                               (cdr (method-for-inspect-value method))))
 
251
              " "
 
252
              (:action "[remove method]" 
 
253
                       ,(let ((m method)) ; LOOP reassigns method
 
254
                          (lambda () 
 
255
                            (remove-method gf m))))
 
256
              (:newline)))
 
257
      `((:newline))
 
258
      (all-slots-for-inspector gf inspector)))))
 
259
 
 
260
(defmethod inspect-for-emacs ((method standard-method) 
 
261
                              (inspector fancy-inspector))
 
262
  (values "A method." 
 
263
          `("Method defined on the generic function " 
 
264
            (:value ,(swank-mop:method-generic-function method)
 
265
                    ,(inspector-princ
 
266
                      (swank-mop:generic-function-name
 
267
                       (swank-mop:method-generic-function method))))
 
268
            (:newline)
 
269
            ,@(docstring-ispec "Documentation" method t)
 
270
            "Lambda List: " (:value ,(swank-mop:method-lambda-list method))
 
271
            (:newline)
 
272
            "Specializers: " (:value ,(swank-mop:method-specializers method)
 
273
                                     ,(inspector-princ (method-specializers-for-inspect method)))
 
274
            (:newline)
 
275
            "Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
 
276
            (:newline)
 
277
            "Method function: " (:value ,(swank-mop:method-function method))
 
278
            (:newline)
 
279
            ,@(all-slots-for-inspector method inspector))))
 
280
 
 
281
(defmethod inspect-for-emacs ((class standard-class) 
 
282
                              (inspector fancy-inspector))
 
283
  (values "A class."
 
284
          `("Name: " (:value ,(class-name class))
 
285
            (:newline)
 
286
            "Super classes: "
 
287
            ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
 
288
            (:newline)
 
289
            "Direct Slots: "
 
290
            ,@(common-seperated-spec
 
291
               (swank-mop:class-direct-slots class)
 
292
               (lambda (slot)
 
293
                 `(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot)))))
 
294
            (:newline)
 
295
            "Effective Slots: "
 
296
            ,@(if (swank-mop:class-finalized-p class)
 
297
                  (common-seperated-spec
 
298
                   (swank-mop:class-slots class)
 
299
                   (lambda (slot)
 
300
                     `(:value ,slot ,(inspector-princ
 
301
                                      (swank-mop:slot-definition-name slot)))))
 
302
                  '("#<N/A (class not finalized)>"))
 
303
            (:newline)
 
304
            ,@(let ((doc (documentation class t)))
 
305
                (when doc
 
306
                  `("Documentation:" (:newline) ,(inspector-princ doc) (:newline))))
 
307
            "Sub classes: "
 
308
            ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
 
309
                                     (lambda (sub)
 
310
                                       `(:value ,sub ,(inspector-princ (class-name sub)))))
 
311
            (:newline)
 
312
            "Precedence List: "
 
313
            ,@(if (swank-mop:class-finalized-p class)
 
314
                  (common-seperated-spec (swank-mop:class-precedence-list class)
 
315
                                         (lambda (class)
 
316
                                           `(:value ,class ,(inspector-princ (class-name class)))))
 
317
                  '("#<N/A (class not finalized)>"))
 
318
            (:newline)
 
319
            ,@(when (swank-mop:specializer-direct-methods class)
 
320
               `("It is used as a direct specializer in the following methods:" (:newline)
 
321
                 ,@(loop
 
322
                      for method in (sort (copy-seq (swank-mop:specializer-direct-methods class))
 
323
                                          #'string< :key (lambda (x)
 
324
                                                           (symbol-name
 
325
                                                            (let ((name (swank-mop::generic-function-name
 
326
                                                                         (swank-mop::method-generic-function x))))
 
327
                                                              (if (symbolp name) name (second name))))))
 
328
                      collect "  "
 
329
                      collect `(:value ,method ,(inspector-princ (method-for-inspect-value method)))
 
330
                      collect '(:newline)
 
331
                      if (documentation method t)
 
332
                      collect "    Documentation: " and
 
333
                      collect (abbrev-doc (documentation method t)) and
 
334
                      collect '(:newline))))
 
335
            "Prototype: " ,(if (swank-mop:class-finalized-p class)
 
336
                               `(:value ,(swank-mop:class-prototype class))
 
337
                               '"#<N/A (class not finalized)>")
 
338
            (:newline)
 
339
            ,@(all-slots-for-inspector class inspector))))
 
340
 
 
341
(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition) 
 
342
                              (inspector fancy-inspector))
 
343
  (values "A slot."
 
344
          `("Name: " (:value ,(swank-mop:slot-definition-name slot))
 
345
            (:newline)
 
346
            ,@(when (swank-mop:slot-definition-documentation slot)
 
347
                `("Documentation:"  (:newline)
 
348
                  (:value ,(swank-mop:slot-definition-documentation slot))
 
349
                  (:newline)))
 
350
            "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
 
351
            "Init form: "  ,(if (swank-mop:slot-definition-initfunction slot)
 
352
                             `(:value ,(swank-mop:slot-definition-initform slot))
 
353
                             "#<unspecified>") (:newline)
 
354
            "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))            
 
355
            (:newline)
 
356
            ,@(all-slots-for-inspector slot inspector))))
 
357
 
 
358
 
 
359
;; Wrapper structure over the list of symbols of a package that should
 
360
;; be displayed with their respective classification flags. This is
 
361
;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS.
 
362
;; Used by the Inspector for packages.
 
363
(defstruct (%package-symbols-container (:conc-name   %container.)
 
364
                                       (:constructor %%make-package-symbols-container))
 
365
  title          ;; A string; the title of the inspector page in Emacs.   
 
366
  description    ;; A list of renderable objects; used as description.
 
367
  symbols        ;; A list of symbols. Supposed to be sorted alphabetically.
 
368
  grouping-kind  ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING.
 
369
  )
 
370
 
 
371
(defun %make-package-symbols-container (&key title description symbols)
 
372
  (%%make-package-symbols-container :title title :description description
 
373
                                    :symbols symbols :grouping-kind :symbol))
 
374
 
 
375
(defgeneric make-symbols-listing (grouping-kind symbols))
 
376
 
 
377
(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols)
 
378
  "Returns an object renderable by Emacs' inspector side that
 
379
alphabetically lists all the symbols in SYMBOLS together with a
 
380
concise string representation of what each symbol
 
381
represents (cf. CLASSIFY-SYMBOL & Fuzzy Completion.)"
 
382
  (let ((max-length (loop for s in symbols maximizing (length (symbol-name s))))
 
383
        (distance 10)) ; empty distance between name and classification
 
384
    (flet ((string-representations (symbol)
 
385
             (let* ((name (symbol-name symbol))
 
386
                    (length (length name))
 
387
                    (padding (- max-length length))                    
 
388
                    (classification (classify-symbol symbol)))
 
389
               (values
 
390
                (concatenate 'string
 
391
                             name
 
392
                             (make-string (+ padding distance) :initial-element #\Space))
 
393
                (symbol-classification->string classification)))))
 
394
      `(""                           ; 8 is (length "Symbols:")
 
395
        "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:"
 
396
        (:newline)
 
397
        ,(concatenate 'string        ; underlining dashes
 
398
                      (make-string (+ max-length distance -1) :initial-element #\-)
 
399
                      " "
 
400
                      (let* ((dummy (classify-symbol (gensym)))
 
401
                             (dummy (symbol-classification->string dummy))
 
402
                             (classification-length (length dummy)))
 
403
                        (make-string classification-length :initial-element #\-)))
 
404
        (:newline)          
 
405
        ,@(loop for symbol in symbols appending
 
406
               (multiple-value-bind (symbol-string classification-string)
 
407
                   (string-representations symbol)
 
408
                 `((:value ,symbol ,symbol-string) ,classification-string
 
409
                   (:newline)
 
410
                   )))))))
 
411
 
 
412
(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols)
 
413
  "For each possible classification (cf. CLASSIFY-SYMBOL), group
 
414
all the symbols in SYMBOLS to all of their respective
 
415
classifications. (If a symbol is, for instance, boundp and a
 
416
generic-function, it'll appear both below the BOUNDP group and
 
417
the GENERIC-FUNCTION group.) As macros and special-operators are
 
418
specified to be FBOUNDP, there is no general FBOUNDP group,
 
419
instead there are the three explicit FUNCTION, MACRO and
 
420
SPECIAL-OPERATOR groups."
 
421
  (let ((table (make-hash-table :test #'eq)))
 
422
    (flet ((maybe-convert-fboundps (classifications)
 
423
             ;; Convert an :FBOUNDP in CLASSIFICATIONS to :FUNCTION if possible.
 
424
             (if (and (member :fboundp classifications)
 
425
                      (not (member :macro classifications))
 
426
                      (not (member :special-operator classifications)))
 
427
                 (substitute :function :fboundp classifications)
 
428
                 (remove :fboundp classifications))))
 
429
      (loop for symbol in symbols do
 
430
            (loop for classification in (maybe-convert-fboundps (classify-symbol symbol))
 
431
                  ;; SYMBOLS are supposed to be sorted alphabetically;
 
432
                  ;; this property is preserved here except for reversing.
 
433
                  do (push symbol (gethash classification table)))))
 
434
    (let* ((classifications (loop for k being each hash-key in table collect k))
 
435
           (classifications (sort classifications #'string<)))
 
436
      (loop for classification in classifications
 
437
            for symbols = (gethash classification table)
 
438
            appending`(,(symbol-name classification)
 
439
                        (:newline)
 
440
                        ,(make-string 64 :initial-element #\-)
 
441
                        (:newline)
 
442
                        ,@(mapcan #'(lambda (symbol)
 
443
                                      (list `(:value ,symbol ,(symbol-name symbol)) '(:newline)))
 
444
                                  (nreverse symbols)) ; restore alphabetic orderness.
 
445
                        (:newline)
 
446
                        )))))
 
447
 
 
448
(defmethod inspect-for-emacs ((%container %package-symbols-container) 
 
449
                              (inspector fancy-inspector))
 
450
  (declare (ignore inspector))
 
451
  (with-struct (%container. title description symbols grouping-kind) %container
 
452
    (values title
 
453
            `(,@description
 
454
              (:newline)
 
455
              "  " ,(ecase grouping-kind
 
456
                           (:symbol
 
457
                            `(:action "[Group by classification]"
 
458
                                      ,(lambda () (setf grouping-kind :classification))
 
459
                                      :refreshp t))
 
460
                           (:classification
 
461
                            `(:action "[Group by symbol]"
 
462
                                      ,(lambda () (setf grouping-kind :symbol))
 
463
                                      :refreshp t)))
 
464
              (:newline) (:newline)
 
465
              ,@(make-symbols-listing grouping-kind symbols)))))
 
466
 
 
467
 
 
468
(defmethod inspect-for-emacs ((package package) 
 
469
                              (inspector fancy-inspector))
 
470
  (declare (ignore inspector))
 
471
  (let ((package-name         (package-name package))
 
472
        (package-nicknames    (package-nicknames package))
 
473
        (package-use-list     (package-use-list package))
 
474
        (package-used-by-list (package-used-by-list package))
 
475
        (shadowed-symbols     (package-shadowing-symbols package))
 
476
        (present-symbols      '()) (present-symbols-length  0)
 
477
        (internal-symbols     '()) (internal-symbols-length 0)
 
478
        (external-symbols     '()) (external-symbols-length 0))
 
479
 
 
480
    (do-symbols* (sym package)
 
481
      (let ((status (symbol-status sym package)))
 
482
        (when (not (eq status :inherited))
 
483
          (push sym present-symbols) (incf present-symbols-length)
 
484
          (if (eq status :internal)
 
485
              (progn (push sym internal-symbols) (incf internal-symbols-length))                
 
486
              (progn (push sym external-symbols) (incf external-symbols-length))))))
 
487
    
 
488
    (setf package-nicknames    (sort (copy-list package-nicknames)    #'string<)
 
489
          package-use-list     (sort (copy-list package-use-list)     #'string< :key #'package-name)
 
490
          package-used-by-list (sort (copy-list package-used-by-list) #'string< :key #'package-name)
 
491
          shadowed-symbols     (sort (copy-list shadowed-symbols)     #'string<))
 
492
    
 
493
    (setf present-symbols      (sort present-symbols  #'string<)  ; SORT + STRING-LESSP
 
494
          internal-symbols     (sort internal-symbols #'string<)  ; conses on at least
 
495
          external-symbols     (sort external-symbols #'string<)) ; SBCL 0.9.18.
 
496
 
 
497
    
 
498
    (values
 
499
     "A package."
 
500
     `(""                               ; dummy to preserve indentation.
 
501
       "Name: " (:value ,package-name) (:newline)
 
502
                       
 
503
       "Nick names: " ,@(common-seperated-spec package-nicknames) (:newline)
 
504
              
 
505
       ,@(when (documentation package t)
 
506
               `("Documentation:" (:newline) ,(documentation package t) (:newline)))
 
507
              
 
508
       "Use list: " ,@(common-seperated-spec
 
509
                       package-use-list
 
510
                       (lambda (package)
 
511
                         `(:value ,package ,(package-name package))))
 
512
       (:newline)
 
513
              
 
514
       "Used by list: " ,@(common-seperated-spec
 
515
                           package-used-by-list
 
516
                           (lambda (package)
 
517
                             `(:value ,package ,(package-name package))))
 
518
       (:newline)
 
519
 
 
520
       ,@     ; ,@(flet ((...)) ...) would break indentation in Emacs.
 
521
       (flet ((display-link (type symbols length &key title description)
 
522
                (if (null symbols)
 
523
                    (format nil "0 ~A symbols." type)
 
524
                    `(:value ,(%make-package-symbols-container :title title
 
525
                                                               :description description
 
526
                                                               :symbols symbols)
 
527
                             ,(format nil "~D ~A symbol~P." length type length)))))
 
528
         
 
529
         `(,(display-link "present" present-symbols  present-symbols-length
 
530
                          :title (format nil "All present symbols of package \"~A\"" package-name)
 
531
                          :description
 
532
                          '("A symbol is considered present in a package if it's" (:newline)
 
533
                            "\"accessible in that package directly, rather than"  (:newline)
 
534
                            "being inherited from another package.\""             (:newline)
 
535
                            "(CLHS glossary entry for `present')"                 (:newline)))
 
536
            
 
537
            (:newline)
 
538
            ,(display-link "external" external-symbols external-symbols-length
 
539
                           :title (format nil "All external symbols of package \"~A\"" package-name)
 
540
                           :description
 
541
                           '("A symbol is considered external of a package if it's"  (:newline)
 
542
                             "\"part of the `external interface' to the package and" (:newline)
 
543
                             "[is] inherited by any other package that uses the"     (:newline)
 
544
                             "package.\" (CLHS glossary entry of `external')"        (:newline)))
 
545
            (:newline)
 
546
            ,(display-link "internal" internal-symbols internal-symbols-length
 
547
                           :title (format nil "All internal symbols of package \"~A\"" package-name)
 
548
                           :description
 
549
                           '("A symbol is considered internal of a package if it's"   (:newline)
 
550
                             "present and not external---that is if the package is"   (:newline)
 
551
                             "the home package of the symbol, or if the symbol has"   (:newline)
 
552
                             "been explicitly imported into the package."             (:newline)
 
553
                             (:newline)
 
554
                             "Notice that inherited symbols will thus not be listed," (:newline)
 
555
                             "which deliberately deviates from the CLHS glossary"     (:newline)
 
556
                             "entry of `internal' because it's assumed to be more"    (:newline)
 
557
                             "useful this way."                                       (:newline)))
 
558
            (:newline)
 
559
            ,(display-link "shadowed" shadowed-symbols (length shadowed-symbols)
 
560
                           :title (format nil "All shadowed symbols of package \"~A\"" package-name)
 
561
                           :description nil)))))))
 
562
 
 
563
 
 
564
(defmethod inspect-for-emacs ((pathname pathname) 
 
565
                              (inspector fancy-inspector))
 
566
  (declare (ignore inspector))
 
567
  (values (if (wild-pathname-p pathname)
 
568
              "A wild pathname."
 
569
              "A pathname.")
 
570
          (append (label-value-line*
 
571
                   ("Namestring" (namestring pathname))
 
572
                   ("Host"       (pathname-host pathname))
 
573
                   ("Device"     (pathname-device pathname))
 
574
                   ("Directory"  (pathname-directory pathname))
 
575
                   ("Name"       (pathname-name pathname))
 
576
                   ("Type"       (pathname-type pathname))
 
577
                   ("Version"    (pathname-version pathname)))
 
578
                  (unless (or (wild-pathname-p pathname)
 
579
                              (not (probe-file pathname)))
 
580
                    (label-value-line "Truename" (truename pathname))))))
 
581
 
 
582
(defmethod inspect-for-emacs ((pathname logical-pathname) 
 
583
                              (inspector fancy-inspector))
 
584
  (declare (ignore inspector))
 
585
  (values "A logical pathname."
 
586
          (append 
 
587
           (label-value-line*
 
588
            ("Namestring" (namestring pathname))
 
589
            ("Physical pathname: " (translate-logical-pathname pathname)))
 
590
           `("Host: " 
 
591
             ,(pathname-host pathname)
 
592
             " (" (:value ,(logical-pathname-translations
 
593
                            (pathname-host pathname))) 
 
594
             "other translations)"
 
595
             (:newline))
 
596
           (label-value-line*
 
597
            ("Directory" (pathname-directory pathname))
 
598
            ("Name" (pathname-name pathname))
 
599
            ("Type" (pathname-type pathname))
 
600
            ("Version" (pathname-version pathname))
 
601
            ("Truename" (if (not (wild-pathname-p pathname))
 
602
                            (probe-file pathname)))))))
 
603
 
 
604
(defmethod inspect-for-emacs ((n number) 
 
605
                              (inspector fancy-inspector))
 
606
  (declare (ignore inspector))
 
607
  (values "A number." `("Value: " ,(princ-to-string n))))
 
608
 
 
609
(defun format-iso8601-time (time-value &optional include-timezone-p)
 
610
    "Formats a universal time TIME-VALUE in ISO 8601 format, with
 
611
    the time zone included if INCLUDE-TIMEZONE-P is non-NIL"    
 
612
    ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html
 
613
    ;; Thanks, Nikolai Sandved and Thomas Russ!
 
614
    (flet ((format-iso8601-timezone (zone)
 
615
             (if (zerop zone)
 
616
                 "Z"
 
617
                 (multiple-value-bind (h m) (truncate (abs zone) 1.0)
 
618
                   ;; Tricky.  Sign of time zone is reversed in ISO 8601
 
619
                   ;; relative to Common Lisp convention!
 
620
                   (format nil "~:[+~;-~]~2,'0D:~2,'0D"
 
621
                           (> zone 0) h (round (* 60 m)))))))
 
622
    (multiple-value-bind (second minute hour day month year dow dst zone)
 
623
      (decode-universal-time time-value)
 
624
      (declare (ignore dow dst))
 
625
      (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
 
626
              year month day hour minute second
 
627
              include-timezone-p (format-iso8601-timezone zone)))))
 
628
 
 
629
(defmethod inspect-for-emacs ((i integer) 
 
630
                              (inspector fancy-inspector))
 
631
  (declare (ignore inspector))
 
632
  (values "A number."
 
633
          (append
 
634
           `(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
 
635
                      i i i i (ignore-errors (coerce i 'float)))
 
636
              (:newline))
 
637
           (when (< -1 i char-code-limit)
 
638
             (label-value-line "Code-char" (code-char i)))
 
639
           (label-value-line "Integer-length" (integer-length i))           
 
640
           (ignore-errors
 
641
             (label-value-line "Universal-time" (format-iso8601-time i t))))))
 
642
 
 
643
(defmethod inspect-for-emacs ((c complex) 
 
644
                              (inspector fancy-inspector))
 
645
  (declare (ignore inspector))
 
646
  (values "A complex number."
 
647
          (label-value-line* 
 
648
           ("Real part" (realpart c))
 
649
           ("Imaginary part" (imagpart c)))))
 
650
 
 
651
(defmethod inspect-for-emacs ((r ratio) 
 
652
                              (inspector fancy-inspector))
 
653
  (declare (ignore inspector))
 
654
  (values "A non-integer ratio."
 
655
          (label-value-line*
 
656
           ("Numerator" (numerator r))
 
657
           ("Denominator" (denominator r))
 
658
           ("As float" (float r)))))
 
659
 
 
660
(defmethod inspect-for-emacs ((f float) 
 
661
                              (inspector fancy-inspector))
 
662
  (declare (ignore inspector))
 
663
  (values "A floating point number."
 
664
          (cond
 
665
            ((> f most-positive-long-float)
 
666
             (list "Positive infinity."))
 
667
            ((< f most-negative-long-float)
 
668
             (list "Negative infinity."))
 
669
            ((not (= f f))
 
670
             (list "Not a Number."))
 
671
            (t
 
672
             (multiple-value-bind (significand exponent sign) (decode-float f)
 
673
               (append 
 
674
                `("Scientific: " ,(format nil "~E" f) (:newline)
 
675
                                 "Decoded: " 
 
676
                                 (:value ,sign) " * " 
 
677
                                 (:value ,significand) " * " 
 
678
                                 (:value ,(float-radix f)) "^" (:value ,exponent) (:newline))
 
679
                (label-value-line "Digits" (float-digits f))
 
680
                (label-value-line "Precision" (float-precision f))))))))
 
681
 
 
682
(defmethod inspect-for-emacs ((stream file-stream) 
 
683
                              (inspector fancy-inspector))
 
684
  (declare (ignore inspector))
 
685
  (multiple-value-bind (title content)
 
686
      (call-next-method)
 
687
    (declare (ignore title))
 
688
    (values "A file stream."
 
689
            (append
 
690
             `("Pathname: "
 
691
               (:value ,(pathname stream))
 
692
               (:newline) "  "
 
693
               (:action "[visit file and show current position]"
 
694
                        ,(let ((pathname (pathname stream))
 
695
                               (position (file-position stream)))
 
696
                           (lambda ()
 
697
                             (ed-in-emacs `(,pathname :charpos ,position))))
 
698
                        :refreshp nil)
 
699
               (:newline))
 
700
             content))))
 
701
 
 
702
(defmethod inspect-for-emacs ((condition stream-error) 
 
703
                              (inspector fancy-inspector))
 
704
  (declare (ignore inspector))
 
705
  (multiple-value-bind (title content)
 
706
      (call-next-method)
 
707
    (let ((stream (stream-error-stream condition)))
 
708
      (if (typep stream 'file-stream)
 
709
          (values "A stream error."
 
710
                  (append
 
711
                   `("Pathname: "
 
712
                     (:value ,(pathname stream))
 
713
                     (:newline) "  "
 
714
                     (:action "[visit file and show current position]"
 
715
                              ,(let ((pathname (pathname stream))
 
716
                                     (position (file-position stream)))
 
717
                                    (lambda ()
 
718
                                      (ed-in-emacs `(,pathname :charpos ,position))))
 
719
                              :refreshp nil)
 
720
                     (:newline))
 
721
                   content))
 
722
          (values title content)))))
 
723
 
 
724
(defvar *fancy-inpector-undo-list* nil)
 
725
 
 
726
(defslimefun fancy-inspector-init ()
 
727
  (let ((i *default-inspector*))
 
728
    (push (lambda () (setq *default-inspector* i))
 
729
          *fancy-inpector-undo-list*))
 
730
  (setq *default-inspector* (make-instance 'fancy-inspector))
 
731
  t)
 
732
 
 
733
(defslimefun fancy-inspector-unload ()
 
734
  (loop while *fancy-inpector-undo-list* do
 
735
        (funcall (pop *fancy-inpector-undo-list*))))
 
736
 
 
737
(provide :swank-fancy-inspector)
 
 
b'\\ No newline at end of file'