80 lines
2.6 KiB
Racket
80 lines
2.6 KiB
Racket
#lang scheme/base
|
|
(require scheme/class
|
|
scheme/foreign
|
|
"../../syntax.rkt"
|
|
"item.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"pixbuf.rkt")
|
|
(unsafe!)
|
|
|
|
(provide message%
|
|
|
|
gtk_label_new_with_mnemonic
|
|
gtk_label_set_text_with_mnemonic
|
|
mnemonic-string)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-gtk gtk_label_new (_fun _string -> _GtkWidget))
|
|
(define-gtk gtk_label_set_text (_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_misc_set_alignment (_fun _GtkWidget _float _float -> _void))
|
|
|
|
(define (mnemonic-string s)
|
|
(if (regexp-match? #rx"&" s)
|
|
(regexp-replace*
|
|
#rx"_&"
|
|
(regexp-replace*
|
|
#rx"&(.)"
|
|
(regexp-replace* #rx"_" s "__")
|
|
"_\\1")
|
|
"\\&")
|
|
(regexp-replace* #rx"_" s "__")))
|
|
|
|
(define (gtk_label_new_with_mnemonic s)
|
|
(let ([l (gtk_label_new s)])
|
|
(when (regexp-match? #rx"&" s)
|
|
(let ([s (mnemonic-string s)])
|
|
(gtk_label_set_text_with_mnemonic l s)))
|
|
l))
|
|
|
|
(define icon-size 6) ; = GTK_ICON_SIZE_DIALOG
|
|
|
|
(defclass message% item%
|
|
(init parent label
|
|
x y
|
|
style font)
|
|
(inherit set-auto-size get-gtk)
|
|
|
|
(super-new [parent parent]
|
|
[gtk (if (or (string? label)
|
|
(not label))
|
|
(as-gtk-allocation (gtk_label_new_with_mnemonic (or label "")))
|
|
(if (symbol? label)
|
|
(as-gtk-allocation
|
|
(case label
|
|
[(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)]
|
|
[(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)]
|
|
[else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)]))
|
|
(if (send label ok?)
|
|
(let ([pixbuf (bitmap->pixbuf label)])
|
|
(begin0
|
|
(as-gtk-allocation
|
|
(gtk_image_new_from_pixbuf pixbuf))
|
|
(release-pixbuf pixbuf)))
|
|
(as-gtk-allocation
|
|
(gtk_label_new_with_mnemonic "<bad-image>")))))]
|
|
[no-show? (memq 'deleted style)])
|
|
|
|
(when (string? label)
|
|
(gtk_misc_set_alignment (get-gtk) 0.0 0.0))
|
|
|
|
(set-auto-size)
|
|
|
|
(define/override (set-label s)
|
|
(gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s)))
|
|
|
|
(def/public-unimplemented get-font))
|