diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 36b3cad6ee..767e1f6f30 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -238,18 +238,23 @@ [(windows) 1] [else 2])) - (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system - 'normal 'normal #f 'default - (wx:get-control-font-size-in-pixels?))) - (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system - 'normal 'normal #f 'default - (wx:get-control-font-size-in-pixels?))) - (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system + (define normal-control-font (make-object wx:font% (wx:get-control-font-size) + (wx:get-control-font-face) 'system 'normal 'normal #f 'default (wx:get-control-font-size-in-pixels?))) + (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) + (wx:get-control-font-face) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) + (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) + (wx:get-control-font-face) 'system + 'normal 'normal #f 'default + (wx:get-control-font-size-in-pixels?))) (define view-control-font (if (eq? 'macosx (system-type)) - (make-object wx:font% (- (wx:get-control-font-size) 1) 'system) + (make-object wx:font% (- (wx:get-control-font-size) 1) + (wx:get-control-font-face) 'system) normal-control-font)) (define menu-control-font (if (eq? 'macosx (system-type)) - (make-object wx:font% (+ (wx:get-control-font-size) 1) 'system) + (make-object wx:font% (+ (wx:get-control-font-size) 1) + (wx:get-control-font-face) 'system) normal-control-font))) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index b53bfef32a..98b0bfa7ee 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -65,6 +65,7 @@ flush-display fill-private-color cancel-quit + get-control-font-face get-control-font-size get-control-font-size-in-pixels? get-double-click-time diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index e7f614068c..7b77f911e9 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -44,6 +44,7 @@ file-creator-and-type run-printout get-double-click-time + get-control-font-face get-control-font-size get-control-font-size-in-pixels? cancel-quit @@ -89,6 +90,7 @@ (define (get-double-click-time) 500) +(define (get-control-font-face) "Lucida Grande") (define (get-control-font-size) 13) (define (get-control-font-size-in-pixels?) #f) (define (cancel-quit) (void)) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 40eef1d49e..9f1d9eb210 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -65,6 +65,7 @@ flush-display fill-private-color cancel-quit + get-control-font-face get-control-font-size get-control-font-size-in-pixels? get-double-click-time diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 294ec927c8..3ab44b98af 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -37,6 +37,7 @@ file-creator-and-type run-printout get-double-click-time + get-control-font-face get-control-font-size get-control-font-size-in-pixels? cancel-quit @@ -81,9 +82,42 @@ (define run-printout (make-run-printout printer-dc%)) -(define (get-double-click-time) 250) -(define (get-control-font-size) 10) ;; FIXME -(define (get-control-font-size-in-pixels?) #f) ;; FIXME +(define _GtkSettings (_cpointer 'GtkSettings)) +(define-gtk gtk_settings_get_default (_fun -> _GtkSettings)) +(define-gobj g_object_get/int (_fun _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f) + -> _void + -> r) + #:c-id g_object_get) +(define-gobj g_object_get/string (_fun _GtkSettings _string (r : (_ptr o _pointer)) (_pointer = #f) + -> _void + -> r) + #:c-id g_object_get) + +(define (get-double-click-time) + (let ([s (gtk_settings_get_default)]) + (if s + (g_object_get/int s "gtk-double-click-time") + 250))) +(define (get-control-font proc default) + (or + (let ([s (gtk_settings_get_default)]) + (and s + (let ([f (g_object_get/string s "gtk-font-name")]) + (and f + (begin0 + (cond + [(regexp-match #rx"^(.*) ([0-9]+)$" (cast f _pointer _string)) + => (lambda (m) (proc (cdr m)))] + [else #f]) + (g_free f)))))) + default)) +(define (get-control-font-size) + (get-control-font (lambda (m) (string->number (cadr m))) + 10)) +(define (get-control-font-face) + (get-control-font (lambda (m) (car m)) + "Sans")) +(define (get-control-font-size-in-pixels?) #f) (define (get-display-depth) 32) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 5cf54c11d2..448aa92c91 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -50,6 +50,7 @@ flush-display fill-private-color cancel-quit + get-control-font-face get-control-font-size get-control-font-size-in-pixels? get-double-click-time diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 167ca364be..07c3629e98 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -66,6 +66,7 @@ flush-display fill-private-color cancel-quit + get-control-font-face get-control-font-size get-control-font-size-in-pixels? get-double-click-time diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index be571adaf1..9a4b70b46c 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -37,6 +37,7 @@ file-creator-and-type run-printout get-double-click-time + get-control-font-face get-control-font-size get-control-font-size-in-pixels? cancel-quit @@ -84,6 +85,7 @@ (define run-printout (make-run-printout printer-dc%)) (define (get-double-click-time) 500) +(define (get-control-font-face) "Tahoma") (define (get-control-font-size) (get-theme-font-size)) (define (get-control-font-size-in-pixels?) #t) (define (flush-display) (void))