From: Matt Birkholz Date: Sun, 7 Feb 2016 23:32:04 +0000 (-0700) Subject: gtk-screen: Set pango layout font descriptions; punt style frobbery. X-Git-Tag: mit-scheme-pucked-9.2.12~361 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e00606a180237c80aae8c358398c0307e1dc647f;p=mit-scheme.git gtk-screen: Set pango layout font descriptions; punt style frobbery. Munging the GtkStyleContext on the GtkWindow had no effect. --- diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index bfedafa3d..8c57bb276 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -50,7 +50,8 @@ USA. ;; Toplevel's gtk-style-context, after toplevel is realized. (style-context define standard initial-value #f) - ;; The default font's character dimensions. + ;; The default font (description) and its character dimensions. + (font define standard) (char-width define standard) (line-height define standard) (line-spacing define standard) @@ -94,7 +95,7 @@ USA. (context (gtk-widget-get-pango-context toplevel)) (font (pango-font-description-from-string spec)) (metrics (pango-context-get-metrics context font))) - (pango-font-description-free font) + (set-gtk-screen-font! screen font) (let ((ascent (pangos->pixels (pango-font-metrics-get-ascent metrics))) (descent (pangos->pixels (pango-font-metrics-get-descent metrics))) (width (pangos->pixels @@ -253,7 +254,8 @@ USA. (define-method screen-discard! ((screen )) (set! screen-list (delq! screen screen-list)) - (gtk-widget-destroy (gtk-screen-toplevel screen))) + (gtk-widget-destroy (gtk-screen-toplevel screen)) + (pango-font-description-free (gtk-screen-font screen))) (define-method screen-modeline-event! ((screen ) window type) (%trace "; screen-modeline-event! "screen" "window" "type"\n")) @@ -944,7 +946,7 @@ USA. (set-text-widget-buffer-frame! text window) (set-text-widget-modeline! text modeline) (set-fix-layout-scroll-step! text x-step y-step) - (gtk-scrolled-window-set-placement scroller 'bottom-right) + ;;(gtk-scrolled-window-set-placement scroller 'bottom-right) (if (not modeline) ;; No modeline: the window/text-widget should NOT expand. (begin @@ -1168,23 +1170,7 @@ USA. (%widget-x-size window screen) (%widget-y-size window screen)) (%trace "; initialized geometry: "geometry"\n")))) - (call-next-method widget) - (realize-style-context! widget)) - -(define (realize-style-context! widget) - (%trace "; realize-style-context!\n") - (let ((screen (edwin-widget-screen widget))) - (if (not (gtk-screen-style-context screen)) - (let ((provider (gtk-css-provider-new)) - (context (gtk-widget-get-style-context - (gtk-screen-toplevel screen)))) - (set-gtk-screen-style-context! screen context) - (gtk-css-provider-load-from-data - provider " -ScmWidget { font: Monospace 11 } -#modeline { background: black }") - (gtk-style-context-add-provider context provider 'fallback) - (gobject-unref! provider))))) + (call-next-method widget)) (define-method fix-widget-new-geometry-callback ((widget )) (%trace "; (fix-widget-new-geometry-callback ) "widget"\n") @@ -1358,29 +1344,30 @@ ScmWidget { font: Monospace 11 } (define-method fix-widget-realize-callback ((widget )) (%trace ";(fix-widget-realize-callback ) "widget"\n") - (let ((geometry (fix-widget-geometry widget))) + (let ((screen (edwin-widget-screen widget)) + (geometry (fix-widget-geometry widget))) (if (or (not (fix-rect-width geometry)) (not (fix-rect-height geometry))) ;; Unfortunately a widget can be realized before it is ;; allocated a size -- when it is added to a realized ;; container. In this case, initialize WIDGET's size to ;; something reasonable. - (let ((screen (edwin-widget-screen widget))) + (begin (%trace "; uninitialized geometry: "geometry"\n") (set-fix-rect-size! geometry 0 (y-size->height screen 1)) - (%trace "; initialized geometry: "geometry"\n")))) - (call-next-method widget) - (realize-style-context! widget) - (let ((ink (make-simple-text-ink)) - (drawing (fix-layout-drawing widget))) - (set-simple-text-ink-text! - ink widget "--------Initial mode line.--------------------------------") - (set-text-ink-color! ink "white") - (fix-drawing-add-ink! drawing ink) - (let ((extent (fix-ink-extent ink))) - (set-fix-drawing-size! drawing - (fix-rect-width extent) - (fix-rect-height extent))))) + (%trace "; initialized geometry: "geometry"\n"))) + (call-next-method widget) + (let ((ink (make-simple-text-ink)) + (drawing (fix-layout-drawing widget))) + (set-simple-text-ink-font! ink (gtk-screen-font screen)) + (set-simple-text-ink-text! + ink widget "--------Initial mode line.--------------------------------") + (set-text-ink-color! ink "white") + (fix-drawing-add-ink! drawing ink) + (let ((extent (fix-ink-extent ink))) + (set-fix-drawing-size! drawing + (fix-rect-width extent) + (fix-rect-height extent)))))) (define-class ( (constructor ())) () @@ -2204,10 +2191,11 @@ ScmWidget { font: Monospace 11 } (mark= old-end display-end)))))) (define (layout) - (if pango-layout pango-layout + (or pango-layout (let ((new (gtk-widget-create-pango-layout (gtk-screen-toplevel screen)))) (%trace3 "; created "new" to lay up new text\n") + (pango-layout-set-font-description new (gtk-screen-font screen)) (set! pango-layout new) new))) @@ -2535,6 +2523,8 @@ ScmWidget { font: Monospace 11 } (widget (car (fix-drawing-widgets drawing))) (layout (gtk-widget-create-pango-layout widget)) (new (make-cache line layout))) + (pango-layout-set-font-description layout (gtk-screen-font + (edwin-widget-screen widget))) (set-buffer-drawing-pango-layout-caches! drawing (cons new (buffer-drawing-pango-layout-caches drawing))) (set-line-ink-cached-pango-layout! line layout)