/[cmucl]/src/interface/inspect.lisp
ViewVC logotype

Contents of /src/interface/inspect.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Thu Jul 22 13:25:08 1993 UTC (20 years, 9 months ago) by ram
Branch: MAIN
Changes since 1.5: +2 -2 lines
Changed to use standard-object type instead of pcl::std-instance.
1 ;;;; -*- Mode: Lisp ; Package: Interface -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 ;;; **********************************************************************
10 ;;;
11 ;;; Written by Michael Garland
12 ;;;
13 ;;; This file implements the methods used in graphically inspecting Lisp
14 ;;; objects.
15 ;;;
16 ;;; The inspector mechanism revolves around two generic functions:
17 ;;; - INSPECTOR-PANE-TITLE which returns a string meant to be the
18 ;;; title of the inspection pane displaying the given object
19 ;;; - DISPLAY-INSPECTOR-PANE which creates a window pane displaying
20 ;;; the relevant information about the given object
21 ;;;
22 ;;; You can add new display mechanisms by defining new methods for these
23 ;;; generic functions. Specific functions for aiding in the construction
24 ;;; of inspection panes are given below.
25 ;;;
26
27 (in-package "INTERFACE")
28
29
30 (defvar *inspector-huge-object-threshold* 20)
31 (defvar *inspector-sequence-initial-display* 5)
32
33
34
35 ;;;; Inspector callbacks
36
37 (defun destroy-pane-callback (widget call-data object)
38 (declare (ignore widget call-data))
39 (setf *current-inspector-objects*
40 (delete object *current-inspector-objects*))
41 (destroy-interface-pane object))
42
43 (defun inspect-object-callback (widget call-data object)
44 (declare (ignore widget call-data))
45 (inspect object))
46
47 (defun inspect-eval-callback (widget call-data output shell)
48 (declare (ignore widget call-data))
49 (with-busy-cursor (shell)
50 (inspect (xti:widget-user-data output))))
51
52 (defun eval-callback (widget call-data object output)
53 (declare (ignore call-data))
54 (let* ((input (car (get-values widget :value)))
55 (mark (text-get-last-position output))
56 (response
57 (format nil "* ~a~%~a~%"
58 input
59 (handler-case
60 (multiple-value-bind (out val)
61 (grab-output-as-string
62 (let ((* object))
63 (eval (read-from-string input))))
64 (setf (xti:widget-user-data output) val)
65 (format nil "~a~s~%" out val))
66 (error (cond)
67 (format nil "~2&~A~2&" cond)))))
68 (length (length response)))
69 (declare (simple-string response))
70
71 (text-set-string widget "")
72 (text-insert output mark response)
73 (text-set-insertion-position output (+ length mark))))
74
75 (defun popup-eval-callback (widget call-data pane object)
76 (declare (ignore widget call-data))
77 (multiple-value-bind (form shell)
78 (create-form-dialog pane "evalDialog")
79 (let* ((s1 (compound-string-create "Eval: " "HeaderFont"))
80 (s2 (compound-string-create
81 (format nil "[~a]" (print-for-widget-display "~S" object))
82 "EntryFont"))
83 (s3 (compound-string-concat s1 s2))
84 (done (create-push-button-gadget form "evalDone"
85 :label-string "Done"
86 :bottom-attachment :attach-form))
87 (inspect (create-push-button-gadget form "evalInspect"
88 :label-string "Inspect Last"
89 :bottom-attachment :attach-form
90 :left-attachment :attach-widget
91 :left-widget done))
92 (entry (create-text form "evalEntry"
93 :bottom-attachment :attach-widget
94 :bottom-widget done
95 :left-attachment :attach-form
96 :right-attachment :attach-form))
97 (prompt (create-label-gadget form "evalPrompt"
98 :bottom-attachment :attach-widget
99 :bottom-widget entry
100 :font-list *all-fonts*
101 :label-string s3))
102 (output (create-text form "evalOutput"
103 :edit-mode :multi-line-edit
104 :editable nil
105 :rows 8
106 :columns 40
107 :top-attachment :attach-form
108 :bottom-attachment :attach-widget
109 :bottom-widget prompt
110 :left-attachment :attach-form
111 :right-attachment :attach-form)))
112 (compound-string-free s1)
113 (compound-string-free s2)
114
115 (set-values shell :title "Inspector Eval"
116 :keyboard-focus-policy :pointer)
117 (add-callback entry :activate-callback 'eval-callback object output)
118 (add-callback inspect :activate-callback
119 'inspect-eval-callback output shell)
120 (add-callback done :activate-callback #'destroy-callback shell)
121 (manage-children done inspect entry prompt output)
122 (manage-child form))))
123
124
125
126 ;;;; Methods for constructing the title of inspection panes
127
128 ;;; INSPECTOR-PANE-TITLE -- Public
129 ;;;
130 ;;; This function takes a Lisp object and returns a string which is meant
131 ;;; to be the title of the inspection pane displaying the given object.
132
133 ;;; This particular method is a catch-all for the types which PCL does not
134 ;;; allow us to discriminate.
135 ;;;
136 (defmethod inspector-pane-title (object)
137 (typecase object
138 (standard-object
139 (format nil "Instance ~a of Class ~a"
140 object (pcl::class-name (pcl::class-of object))))
141 (function (format nil "~a" object))
142 (structure-object
143 (let ((default (format nil "~a" object)))
144 (declare (simple-string default))
145 (if (and (> (length default) 2)
146 (char= (schar default 0) #\#)
147 (char= (schar default 1) #\S))
148 (format nil "#<~a Structure>" (type-of object))
149 default)))
150 (t
151 (format nil "~a ~a" (string-capitalize (type-of object))
152 (print-for-widget-display "~s" object)))))
153
154 (defmethod inspector-pane-title ((sym symbol))
155 (format nil "Symbol ~s" sym))
156
157 (defmethod inspector-pane-title ((v vector))
158 (declare (vector v))
159 (let ((length (length v))
160 (type (type-of v)))
161 (format nil "~a of length ~a"
162 (string-capitalize (if (listp type) (car type) type))
163 length)))
164
165 (defmethod inspector-pane-title ((a array))
166 (let ((dimensions (array-dimensions a)))
167 (format nil "Array of ~a Dimensions = ~s"
168 (array-element-type a) dimensions)))
169
170 (defmethod inspector-pane-title ((l list))
171 (if (listp (cdr l))
172 (format nil "List of length ~a" (length l))
173 (format nil "Dotted Pair")))
174
175
176
177 ;;;; Methods for displaying object inspection panes
178
179 ;;; WITH-INSPECTOR-PANE -- Public
180 ;;;
181 ;;; This macro is the primary tool for building inspection panes. It
182 ;;; creates all the fundamental pieces of the display pane and then calls
183 ;;; the supplied body to create the rest. A typical display method would
184 ;;; like something like:
185 ;;; (defmethod display-inspector-pane ((x mytype))
186 ;;; (with-inspector-pane (x)
187 ;;; ... custom forms ...
188 ;;; ))
189 ;;;
190 (defmacro with-inspector-pane ((object) &body forms)
191 `(multiple-value-bind
192 (pane is-new)
193 (create-interface-pane-shell (format nil "Inspect: ~a" (type-of ,object))
194 ,object)
195 (when is-new
196 (let* ((frame (create-frame pane "inspectFrame"))
197 (over-form (create-form frame "inspectForm"))
198 (menu-bar (create-menu-bar over-form "menubar"
199 :left-attachment :attach-form
200 :right-attachment :attach-form))
201 (obmenu (create-interface-menu
202 menu-bar "Object"
203 ,``(("Eval Expression" popup-eval-callback ,pane ,,object)
204 ("Close Pane" destroy-pane-callback ,,object)
205 ("Close All Panes" close-all-callback))))
206 (title (create-label-gadget
207 over-form "inspectTitle"
208 :label-string (inspector-pane-title ,object)
209 :font-list *header-font*
210 :top-attachment :attach-widget
211 :top-widget menu-bar
212 :left-attachment :attach-form
213 :right-attachment :attach-form))
214 (form (create-form over-form "inspectForm"
215 :left-attachment :attach-form
216 :right-attachment :attach-form
217 :bottom-attachment :attach-form
218 :top-attachment :attach-widget
219 :top-widget title)))
220
221 ,@forms
222 (manage-child frame)
223 (manage-child over-form)
224 (manage-child obmenu)
225 (manage-children menu-bar title form)))
226 (popup-interface-pane pane)))
227
228 ;;; DISPLAY-INSPECTOR-PANE -- Public
229 ;;;
230 ;;; This function takes an object and creates a graphical inspection pane
231 ;;; for displaying it.
232
233 ;;; This particular method is a catch all for the types which PCL won't
234 ;;; specialize on.
235 ;;;
236 (defmethod display-inspector-pane (object)
237 (typecase object
238 (standard-object (display-clos-pane object))
239 (function (display-function-pane object))
240 (structure-object (display-structure-pane object))
241 (t
242 (with-inspector-pane (object)
243 (let ((label (create-label-gadget
244 form "label"
245 :label-string (format nil "~s" object))))
246 (manage-child label))))))
247
248
249
250 (defmethod display-inspector-pane ((sym symbol))
251 (with-inspector-pane (sym)
252 (let* ((value (if (boundp sym) (symbol-value sym) "Unbound"))
253 (function (if (fboundp sym) (symbol-function sym) "Undefined"))
254 (plist (symbol-plist sym))
255 (package (symbol-package sym))
256 (rc (create-row-column form "rowColumn"))
257 (vview (create-value-box rc "Value:" value
258 :callback 'inspect-object-callback
259 :activep (boundp sym)))
260 (fview (create-value-box rc "Function:" function
261 :callback 'inspect-object-callback
262 :activep (fboundp sym)))
263 (plview (create-value-box rc "PList:" plist
264 :callback 'inspect-object-callback))
265 (pview (create-value-box rc "Package:" package
266 :callback 'inspect-object-callback)))
267 (manage-child rc)
268 (manage-children vview fview plview pview))))
269
270 (defun is-traced (function)
271 (let ((fun (debug::trace-fdefinition function)))
272 (if (gethash fun debug::*traced-functions*) t)))
273
274 (defun trace-function-callback (widget call-data function)
275 (declare (ignore widget))
276 (if (toggle-button-callback-set call-data)
277 (debug::trace-1 function (debug::make-trace-info))
278 (debug::untrace-1 function)))
279
280 (defun display-function-pane (f)
281 (with-inspector-pane (f)
282 (multiple-value-bind
283 (dstring dval)
284 (grab-output-as-string (describe f))
285 (declare (ignore dval))
286 (let* ((trace (create-toggle-button-gadget form "functionTrace"
287 :bottom-attachment :attach-form
288 :label-string "Trace Function"
289 :set (is-traced f)))
290 (sep (create-separator-gadget form "separator"
291 :left-attachment :attach-form
292 :right-attachment :attach-form
293 :bottom-attachment :attach-widget
294 :bottom-widget trace))
295 (descview (create-scrolled-window form "scrolledView"
296 :left-attachment :attach-form
297 :right-attachment :attach-form
298 :bottom-attachment :attach-widget
299 :bottom-widget sep
300 :top-attachment :attach-form
301 :scrolling-policy :automatic))
302 (desc (create-label descview "functionDescription"
303 :alignment :alignment-beginning
304 :label-string dstring)))
305
306 (add-callback trace :value-changed-callback
307 'trace-function-callback f)
308 (manage-child desc)
309 (manage-children trace sep descview)))))
310
311 (defun display-structure-pane (s)
312 (with-inspector-pane (s)
313 (let* ((dd (kernel:layout-info (kernel:%instance-layout s)))
314 (dsds (kernel:dd-slots dd))
315 (viewer (when (> (length dsds) *inspector-huge-object-threshold*)
316 (create-scrolled-window form "structureViewer"
317 :left-attachment :attach-form
318 :right-attachment :attach-form
319 :top-attachment :attach-form
320 :bottom-attachment :attach-form
321 :scrolling-policy :automatic)))
322 (rc (create-row-column (or viewer form) "rowColumn"))
323 (widgets))
324 (declare (list dsds))
325 (dolist (dsd dsds)
326 (push
327 (create-value-box rc (format nil "~A:"
328 (string-capitalize
329 (kernel:dsd-%name dsd)))
330 (funcall (kernel:dsd-accessor dsd) s)
331 :callback #'inspect-object-callback)
332 widgets))
333 (apply #'manage-children widgets)
334 (manage-child rc)
335 (when viewer (manage-child viewer)))))
336
337
338 (defun sequence-redisplay-callback (widget call-data v s-text c-text view pane)
339 (declare (ignore widget call-data))
340 (handler-case
341 (let* ((start (read-from-string (car (get-values s-text :value))))
342 (count (read-from-string (car (get-values c-text :value))))
343 (length (length v))
344 (widgets (reverse (xti:widget-children view)))
345 (unused-ones)
346 (used-ones))
347
348 (when (> (+ start count) length)
349 (setf count (- length start))
350 (set-values c-text :value (format nil "~a" count)))
351
352 (when (minusp start)
353 (setf start 0)
354 (set-values s-text :value (format nil "~a" 0)))
355
356 (dolist (widget widgets)
357 (if (zerop count)
358 (push widget unused-ones)
359 (progn
360 (set-value-box widget (format nil "~a:" start) (elt v start)
361 :callback #'inspect-object-callback)
362 (push widget used-ones)
363 (incf start)
364 (decf count))))
365
366 (dotimes (i count)
367 (let ((pos (+ start i)))
368 (push (create-value-box view (format nil "~a:" pos) (elt v pos)
369 :callback #'inspect-object-callback)
370 used-ones)))
371 (when unused-ones
372 (apply #'unmanage-children unused-ones))
373 (apply #'manage-children used-ones))
374 (error (e)
375 (interface-error (format nil "~a" e) pane))))
376
377 (defun sequence-filter-callback (widget call-data v fexp view pane)
378 (declare (ignore widget call-data))
379 (handler-case
380 (let* ((exp (read-from-string (car (get-values fexp :value))))
381 (length (length v))
382 (widgets (reverse (xti:widget-children view)))
383 (used-ones))
384 (dotimes (index length)
385 (let* ((item (elt v index))
386 (* item)
387 (** index))
388 (when (eval exp)
389 (let ((widget (pop widgets)))
390 (if widget
391 (set-value-box widget (format nil "~a:" index) item
392 :callback #'inspect-object-callback)
393 (setf widget (create-value-box
394 view (format nil "~a:" index) item
395 :callback #'inspect-object-callback)))
396 (push widget used-ones)))))
397 (when widgets
398 (apply #'unmanage-children widgets))
399 (apply #'manage-children used-ones))
400 (error (e)
401 (interface-error (format nil "~a" e) pane))))
402
403 (defun display-cons-pane (p form)
404 (let* ((rc (create-row-column form "rowColumn"))
405 (car-view (create-value-box rc "Car:" (car p)
406 :callback #'inspect-object-callback))
407 (cdr-view (create-value-box rc "Cdr:" (cdr p)
408 :callback #'inspect-object-callback)))
409 (manage-children car-view cdr-view)
410 (manage-child rc)))
411
412 (defmethod display-inspector-pane ((v sequence))
413 (with-inspector-pane (v)
414 (if (and (listp v)
415 (not (listp (cdr v))))
416 (display-cons-pane v form)
417 (let* ((length (length v))
418 (controls (create-row-column form "sequenceStartHolder"
419 :left-attachment :attach-form
420 :right-attachment :attach-form
421 :orientation :horizontal))
422 (slabel (create-label-gadget controls "sequenceStartLabel"
423 :font-list *header-font*
424 :label-string "Start:"))
425 (start (create-text controls "sequenceStart"
426 :value "0"
427 :columns 4))
428 (clabel (create-label-gadget controls "sequenceCountLabel"
429 :font-list *header-font*
430 :label-string "Count:"))
431 (count (create-text controls "sequenceCount"
432 :value "5"
433 :columns 4))
434 (filter (create-row-column form "sequenceFilterHolder"
435 :top-attachment :attach-widget
436 :top-widget controls
437 :left-attachment :attach-form
438 :right-attachment :attach-form
439 :orientation :horizontal))
440 (flabel (create-label-gadget filter "sequenceFilterLabel"
441 :font-list *header-font*
442 :label-string "Filter:"))
443 (fexp (create-text filter "sequenceFilterExp" :value "T"))
444 (apply (create-push-button-gadget filter "sequenceFilterApply"
445 :label-string "Apply"))
446 (unapply (create-push-button-gadget filter
447 "sequenceFilterUnapply"
448 :label-string "No Filter"))
449 (view (create-scrolled-window form "sequenceViewPort"
450 :scrolling-policy :automatic
451 :top-attachment :attach-widget
452 :top-widget filter
453 :bottom-attachment :attach-form
454 :left-attachment :attach-form
455 :right-attachment :attach-form))
456 (rc (create-row-column view "sequenceView"
457 :spacing 0))
458 (widgets))
459
460 (manage-children slabel start clabel count)
461 (manage-children flabel fexp apply unapply)
462
463 (dotimes (i (min length *inspector-sequence-initial-display*))
464 (let ((item (elt v i)))
465 (push (create-value-box rc (format nil "~a:" i) item
466 :callback #'inspect-object-callback)
467 widgets)))
468
469 (apply #'manage-children widgets)
470
471 (add-callback start :activate-callback 'sequence-redisplay-callback
472 v start count rc pane)
473 (add-callback count :activate-callback 'sequence-redisplay-callback
474 v start count rc pane)
475 (add-callback apply :activate-callback 'sequence-filter-callback
476 v fexp rc pane)
477 (add-callback fexp :activate-callback 'sequence-filter-callback
478 v fexp rc pane)
479 (add-callback unapply :activate-callback
480 #'(lambda (widget call-data)
481 (declare (ignore widget call-data))
482 (sequence-redisplay-callback
483 nil nil v start count rc pane)))
484
485 (manage-children view controls filter)
486 (manage-child rc)))))
487
488 (defun show-slot-list (object slot-list view allocp label)
489 (let ((label (create-label-gadget view "slotLabel"
490 :label-string label
491 :font-list *header-font*))
492 (widgets))
493 (dolist (slotd slot-list)
494 (pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
495 slotd
496 (let* ((slot-label (if allocp
497 (format nil "~a: " slot)
498 (format nil "~a [~a]: " slot allocation)))
499 (slot-bound (pcl:slot-boundp object slot))
500 (slot-value (if slot-bound
501 (pcl:slot-value object slot)
502 "Unbound")))
503 (push
504 (create-value-box view slot-label slot-value
505 :callback #'inspect-object-callback
506 :activep slot-bound)
507 widgets)))
508 (apply #'manage-children label widgets))))
509
510 (defun display-clos-pane (object)
511 (with-inspector-pane (object)
512 (let* ((class (pcl::class-of object))
513 (slotds (pcl::slots-to-inspect class object))
514 (view (create-row-column form "rowColumn"
515 :left-attachment :attach-form
516 :right-attachment :attach-form
517 :top-attachment :attach-form
518 :bottom-attachment :attach-form))
519 instance-slots class-slots other-slots)
520
521 (dolist (slotd slotds)
522 (pcl:with-slots ((slot pcl::name) (allocation pcl::allocation))
523 slotd
524 (case allocation
525 (:instance (push slotd instance-slots))
526 (:class (push slotd class-slots))
527 (otherwise (push slotd other-slots))))
528 (when instance-slots
529 (show-slot-list object instance-slots view t
530 "Slots with Instance allocation:"))
531 (when class-slots
532 (show-slot-list object class-slots view t
533 "Slots with Class allocation:"))
534 (when other-slots
535 (show-slot-list object other-slots view nil
536 "Slots with Other allocation:"))))))
537
538
539
540 ;;;; Functions for creating the Motif inspector
541
542 (defun start-motif-inspector (object)
543 (verify-system-server-exists)
544 (multiple-value-bind (shell connection)
545 (create-interface-shell)
546 (declare (ignore shell))
547 (with-motif-connection (connection)
548 (verify-control-pane-displayed)
549 (display-inspector-pane object)
550 (push object *current-inspector-objects*)
551 (inspector-add-history-item object)))
552 object)
553
554
555
556 ;;;; User visible INSPECT function
557
558 ;;; INSPECT -- Public.
559 ;;;
560 (defun inspect (object)
561 "This function allows the user to interactively examine Lisp objects.
562 INTERFACE indicates whether this should run with a :graphics interface
563 or a :command-line oriented one; when running without X, there is no
564 choice. Supplying :window, :windows, :graphics, :graphical, and :x gets
565 a windowing interface, and supplying :command-line or :tty gets the
566 other style."
567
568 (if (use-graphics-interface)
569 (start-motif-inspector object)
570 (inspect::tty-inspect object)))

  ViewVC Help
Powered by ViewVC 1.1.5