From 93d59f4cf5bf6c616d6ebc45a54786061d86f6d1 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 19 Oct 2010 09:50:22 -0600
Subject: [PATCH] gtk: configurable control font

---
 collects/mred/private/wx/gtk/button.rkt    |  6 +++++-
 collects/mred/private/wx/gtk/choice.rkt    |  3 +++
 collects/mred/private/wx/gtk/item.rkt      | 24 ++++++++++++++++++----
 collects/mred/private/wx/gtk/list-box.rkt  |  1 +
 collects/mred/private/wx/gtk/message.rkt   |  1 +
 collects/mred/private/wx/gtk/radio-box.rkt |  2 ++
 6 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt
index 3c20717802..a064b58680 100644
--- a/collects/mred/private/wx/gtk/button.rkt
+++ b/collects/mred/private/wx/gtk/button.rkt
@@ -38,7 +38,7 @@
         [gtk_new_with_mnemonic gtk_button_new_with_mnemonic]
         [gtk_new gtk_button_new])
   (init-field [event-type 'button])
-  (inherit get-gtk set-auto-size is-window-enabled?
+  (inherit get-gtk get-client-gtk set-auto-size is-window-enabled?
            get-window-gtk)
 
   (super-new [parent parent]
@@ -58,6 +58,7 @@
                    [else
                     (as-gtk-allocation (gtk_new_with_mnemonic "<bad>"))])]
              [callback cb]
+             [font font]
              [no-show? (memq 'deleted style)])
   (define gtk (get-gtk))
   
@@ -81,6 +82,9 @@
     ;; Called from event-handling thread
     (queue-window-event this (lambda () (clicked))))
 
+  (define/override (get-label-gtk)
+    (gtk_bin_get_child (get-client-gtk)))
+
   (define/override (set-label s)
     (cond
      [(string? s)
diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt
index 0f79c489ed..9127a22968 100644
--- a/collects/mred/private/wx/gtk/choice.rkt
+++ b/collects/mred/private/wx/gtk/choice.rkt
@@ -21,6 +21,7 @@
 (define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void))
 (define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void))
 (define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int))
+(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
 
 (define-signal-handler connect-changed "changed"
   (_fun _GtkWidget -> _void)
@@ -53,6 +54,8 @@
 
   (gtk_combo_box_set_active gtk 0)
 
+  (install-control-font (gtk_bin_get_child gtk) font)
+
   (set-auto-size)
 
   (connect-changed gtk)
diff --git a/collects/mred/private/wx/gtk/item.rkt b/collects/mred/private/wx/gtk/item.rkt
index b2fa259ac5..e63bfada29 100644
--- a/collects/mred/private/wx/gtk/item.rkt
+++ b/collects/mred/private/wx/gtk/item.rkt
@@ -1,20 +1,36 @@
-#lang scheme/base
-(require scheme/class
+#lang racket/base
+(require ffi/unsafe
+         racket/class
+         racket/draw/local
           "../../syntax.rkt"
-         "window.rkt")
+         "window.rkt"
+         "utils.rkt"
+         "types.rkt")
 
-(provide item%)
+(provide item%
+         install-control-font)
+
+(define _PangoFontDescription _pointer)
+(define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void))
+
+(define (install-control-font gtk font)
+  (when font
+    (gtk_widget_modify_font gtk (send font get-pango))))
 
 (defclass item% window%
   (inherit get-client-gtk)
 
   (init-field [callback void])
+  (init [font #f])
 
   (super-new)
 
   (let ([client-gtk (get-client-gtk)])
     (connect-focus client-gtk)
     (connect-key-and-mouse client-gtk))
+  (install-control-font (get-label-gtk) font)
+  
+  (define/public (get-label-gtk) (get-client-gtk))
 
   (def/public-unimplemented set-label)
   (def/public-unimplemented get-label)
diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt
index 1fdb863898..291ea5c38b 100644
--- a/collects/mred/private/wx/gtk/list-box.rkt
+++ b/collects/mred/private/wx/gtk/list-box.rkt
@@ -116,6 +116,7 @@
              [gtk gtk]
              [extra-gtks (list client-gtk selection)]
              [callback cb]
+             [font font]
              [no-show? (memq 'deleted style)])
 
   (set-auto-size)
diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt
index aa3c26b9de..d74513fd07 100644
--- a/collects/mred/private/wx/gtk/message.rkt
+++ b/collects/mred/private/wx/gtk/message.rkt
@@ -66,6 +66,7 @@
                                  (release-pixbuf pixbuf)))
                               (as-gtk-allocation
                                (gtk_label_new_with_mnemonic "<bad-image>")))))]
+             [font font]
              [no-show? (memq 'deleted style)])
 
   (when (string? label)
diff --git a/collects/mred/private/wx/gtk/radio-box.rkt b/collects/mred/private/wx/gtk/radio-box.rkt
index 8bb12b757c..6039e5d486 100644
--- a/collects/mred/private/wx/gtk/radio-box.rkt
+++ b/collects/mred/private/wx/gtk/radio-box.rkt
@@ -26,6 +26,7 @@
 (define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void))
 (define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean))
 (define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean))
+(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
 
 (define-signal-handler connect-clicked "clicked"
   (_fun _GtkWidget -> _void)
@@ -64,6 +65,7 @@
                                           [else
                                            (gtk_radio_button_new_with_mnemonic #f "<bad bitmap>")])])
                           (gtk_box_pack_start gtk radio-gtk #t #t 0)
+                          (install-control-font (gtk_bin_get_child radio-gtk) font)
                           (gtk_widget_show radio-gtk)
                           radio-gtk))))
   (for ([radio-gtk (in-list (cdr radio-gtks))])