allow a button% to have both a string and a bitmap for its label

collects/games/main.rkt

@@ -87,8 +87,7 @@
   (define buttons
     (map (lambda (game)
            (new button%
-                [label ((bitmap-label-maker (game-name game) (game-icon game))
+                [label (list (read-bitmap (game-icon game)) (game-name game) 'left)]
-                        panel)]
                 [parent panel]
                 [callback (lambda _ (run-game game))]))
          games))

collects/mred/private/check.rkt

@@ -146,6 +146,19 @@
     (unless (or (label-string? label) (is-a? label wx:bitmap%))
       (raise-type-error (who->name who) "string (up to 200 characters) or bitmap% object" label)))
 
+  (define (check-label-string-or-bitmap-or-both who label)
+    (unless (or (label-string? label) (is-a? label wx:bitmap%)
+                (and (list? label) 
+                     (= 3 (length label)) 
+                     (is-a? (car label) wx:bitmap%)
+                     (label-string? (cadr label))
+                     (memq (caddr label) '(left right top bottom))))
+      (raise-type-error (who->name who) 
+                        (string-append
+                         "string (up to 200 characters), bitmap% object, or list of bitmap%, "
+                         "string, and image-placement symbol ('left, 'right, 'top, or 'bottom)")
+                        label)))
+
   (define (check-label-string-or-bitmap/false who label)
     (unless (or (not label) (label-string? label) (is-a? label wx:bitmap%))
       (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or #f" label)))

collects/mred/private/mritem.rkt

@@ -58,10 +58,16 @@
 									   ;; for keyword use
 									   [font no-val])
       (rename [super-set-label set-label])
-      (private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)])
+      (private-field [label lbl][callback cb] 
+                     [can-bitmap? (or (lbl . is-a? . wx:bitmap%)
+                                      (pair? lbl))]
+                     [can-string? (or (string? lbl)
+                                      (pair? lbl))])
       (override
 	[get-label (lambda () label)]
-	[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
+	[get-plain-label (lambda () 
+                           (let ([label (if (pair? label) (cadr label) label)])
+                             (and (string? label) (wx:label->plain-label label))))]
 	[set-label (entry-point
 		    (lambda (l)
 		      ((label-checker)
@@ -69,12 +75,16 @@
 		      (let ([l (if (string? l)
                                  (string->immutable-string l)
                                  l)])
-                        (when (or (and is-bitmap?
+                        (when (or (and can-bitmap?
                                        (l . is-a? . wx:bitmap%))
-                                  (and (not is-bitmap?)
+                                  (and can-string?
                                        (string? l)))
                           (send wx set-label l)
-                          (set! label l)))))])
+                          (if (pair? label)
+                              (if (string? l)
+                                  (set! label (list (car label) l (caddr label)))
+                                  (set! label (list l (cadr label) (caddr label))))
+                              (set! label l))))))])
       (public
 	[hidden-child? (lambda () #f)] ; module-local method
 	[label-checker  (lambda () check-label-string/false)] ; module-local method
@@ -210,7 +220,7 @@
 	[label-checker  (lambda () check-label-string-or-bitmap)]) ; module-local method
       (sequence
 	(let ([cwho '(constructor button)])
-	  (check-label-string-or-bitmap cwho label)
+	  (check-label-string-or-bitmap-or-both cwho label)
 	  (check-container-parent cwho parent)
 	  (check-callback cwho callback)
 	  (check-style cwho #f '(border deleted) style)

collects/mred/private/wx/cocoa/button.rkt

@@ -32,6 +32,11 @@
   (-a _void (clicked: [_id sender])
       (queue-window*-event wxb (lambda (wx) (send wx clicked)))))
 
+(define NSImageLeft 2)
+(define NSImageRight 3)
+(define NSImageBelow 4)
+(define NSImageAbove 5)
+
 (defclass core-button% item%
   (init parent cb label x y w h style font
         [button-type #f])
@@ -57,11 +62,21 @@
        [else
         (if button-type
             (tellv cocoa setTitle: #:type _NSString "")
-            (tellv cocoa setImage: (bitmap->image label)))])
+            (begin
+              (when (pair? label)
+                (tellv cocoa setTitle: #:type _NSString (cadr label))
+                (tellv cocoa setImagePosition: #:type _NSInteger 
+                       (case (caddr label)
+                         [(left) NSImageLeft]
+                         [(right) NSImageRight]
+                         [(top) NSImageAbove]
+                         [(bottom) NSImageBelow])))
+              (tellv cocoa setImage: (bitmap->image (if (pair? label) (car label) label)))))])
       (init-font cocoa font)
       (tellv cocoa sizeToFit)
       (when (and (eq? event-type 'button)
-                 (string? label))
+                 (or (string? label)
+                     (pair? label)))
         (when font
           (let ([n (send font get-point-size)])
             ;; If the font is small, adjust the control size:
@@ -85,10 +100,19 @@
                                            (NSSize-height (NSRect-size frame)))))))
       cocoa))
 
+  (when (pair? label)
+    ;; It looks better to add extra padding around the button:
+    (let ([f (tell #:type _NSRect button-cocoa frame)])
+      (tellv button-cocoa setFrame: #:type _NSRect 
+             (make-NSRect
+              (NSRect-origin f)
+              (make-NSSize (+ (NSSize-width (NSRect-size f)) 2)
+                           (+ (NSSize-height (NSRect-size f)) 4))))))
+  
   (define-values (cocoa image-cocoa)
     (if (and button-type
              (not (string? label)))
-        ;; Check-box image: need an view to join a button and an image view:
+        ;; Check-box image: need a view to join a button and an image view:
         ;; (Could we use the NSImageButtonCell from the radio-box implementation
         ;;  instead?)
         (let* ([frame (tell #:type _NSRect button-cocoa frame)]

collects/mred/private/wx/gtk/button.rkt

@@ -22,6 +22,13 @@
 (define-gtk gtk_button_new (_fun -> _GtkWidget))
 (define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void))
 (define-gtk gtk_button_set_label (_fun _GtkWidget _string -> _void))
+(define-gtk gtk_button_set_image (_fun _GtkWidget _GtkWidget -> _void))
+(define-gtk gtk_button_set_image_position (_fun _GtkWidget _int -> _void))
+
+(define GTK_POS_LEFT 0)
+(define GTK_POS_RIGHT 1)
+(define GTK_POS_TOP 2)
+(define GTK_POS_BOTTOM 3)
 
 (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
 (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
@@ -47,19 +54,36 @@
                     (as-gtk-allocation
                      (gtk_new_with_mnemonic (or (mnemonic-string label) "")))]
                    [else
-                    (let ([pixbuf (bitmap->pixbuf label)])
+                    (let ([pixbuf (bitmap->pixbuf (if (pair? label) 
+                                                      (car label)
+                                                      label))])
                       (atomically
-                       (let ([gtk (as-gtk-allocation (gtk_new))]
+                       (let ([gtk (if (pair? label)
+                                      (as-gtk-allocation (gtk_new_with_mnemonic (cadr label)))
+                                      (as-gtk-allocation (gtk_new)))]
                              [image-gtk (gtk_image_new_from_pixbuf pixbuf)])
                          (release-pixbuf pixbuf)
-                         (gtk_container_add gtk image-gtk)
+                         (if (pair? label)
-                         (gtk_widget_show image-gtk)
+                             (begin
+                               (gtk_button_set_image gtk image-gtk)
+                               (gtk_button_set_image_position 
+                                gtk
+                                (case (caddr label)
+                                  [(left) GTK_POS_LEFT]
+                                  [(right) GTK_POS_RIGHT]
+                                  [(top) GTK_POS_TOP]
+                                  [(bottom) GTK_POS_BOTTOM])))
+                             (begin
+                               (gtk_container_add gtk image-gtk)
+                               (gtk_widget_show image-gtk)))
                          gtk)))])]
              [callback cb]
              [font font]
              [no-show? (memq 'deleted style)])
   (define gtk (get-gtk))
 
+  (define both-labels? (pair? label))
+  
   (when (eq? event-type 'button)
     (set-gtk-object-flags! gtk (bitwise-ior (get-gtk-object-flags gtk)
                                             GTK_CAN_DEFAULT)))
@@ -92,9 +116,12 @@
         (atomically
          (let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)])
            (release-pixbuf pixbuf)
-           (gtk_container_remove gtk (gtk_bin_get_child gtk))
+           (if both-labels?
-           (gtk_container_add gtk image-gtk)
+               (gtk_button_set_image gtk image-gtk)
-           (gtk_widget_show image-gtk))))]))
+               (begin
+                 (gtk_container_remove gtk (gtk_bin_get_child gtk))
+                 (gtk_container_add gtk image-gtk)
+                 (gtk_widget_show image-gtk))))))]))
 
   (define/public (set-border on?)
     (gtk_window_set_default (get-window-gtk) (if on? gtk #f))))

collects/scribblings/gui/button-class.scrbl

@@ -7,7 +7,11 @@ Whenever a button is clicked by the user, the button's callback
  procedure is invoked. A callback procedure is provided as an
  initialization argument when each button is created.
 
-@defconstructor[([label (or/c label-string? (is-a?/c bitmap%))]
+@defconstructor[([label (or/c label-string? 
+                              (is-a?/c bitmap%)
+                              (list/c (is-a?/c bitmap%)
+                                      label-string?
+                                      (one-of/c 'left 'top 'right 'bottom)))]
                  [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) 
                                (is-a?/c panel%) (is-a?/c pane%))]
                  [callback ((is-a?/c button%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))]
@@ -21,10 +25,13 @@ Whenever a button is clicked by the user, the button's callback
                  [stretchable-width any/c #f]
                  [stretchable-height any/c #f])]{
 
-Creates a button with a string or bitmap label.
+Creates a button with a string label, bitmap label, or both.
- @bitmaplabeluse[label]
+ @bitmaplabeluse[label] If @racket[label] is a list, then
+ the button has both a bitmap and string label, and the
+ symbol @racket['left], @racket['top], @racket['right], or @racket['bottom]
+ specifies the location of the image relative to the text on the button.
 
-If @litchar{&} occurs in @scheme[label] (when @scheme[label] is a
+If @litchar{&} occurs in @scheme[label] (when @scheme[label] includes a
 string), it is specially parsed; under Windows and X, the character
 following @litchar{&} is underlined in the displayed control to
 indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are
@@ -56,7 +63,8 @@ on-traverse-char]). @DeletedStyleNote[@scheme[style] @scheme[parent]]{button}
 
 
 @defmethod[#:mode override
-           (set-label [label (or/c label-string? (is-a?/c bitmap%))])
+           (set-label [label (or/c label-string? 
+                                   (is-a?/c bitmap%))])
            void?]{
 
 The same as @xmethod[window<%> set-label] when @scheme[label] is a
@@ -65,5 +73,8 @@ The same as @xmethod[window<%> set-label] when @scheme[label] is a
 Otherwise, sets the bitmap label for a bitmap button. @bitmaplabeluseisbm[label]
  @|bitmapiforiglabel|
 
+If the button has both a string and a bitmap label, then either can be
+ set using @method[button% set-label].
+
 }}
 

collects/scribblings/gui/window-intf.scrbl

@@ -98,7 +98,7 @@ See also
 
 
 @defmethod[(get-cursor)
-           (or/c (is-a?/c cursor%) false/c)]{
+           (or/c (is-a?/c cursor%) #f)]{
 
 Returns the window's cursor, or @scheme[#f] if this window's cursor
  defaults to the parent's cursor.  See
@@ -141,8 +141,13 @@ See also
 }
 
 @defmethod[(get-label)
-           (or/c label-string? (is-a?/c bitmap%)
+           (or/c label-string? 
-                 (one-of/c 'app 'caution 'stop) false/c)]{
+                 (is-a?/c bitmap%)
+                 (one-of/c 'app 'caution 'stop) 
+                 (list/c (is-a?/c bitmap%)
+                         label-string?
+                         (one-of/c 'left 'top 'right 'bottom))
+                 #f)]{
 
 Gets a window's label, if any. Control windows generally display their
  label in some way. Frames and dialogs display their label as a window
@@ -151,9 +156,10 @@ Gets a window's label, if any. Control windows generally display their
  have bitmap labels (only when they are created with bitmap labels),
  but all other windows have string labels. In addition, a message
  label can be an icon symbol @scheme['app], @scheme['caution], or
- @scheme['stop].
+ @scheme['stop], and a button can have both a bitmap label and a
+ string label (along with a position for the bitmap).
 
-The label string may contain @litchar{&}s, which serve as
+A label string may contain @litchar{&}s, which serve as
  keyboard navigation annotations for controls under Windows and X. The
  ampersands are not part of the displayed label of a control; instead,
  ampersands are removed in the displayed label (under all platforms),
@@ -169,7 +175,7 @@ If the window does not have a label, @scheme[#f] is returned.
 
 
 @defmethod[(get-plain-label)
-           (or/c string false/c)]{
+           (or/c string #f)]{
 
 Like
 @method[window<%> get-label], except that ampersands in the label are removed. If the window has
@@ -467,7 +473,7 @@ Enqueues an event to repaint the window.
 }
 
 
-@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) false/c)])
+@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) #f)])
            void?]{
 
 Sets the window's cursor. Providing @scheme[#f] instead of a cursor

collects/tests/gracket/item.rkt

@@ -1235,6 +1235,55 @@
   (instructions p "button-steps.txt")
   (send f show #t))
 
+(define (image-button-frame)
+  (define f (make-frame frame% "Image Button Test"))
+  (define pt (make-object vertical-panel% f))
+  (define pm (make-object horizontal-panel% f))
+  (define pb (make-object vertical-panel% f))
+  (define pc (make-object horizontal-panel% f))
+  (define bt (new button% [parent pt]
+                  [label (list (read-bitmap
+                                (collection-file-path "foot.png" "icons"))
+                               "Top"
+                               'top)]))
+  (define bl (new button% [parent pm]
+                  [label (list (read-bitmap
+                                (collection-file-path "b-wait.png" "icons"))
+                               "Left"
+                               'left)]))
+  (define br (new button% [parent pm]
+                  [label (list (read-bitmap
+                                (collection-file-path "b-run.png" "icons"))
+                               "Right"
+                               'right)]))
+  (define bb (new button% [parent pb]
+                  [label (list (read-bitmap
+                                (collection-file-path "bug09.png" "icons"))
+                               "Bottom"
+                               'bottom)]))
+  (new button% [parent pc]
+       [label "Strings"]
+       [callback (lambda (b e)
+                   (for ([b (in-list (list bt bl br bb))])
+                     (send b set-label (list->string
+                                        (reverse
+                                         (string->list
+                                          (cadr (send b get-label))))))))])
+  (new button% [parent pc]
+       [label "Bitmaps"]
+       [callback (lambda (b e)
+                   (for ([b (in-list (list bt bl br bb))])
+                     (send b set-label (let ([bm (car (send b get-label))])
+                                         (let* ([bm2 (make-bitmap (send bm get-width)
+                                                                  (send bm get-height))]
+                                                [dc (make-object bitmap-dc% bm2)])
+                                           (send dc scale 1 -1)
+                                           (send dc translate 0 (send bm get-height))
+                                           (send dc draw-bitmap bm 0 0)
+                                           (send dc set-bitmap #f)
+                                           bm2)))))])
+  (send f show #t))
+
 (define (checkbox-frame)
   (define f (make-frame frame% "Checkbox Test"))
   (define p f)
@@ -2223,6 +2272,7 @@
 (make-object button% "Make Button Frame" bp (lambda (b e) (button-frame frame% null)))
 (make-object button% "Make Default Button Frame" bp (lambda (b e) (button-frame frame% '(border))))
 (make-object button% "Make Button Dialog" bp (lambda (b e) (button-frame dialog% null)))
+(make-object button% "Make Image Buttons" bp (lambda (b e) (image-button-frame)))
 (define crp (make-object horizontal-pane% ap))
 (send crp stretchable-height #f)
 (make-object button% "Make Checkbox Frame" crp (lambda (b e) (checkbox-frame)))