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

Contents of /src/interface/inspect.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Fri Sep 30 23:50:57 1994 UTC (19 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.8: +18 -13 lines
Fixed way broken INSPECT-CLOS-PANE according to patch from Marco Antoniotti.
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 (let ((*print-level* (or debug:*debug-print-level* *print-level*))
138 (*print-length* (or debug:*debug-print-length* *print-length*)))
139 (typecase object
140 (standard-object
141 (format nil "Instance ~a of Class ~a" object (type-of object)))
142 (function (format nil "~a" object))
143 (structure-object
144 (let ((default (format nil "~a" object)))
145 (declare (simple-string default))
146 (if (and (> (length default) 2)
147 (char= (schar default 0) #\#)
148 (char= (schar default 1) #\S))
149 (format nil "#<~a Structure>" (type-of object))
150 default)))
151 (t
152 (format nil "~a ~a" (string-capitalize (type-of object))
153 (print-for-widget-display "~s" object))))))
154
155 (defmethod inspector-pane-title ((sym symbol))
156 (format nil "Symbol ~s" sym))
157
158 (defmethod inspector-pane-title ((v vector))
159 (declare (vector v))
160 (let ((length (length v))
161 (type (type-of v)))
162 (format nil "~a of length ~a"
163 (string-capitalize (if (listp type) (car type) type))
164 length)))
165
166 (defmethod inspector-pane-title ((a array))
167 (let ((dimensions (array-dimensions a)))
168 (format nil "Array of ~a Dimensions = ~s"
169 (array-element-type a) dimensions)))
170
171 (defmethod inspector-pane-title ((l list))
172 (if (listp (cdr l))
173 (format nil "List of length ~a" (length l))
174 (format nil "Dotted Pair")))
175
176
177
178 ;;;; Methods for displaying object inspection panes
179
180 ;;; WITH-INSPECTOR-PANE -- Public
181 ;;;
182 ;;; This macro is the primary tool for building inspection panes. It
183 ;;; creates all the fundamental pieces of the display pane and then calls
184 ;;; the supplied body to create the rest. A typical display method would
185 ;;; like something like:
186 ;;; (defmethod display-inspector-pane ((x mytype))
187 ;;; (with-inspector-pane (x)
188 ;;; ... custom forms ...
189 ;;; ))
190 ;;;
191 (defmacro with-inspector-pane ((object) &body forms)
192 `(multiple-value-bind
193 (pane is-new)
194 (create-interface-pane-shell (format nil "Inspect: ~a" (type-of ,object))
195 ,object)
196 (when is-new
197 (let* ((frame (create-frame pane "inspectFrame"))
198 (over-form (create-form frame "inspectForm"))
199 (menu-bar (create-menu-bar over-form "menubar"
200 :left-attachment :attach-form
201 :right-attachment :attach-form))
202 (obmenu (create-interface-menu
203 menu-bar "Object"
204 ,``(("Eval Expression" popup-eval-callback ,pane ,,object)
205 ("Close Pane" destroy-pane-callback ,,object)
206 ("Close All Panes" close-all-callback))))
207 (title (create-label-gadget
208 over-form "inspectTitle"
209 :label-string (inspector-pane-title ,object)
210 :font-list *header-font*
211 :top-attachment :attach-widget
212 :top-widget menu-bar
213 :left-attachment :attach-form
214 :right-attachment :attach-form))
215 (form (create-form over-form "inspectForm"
216 :left-attachment :attach-form
217 :right-attachment :attach-form
218 :bottom-attachment :attach-form
219 :top-attachment :attach-widget
220 :top-widget title)))
221
222 ,@forms
223 (manage-child frame)
224 (manage-child over-form)
225 (manage-child obmenu)
226 (manage-children menu-bar title form)))
227 (popup-interface-pane pane)))
228
229 ;;; DISPLAY-INSPECTOR-PANE -- Public
230 ;;;
231 ;;; This function takes an object and creates a graphical inspection pane
232 ;;; for displaying it.
233
234 ;;; This particular method is a catch all for the types which PCL won't
235 ;;; specialize on.
236 ;;;
237 (defmethod display-inspector-pane (object)
238 (typecase object
239 (standard-object (display-clos-pane object))
240 (function (display-function-pane object))
241 (structure-object (display-structure-pane object))
242 (t
243 (with-inspector-pane (object)
244 (let ((label (create-label-gadget
245 form "label"
246 :label-string (format nil "~s" object))))
247 (manage-child label))))))
248
249
250
251 (defmethod display-inspector-pane ((sym symbol))
252 (with-inspector-pane (sym)
253 (let* ((value (if (boundp sym) (symbol-value sym) "Unbound"))
254 (function (if (fboundp sym) (symbol-function sym) "Undefined"))
255 (plist (symbol-plist sym))
256 (package (symbol-package sym))
257 (rc (create-row-column form "rowColumn"))
258 (vview (create-value-box rc "Value:" value
259 :callback 'inspect-object-callback
260 :activep (boundp sym)))
261 (fview (create-value-box rc "Function:" function
262 :callback 'inspect-object-callback
263 :activep (fboundp sym)))
264 (plview (create-value-box rc "PList:" plist
265 :callback 'inspect-object-callback))
266 (pview (create-value-box rc "Package:" package
267 :callback 'inspect-object-callback)))
268 (manage-child rc)
269 (manage-children vview fview plview pview))))
270
271 (defun is-traced (function)
272 (let ((fun (debug::trace-fdefinition function)))
273 (if (gethash fun debug::*traced-functions*) t)))
274
275 (defun trace-function-callback (widget call-data function)
276 (declare (ignore widget))
277 (if (toggle-button-callback-set call-data)
278 (debug::trace-1 function (debug::make-trace-info))
279 (debug::untrace-1 function)))
280
281 (defun display-function-pane (f)
282 (with-inspector-pane (f)
283 (multiple-value-bind
284 (dstring dval)
285 (grab-output-as-string (describe f))
286 (declare (ignore dval))
287 (let* ((trace (create-toggle-button-gadget form "functionTrace"
288 :bottom-attachment :attach-form
289 :label-string "Trace Function"
290 :set (is-traced f)))
291 (sep (create-separator-gadget form "separator"
292 :left-attachment :attach-form
293 :right-attachment :attach-form
294 :bottom-attachment :attach-widget
295 :bottom-widget trace))
296 (descview (create-scrolled-window form "scrolledView"
297 :left-attachment :attach-form
298 :right-attachment :attach-form
299 :bottom-attachment :attach-widget
300 :bottom-widget sep
301 :top-attachment :attach-form
302 :scrolling-policy :automatic))
303 (desc (create-label descview "functionDescription"
304 :alignment :alignment-beginning
305 :label-string dstring)))
306
307 (add-callback trace :value-changed-callback
308 'trace-function-callback f)
309 (manage-child desc)
310 (manage-children trace sep descview)))))
311
312 (defun display-structure-pane (s)
313 (with-inspector-pane (s)
314 (let* ((dd (kernel:layout-info (kernel:%instance-layout s)))
315 (dsds (kernel:dd-slots dd))
316 (viewer (when (> (length dsds) *inspector-huge-object-threshold*)
317 (create-scrolled-window form "structureViewer"
318 :left-attachment :attach-form
319 :right-attachment :attach-form
320 :top-attachment :attach-form
321 :bottom-attachment :attach-form
322 :scrolling-policy :automatic)))
323 (rc (create-row-column (or viewer form) "rowColumn"))
324 (widgets))
325 (declare (list dsds))
326 (dolist (dsd dsds)
327 (push
328 (create-value-box rc (format nil "~A:"
329 (string-capitalize
330 (kernel:dsd-%name dsd)))
331 (funcall (kernel:dsd-accessor dsd) s)
332 :callback #'inspect-object-callback)
333 widgets))
334 (apply #'manage-children widgets)
335 (manage-child rc)
336 (when viewer (manage-child viewer)))))
337
338
339 (defun sequence-redisplay-callback (widget call-data v s-text c-text view pane)
340 (declare (ignore widget call-data))
341 (handler-case
342 (let* ((start (read-from-string (car (get-values s-text :value))))
343 (count (read-from-string (car (get-values c-text :value))))
344 (length (length v))
345 (widgets (reverse (xti:widget-children view)))
346 (unused-ones)
347 (used-ones))
348
349 (when (> (+ start count) length)
350 (setf count (- length start))
351 (set-values c-text :value (format nil "~a" count)))
352
353 (when (minusp start)
354 (setf start 0)
355 (set-values s-text :value (format nil "~a" 0)))
356
357 (dolist (widget widgets)
358 (if (zerop count)
359 (push widget unused-ones)
360 (progn
361 (set-value-box widget (format nil "~a:" start) (elt v start)
362 :callback #'inspect-object-callback)
363 (push widget used-ones)
364 (incf start)
365 (decf count))))
366
367 (dotimes (i count)
368 (let ((pos (+ start i)))
369 (push (create-value-box view (format nil "~a:" pos) (elt v pos)
370 :callback #'inspect-object-callback)
371 used-ones)))
372 (when unused-ones
373 (apply #'unmanage-children unused-ones))
374 (apply #'manage-children used-ones))
375 (error (e)
376 (interface-error (format nil "~a" e) pane))))
377
378 (defun sequence-filter-callback (widget call-data v fexp view pane)
379 (declare (ignore widget call-data))
380 (handler-case
381 (let* ((exp (read-from-string (car (get-values fexp :value))))
382 (length (length v))
383 (widgets (reverse (xti:widget-children view)))
384 (used-ones))
385 (dotimes (index length)
386 (let* ((item (elt v index))
387 (* item)
388 (** index))
389 (when (eval exp)
390 (let ((widget (pop widgets)))
391 (if widget
392 (set-value-box widget (format nil "~a:" index) item
393 :callback #'inspect-object-callback)
394 (setf widget (create-value-box
395 view (format nil "~a:" index) item
396 :callback #'inspect-object-callback)))
397 (push widget used-ones)))))
398 (when widgets
399 (apply #'unmanage-children widgets))
400 (apply #'manage-children used-ones))
401 (error (e)
402 (interface-error (format nil "~a" e) pane))))
403
404 (defun display-cons-pane (p form)
405 (let* ((rc (create-row-column form "rowColumn"))
406 (car-view (create-value-box rc "Car:" (car p)
407 :callback #'inspect-object-callback))
408 (cdr-view (create-value-box rc "Cdr:" (cdr p)
409 :callback #'inspect-object-callback)))
410 (manage-children car-view cdr-view)
411 (manage-child rc)))
412
413 (defmethod display-inspector-pane ((v sequence))
414 (with-inspector-pane (v)
415 (if (and (listp v)
416 (not (listp (cdr v))))
417 (display-cons-pane v form)
418 (let* ((length (length v))
419 (controls (create-row-column form "sequenceStartHolder"
420 :left-attachment :attach-form
421 :right-attachment :attach-form
422 :orientation :horizontal))
423 (slabel (create-label-gadget controls "sequenceStartLabel"
424 :font-list *header-font*
425 :label-string "Start:"))
426 (start (create-text controls "sequenceStart"
427 :value "0"
428 :columns 4))
429 (clabel (create-label-gadget controls "sequenceCountLabel"
430 :font-list *header-font*
431 :label-string "Count:"))
432 (count (create-text controls "sequenceCount"
433 :value "5"
434 :columns 4))
435 (filter (create-row-column form "sequenceFilterHolder"
436 :top-attachment :attach-widget
437 :top-widget controls
438 :left-attachment :attach-form
439 :right-attachment :attach-form
440 :orientation :horizontal))
441 (flabel (create-label-gadget filter "sequenceFilterLabel"
442 :font-list *header-font*
443 :label-string "Filter:"))
444 (fexp (create-text filter "sequenceFilterExp" :value "T"))
445 (apply (create-push-button-gadget filter "sequenceFilterApply"
446 :label-string "Apply"))
447 (unapply (create-push-button-gadget filter
448 "sequenceFilterUnapply"
449 :label-string "No Filter"))
450 (view (create-scrolled-window form "sequenceViewPort"
451 :scrolling-policy :automatic
452 :top-attachment :attach-widget
453 :top-widget filter
454 :bottom-attachment :attach-form
455 :left-attachment :attach-form
456 :right-attachment :attach-form))
457 (rc (create-row-column view "sequenceView"
458 :spacing 0))
459 (widgets))
460
461 (manage-children slabel start clabel count)
462 (manage-children flabel fexp apply unapply)
463
464 (dotimes (i (min length *inspector-sequence-initial-display*))
465 (let ((item (elt v i)))
466 (push (create-value-box rc (format nil "~a:" i) item
467 :callback #'inspect-object-callback)
468 widgets)))
469
470 (apply #'manage-children widgets)
471
472 (add-callback start :activate-callback 'sequence-redisplay-callback
473 v start count rc pane)
474 (add-callback count :activate-callback 'sequence-redisplay-callback
475 v start count rc pane)
476 (add-callback apply :activate-callback 'sequence-filter-callback
477 v fexp rc pane)
478 (add-callback fexp :activate-callback 'sequence-filter-callback
479 v fexp rc pane)
480 (add-callback unapply :activate-callback
481 #'(lambda (widget call-data)
482 (declare (ignore widget call-data))
483 (sequence-redisplay-callback
484 nil nil v start count rc pane)))
485
486 (manage-children view controls filter)
487 (manage-child rc)))))
488
489 (defun show-slot-list (object slot-list view allocp label)
490 (let ((label (create-label-gadget view "slotLabel"
491 :label-string label
492 :font-list *header-font*))
493 (widgets))
494 (dolist (slotd slot-list)
495 (with-slots ((slot pcl::name) (allocation pcl::allocation))
496 slotd
497 (let* ((slot-label (if allocp
498 (format nil "~a: " slot)
499 (format nil "~a [~a]: " slot allocation)))
500 (slot-bound (slot-boundp object slot))
501 (slot-value (if slot-bound
502 (slot-value object slot)
503 "Unbound")))
504 (push
505 (create-value-box view slot-label slot-value
506 :callback #'inspect-object-callback
507 :activep slot-bound)
508 widgets)))
509 (apply #'manage-children label widgets))))
510
511 (defun display-clos-pane (object)
512 (with-inspector-pane (object)
513 (let* ((class (pcl::class-of object))
514 (slotds (pcl::slots-to-inspect class object))
515 (view (create-row-column form "rowColumn"
516 :left-attachment :attach-form
517 :right-attachment :attach-form
518 :top-attachment :attach-form
519 :bottom-attachment :attach-form))
520 (instance-slots ())
521 (class-slots ())
522 (other-slots ()))
523
524 (dolist (slotd slotds)
525 (with-slots ((slot pcl::name) (allocation pcl::allocation))
526 slotd
527 (case allocation
528 (:instance (push slotd instance-slots))
529 (:class (push slotd class-slots))
530 (otherwise (push slotd other-slots)))))
531
532 (when instance-slots
533 (show-slot-list object instance-slots view t
534 "Slots with Instance allocation:"))
535 (when class-slots
536 (show-slot-list object class-slots view t
537 "Slots with Class allocation:"))
538 (when other-slots
539 (show-slot-list object other-slots view nil
540 "Slots with Other allocation:"))
541
542 (when view (manage-child view)))))
543
544
545
546 ;;;; Functions for creating the Motif inspector
547
548 (defun start-motif-inspector (object)
549 (verify-system-server-exists)
550 (multiple-value-bind (shell connection)
551 (create-interface-shell)
552 (declare (ignore shell))
553 (with-motif-connection (connection)
554 (verify-control-pane-displayed)
555 (display-inspector-pane object)
556 (push object *current-inspector-objects*)
557 (inspector-add-history-item object)))
558 object)
559
560
561
562 ;;;; User visible INSPECT function
563
564 ;;; INSPECT -- Public.
565 ;;;
566 (defun inspect (object &optional (style interface:*interface-style*))
567 "This function allows the user to interactively examine Lisp objects.
568 STYLE indicates whether this should run with a :graphics interface
569 or a :command-line oriented one; when running without X, there is no
570 choice. Supplying :window, :windows, :graphics, :graphical, and :x gets
571 a windowing interface, and supplying :command-line or :tty gets the
572 other style."
573
574 (let ((interface:*interface-style* style))
575 (if (use-graphics-interface)
576 (start-motif-inspector object)
577 (inspect::tty-inspect object))))

  ViewVC Help
Powered by ViewVC 1.1.5