[mcclim-cvs] CVS mcclim

[ahefner]

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 , at 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