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