Update of /project/mcclim/cvsroot/mcclim In directory cl-net:/tmp/cvs-serv9908
Modified Files: commands.lisp dialog.lisp Log Message: Add new keyword to accepting-values, select-first-query, to automatically select the first field in the dialog (we could do this using an existing keyword, but figuring out the right query ID and getting it where it needed to be looked like too much work). This highlights what I think is an existing bug - the exit buttons often don't work when a field in the dialog is accepting.
Minor aesthetic tweaks to accepting-values dialog (change border styles, dress up exit buttons, rearrange some line breaks).
--- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/10/23 20:49:41 1.80 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/12/06 14:56:41 1.81 @@ -856,24 +856,26 @@ ,command-table :errorp nil)) ,@(mapcar #'list required-arg-names original-args)) - (accepting-values (,stream) + (accepting-values (,stream :select-first-query t + :align-prompts t) (format ,stream - "You are being prompted for arguments to ~S~%~%" + "You are being prompted for arguments to ~S~%" ,command-line-name) ,@(loop for var in required-arg-names for original-var in original-args for parameter in required-args + for first-arg = t then nil append `((multiple-value-bind (,value ,ptype ,changedp) ,(accept-form-for-argument-partial stream parameter var original-var) (declare (ignore ,ptype)) - (terpri ,stream) + ,@(unless first-arg `((terpri ,stream))) (when ,changedp (setq ,var ,value))))) (when still-missing (format ,stream - "~&Please supply all arguments."))) + "~&Please supply all arguments.~%"))) (setf ,partial-command (list ,command-name ,@required-arg-names)) (unless (partial-command-p ,partial-command) (return ,partial-command)))))))))) --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2008/02/01 00:22:04 1.29 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2008/12/06 14:56:41 1.30 @@ -155,12 +155,12 @@ &rest args &key own-window exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame - align-prompts label scroll-bars + align-prompts label scroll-bars select-first-query x-position y-position width height command-table frame-class) &body body) (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame - align-prompts scroll-bars + align-prompts scroll-bars select-first-query x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) @@ -185,6 +185,7 @@ (stream body &key own-window exit-boxes (initially-select-query-identifier nil initially-select-p) + select-first-query modify-initial-query resynchronize-every-pass resize-frame align-prompts label scroll-bars x-position y-position width height @@ -229,6 +230,14 @@ ('(command :command-table accept-values)) (object) (progn + (when (and select-first-query + (not initially-select-p)) + (setf current-command + `(com-select-query + ,(query-identifier + (first + (queries *accepting-values-stream*)))) + select-first-query nil)) (apply (command-name current-command) (command-arguments current-command)) ;; If current command returns without throwing a @@ -252,13 +261,22 @@ (declare (ignore frame)) (updating-output (stream :unique-id 'buttons :cache-value t) (fresh-line stream) - (with-output-as-presentation - (stream nil 'exit-button) - (format stream "OK")) - (write-char #\space stream) - (with-output-as-presentation - (stream nil 'abort-button) - (format stream "Cancel")) + (formatting-table (stream) + (formatting-row (stream) + (formatting-cell (stream) + (with-output-as-presentation (stream nil 'exit-button) + (surrounding-output-with-border + (stream :shape :rounded :radius 6 + :background +gray80+ :highlight-background +gray90+) + (format stream "OK")))) + (formatting-cell (stream) + (with-output-as-presentation + (stream nil 'abort-button) (with-output-as-presentation + (stream nil 'exit-button) + (surrounding-output-with-border + (stream :shape :rounded :radius 6 + :background +gray80+ :highlight-background +gray90+) + (format stream "Cancel"))))))) (terpri stream)))
(defmethod stream-accept ((stream accepting-values-stream) type @@ -457,16 +475,25 @@ (stream query-identifier 'selectable-query :single-box t) (surrounding-output-with-border - (stream :shape :inset :move-cursor t) + (stream :shape :rounded + :radius 3 :background +white+ + :foreground +gray40+ + :move-cursor t) + ;;; FIXME: In this instance we really want borders that + ;;; react to the growth of their children. This should + ;;; be straightforward unless there is some involvement + ;;; of incremental redisplay. + ;;; KLUDGE: Arbitrary min-width. (setq editing-stream (make-instance (if *use-goatee* 'goatee-input-editing-stream 'standard-input-editing-stream) :stream stream :cursor-visibility nil - :background-ink +grey90+ :single-line t - :min-width t)))) + :min-width (- (bounding-rectangle-max-x stream) + (stream-cursor-position stream) + 100))))) (when default-supplied-p (input-editing-rescan-loop ;XXX probably not needed editing-stream