1#lang racket/base 2(require racket/class 3 racket/draw/private/color 4 racket/math 5 (only-in racket/draw/unsafe/pango 6 pango_attr_list_new 7 pango_attr_list_insert 8 pango_attr_foreground_new 9 pango_attr_foreground_alpha_new) 10 ffi/unsafe 11 "../../syntax.rkt" 12 "../../lock.rkt" 13 "item.rkt" 14 "utils.rkt" 15 "types.rkt" 16 "pixbuf.rkt" 17 "window.rkt") 18 19(provide 20 (protect-out message% 21 22 gtk_label_new_with_mnemonic 23 gtk_label_set_text_with_mnemonic)) 24 25;; ---------------------------------------- 26 27(define-gtk gtk_label_new (_fun _string -> _GtkWidget)) 28(define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) 29(define-gtk gtk_label_set_attributes (_fun _GtkWidget _pointer -> _void)) 30(define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) 31(define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) 32(define-gtk gtk_image_set_from_pixbuf (_fun _GtkWidget _GdkPixbuf -> _void)) 33 34(define (gtk_label_new_with_mnemonic s) 35 (let ([l (gtk_label_new s)]) 36 (when (regexp-match? #rx"&" s) 37 (let ([s (mnemonic-string s)]) 38 (gtk_label_set_text_with_mnemonic l s))) 39 l)) 40 41(define icon-size 6) ; = GTK_ICON_SIZE_DIALOG 42 43(define (color-component->gtk c) 44 (exact-round (* (/ c 255.0) 65535))) 45 46(define (do-set-label-color label c) 47 (define attrs (pango_attr_list_new)) 48 (define color-attr (pango_attr_foreground_new 49 (color-component->gtk (color-red c)) 50 (color-component->gtk (color-green c)) 51 (color-component->gtk (color-blue c)))) 52 (define color-alpha-attr (pango_attr_foreground_alpha_new 53 (color-component->gtk (* (color-alpha c) 255)))) 54 (pango_attr_list_insert attrs color-attr) 55 (when color-alpha-attr 56 (pango_attr_list_insert attrs color-alpha-attr)) 57 (gtk_label_set_attributes label attrs)) 58 59(defclass message% item% 60 (init parent label 61 x y 62 style font) 63 (init-field color) 64 (inherit set-auto-size get-gtk) 65 66 (define text-label? (string? label)) 67 68 (super-new [parent parent] 69 [gtk (cond 70 [(or (string? label) (not label)) 71 (define gtk-label 72 (as-gtk-allocation (gtk_label_new_with_mnemonic (or label "")))) 73 (when color 74 (do-set-label-color gtk-label color)) 75 gtk-label] 76 [(symbol? label) 77 (as-gtk-allocation 78 (case label 79 [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)] 80 [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)] 81 [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)]))] 82 [else 83 (define pixbuf (bitmap->pixbuf label (->screen 1.0))) 84 (begin0 85 (as-gtk-allocation 86 (gtk_image_new_from_pixbuf pixbuf)) 87 (release-pixbuf pixbuf))])] 88 [font font] 89 [no-show? (memq 'deleted style)]) 90 91 (when (string? label) 92 (gtk_misc_set_alignment (get-gtk) 0.0 0.0)) 93 94 (set-auto-size) 95 96 (define/override (set-label s) 97 (set! text-label? (string? s)) 98 (cond 99 [(string? s) 100 (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))] 101 [else 102 (let ([pixbuf (bitmap->pixbuf s (->screen 1.0))]) 103 (atomically 104 (gtk_image_set_from_pixbuf (get-gtk) pixbuf) 105 (release-pixbuf pixbuf)))])) 106 107 (define/public (get-color) color) 108 (define/public (set-color c) 109 (when text-label? 110 (set! color c) 111 (do-set-label-color (get-gtk) c))) 112 113 (define/public (set-preferred-size) 114 (gtk_widget_set_size_request (get-gtk) -1 -1) 115 (set-auto-size) 116 #t) 117 118 (define/override (gets-focus?) #f) 119 120 (def/public-unimplemented get-font)) 121