From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Wed, 3 Feb 2016 05:28:55 +0000 (-0700)
Subject: gtk-screen: Use gtk-style-context to set widget fonts/colors.
X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=be31b7e742a0ea6812e3bcd14e5287a98b77ae51;p=mit-scheme.git

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 3d9c8bb2a..46efbe0f8 100644
--- 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 254261305..0ccb27c71 100644
--- 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")