gtk: Add background color parameter to make-fix-layout.
authorMatt Birkholz <puck@birchwood-abbey.net>
Sun, 7 Feb 2016 23:52:26 +0000 (16:52 -0700)
committerMatt Birkholz <puck@birchwood-abbey.net>
Sun, 7 Feb 2016 23:52:26 +0000 (16:52 -0700)
The widget will have to paint its background itself.  Adding a
GtkCssProvider to a GtkStyleContext didn't work.

src/gl/gl-glx.scm
src/gtk-screen/gtk-screen.scm
src/gtk/fix-demo.scm
src/gtk/fix-layout.scm
src/gtk/gtk-graphics.scm
src/gtk/gtk.texinfo
src/gtk/swat.scm

index aaf4d9c621a3675cc2b1f886244b4a68e00dfc6f..8b905b3555e8ab425c5c0abdebaf9e0a55ec5a22 100644 (file)
@@ -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)))
index bd04f4bdcdc9341dda18538dcbfdd9f753200a78..bfedafa3dc59e6628f948e62f911d34d7be82b04 100644 (file)
@@ -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")
index b18dad3248d48d525d601e1edeee02bdda919bbf..999f243a52bd6e0ac1af0b2988114b223d1ed001 100644 (file)
@@ -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)))
index 157964c138afb801c268adcd690c3620a2973da4..30c4433e3773637e6ee0529409597d63285f0122 100644 (file)
@@ -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)))
 \f
-(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)
index 8ee68607f73fdf787ea1706698cb25edbd3fcd44..1c66cbb69720decb34a47bb1233f8cf30cbdbe91 100644 (file)
@@ -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)
index 1d998899d6629134cb866d3f806e6c2fed513736..e771d0913829773b9b8c1df72d597949841b4e57 100644 (file)
@@ -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
index f234ef360c9a7af2204ce2083a3530e48ce37e99..0a74514d43af24dcc85ea38e494d7c103d47a2e5 100644 (file)
@@ -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)