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

Contents of /src/interface/inspect.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Tue Nov 16 11:42:35 1993 UTC (20 years, 5 months ago) by garland
Branch: MAIN
Changes since 1.7: +6 -5 lines
Added an optional STYLE arg to the graphical inspector to make the
function consistent with its doc string (as well as the old inspector).
1 garland 1.1 ;;;; -*- Mode: Lisp ; Package: Interface -*-
2     ;;;
3 garland 1.2 ;;; **********************************************************************
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 garland 1.1 ;;;
9 garland 1.2 ;;; **********************************************************************
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 garland 1.1
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 garland 1.2 (setf *current-inspector-objects*
40     (delete object *current-inspector-objects*))
41 garland 1.1 (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 garland 1.2 ;;; 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 garland 1.1 (defmethod inspector-pane-title (object)
137 ram 1.7 (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 garland 1.1
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 garland 1.5 (if (listp (cdr l))
173     (format nil "List of length ~a" (length l))
174     (format nil "Dotted Pair")))
175 garland 1.1
176    
177    
178     ;;;; Methods for displaying object inspection panes
179    
180 garland 1.2 ;;; 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 garland 1.1 (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 garland 1.2 ("Close Pane" destroy-pane-callback ,,object)
206     ("Close All Panes" close-all-callback))))
207 garland 1.1 (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 garland 1.2 ;;; 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 garland 1.1 (defmethod display-inspector-pane (object)
238     (typecase object
239 ram 1.6 (standard-object (display-clos-pane object))
240 garland 1.1 (function (display-function-pane object))
241 ram 1.4 (structure-object (display-structure-pane object))
242 garland 1.1 (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 garland 1.5
251 garland 1.1 (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 ram 1.4 (let* ((dd (kernel:layout-info (kernel:%instance-layout s)))
315     (dsds (kernel:dd-slots dd))
316 garland 1.1 (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 ram 1.4 (string-capitalize
330     (kernel:dsd-%name dsd)))
331     (funcall (kernel:dsd-accessor dsd) s)
332 garland 1.1 :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 garland 1.5 (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 garland 1.1 (defmethod display-inspector-pane ((v sequence))
414     (with-inspector-pane (v)
415 garland 1.5 (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 garland 1.1
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 ram 1.7 (with-slots ((slot pcl::name) (allocation pcl::allocation))
496 garland 1.1 slotd
497     (let* ((slot-label (if allocp
498     (format nil "~a: " slot)
499     (format nil "~a [~a]: " slot allocation)))
500 ram 1.7 (slot-bound (slot-boundp object slot))
501 garland 1.1 (slot-value (if slot-bound
502 ram 1.7 (slot-value object slot)
503 garland 1.1 "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 ram 1.3 (let* ((class (pcl::class-of object))
514 garland 1.1 (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 class-slots other-slots)
521    
522     (dolist (slotd slotds)
523 ram 1.7 (with-slots ((slot pcl::name) (allocation pcl::allocation))
524     slotd
525 garland 1.1 (case allocation
526     (:instance (push slotd instance-slots))
527     (:class (push slotd class-slots))
528     (otherwise (push slotd other-slots))))
529     (when instance-slots
530     (show-slot-list object instance-slots view t
531     "Slots with Instance allocation:"))
532     (when class-slots
533     (show-slot-list object class-slots view t
534     "Slots with Class allocation:"))
535     (when other-slots
536     (show-slot-list object other-slots view nil
537     "Slots with Other allocation:"))))))
538    
539    
540    
541     ;;;; Functions for creating the Motif inspector
542    
543     (defun start-motif-inspector (object)
544     (verify-system-server-exists)
545     (multiple-value-bind (shell connection)
546     (create-interface-shell)
547     (declare (ignore shell))
548     (with-motif-connection (connection)
549     (verify-control-pane-displayed)
550     (display-inspector-pane object)
551 garland 1.2 (push object *current-inspector-objects*)
552 garland 1.1 (inspector-add-history-item object)))
553     object)
554    
555    
556    
557     ;;;; User visible INSPECT function
558    
559     ;;; INSPECT -- Public.
560     ;;;
561 garland 1.8 (defun inspect (object &optional (style interface:*interface-style*))
562 garland 1.1 "This function allows the user to interactively examine Lisp objects.
563 garland 1.8 STYLE indicates whether this should run with a :graphics interface
564 garland 1.1 or a :command-line oriented one; when running without X, there is no
565     choice. Supplying :window, :windows, :graphics, :graphical, and :x gets
566     a windowing interface, and supplying :command-line or :tty gets the
567     other style."
568    
569 garland 1.8 (let ((interface:*interface-style* style))
570     (if (use-graphics-interface)
571     (start-motif-inspector object)
572     (inspect::tty-inspect object))))

  ViewVC Help
Powered by ViewVC 1.1.5