[mcclim-cvs] CVS mcclim/Apps/Listener
crhodes
crhodes at common-lisp.net
Fri Nov 17 12:30:56 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Apps/Listener
In directory clnet:/tmp/cvs-serv4741
Modified Files:
dev-commands.lisp listener.lisp
Log Message:
A bit more prettiness: define a stream-present method to enforce
:single-box t on listener-interactor streams; pass :single-box t
explicitly to with-output-as-presentation, which is different.
Make package prompts be presented as type 'package.
--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 09:51:18 1.36
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 12:30:56 1.37
@@ -106,7 +106,8 @@
(write-char #\( stream)
(present arg 'symbol :stream stream)
(write-char #\space stream)
- (with-output-as-presentation (stream spec 'specializer)
+ (with-output-as-presentation (stream spec 'specializer
+ :single-box t)
(if (typep spec 'class)
(format stream "~S" (clim-mop:class-name spec))
(format stream "~S" `(eql ,(clim-mop:eql-specializer-object spec)))))
@@ -476,7 +477,8 @@
:text-style text-style)
;; Present class name rather than class here because the printing of the
;; 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)
+ (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name
+ :single-box t)
; (surrounding-output-with-border (stream :shape :drop-shadow)
(princ (clim-mop:class-name class) stream)))) ;)
inferior-fun
@@ -567,7 +569,7 @@
(with-ink (,var) , at body) )))
(fcell (name :left)
- (with-output-as-presentation (t slot 'slot-definition)
+ (with-output-as-presentation (t slot 'slot-definition :single-box t)
(princ name))
(unless (eq type t)
(fresh-line)
@@ -602,13 +604,13 @@
(with-ink (readers)
(if readers
(dolist (reader readers)
- (present reader (presentation-type-of reader) :single-box t)
+ (present reader (presentation-type-of reader))
(terpri))
(note "No readers~%")))
(with-ink (writers)
(if writers
(dolist (writer writers)
- (present writer (presentation-type-of writer) :single-box t)
+ (present writer (presentation-type-of writer))
(terpri))
(note "No writers"))))))
@@ -687,7 +689,7 @@
(invoke-as-heading
(lambda ()
(format t "~&Slots for ")
- (with-output-as-presentation (t (clim-mop:class-name class) 'class-name)
+ (with-output-as-presentation (t (clim-mop:class-name class) 'class-name :single-box t)
(princ (clim-mop:class-name class)))))
(present-the-slots class) ))))))
@@ -916,7 +918,8 @@
do (progn
(with-output-as-presentation (*standard-output*
(clim-mop:class-name class)
- 'class-name)
+ 'class-name
+ :single-box t)
(format *standard-output*
"~S~%" (clim-mop:class-name class)))))))
(when methods
@@ -1009,7 +1012,8 @@
normal-ink
(make-rgb-color 0.4 0.4 0.4))
:text-style text-style)
- (with-output-as-presentation (stream package 'package)
+ (with-output-as-presentation (stream package 'package
+ :single-box t)
(format stream "~A (~D/~D)" (package-name package) internal external)))))
inferior-fun
:stream stream
@@ -1061,7 +1065,8 @@
:version (pathname-version pathname))))))
(defun pretty-pretty-pathname (pathname stream &key (long-name t))
- (with-output-as-presentation (stream pathname 'clim:pathname)
+ (with-output-as-presentation (stream pathname 'clim:pathname
+ :single-box t)
(let ((icon (icon-of pathname)))
(when icon (draw-icon stream icon :extra-spacing 3)))
(princ (pathname-printing-name pathname long-name) stream))
@@ -1135,7 +1140,7 @@
(format t " (only files of type ~a)" (pathname-type pathname)))))
(when (parent-directory pathname)
- (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname)
+ (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname :single-box t)
(draw-icon t (standard-icon "up-folder.xpm") :extra-spacing 3)
(format t "Parent Directory~%")))
@@ -1441,19 +1446,23 @@
(with-drawing-options (t :ink +olivedrab+)
(cond ((null values)
(format t "No values.~%"))
- ((= 1 (length values))
- (present (first values) (presentation-type-of (first values))
- :single-box t)
+ ((= 1 (length values))
+ (let ((o (first values)))
+ (with-output-as-presentation (t o (presentation-type-of o)
+ :single-box t)
+ (present (first values) 'expression)))
(fresh-line))
- (t (do ((i 0 (1+ i))
- (item values (rest item)))
- ((null item))
+ (t (do* ((i 0 (1+ i))
+ (items values (rest items))
+ (o (first items) (first items)))
+ ((null items))
(with-drawing-options (t :ink +limegreen+)
(with-text-style (t (make-text-style nil :italic :small))
(format t "~A " i)))
- (present (first item) (presentation-type-of (first item))
- :single-box t)
- (fresh-line))))))
+ (with-output-as-presentation (t o (presentation-type-of o)
+ :single-box t)
+ (present o 'expression))
+ (fresh-line))))))
(defun shuffle-specials (form values)
(setf +++ ++
@@ -1510,7 +1519,7 @@
(invoke-as-heading
(lambda ()
(format t "Command table ")
- (with-output-as-presentation (t ct 'clim:command-table)
+ (with-output-as-presentation (t ct 'clim:command-table :single-box t)
(princ (command-table-name ct)))))
(if commands
(format-items commands :printer (lambda (cmd s) (present cmd 'clim:command-name :stream s))
--- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 09:51:18 1.27
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 12:30:56 1.28
@@ -186,15 +186,35 @@
(values result type)
(input-not-of-required-type result type))))
+;;; Listener interactor stream. If only STREAM-PRESENT were
+;;; specializable on the VIEW argument, this wouldn't be necessary.
+;;; However, it isn't, so we have to play this game. We currently
+;;; only use this to get single-box presentation highlighting.
+
+(defclass listener-interactor-pane (interactor-pane) ())
+
+(defmethod stream-present :around
+ ((stream listener-interactor-pane) object type
+ &rest args &key (single-box nil sbp) &allow-other-keys)
+ (apply #'call-next-method stream object type :single-box t args)
+ ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all
+ ;; the keyword arguments explicitly. *sigh*.
+ #+nil
+ (if sbp
+ (call-next-method)
+ (apply #'call-next-method stream object type :single-box t args)))
+
;;; Listener application frame
(define-application-frame listener (standard-application-frame
command-history-mixin)
((system-command-reader :accessor system-command-reader
:initarg :system-command-reader
:initform t))
- (:panes (interactor :interactor :scroll-bars t
- :display-function #'listener-initial-display-function
- :display-time t)
+ (:panes (interactor-container
+ (make-clim-stream-pane
+ :type 'listener-interactor-pane
+ :name 'interactor :scroll-bars t :display-time t
+ :display-function #'listener-initial-display-function))
(doc :pointer-documentation)
(wholine (make-pane 'wholine-pane
:display-function 'display-wholine :scroll-bars nil
@@ -210,7 +230,7 @@
(:menu-bar t)
(:layouts (default
(vertically ()
- interactor
+ interactor-container
doc
wholine))))
@@ -298,16 +318,17 @@
object type)
(flet ((sensitizer (stream cont)
(case type
- ((command) (with-output-as-presentation
- (stream object type :single-box t)
+ ((command) (with-output-as-presentation (stream object type :single-box t)
(funcall cont)))
- ((form) (with-output-as-presentation
- (stream object 'command :single-box t)
- (with-output-as-presentation
- (stream (cadr object)
- (presentation-type-of (cadr object))
- :single-box t)
- (funcall cont))))
+ ((form)
+ (with-output-as-presentation (stream object 'command :single-box t)
+ (with-output-as-presentation
+ (stream (cadr object) 'expression :single-box t)
+ (with-output-as-presentation
+ (stream (cadr object)
+ (presentation-type-of (cadr object))
+ :single-box t)
+ (funcall cont)))))
(t (funcall cont)))))
(handler-case
;; Body
@@ -354,15 +375,15 @@
(command
;; Kludge the cursor position - Goatee will have moved it all around
(setf (stream-cursor-position stream) (values x y))
- (present object object-type
- :view (stream-default-view stream)
- :stream stream :single-box t)
+ (present object object-type :stream stream
+ :view (stream-default-view stream))
object))))
(defun print-listener-prompt (stream frame)
(declare (ignore frame))
(with-text-face (stream :italic)
- (print-package-name stream)
+ (with-output-as-presentation (stream *package* 'package :single-box t)
+ (print-package-name stream))
(princ "> " stream)))
(defmethod frame-standard-output ((frame listener))
More information about the Mcclim-cvs
mailing list