Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv20883

Modified Files: dev-commands.lisp listener.lisp Log Message: If we're going to present the package portion of the prompt, we might as well define a translator to do something useful with it (or am I missing the point?). While we're at it, present the package in the wholine-pane, and add a popup to choose a new package.

Also, added discussion of presentation of values at the REPL, as I'm not entirely happy with the current behavior, but leave it unchanged for the moment.

--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/21 20:34:40 1.38 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/12/03 22:56:46 1.39 @@ -23,7 +23,7 @@

(define-command-table application-commands)

-(define-command-table lisp-dev-commands :inherit-from nil) ;; "Abstract" command table used for defining some translators in +(define-command-table lisp-dev-commands :inherit-from nil) ;; Translators live here (define-command-table lisp-commands :inherit-from (lisp-dev-commands))

(define-command-table show-commands :inherit-from (lisp-dev-commands)) @@ -519,11 +519,11 @@ ((class-spec 'class-name :prompt "class") &key (orientation 'keyword :prompt "orientation" :default :horizontal)) - (let ((class (frob-to-class class-spec))) - (if (not (null class)) + (let ((class (frob-to-class class-spec))) + (if (not (null class)) (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses :orientation orientation) - (note "~A is not a defined class." class-spec)))) + (note "~A is not a defined class." class-spec))))

; Lookup direct slots from along the CPL given a class and a slot name. @@ -1261,7 +1261,7 @@ ;; So.. yeah.

(defun automagic-translator (pathname) - "Returns values, the command translation, and a documentation string for the translation." + "Returns 2 values: the command translation, and a documentation string for the translation." (cond ((wild-pathname-p pathname) (values `(com-show-directory ,pathname) "Show Matching Files" @@ -1443,26 +1443,47 @@ ;;; Eval

(defun display-evalues (values) - (with-drawing-options (t :ink +olivedrab+) - (cond ((null values) - (format t "No values.~%")) - ((= 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)) - (items values (rest items)) - (o (first items) (first items))) - ((null items)) + (labels + ((present-value (value) + ;; I would really prefer this to behave as below, as presenting + ;; things as expressions causes translators applicable to expression + ;; to override those which would be otherwise applicable (such as + ;; the set-current-package translator). I retain the use of w-o-a-p, + ;; swapping the inner/outer presentation types, with the assumption + ;; that someone (the form reader?) really does want expressions, and + ;; the presentation-type-of is seldom a subtype of expression. + ;; Aside from that, the problem with my code below is that it + ;; will use the default presentation method for the type, which will + ;; not necessarily print in the fashion expected from the lisp REPL. + ;; Possibly this +listener-view+ could save the day here, but I'm + ;; unclear on why it exists. --Hefner + + ;; Okay, set-current-package translator now mysteriously works, but + ;; I stand by the notion that 'expression should not be the type of + ;; the innermost presentation. + + #+(or) + (with-output-as-presentation (t value 'expression :single-box t) + (present value (presentation-type-of value) :single-box t)) + + (with-output-as-presentation (t value (presentation-type-of value) + :single-box t) + (present (first values) 'expression)))) + (with-drawing-options (t :ink +olivedrab+) + (cond ((null values) + (format t "No values.~%")) + ((= 1 (length values)) + (present-value (first values)) + (fresh-line)) + (t (do* ((i 0 (1+ i)) + (items values (rest items)) + (object (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))) - (with-output-as-presentation (t o (presentation-type-of o) - :single-box t) - (present o 'expression)) - (fresh-line)))))) + (present-value object) + (fresh-line)))))))

(defun shuffle-specials (form values) (setf +++ ++ @@ -1476,7 +1497,7 @@ * (first values)))

(define-command (com-eval :menu t :command-table lisp-commands) - ((form 'clim:form :prompt "form")) + ((form 'clim:form :prompt "form")) (let* ((- form) (values (multiple-value-list (eval form)))) (fresh-line) @@ -1563,3 +1584,14 @@ :provide-output-destination-keyword nil) ((p 'package)) (setf *package* p)) + +(define-presentation-to-command-translator set-current-package + (package com-set-package lisp-commands + :pointer-documentation ((object stream) + (format stream "Set current package to ~A" (package-name object))) + :documentation ((stream) (format stream "Set Package")) + :menu t + :tester ((object) (not (eql *package* object)))) + (object) + (list object)) + --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/21 22:39:32 1.30 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/12/03 22:56:46 1.31 @@ -19,6 +19,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.

+(define-presentation-type listener-current-package () :inherit-from 'package)

;; Wholine Pane

@@ -92,7 +93,8 @@ (cell (:left) (format t "~A@~A" username sitename)) (cell (:center) (format t "Package ") - (print-package-name t)) + (with-output-as-presentation (t *package* 'listener-current-package) + (print-package-name t))) (cell (:center) (when (probe-file *default-pathname-defaults*) (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) @@ -163,7 +165,7 @@ (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) + (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 @@ -199,6 +201,29 @@ doc wholine))))

+;;; Package selection popup + +(define-listener-command (com-choose-package) + () + (let ((new-package (menu-choose (sort (mapcar (lambda (package) (cons (package-name package) + package)) + (list-all-packages)) + #'string< + :key #'car) + :label "Choose Package"))) + (when new-package + (setf *package* new-package)))) + +(define-presentation-to-command-translator choose-package-translator + (listener-current-package com-choose-package listener + :echo nil + :priority 100 ; These presentations appear in exactly one context, so give this a high priority. + :documentation ((object stream) + (declare (ignore object)) + (format stream "Choose package"))) + (current-package) + nil) + ;;; Lisp listener command loop

(defmethod read-frame-command ((frame listener) &key (stream *standard-input*))