gtk-screen: Use gtk-style-context to set widget fonts/colors.

diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg
index 3d9c8bb2aae1c2b7a5b7e75b1ec17d350e747cd2..46efbe0f84c62156a6a2ce4fa2ee16750510eef7 100644 (file)
--- a/src/gtk-screen/gtk-screen.pkg
+++ b/src/gtk-screen/gtk-screen.pkg
@@ -107,6 +107,12 @@ USA.
   (import (glib)
          gobject-alien gobject-unref!)
   (import (gtk)
+         gtk-css-provider-load-from-data
+         gtk-css-provider-new
+         gtk-style-context-add-provider
+         gtk-widget-get-style-context
+         gtk-widget-set-name
+
          gdk-key-state->char-bits gdk-keyval->name
          gdk-window-process-updates
 
@@ -118,13 +124,11 @@ USA.
          gtk-widget-error-bell
          gtk-widget-queue-draw
          gtk-widget-queue-resize-no-redraw
-         gtk-widget-font set-gtk-widget-font!
          gtk-widget-get-pango-context
          gtk-widget-create-pango-layout
          gtk-widget-set-hexpand
          gtk-widget-set-vexpand
-         gtk-widget-bg-color set-gtk-widget-bg-color!
-         gtk-widget-fg-color set-gtk-widget-fg-color!
+         gtk-widget-set-opacity
 
          gtk-container?
          gtk-container-children gtk-container-add gtk-container-remove
@@ -146,7 +150,6 @@ USA.
          gtk-window-new
          gtk-window-present
          gtk-window-set-title
-         gtk-window-set-opacity
          gtk-window-set-default-size
 
          set-scm-widget-minimum-size!

diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm
index 2542613054eaa99c73010a72358d2d472ad5e6ac..0ccb27c71f28ddc9add27c61c025c14822ff9c09 100644 (file)
--- a/src/gtk-screen/gtk-screen.scm
+++ b/src/gtk-screen/gtk-screen.scm
@@ -47,9 +47,8 @@ USA.
   ;; set to #f!
   (name define standard initial-value #f)
 
-  ;; The default font.  Initially a string.  Replaced with a
-  ;; PangoFontDescription when the toplevel has been realized.
-  (font define standard)
+  ;; Toplevel's gtk-style-context, after toplevel is realized.
+  (style-context define standard initial-value #f)
 
   ;; The default font's character dimensions.
   (char-width define standard)
@@ -74,9 +73,8 @@ USA.
                        (begin
                          (guarantee-string geometry 'make-gtk-screen)
                          geometry))))
-    (gtk-window-set-opacity toplevel 0.95)
-    (set-gtk-screen-font! screen "Monospace 11")
-    (init-font-dimensions! screen)
+    (gtk-widget-set-opacity toplevel 0.95)
+    (init-font-dimensions! screen "Monospace 11")
     (init-size! screen geometry*)
     (let ((thread (create-blinker-thread screen)))
       (%trace ";   blinker thread: "thread"\n")
@@ -87,13 +85,12 @@ USA.
     (%trace ";   screen: "screen"\n")
     screen))
 
-(define (init-font-dimensions! screen)
-  (%trace ";   init-font-dimensions! "screen"\n")
+(define (init-font-dimensions! screen spec)
+  (%trace ";   init-font-dimensions! "screen" "spec"\n")
   ;; Lookup SCREEN's font via the toplevel widget's pango-context,
   ;; which appears to be available before toplevel is realized.
 
-  (let* ((spec (gtk-screen-font screen))
-        (toplevel (gtk-screen-toplevel screen))
+  (let* ((toplevel (gtk-screen-toplevel screen))
         (context (gtk-widget-get-pango-context toplevel))
         (font (pango-font-description-from-string spec))
         (metrics (pango-context-get-metrics context font)))
@@ -111,17 +108,6 @@ USA.
       (%trace ";     Font: \""spec"\" "width"x"ascent"+"descent" "spacing"\n")
       (pango-font-metrics-unref metrics))))
 
-(define (realize-font! widget)
-  (let* ((screen (edwin-widget-screen widget))
-        (font (gtk-screen-font screen)))
-    (if (string? font)
-       (let ((desc (pango-font-description-from-string font)))
-         (%trace ";  realize-font!\n")
-         (set-gtk-widget-font! (gtk-screen-toplevel screen) desc)
-         (set-gtk-widget-font! widget desc)
-         (set-gtk-screen-font! screen desc))
-       (set-gtk-widget-font! widget font))))
-
 (define (init-size! screen geometry)
   (%trace ";   init-size! "screen" "geometry"\n")
   ;; Sets the logical screen size.  This sets Edwin window and thus
@@ -1182,8 +1168,22 @@ USA.
                              (%widget-y-size window screen))
          (%trace "; initialized geometry: "geometry"\n"))))
   (call-next-method widget)
-  (realize-font! widget)
-  (set-gtk-widget-bg-color! widget "white"))
+  (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)))))
 
 (define-method fix-widget-new-geometry-callback ((widget <text-widget>))
   (%trace "; (fix-widget-new-geometry-callback <text-widget>) "widget"\n")
@@ -1344,6 +1344,7 @@ USA.
     (call-next-method widget 0 (y-size->height screen 1)))
   (gtk-widget-set-hexpand widget #t)
   (gtk-widget-set-vexpand widget #f)
+  (gtk-widget-set-name widget "modeline")
   (let ((drawing (make-fix-drawing)))
 ;;;    (%trace "; drawing: "drawing"\n")
     (set-fix-layout-drawing! widget drawing 0 0))
@@ -1368,12 +1369,9 @@ USA.
          (set-fix-rect-size! geometry 0 (y-size->height screen 1))
          (%trace "; initialized geometry: "geometry"\n"))))
   (call-next-method widget)
-  (set-gtk-widget-bg-color! widget "black")
-  (realize-font! widget)
+  (realize-style-context! widget)
   (let ((ink (make-simple-text-ink))
        (drawing (fix-layout-drawing widget)))
-    (set-simple-text-ink-font! ink (gtk-screen-font
-                                   (edwin-widget-screen widget)))
     (set-simple-text-ink-text!
      ink widget "--------Initial mode line.--------------------------------")
     (set-text-ink-color! ink "white")