From 6ee3d61efb5d5330f98aa6786bf4bffa137ce202 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sun, 7 Feb 2016 16:52:26 -0700
Subject: [PATCH] gtk: Add background color parameter to make-fix-layout.
The widget will have to paint its background itself. Adding a
GtkCssProvider to a GtkStyleContext didn't work.
---
src/gl/gl-glx.scm | 2 +-
src/gtk-screen/gtk-screen.scm | 5 ++--
src/gtk/fix-demo.scm | 10 ++------
src/gtk/fix-layout.scm | 44 ++++++++++++++++++++++-------------
src/gtk/gtk-graphics.scm | 6 ++---
src/gtk/gtk.texinfo | 5 ++--
src/gtk/swat.scm | 2 +-
7 files changed, 41 insertions(+), 33 deletions(-)
diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm
index aaf4d9c62..8b905b355 100644
--- a/src/gl/gl-glx.scm
+++ b/src/gl/gl-glx.scm
@@ -54,7 +54,7 @@ USA.
initializer (lambda () (make-alien '(struct |__GLXcontextRec|)))))
(define-method initialize-instance ((widget <glx-widget>) width height)
- (call-next-method widget width height)
+ (call-next-method widget width height '())
(add-glib-cleanup widget (make-glx-widget-cleanup
(glx-widget-xdisplay widget)
(glx-widget-glxcontext widget)))
diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm
index bd04f4bdc..bfedafa3d 100644
--- a/src/gtk-screen/gtk-screen.scm
+++ b/src/gtk-screen/gtk-screen.scm
@@ -1114,7 +1114,8 @@ USA.
(let ((screen (edwin-widget-screen widget)))
(call-next-method widget
(x-size->width screen x-size)
- (y-size->height screen y-size)))
+ (y-size->height screen y-size)
+ 'white))
(gtk-widget-set-hexpand widget #t)
(gtk-widget-set-vexpand widget #t)
(let ((drawing (make-fix-drawing)))
@@ -1341,7 +1342,7 @@ ScmWidget { font: Monospace 11 }
(define-method initialize-instance ((widget <modeline-widget>))
;;; (%trace ";(initialize-instance <modeline-widget>) "widget"\n")
(let ((screen (edwin-widget-screen widget)))
- (call-next-method widget 0 (y-size->height screen 1)))
+ (call-next-method widget 0 (y-size->height screen 1) 'black))
(gtk-widget-set-hexpand widget #t)
(gtk-widget-set-vexpand widget #f)
(gtk-widget-set-name widget "modeline")
diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm
index b18dad324..999f243a5 100644
--- a/src/gtk/fix-demo.scm
+++ b/src/gtk/fix-demo.scm
@@ -90,7 +90,7 @@ USA.
(<fix-layout>))
(define-method initialize-instance ((layout <demo-layout>) width height)
- (call-next-method layout width height)
+ (call-next-method layout width height 'white)
(set-fix-widget-motion-handler! layout demo-motion-handler)
(set-fix-widget-button-handler! layout 'release demo-button-release-handler)
(set-fix-widget-key-press-handler! layout demo-key-press-handler)
@@ -98,13 +98,7 @@ USA.
(define-method fix-widget-realize-callback ((widget <demo-layout>))
(call-next-method widget)
- (set-fix-widget-pointer-shape! widget 'crosshair)
- (let ((style-provider (gtk-css-provider-new)))
- (gtk-css-provider-load-from-data
- style-provider "ScmWidget { background: white }")
- (gtk-style-context-add-provider (gtk-widget-get-style-context widget)
- style-provider 'fallback)
- (gobject-unref! style-provider)))
+ (set-fix-widget-pointer-shape! widget 'crosshair))
(define (make-demo-drawing widget)
(let ((drawing (%make-demo-drawing)))
diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index 157964c13..30c4433e3 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -29,12 +29,13 @@ USA.
;;; widget's GdkWindow. It will allocate/move/resize the GdkWindow
;;; and dispatch events received on it.
-(define-class (<fix-widget> (constructor () (width height)))
+(define-class (<fix-widget> (constructor () (width height bgcolor)))
(<scm-widget>)
;; Our window -- a GdkWindow alien. Until realized, a NULL pointer.
(window define accessor
initializer (lambda () (make-alien '|GdkWindow|)))
+ (%background-color define standard)
;; Our window geometry (allocation) -- a rectangular extent in
;; fixnum device coordinates (e.g. size in pixels, offset within
@@ -48,18 +49,22 @@ USA.
(define-integrable guarantee-size guarantee-non-negative-fixnum)
-(define-method initialize-instance ((widget <fix-widget>) width height)
- (call-next-method widget)
- (%trace "; (initialize-instance <fix-widget>) "widget" "width"x"height"\n")
- (set-scm-widget-natural-size! widget width height)
- ;; Init. size, for a realize signal arriving before an allocation.
- (set-fix-rect-size! (fix-widget-geometry widget) width height)
- (C-call "gtk_widget_set_has_window" (gobject-alien widget) 1)
-
- (set-gtk-widget-realize-callback! widget fix-widget-realize-callback)
- (set-gtk-widget-unrealize-callback! widget fix-widget-unrealize-callback)
- (set-gtk-widget-size-allocate-callback! widget allocate-callback)
- (set-gtk-widget-event-callback! widget event-callback))
+(define-method initialize-instance ((widget <fix-widget>) width height bgcolor)
+ (let ((bg (if (null? bgcolor)
+ '()
+ (->color bgcolor '(initialize-instance <fix-widget>)))))
+ (call-next-method widget)
+ (%trace "; (initialize-instance <fix-widget>) "widget" "width"x"height"\n")
+ (set-scm-widget-natural-size! widget width height)
+ (set-fix-widget-%background-color! widget bg)
+ ;; Init. size, for a realize signal arriving before an allocation.
+ (set-fix-rect-size! (fix-widget-geometry widget) width height)
+ (C-call "gtk_widget_set_has_window" (gobject-alien widget) 1)
+
+ (set-gtk-widget-realize-callback! widget fix-widget-realize-callback)
+ (set-gtk-widget-unrealize-callback! widget fix-widget-unrealize-callback)
+ (set-gtk-widget-size-allocate-callback! widget allocate-callback)
+ (set-gtk-widget-event-callback! widget event-callback)))
(define-generic fix-widget-realize-callback (widget))
@@ -336,7 +341,7 @@ USA.
((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS)
(else 'BOGUS)))
-(define-class (<fix-layout> (constructor () (width height)))
+(define-class (<fix-layout> (constructor () (width height bgcolor)))
(<fix-widget>)
;; Scrollbar widgets.
@@ -358,8 +363,8 @@ USA.
(define-guarantee fix-layout "a <fix-layout>")
-(define-method initialize-instance ((widget <fix-layout>) width height)
- (call-next-method widget width height)
+(define-method initialize-instance ((widget <fix-layout>) width height bgcolor)
+ (call-next-method widget width height bgcolor)
(%trace "; (initialize-instance <fix-layout>) "widget" "width"x"height"\n")
(set-fix-rect! (fix-layout-view widget) 0 0 width height)
(set-gtk-widget-draw-callback! widget layout-draw-callback)
@@ -409,6 +414,13 @@ USA.
(area (fix-layout-clip-area layout cr)))
(%trace2 "; view: "(fix-rect-string (fix-layout-view layout))"\n")
(%trace2 "; area: "(fix-rect-string area)"\n")
+ (let ((bg (fix-widget-%background-color layout)))
+ (if (color? bg)
+ (begin
+ (cairo-save cr)
+ (cairo-set-source-color cr bg)
+ (cairo-paint cr)
+ (cairo-restore cr))))
(if drawing
(for-each
(lambda (ink)
diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm
index 8ee68607f..1c66cbb69 100644
--- a/src/gtk/gtk-graphics.scm
+++ b/src/gtk/gtk-graphics.scm
@@ -53,8 +53,8 @@ USA.
(cairo-matrix k 0. 0.
0. (flo:negate k) 0.)))
(cairo-translate cr 1.0 -1.0)
- (let ((black (->color "black" 'make-gtk-graphics))
- (white (->color "white" 'make-gtk-graphics)))
+ (let ((black (->color 'black 'make-gtk-graphics))
+ (white (->color 'white 'make-gtk-graphics)))
(cairo-set-source-color cr white)
(cairo-paint cr)
(cairo-set-source-color cr black)
@@ -76,7 +76,7 @@ USA.
(make-device (make-gtk-graphics width height))
(let ((window (gtk-window-new 'toplevel))
(scroller (gtk-scrolled-view-new))
- (layout (make-fix-layout width height))
+ (layout (make-fix-layout width height 'white))
(drawing (make-fix-drawing))
(graphics (make-gtk-graphics width height)))
(fix-drawing-add-ink! drawing graphics)
diff --git a/src/gtk/gtk.texinfo b/src/gtk/gtk.texinfo
index 1d998899d..e771d0913 100644
--- a/src/gtk/gtk.texinfo
+++ b/src/gtk/gtk.texinfo
@@ -1548,8 +1548,9 @@ A direct subclass of fix-widget.
Type predicate.
@end deffn
-@deffn Procedure make-fix-layout width height
-A new fix-layout with natural size @var{width} x @var{height}.
+@deffn Procedure make-fix-layout width height bgcolor
+A new fix-layout with natural size @var{width} x @var{height} and
+background color @var{bgcolor}.
@end deffn
@deffn {Generic Procedure} fix-layout-drawing layout
diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm
index f234ef360..0a74514d4 100644
--- a/src/gtk/swat.scm
+++ b/src/gtk/swat.scm
@@ -142,7 +142,7 @@ USA.
(define-method initialize-instance ((canvas <swat-canvas>) width height)
(%trace ";(initialize-instance <swat-canvas>) "canvas" "width"x"height"\n")
- (call-next-method canvas width height)
+ (call-next-method canvas width height '())
(set-fix-layout-drawing! canvas (make-fix-drawing) 0 0))
(define (set-swat-canvas-handler! canvas type.modifiers handler)
--
2.25.1