suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cocoa & gtk: fix set-label with bitmap on message%

Browse Source 
Closes PR 11462

original commit: 04a4ad269fb446000bb463e793e6e8e16457499d
This commit is contained in:
Matthew Flatt 2010-11-26 11:55:32 -07:00
parent 86e4eed112
commit f7594ac5c4
3 changed files with 22 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/mred/private/mritem.rkt
View File

@ -58,7 +58,7 @@
;; for keyword use ;; for keyword use
[font no-val]) [font no-val])
(rename [super-set-label set-label]) (rename [super-set-label set-label])
(private-field [label lbl][callback cb]) (private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)])
(override (override
[get-label (lambda () label)] [get-label (lambda () label)]
[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))] [get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
@ -69,8 +69,12 @@
(let ([l (if (string? l) (let ([l (if (string? l)
(string->immutable-string l) (string->immutable-string l)
l)]) l)])
(send wx set-label l) (when (or (and is-bitmap?
(set! label l))))]) (l . is-a? . wx:bitmap%))
(and (not is-bitmap?)
(string? l)))
(send wx set-label l)
(set! label l)))))])
(public (public
[hidden-child? (lambda () #f)] ; module-local method [hidden-child? (lambda () #f)] ; module-local method
[label-checker (lambda () check-label-string/false)] ; module-local method [label-checker (lambda () check-label-string/false)] ; module-local method

6
collects/mred/private/wx/cocoa/message.rkt
View File

@ -94,7 +94,11 @@
[no-show? (memq 'deleted style)]) [no-show? (memq 'deleted style)])
(define/override (set-label label) (define/override (set-label label)
(tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)) (cond
[(string? label)
(tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)]
[else
(tellv (get-cocoa) setImage: (bitmap->image label))]))
(define/override (gets-focus?) #f) (define/override (gets-focus?) #f)

11
collects/mred/private/wx/gtk/message.rkt
View File

@ -2,6 +2,7 @@
(require racket/class (require racket/class
ffi/unsafe ffi/unsafe
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt"
"item.rkt" "item.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
@ -21,6 +22,7 @@
(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void))
(define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) (define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget))
(define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) (define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void))
(define-gtk gtk_image_set_from_pixbuf (_fun _GtkWidget _GdkPixbuf -> _void))
(define (mnemonic-string s) (define (mnemonic-string s)
(if (regexp-match? #rx"&" s) (if (regexp-match? #rx"&" s)
@ -75,6 +77,13 @@
(set-auto-size) (set-auto-size)
(define/override (set-label s) (define/override (set-label s)
(gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))) (cond
[(string? s)
(gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))]
[else
(let ([pixbuf (bitmap->pixbuf s)])
(atomically
(gtk_image_set_from_pixbuf (get-gtk) pixbuf)
(release-pixbuf pixbuf)))]))
(def/public-unimplemented get-font)) (def/public-unimplemented get-font))