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 bfedafa3dc59e6628f948e62f911d34d7be82b04..8c57bb2760b57ce86a5e15766514e9d97a4e5ac8 100644 (file)
--- 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 <gtk-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 <gtk-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 <text-widget>))
   (%trace "; (fix-widget-new-geometry-callback <text-widget>) "widget"\n")
@@ -1358,29 +1344,30 @@ ScmWidget { font: Monospace 11 }
 
 (define-method fix-widget-realize-callback ((widget <modeline-widget>))
   (%trace ";(fix-widget-realize-callback <modeline-widget>) "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 (<buffer-frame-widget> (constructor ()))
     (<gtk-grid>)
@@ -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)