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.
