[mcclim-cvs] CVS mcclim/Apps/Listener
ahefner
ahefner at common-lisp.net
Sun Dec 3 22:56:46 UTC 2006
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*))
More information about the Mcclim-cvs
mailing list