f42356da3f
The main advantage of GTK+ 3 is better support for HiDPI displays. If GTK+ 3 libraries are not available or if the `PLT_GTK2` environment variable is defined, GTK+ 2 is used as before.
76 lines
2.1 KiB
Racket
76 lines
2.1 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/define
|
|
racket/class
|
|
racket/draw/private/local
|
|
(only-in racket/draw/unsafe/pango
|
|
pango_cairo_font_map_get_resolution
|
|
pango_cairo_font_map_get_default)
|
|
(only-in racket/draw make-font)
|
|
"../../syntax.rkt"
|
|
"window.rkt"
|
|
"utils.rkt"
|
|
"types.rkt")
|
|
|
|
(provide
|
|
(protect-out item%
|
|
install-control-font))
|
|
|
|
(define _PangoFontDescription _pointer)
|
|
(define-gtk gtk_widget_override_font (_fun _GtkWidget _PangoFontDescription -> _void)
|
|
#:make-fail make-not-available)
|
|
(define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void)
|
|
#:fail (lambda () gtk_widget_override_font))
|
|
|
|
(define (install-control-font gtk font)
|
|
(when font
|
|
(let* ([target-size
|
|
(cond
|
|
[gtk3?
|
|
;; Gtk3 ignores the "size-in-pixels" part of a
|
|
;; font spec, so we have to adjust the text size
|
|
;; to compensate.
|
|
(* (send font get-size)
|
|
(/ 72.0
|
|
(pango_cairo_font_map_get_resolution
|
|
(pango_cairo_font_map_get_default))))]
|
|
[else (->screen (send font get-size))])]
|
|
[font (if (= target-size (send font get-size))
|
|
font
|
|
(make-font #:size target-size
|
|
#:face (send font get-face)
|
|
#:family (send font get-family)
|
|
#:style (send font get-style)
|
|
#:weight (send font get-weight)
|
|
#:underlined? (send font get-underlined)
|
|
#:smoothing (send font get-smoothing)
|
|
#:size-in-pixels? (send font get-size-in-pixels)
|
|
#:hinting (send font get-hinting)))])
|
|
(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)
|
|
|
|
(define/public (command e)
|
|
(callback this e)))
|
|
|
|
|
|
|
|
|
|
|