5e70534b43
Adjust a workaround for versions before 3.22 when setting the font for a control. GTK+ version 3.22 starts paying attention to whether a font size for a control is absolute (as opposed to being in points), so the workaround that was put in place for earlier versions breaks. In addition, some part of the drawing stack seems to round point sizes to an integeral size after DPI conversion. Take that rounding into account when setting the font size in `normal-control-font`. Closes #1522
80 lines
2.3 KiB
Racket
80 lines
2.3 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
|
|
[(and gtk3?
|
|
((gtk_get_minor_version) . < . 22))
|
|
;; Prior to version 3.22, GTK+3 ignores the
|
|
;; "size-in-pixels" part of a font spec, so we have to
|
|
;; adjust the text size to compensate.
|
|
;; With 3.22 and later, a size in points is effectively
|
|
;; rounded to an integer absolute size; the `get-control-font-size`
|
|
;; function takes that rounding into account.
|
|
(* (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)))
|
|
|
|
|
|
|
|
|
|
|