Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv13750
Modified Files: dev-commands.lisp icons.lisp listener.lisp util.lisp Log Message: Added additional presentation translators to the listener to make class metaobjects and class names more interchangable (thanks to someone on IRC, I've forgotten who, very sorry..). Also a bugfix where class names were potentially printed to the wrong stream.
Adjust menu item names for entries in the listener show-commands table.
Some cleanups to the listener wholine-pane, and addition of a spiffy 3D background.
Date: Sun Jan 2 06:14:28 2005 Author: ahefner
Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.27 mcclim/Apps/Listener/dev-commands.lisp:1.28 --- mcclim/Apps/Listener/dev-commands.lisp:1.27 Mon Dec 20 16:44:47 2004 +++ mcclim/Apps/Listener/dev-commands.lisp Sun Jan 2 06:14:28 2005 @@ -384,10 +384,51 @@ (room))
(define-presentation-to-command-translator mem-room-translator - (lisp-memory-usage com-room lisp-commands :gesture :select) + (lisp-memory-usage com-room lisp-commands + :gesture :select + :documentation "Room" + :pointer-documentation "Room") ())
+(define-presentation-to-command-translator com-show-class-subclasses-translator + (class-name com-show-class-subclasses lisp-commands + :menu t + :documentation "Show Class Subclasses" + :pointer-documentation "Show Class Subclasses") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-superclasses-translator + (class-name com-show-class-superclasses lisp-commands + :menu t + :tester ((presentation) + (not (eq t (presentation-object presentation)))) + :documentation "Show Class Superclasses" + :pointer-documentation "Show Class Superclasses") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-generic-functions-translator + (class-name com-show-class-generic-functions lisp-commands + :menu t + :documentation "Show Class Generic Functions" + :pointer-documentation "Show Class Generic Functions") + (presentation) + (list (presentation-object presentation))) + + +(define-presentation-to-command-translator com-show-class-slots-translator + (class-name com-show-class-slots lisp-commands + :menu t + :documentation "Show Class Slots" + :pointer-documentation "Show Class Slots") + (presentation) + (list (presentation-object presentation))) + + ;;; CLOS introspection commands
(defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72)) @@ -407,7 +448,7 @@ ;; class object itself is rather long and freaks out the pointer doc pane. (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name) ; (surrounding-output-with-border (stream :shape :drop-shadow) - (princ (clim-mop:class-name class))))) ;) + (princ (clim-mop:class-name class) stream)))) ;) inferior-fun :stream stream :merge-duplicates T @@ -425,7 +466,7 @@
(define-command (com-show-class-superclasses :name "Show Class Superclasses" :command-table show-commands - :menu t + :menu "Class Superclasses" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -435,7 +476,7 @@
(define-command (com-show-class-subclasses :name "Show Class Subclasses" :command-table show-commands - :menu t + :menu "Class Subclasses" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -551,7 +592,7 @@ (defun print-slot-table-heading () (formatting-row (T) (dolist (name '("Slot name" "Initargs" "Initform" "Accessors")) - (formatting-cell (T :align-x :center) + (formatting-cell (T :align-x :center) (underlining (T) (with-text-family (T :sans-serif) (princ name))))))) @@ -586,7 +627,7 @@
(define-command (com-show-class-slots :name "Show Class Slots" :command-table show-commands - :menu t + :menu "Class Slots" :provide-output-destination-keyword t) ((class-name 'clim:symbol :prompt "class name")) (let ((class (find-class class-name nil))) @@ -652,7 +693,7 @@ (define-command (com-show-class-generic-functions :name "Show Class Generic Functions" :command-table show-commands - :menu t + :menu "Class Generic Functions" :provide-output-destination-keyword t) ((class-spec 'class-name :prompt "class")) (let ((class (frob-to-class class-spec))) @@ -796,7 +837,7 @@ (define-command (com-show-generic-function :name t :command-table show-commands - :menu t + :menu "Generic Function" :provide-output-destination-keyword t) ((gf 'generic-function :prompt "a generic function") &key (classes 'boolean :default nil :mentioned-default t) @@ -936,7 +977,7 @@
(define-command (com-show-used-packages :name "Show Used Packages" :command-table show-commands - :menu t + :menu "Used Packages" :provide-output-destination-keyword t) ((package-spec '(or package-name package) :prompt "package" :default *package*)) (let ((real-package (when package-spec @@ -949,7 +990,7 @@
(define-command (com-show-package-users :name "Show Package Users" :command-table show-commands - :menu t + :menu "Package Users" :provide-output-destination-keyword t) ((package-spec '(or package-name package) :prompt "package" :default *package*)) (let ((real-package (when package-spec @@ -1388,7 +1429,9 @@
;;; Some CLIM developer commands
-(define-command (com-show-command-table :name t :menu t :command-table show-commands) +(define-command (com-show-command-table :name t + :menu "Command Table" + :command-table show-commands) ((table 'clim:command-table :prompt "command table") &key (locally 'boolean :default nil :mentioned-default t) @@ -1407,7 +1450,8 @@ (push (cons ct (sort commands (lambda (x y) (string-lessp (command-line-name-for-command x ct :errorp :create) - (command-line-name-for-command y ct :errorp :create))))) our-tables))) + (command-line-name-for-command y ct :errorp :create))))) + our-tables))) (setq our-tables (nreverse our-tables))
(when show-commands ;; sure, why not?
Index: mcclim/Apps/Listener/icons.lisp diff -u mcclim/Apps/Listener/icons.lisp:1.2 mcclim/Apps/Listener/icons.lisp:1.3 --- mcclim/Apps/Listener/icons.lisp:1.2 Mon Sep 29 22:33:03 2003 +++ mcclim/Apps/Listener/icons.lisp Sun Jan 2 06:14:28 2005 @@ -33,7 +33,8 @@ ;(defparameter *icon-path* (merge-pathnames #P"icons/" #.*compile-file-truename*))
(defmacro deficon (var pathname) - `(defparameter ,var (climi::xpm-parse-file ,(merge-pathnames pathname *icon-path*)))) + `(eval-when (:load-toplevel :execute) + (defparameter ,var (climi::xpm-parse-file ,(merge-pathnames pathname *icon-path*)))))
(defvar *icon-cache* (make-hash-table :test #'equal))
Index: mcclim/Apps/Listener/listener.lisp diff -u mcclim/Apps/Listener/listener.lisp:1.19 mcclim/Apps/Listener/listener.lisp:1.20 --- mcclim/Apps/Listener/listener.lisp:1.19 Mon Dec 20 16:45:34 2004 +++ mcclim/Apps/Listener/listener.lisp Sun Jan 2 06:14:28 2005 @@ -22,26 +22,21 @@
;; Wholine Pane
-(defclass wholine-pane (application-pane) ()) +(defclass wholine-pane (application-pane) () + (:default-initargs :background +gray90+))
(defmethod compose-space ((pane wholine-pane) &key width height) (declare (ignore width height)) - (let ((h (+ 3 (text-style-height (medium-text-style pane) pane)))) ; magic padding - (make-space-requirement :min-width 500 :width 768 ; magic space requirements - :height h - :min-height h - :max-height h))) - -(defvar *reconfiguring-wholine* nil) - -(defmethod allocate-space ((pane wholine-pane) width height) - (unless *reconfiguring-wholine* - (let ((*reconfiguring-wholine* t)) - (call-next-method) - (window-clear pane) - (redisplay-frame-pane (pane-frame pane) pane)))) - - + (let ((h (* 1.5 (text-style-height (medium-text-style pane) pane)))) ; magic padding + (make-space-requirement :height h + :min-height h + :max-height h))) + +;; When the pane is grown, we must repaint more than just the newly exposed +;; regions, because the decoration within the previous region must move. +;; Likewise, shrinking the pane requires repainting some of the interior. +(defmethod allocate-space :after ((pane wholine-pane) width height) + (repaint-sheet pane (sheet-region pane)))
(defun print-package-name (stream) (let ((foo (package-name *package*))) @@ -53,7 +48,27 @@ (defun frob-pathname (pathname) (namestring (truename pathname)))
-(defun display-wholine (frame pane) +;; How to add repaint-time decoration underneath the contents of a +;; stream pane: Write your own handle-repaint that draws the +;; decoration then replays the recorded output, and define a +;; window-clear method which calls the next window-clear method, +;; then calls handle-repaint to redraw the decoration. + +(defmethod handle-repaint ((pane wholine-pane) region) + (declare (ignore region)) + (with-output-recording-options (pane :draw t :record nil) + (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) + (climi::draw-bordered-rectangle* (sheet-medium pane) + x0 y0 x1 y1 + :style :mickey-mouse-inset) + #+NIL (draw-rectangle* (sheet-medium pane) x0 y0 x1 y1 :ink +red+)) + (replay-output-record (stream-output-history pane) pane))) + +(defmethod window-clear ((pane wholine-pane)) + (call-next-method) + (handle-repaint pane (sheet-region pane))) + +(defun generate-wholine-contents (frame pane) (declare (ignore frame)) (let* ((*standard-output* pane) (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) @@ -84,15 +99,19 @@ (format T " (~D deep)" (length *directory-stack*))))) ;; Although the CLIM spec says the item formatter should try to fill ;; the available width, I can't get either the item or table formatters - ;; to really do so such that the memory usage appears right justified. + ;; to really do so such that the memory usage appears right justified. (cell (:center) (when (numberp memusage) (present memusage 'lisp-memory-usage)))))))))
-;; This is a (very simple) command history. -;; Should we move this into CLIM-INTERNALS ? +(defun display-wholine (frame pane) + (invoke-and-center-output pane + (lambda () (generate-wholine-contents frame pane)) + :horizontally nil :hpad 5)) + +;; This is a toy command history. ;; Possibly this should become something integrated with the presentation -;; histories which I have not played with. +;; histories, which I have not played with.
(defclass command-history-mixin () ((history :initform nil :accessor history) @@ -224,8 +243,6 @@ '(#( #) #[ #] ## #; #: #' #" #* #, #` #- #+ #/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
- - (defmethod read-frame-command ((frame listener) &key (stream *standard-input*)) "Specialized for the listener, read a lisp form to eval, or a command." (if (system-command-reader frame) @@ -302,11 +319,15 @@
(defun run-listener (&key (system-command-reader nil) (new-process nil) + (width 800) + (height 800) (process-name "Listener") (eval nil)) (flet ((run () (run-frame-top-level (make-application-frame 'listener + :width width + :height height :system-command-reader system-command-reader) :listener-funcall (cond ((null eval) nil) ((functionp eval) eval)
Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.15 mcclim/Apps/Listener/util.lisp:1.16 --- mcclim/Apps/Listener/util.lisp:1.15 Mon Dec 20 16:46:49 2004 +++ mcclim/Apps/Listener/util.lisp Sun Jan 2 06:14:28 2005 @@ -209,6 +209,26 @@ (- x (stream-cursor-position stream))) 0))
+(defun invoke-and-center-output (stream-pane continuation + &key (horizontally t) (vertically t) (hpad 0) (vpad 0)) + (let ((record (with-output-to-output-record (stream-pane) + (funcall continuation)))) + (with-bounding-rectangle* (sx0 sy0 sx1 sy1) (sheet-region stream-pane) + (with-bounding-rectangle* (rx0 ry0 rx1 ry1) (bounding-rectangle record) + (setf (output-record-position record) + (values (if horizontally + (+ rx0 (/ (- (- sx1 sx0) + (- rx1 rx0)) + 2)) + (+ rx0 hpad)) + (if vertically + (+ ry0 (/ (- (- sy1 sy0) + (- ry1 ry0)) + 2)) + (+ ry0 vpad)))))) + (add-output-record record (stream-output-history stream-pane)) + (repaint-sheet stream-pane record))) + ;;; Pathname evil ;;; Fixme: Invent some more useful operators for manipulating pathnames, add a ;;; pinch of syntactic sugar, and cut the LOC here down to a fraction.