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) ,@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))