From: Matt Birkholz Date: Mon, 4 Jan 2016 08:40:08 +0000 (-0700) Subject: gtk: Get with Gtk+ v3.16; punt widget colors; use GtkCssProviders. X-Git-Tag: mit-scheme-pucked-9.2.12~383 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9f76a09275d89398dbf78b4d46cad4e25cfae4fc;p=mit-scheme.git gtk: Get with Gtk+ v3.16; punt widget colors; use GtkCssProviders. Eliminate or replace calls to deprecated Gtk+ functions. Punt gtk- widget-parse-color, gtk-widget-bg-color, etc. Add gtk-widget-set- name, gtk-widget-get-style-context, gtk-style-context-add-provider, , etc. --- diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm index 4855a9122..eafae92ee 100644 --- a/src/gl/gl-glxgears.scm +++ b/src/gl/gl-glxgears.scm @@ -41,7 +41,6 @@ USA. (define (make-glxgears-demo-device width height title) (let ((window (gtk-window-new 'toplevel))) - (gtk-window-set-opacity window 1.0) (gtk-window-set-title window title) (set-gtk-window-delete-event-callback! window (lambda (w) (%trace "closed "w) 0)) diff --git a/src/gl/gl.pkg b/src/gl/gl.pkg index 5d502622f..4f09720cb 100644 --- a/src/gl/gl.pkg +++ b/src/gl/gl.pkg @@ -99,7 +99,6 @@ USA. gtk-widget-show-all gtk-widget-queue-draw set-gtk-widget-draw-callback! - gtk-window-set-opacity gtk-window-set-title set-gtk-window-delete-event-callback! gtk-container-set-border-width @@ -131,7 +130,7 @@ USA. gtk-widget-parent gtk-widget-show-all set-gtk-widget-draw-callback! gtk-container-add gtk-container-set-border-width - gtk-window-new gtk-window-set-opacity gtk-window-set-title + gtk-window-new gtk-window-set-title set-gtk-window-delete-event-callback! fix-widget-new-geometry-callback fix-widget-realize-callback diff --git a/src/gtk/Includes/gdkcursor.cdecl b/src/gtk/Includes/gdkcursor.cdecl index b17bf152a..30869489d 100644 --- a/src/gtk/Includes/gdkcursor.cdecl +++ b/src/gtk/Includes/gdkcursor.cdecl @@ -84,5 +84,6 @@ gdk/gdkcursor.h |# (GDK_LAST_CURSOR) (GDK_CURSOR_IS_PIXMAP))) -(extern (* GdkCursor) gdk_cursor_new +(extern (* GdkCursor) gdk_cursor_new_for_display + (display (* GdkDisplay)) (cursor_type GdkCursorType)) \ No newline at end of file diff --git a/src/gtk/Includes/glib.cdecl b/src/gtk/Includes/glib.cdecl index 17b4ab49a..6fbaa2850 100644 --- a/src/gtk/Includes/glib.cdecl +++ b/src/gtk/Includes/glib.cdecl @@ -10,7 +10,7 @@ (typedef guint16 ushort) (typedef guint32 uint) ;(typedef guint64 ulonglong) -;(typedef gssize int) +(typedef gssize int) (typedef gsize uint) ;(typedef gchar char) diff --git a/src/gtk/Includes/gtk.cdecl b/src/gtk/Includes/gtk.cdecl index 25fcdea1f..7fc290245 100644 --- a/src/gtk/Includes/gtk.cdecl +++ b/src/gtk/Includes/gtk.cdecl @@ -5,6 +5,7 @@ gtk/gtk.h |# (include "gdk") (include "gtkadjustment") (include "gtkcontainer") +(include "gtkcssprovider") (include "gtkenums") (include "gtkframe") (include "gtkgrid") @@ -13,6 +14,7 @@ gtk/gtk.h |# (include "gtkpaned") (include "gtkscrolledwindow") (include "gtkstylecontext") +(include "gtkstyleprovider") (include "gtktogglebutton") (include "gtktypeutils") (include "gtkwidget") diff --git a/src/gtk/Includes/gtkcontainer.cdecl b/src/gtk/Includes/gtkcontainer.cdecl index 88301aacb..e017696e5 100644 --- a/src/gtk/Includes/gtkcontainer.cdecl +++ b/src/gtk/Includes/gtkcontainer.cdecl @@ -15,8 +15,4 @@ gtk/gtkcontainer.h |# (extern void gtk_container_set_border_width (container (* GtkContainer)) - (border_width guint)) - -(extern void - gtk_container_resize_children - (container (* GtkContainer))) \ No newline at end of file + (border_width guint)) \ No newline at end of file diff --git a/src/gtk/Includes/gtkcssprovider.cdecl b/src/gtk/Includes/gtkcssprovider.cdecl new file mode 100644 index 000000000..16515dfff --- /dev/null +++ b/src/gtk/Includes/gtkcssprovider.cdecl @@ -0,0 +1,33 @@ +#| -*-Scheme-*- + +gtk/gtkcssprovider.h |# + +(extern (* GtkCssProvider) + gtk_css_provider_new) + +(extern gboolean + gtk_css_provider_load_from_data + (css_provider (* GtkCssProvider)) + (data (* (const gchar))) + (length gssize) + (error (* (* GError)))) + +(extern gboolean + gtk_css_provider_load_from_file + (css_provider (* GtkCssProvider)) + (file (* GFile)) + (error (* (* GError)))) + +(extern gboolean + gtk_css_provider_load_from_path + (css_provider (* GtkCssProvider)) + (path (* (const gchar))) + (error (* (* GError)))) + +(extern (* GtkCssProvider) + gtk_css_provider_get_default) + +(extern (* GtkCssProvider) + gtk_css_provider_get_named + (name (* (const gchar))) + (variant (* (const gchar)))) \ No newline at end of file diff --git a/src/gtk/Includes/gtkstylecontext.cdecl b/src/gtk/Includes/gtkstylecontext.cdecl index 67289ad62..4920362ea 100644 --- a/src/gtk/Includes/gtkstylecontext.cdecl +++ b/src/gtk/Includes/gtkstylecontext.cdecl @@ -2,29 +2,10 @@ gtk/gtkstylecontext.h |# -(extern void gtk_style_context_add_class +(extern void gtk_style_context_add_provider (context (* GtkStyleContext)) - (class_name (* (const gchar)))) - -(extern gboolean gtk_style_context_lookup_color - (context (* GtkStyleContext)) - (color_name (* (const gchar))) - (color (* GdkRGBA))) - -(extern void gtk_style_context_get_color - (context (* GtkStyleContext)) - (state GtkStateFlags) - (color (* GdkRGBA))) - -(extern void gtk_style_context_get_background_color - (context (* GtkStyleContext)) - (state GtkStateFlags) - (color (* GdkRGBA))) - -(extern (* (const PangoFontDescription)) - gtk_style_context_get_font - (context (* GtkStyleContext)) - (state GtkStateFlags)) + (provider (* GtkStyleProvider)) + (priority guint)) (extern void gtk_style_context_set_background (context (* GtkStyleContext)) diff --git a/src/gtk/Includes/gtkstyleprovider.cdecl b/src/gtk/Includes/gtkstyleprovider.cdecl new file mode 100644 index 000000000..d75d4fce1 --- /dev/null +++ b/src/gtk/Includes/gtkstyleprovider.cdecl @@ -0,0 +1,9 @@ +#| -*-Scheme-*- + +gtk/gtkstyleprovider.h |# + +(enum (GTK_STYLE_PROVIDER_PRIORITY_FALLBACK) + (GTK_STYLE_PROVIDER_PRIORITY_THEME) + (GTK_STYLE_PROVIDER_PRIORITY_SETTINGS) + (GTK_STYLE_PROVIDER_PRIORITY_APPLICATION) + (GTK_STYLE_PROVIDER_PRIORITY_USER)) \ No newline at end of file diff --git a/src/gtk/Includes/gtkwidget.cdecl b/src/gtk/Includes/gtkwidget.cdecl index 0d8e20910..604d623ef 100644 --- a/src/gtk/Includes/gtkwidget.cdecl +++ b/src/gtk/Includes/gtkwidget.cdecl @@ -47,6 +47,10 @@ gtk/gtkwidget.h |# (extern void gtk_widget_grab_focus (widget (* GtkWidget))) +(extern void gtk_widget_set_name + (widget (* GtkWidget)) + (name (* (const gchar)))) + (extern void gtk_widget_set_state_flags (widget (* GtkWidget)) @@ -99,6 +103,13 @@ gtk/gtkwidget.h |# (width gint) (height gint)) +(extern void gtk_widget_set_opacity + (widget (* GtkWidget)) + (opacity gdouble)) + +(extern (* GdkDisplay) gtk_widget_get_display + (widget (* GtkWidget))) + (extern void gtk_widget_set_hexpand (widget (* GtkWidget)) (expand gboolean)) @@ -110,20 +121,6 @@ gtk/gtkwidget.h |# (extern gint gtk_widget_get_events (widget (* GtkWidget))) -(extern void gtk_widget_override_color - (widget (* GtkWidget)) - (state GtkStateFlags) - (color (* (const GdkRGBA)))) - -(extern void gtk_widget_override_background_color - (widget (* GtkWidget)) - (state GtkStateFlags) - (color (* (const GdkRGBA)))) - -(extern void gtk_widget_override_font - (widget (* GtkWidget)) - (font_desc (* (const PangoFontDescription)))) - (extern gboolean gtk_widget_is_composited (widget (* GtkWidget))) diff --git a/src/gtk/Includes/gtkwindow.cdecl b/src/gtk/Includes/gtkwindow.cdecl index 74a29dd43..9c3b00cbf 100644 --- a/src/gtk/Includes/gtkwindow.cdecl +++ b/src/gtk/Includes/gtkwindow.cdecl @@ -20,20 +20,11 @@ gtk-2.0/gtk/gtkwindow.h |# (window (* GtkWindow)) (title (* (const gchar)))) -(extern void - gtk_window_set_opacity - (window (* GtkWindow)) - (opacity gdouble)) - (extern void gtk_window_set_type_hint (window (* GtkWindow)) (hint GdkWindowTypeHint)) -(extern gdouble - gtk_window_get_opacity - (window (* GtkWindow))) - (extern void gtk_window_set_geometry_hints (window (* GtkWindow)) diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index 26b30c2df..9dc163018 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -53,13 +53,12 @@ USA. (compile-file "fix-layout" '("gtk") (->environment '(gtk fix-layout))) (compile-file "keys" '("gtk") (->environment '(gtk keys))) (compile-file "main" '("gtk") (->environment '(gtk main))) - ;(compile-file "thread" '("main") (->environment '(gtk thread))) (compile-file "gtk-ev" '("gtk") (->environment '(gtk event-viewer))) - (compile-file "gtk-graphics" '("gtk") - (->environment '(runtime gtk-graphics))) ;; Users of the toolkit interface do NOT use the FFI directly, ;; and do not need integrable definitions. + (compile-file "gtk-graphics" '("gtk") + (->environment '(runtime gtk-graphics))) (compile-file "fix-demo" '() (->environment '(gtk fix-layout demo))) (compile-file "swat" '() (->environment '(gtk swat))) (compile-file "swat-pole-zero" '() (->environment '(swat))) diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index b19f8be1e..3f0447a6a 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -29,7 +29,7 @@ USA. (define (make-fix-layout-demo) (let* ((window (let ((w (gtk-window-new 'toplevel))) - (gtk-window-set-opacity w 0.90) + (gtk-widget-set-opacity w 0.90) (gtk-window-set-title w "fix-layout-demo") (set-gtk-window-delete-event-callback! w (lambda (w) (%trace ";closed "w"\n") 0)) @@ -91,8 +91,13 @@ USA. (define-method fix-widget-realize-callback ((widget )) (call-next-method widget) - (set-gtk-widget-bg-color! widget "white") - (set-fix-widget-pointer-shape! widget 'crosshair)) + (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))) (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 121485f88..d8fdd235c 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -151,11 +151,13 @@ USA. (let ((name.value (or (assq name alist) (error "Not a pointer shape:" name (map car alist)))) - (alien (make-alien '|GdkCursor|))) - ;; Not GC-protecting alien? - (C-call "gdk_cursor_new" alien (cdr name.value)) - (C-call "gdk_window_set_cursor" (fix-widget-window widget) alien) - (C-call "g_object_unref" alien))))) + (cursor (make-alien '|GdkCursor|)) + (display (make-alien '|GdkDisplay|))) + ;; GC-protect cursor! + (C-call "gtk_widget_get_display" display (gobject-alien widget)) + (C-call "gdk_cursor_new_for_display" cursor display (cdr name.value)) + (C-call "gdk_window_set_cursor" (fix-widget-window widget) cursor) + (C-call "g_object_unref" cursor))))) (define (event-callback widget GdkEvent) (%trace2 ";event-callback "widget) @@ -333,16 +335,6 @@ USA. ((= type (C-enum "GDK_2BUTTON_PRESS")) 'DOUBLE-PRESS) ((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS) (else 'BOGUS))) - -(define-method set-gtk-widget-bg-color! ((widget ) color - #!optional state) - (call-next-method widget color state) - (%trace "; (set-gtk-widget-bg-color! ) "widget" "color" "state"\n") - (if (not (or (default-object? state) (eq? state 'normal))) - (warn "Fix-widget states are not (yet) supported:" widget color state)) - (let ((style (gtk-widget-style-context widget))) - (C-call "gtk_style_context_set_background" - style (fix-widget-window widget)))) (define-class ( (constructor () (width height))) () @@ -562,6 +554,9 @@ USA. (define-method fix-widget-realize-callback ((widget )) (call-next-method widget) (%trace "; (fix-widget-realize-callback ) "widget"\n") + #;(let ((style (gtk-widget-style-context widget))) + (C-call "gtk_style_context_set_background" + style (fix-widget-window widget))) (adjust-adjustments widget)) (define (adjustments-callback widget hGtkAdjustment vGtkAdjustment) diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm index a5bf11213..050cf6b14 100644 --- a/src/gtk/gtk-ev.scm +++ b/src/gtk/gtk-ev.scm @@ -101,7 +101,10 @@ USA. (C-call "gdk_window_set_user_data" main-GdkWindow alien) ;; Event window - (C-call "gdk_cursor_new" GdkCursor (C-enum "GDK_CROSSHAIR")) + (let ((GdkDisplay (make-alien '|GdkDisplay|))) + (C-call "gtk_widget_get_display" GdkDisplay alien) + (C-call "gdk_cursor_new_for_display" GdkCursor + GdkDisplay (C-enum "GDK_CROSSHAIR"))) (error-if-null GdkCursor "Could not create cursor:" widget) (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) (let ((b (gtk-event-viewer-event-box widget))) @@ -120,9 +123,6 @@ USA. (C-call "gdk_window_show" event-GdkWindow) (C-call "g_object_unref" GdkCursor) - #;(let ((style (gtk-widget-style-context widget))) - (C-call "gtk_style_context_add_class" style "view?") - (C-call "gtk_style_context_set_background" style event-GdkWindow)) (let ((rgba (malloc (C-sizeof "GdkRGBA") '|GdkRGBA|))) (C->= rgba "GdkRGBA red" 1.0) (C->= rgba "GdkRGBA green" 1.0) diff --git a/src/gtk/gtk-widget.scm b/src/gtk/gtk-widget.scm index 32535fdc1..5eae0ff76 100644 --- a/src/gtk/gtk-widget.scm +++ b/src/gtk/gtk-widget.scm @@ -269,8 +269,20 @@ USA. ((eq? handled? #f) 0) (else (warn "Event callback not boolean:" callback) 0))))) + +(define (gtk-widget-set-opacity widget opacity) + (guarantee-gtk-widget widget 'gtk-widget-set-opacity) + (guarantee-real opacity 'gtk-widget-set-opacity) + (if (not (<= 0. opacity 1.)) + (error:bad-range-argument opacity 'gtk-widget-set-opacity)) + (C-call "gtk_widget_set_opacity" (gobject-alien widget) opacity)) + +(define (gtk-widget-set-name widget name) + (guarantee-gtk-widget widget 'gtk-widget-set-name) + (guarantee-string name 'gtk-widget-set-name) + (C-call "gtk_widget_set_name" (gobject-alien widget) name)) -;;; GtkWidget Font +;;; GtkStyleContext & GtkCssProvider (define-integrable (gtk-widget-style-context widget) (let ((style (make-alien '|GtkStyleContext|))) @@ -280,126 +292,137 @@ USA. (define-integrable-operator (guarantee-gtk-widget-realized widget operator) (guarantee-gtk-widget widget operator) (if (not (gtk-widget-realized? widget)) - (error "Not yet realized:" widget operator))) - -(define (gtk-widget-font widget #!optional state) - (guarantee-gtk-widget-realized widget 'gtk-widget-font) - (let ((style (gtk-widget-style-context widget)) - (state (->gtk-widget-state state 'gtk-widget-font)) - (desc (make-alien '|PangoFontDescription|))) - (C-call "gtk_style_context_get_font" style state desc) - desc)) - -(define (set-gtk-widget-font! widget desc) - (guarantee-gtk-widget widget 'set-gtk-widget-font!) - (let ((font (->PangoFontDescription desc))) - (C-call "gtk_widget_override_font" (gobject-alien widget) font) - (pango-font-description-free font) - (C-call "gtk_widget_queue_draw" (gobject-alien widget)))) - -(define (->PangoFontDescription desc) - (cond ((and (alien? desc) (eq? '|PangoFontDescription| (alien/ctype desc))) - (pango-font-description-copy desc)) - ((string? desc) - (let ((alien (pango-font-description-from-string desc))) - (if (alien-null? alien) - (error:wrong-type-argument desc "PangoFontDescription string" - '->PangoFontDescription) - alien))) - (else (error:wrong-type-argument desc "PangoFontDescription" - '->PangoFontDescription)))) - -;;; GtkWidget Colors - -(define (gtk-widget-fg-color widget #!optional state) - (guarantee-gtk-widget-realized widget 'gtk-widget-fg-color) - (let ((style (gtk-widget-style-context widget)) - (state (->gtk-widget-state state 'gtk-widget-fg-color)) - (rgba (malloc (C-sizeof "GdkRGBA") '|GdkRGBA|))) - (C-call "gtk_style_context_get_color" style state rgba) - (let ((color (peek-rgba rgba))) - (free rgba) - color))) - -(define (gtk-widget-bg-color widget #!optional state) - (guarantee-gtk-widget-realized widget 'gtk-widget-bg-color) - (let ((style (gtk-widget-style-context widget)) - (state (->gtk-widget-state state 'gtk-widget-bg-color)) - (rgba (malloc (C-sizeof "GdkRGBA") '|GdkRGBA|))) - (C-call "gtk_style_context_get_background_color" style state rgba) - (let ((color (peek-rgba rgba))) - (free rgba) - color))) - -(define (set-gtk-widget-fg-color! widget color #!optional state) - (guarantee-gtk-widget widget 'set-gtk-widget-fg-color!) - (let ((rgba (->rgba color widget 'set-gtk-widget-fg-color!)) - (state (->gtk-widget-state state 'set-gtk-widget-fg-color!))) - (C-call "gtk_widget_override_color" (gobject-alien widget) state rgba) - (free rgba))) - -(define-generic set-gtk-widget-bg-color! (widget color #!optional state)) - -(define-method set-gtk-widget-bg-color! ((widget ) color - #!optional state) - (let ((rgba (->rgba color widget '(set-gtk-widget-bg-color! ))) - (state (->gtk-widget-state state '(set-gtk-widget-bg-color! )))) - (C-call "gtk_widget_override_background_color" - (gobject-alien widget) state rgba) - (free rgba))) - -(define (->gtk-widget-state object operator) - (case (if (default-object? object) 'normal object) - ((NORMAL) (C-enum "GTK_STATE_FLAG_NORMAL")) - ((ACTIVE) (C-enum "GTK_STATE_FLAG_ACTIVE")) - ((PRELIGHT) (C-enum "GTK_STATE_FLAG_PRELIGHT")) - ((SELECTED) (C-enum "GTK_STATE_FLAG_SELECTED")) - ((INSENSITIVE) (C-enum "GTK_STATE_FLAG_INSENSITIVE")) - ((INCONSISTENT) (C-enum "GTK_STATE_FLAG_INCONSISTENT")) - ((FOCUSED) (C-enum "GTK_STATE_FLAG_FOCUSED")) - ((BACKDROP) (C-enum "GTK_STATE_FLAG_BACKDROP")) - (else (error:wrong-type-argument object "a GtkWidget state" operator)))) - -(define-integrable-operator (peek-rgba rgba) - (let ((c (make-color))) - (set-color-red! c (C-> rgba "GdkRGBA red")) - (set-color-green! c (C-> rgba "GdkRGBA green")) - (set-color-blue! c (C-> rgba "GdkRGBA blue")) - (set-color-alpha! c (C-> rgba "GdkRGBA alpha")) - c)) - -(define (->rgba color widget operator) - (cond ((color? color) - (let ((rgba (malloc (C-sizeof "GdkRGBA") '|GdkRGBA|))) - (C->= rgba "GdkRGBA red" (color-red color)) - (C->= rgba "GdkRGBA green" (color-green color)) - (C->= rgba "GdkRGBA blue" (color-blue color)) - (C->= rgba "GdkRGBA alpha" (color-alpha color)) - rgba)) - ((string? color) - (let ((rgba (malloc (C-sizeof "GdkRGBA") '|GdkRGBA|))) - (or (and (not (zero? (C-call "gtk_style_context_lookup_color" - (gtk-widget-style-context widget) - color rgba))) - rgba) - (and (not (zero? (C-call "gdk_rgba_parse" rgba color))) - rgba) - (error:wrong-type-argument color "a color spec" operator)))) - (else - (error:wrong-type-argument color "a color spec" operator)))) - -(define (gtk-widget-parse-color widget spec) - (guarantee-gtk-widget-realized widget 'gtk-widget-parse-color) - (guarantee-string spec 'gtk-widget-parse-color) - (let ((style (gtk-widget-style-context widget)) - (rgba (malloc (C-sizeof "GdkRGBA") '|GdkRGBA|))) - (if (zero? (C-call "gtk_style_context_lookup_color" style spec rgba)) - (begin - (free rgba) - #f) - (let ((color (peek-rgba rgba))) - (free rgba) - color)))) + (warn "Not yet realized:" widget operator))) + +(define (gtk-widget-get-style-context widget) + (guarantee-gtk-widget-realized widget 'gtk-widget-get-style-context) + (gtk-widget-style-context widget)) + +(define-integrable (gtk-style-context? object) + (and (alien? object) (eq? '|GtkStyleContext| (alien/ctype object)))) + +(define-guarantee gtk-style-context "a GtkStyleContext alien") + +(define (gtk-style-context-add-provider style-context css-provider priority) + (guarantee-gtk-style-context style-context 'gtk-style-context-add-provider) + (guarantee-gtk-css-provider css-provider 'gtk-style-context-add-provider) + (C-call "gtk_style_context_add_provider" + style-context + (gobject-alien css-provider) + (->gtk-style-provider-priority priority + 'gtk-style-context-add-provider))) + +(define (->gtk-style-provider-priority priority operator) + (if (exact-nonnegative-integer? priority) + priority + (case priority + ((FALLBACK) (C-enum "GTK_STYLE_PROVIDER_PRIORITY_FALLBACK")) + ((THEME) (C-enum "GTK_STYLE_PROVIDER_PRIORITY_THEME")) + ((SETTINGS) (C-enum "GTK_STYLE_PROVIDER_PRIORITY_SETTINGS")) + ((APPLICATION) (C-enum "GTK_STYLE_PROVIDER_PRIORITY_APPLICATION")) + ((USER) (C-enum "GTK_STYLE_PROVIDER_PRIORITY_USER")) + (else (error:wrong-type-argument + priority "a GtkStylProvider priority" operator))))) + +(define-class () + ;; A with associated *GError that gets freed when the + ;; is GCed. + (gerror* define accessor accessor gobject-gerror* + initializer (lambda () (make-alien '(* |GError|))))) + +(define-method initialize-instance ((object )) + (call-next-method object) + (let ((gerror* (gobject-gerror* object))) + (C-call "g_try_malloc0" gerror* (C-sizeof "* GError")) + (error-if-null gerror* "Could not allocate:" gerror*) + (add-glib-cleanup object (make-gerror*-cleanup gerror*)))) + +(define (make-gerror*-cleanup gerror*) + (named-lambda (gerror*-cleanup) + (if (not (alien-null? gerror*)) + (let ((gerror (make-alien '|GError|))) + (C-> gerror* "* GError" gerror) + (if (not (alien-null? gerror)) + (C-call "g_error_free" gerror)) + (C-call "g_free" gerror*) + (alien-null! gerror*))))) + +(define (error-if-gerror* gerror* message . data) + (let ((gerror (C-> gerror* "* GError"))) + (if (not (alien-null? gerror)) + (let ((errmsg (c-peek-cstring (C-> gerror "GError message")))) + (without-interruption + (lambda () + (C->= gerror* "* GError" 0) + (C-call "g_error_free" gerror))) + (apply error message errmsg data))))) + +(define-class ( (constructor ())) + ()) + +(define-guarantee gtk-css-provider "a ") + +(define (gtk-css-provider-new) + (let* ((object (make-gtk-css-provider)) + (alien (gobject-alien object))) + (C-call "gtk_css_provider_new" alien) + (error-if-null alien "Could not create:" object) + (C-call "g_object_ref_sink" alien alien) + object)) + +(define (gtk-css-provider-get-default) + (let* ((object (make-gtk-css-provider)) + (alien (gobject-alien object))) + (C-call "gtk_css_provider_get_default" alien) + (error-if-null alien "Could not get default GtkCssProvider:" object) + (C-call "g_object_ref" alien alien) + object)) + +(define (gtk-css-provider-get-named name variant) + (guarantee-string name 'gtk-css-provider-get-named) + (let* ((v (if (eq? #f variant) + 0 + (begin + (guarantee-string variant 'gtk-css-provider-get-named) + variant))) + (object (make-gtk-css-provider)) + (alien (gobject-alien object))) + (C-call "gtk_css_provider_get_named" alien name v) + (error-if-null alien "Could not get named GtkCssProvider:" + object name variant) + (C-call "g_object_ref" alien alien) + object)) + +(define (gtk-css-provider-load-from-data provider string) + (guarantee-gtk-css-provider provider 'gtk-css-provider-load-from-data) + (guarantee-string string 'gtk-css-provider-load-from-data) + (let ((alien (gobject-alien provider)) + (gerror* (gobject-gerror* provider))) + (C-call "gtk_css_provider_load_from_data" alien string -1 gerror*) + (error-if-gerror* gerror* "Could not load GtkCssProvider data:" provider))) + +(define-guarantee gfile "a ") + +(define (gtk-css-provider-load-from-file provider gfile) + (guarantee-gtk-css-provider provider 'gtk-css-provider-load-from-file) + (guarantee-gfile gfile 'gtk-css-provider-load-from-file) + (let ((alien (gobject-alien provider)) + (gerror* (gobject-gerror* provider)) + (gfile-alien (gobject-alien gfile))) + (C-call "gtk_css_provider_load_from_file" alien gfile-alien gerror*) + (error-if-gerror* gerror* "Could not load GtkCssProvider GFile:" + provider gfile))) + +(define (gtk-css-provider-load-from-path provider pathname) + (guarantee-gtk-css-provider provider 'gtk-css-provider-load-from-file) + (let ((namestring (->namestring + (pathname-simplify + (merge-pathnames pathname (working-directory-pathname))))) + (alien (gobject-alien provider)) + (gerror* (gobject-gerror* provider))) + (C-call "gtk_css_provider_load_from_path" alien namestring gerror*) + (error-if-gerror* gerror* "Could not load GtkCssProvider path:" + provider namestring))) ;;; GtkContainers @@ -827,13 +850,6 @@ USA. (guarantee-string title 'gtk-window-set-title) (C-call "gtk_window_set_title" (gobject-alien window) title)) -(define (gtk-window-set-opacity window opacity) - (guarantee-gtk-window window 'gtk-window-set-opacity) - (guarantee-real opacity 'gtk-window-set-opacity) - (if (not (<= 0. opacity 1.)) - (error:bad-range-argument opacity 'gtk-window-set-opacity)) - (C-call "gtk_window_set_opacity" (gobject-alien window) opacity)) - (define (gtk-window-set-type-hint window hint) (guarantee-gtk-window window 'gtk-window-set-type-hint) (let ((type-hint (->type-hint hint 'gtk-window-set-type-hint))) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index fb85a3d37..b294cdb39 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -58,7 +58,7 @@ USA. (define-package (gtk gtk-widget) (parent (gtk)) (files "gtk-widget") - ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi") + ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi" "../pango/" "../glib/") (export (gtk) gtk-adjustment? guarantee-gtk-adjustment make-gtk-adjustment set-gtk-adjustment! @@ -87,11 +87,19 @@ USA. set-gtk-widget-unrealize-callback! set-gtk-widget-draw-callback! set-gtk-widget-event-callback! - - gtk-widget-parse-color - gtk-widget-fg-color gtk-widget-bg-color - set-gtk-widget-fg-color! set-gtk-widget-bg-color! - gtk-widget-font set-gtk-widget-font! + gtk-widget-set-opacity + gtk-widget-set-name + gtk-widget-get-style-context + gtk-style-context? + gtk-style-context-add-provider + + gtk-css-provider? guarantee-gtk-css-provider + gtk-css-provider-new + gtk-css-provider-get-default + gtk-css-provider-get-named + gtk-css-provider-load-from-data + gtk-css-provider-load-from-file + gtk-css-provider-load-from-path gtk-container? guarantee-gtk-container gtk-container-children gtk-bin-child @@ -102,7 +110,6 @@ USA. gtk-window-new gtk-window-type gtk-window-set-geometry-hints gtk-window-set-title - gtk-window-set-opacity gtk-window-set-type-hint gtk-window-set-default-size gtk-window-get-default-size gtk-window-parse-geometry @@ -138,7 +145,8 @@ USA. gtk-paned-get-child1 gtk-paned-get-child2 gtk-paned-get-position gtk-paned-set-position gtk-paned-view? gtk-paned-view-new) - (import (pango) make-pango-layout guarantee-pango-font-description)) + (import (pango) make-pango-layout guarantee-pango-font-description) + (import (gio) gfile?)) (define-package (gtk widget) (parent (gtk)) @@ -154,7 +162,7 @@ USA. (define-package (gtk fix-layout) (parent (gtk)) (files "fix-layout") - ;;(depends-on "pango" "cairo" "gtk.bin" gtk" "../runtime/ffi" "gtk-const.bin") + ;;(depends-on "pango" "cairo" "gtk.bin" "gtk" "../runtime/ffi" "gtk-const.bin") (import (ffi) find-c-includes c-enum-constant-values) @@ -305,8 +313,6 @@ USA. (import (cairo) cairo-identity-matrix cairo-matrix-scale! cairo-matrix-translate! cairo-point x y cairo-transform! guarantee-flonum) - (import (gtk fix-layout) - fix-layout-view) (export () make-fix-layout-demo)) diff --git a/src/gtk/gtk.texinfo b/src/gtk/gtk.texinfo index e40893963..bc220601e 100644 --- a/src/gtk/gtk.texinfo +++ b/src/gtk/gtk.texinfo @@ -260,8 +260,9 @@ Draws a line that connects the points (@var{x0}, @var{y0}) and @deffn Procedure gtk-graphics/set-foreground-color device color @deffnx Procedure gtk-graphics/set-background-color device color Sets the foreground and background colors for future drawing -operations. @var{Color} can be a color name or specification. -@xref{colors}. +operations. @var{Color} should be a color name or specification +understood by the Cairo plugin. @xref{colors, , Cairo Colors, +mit-scheme-cairo, MIT/GNU Scheme Cairo Plugin}. @end deffn @deffn Procedure gtk-graphics/clear device @@ -286,6 +287,7 @@ the Gtk interface. * Pixbuf Loader:: * Gtk Adjustment:: * Gtk Widget:: +* Gtk CSS Provider:: * Gtk Container:: * Gtk Window:: * Gtk Label:: @@ -433,7 +435,7 @@ is currently visible. @end table @end deffn -@node Gtk Widget, Gtk Container, Gtk Adjustment, API Reference +@node Gtk Widget, Gtk CSS Provider, Gtk Adjustment, API Reference @section Gtk Widget A gtk-widget is a gobject that can be "destroyed". Each instance is @@ -535,6 +537,16 @@ the widget will likely fail and cause critical warnings. @code{#t} if @var{widget} has an alpha channel. @end deffn +@deffn Procedure gtk-widget-set-opacity widget opacity +Request a partially transparent @var{widget}. @var{Opacity} can vary +from 0.0 (fully transparent) to 1.0 (fully opaque). On X11 the +request has no effect without a compositing manager. +@xref{gtk-widget-is-composited?}. +Note that setting a window's +opacity after the window has been shown causes it to flicker once on +Windows. +@end deffn + @deffn Procedure gtk-widget-show widget Indicates @var{widget} is ready to be displayed. If you want to show all widgets in a container, it is easier to call @@ -616,72 +628,87 @@ Unfortunately this procedure also overrides the minimum width and height so that a top-level window cannot be resized to a smaller size. @end deffn -@subsection Gtk Widget Colors & Fonts -@anchor{colors} +@node Gtk CSS Provider, Gtk Container, Gtk Widget, API Reference -Colors are floating-vectors containing four flonums between 0. and -1. inclusive: the red, green, blue and alpha components. For example -@code{#[floating-vector 42 0. 1. 0. 1.]} represents completely opaque -green. +A GtkWidget's GtkStyleContext specifies its default font and colors +per its state and theme. A GtkCssProvider can be added to the context +to specify defaults (or overrides) using a language similar to +Cascading Style Sheets (@acronym{CSS}). In this language, element +names select widgets by class (e.g. @code{ScmWidget}) and element ids +select widgets by name. -Colors can also be specified with a string: -@itemize -@item A standard color name (listed in the X11 rgb.txt file). -@item A hex value: 'RGB', 'RRGGBB', 'RRRGGGBBB', or 'RRRRGGGGBBBB'. -@item An RGB color: 'rgb(R,G,B)' where R, G and B are decimal -numbers between 0 and 255 inclusive or percentages. -@item An RGBA color: 'rgba(R,G,B,A)' where R, G and B are numbers or -percentages as above, and A is a floating point number between 0. and -1. inclusive. -@end itemize +@deffn Procedure gtk-widget-set-name widget name +Gives @var{widget} @var{name}. The style of the widget (its font, +colors, etc.) can then be specified using @var{name} in syntax much +like the id selectors of Cascading Style Sheets (@acronym{CSS}). +@xref{Gtk CSS Provider}. Note that the CSS selector syntax allows +only alphanumerics, dashes and underscores in widget names. +@end deffn -@anchor{gtk-widget-parse-color} -@deffn Procedure gtk-widget-parse-color widget spec -Resolves @var{spec} into a color. A symbolic color name is resolved -according to @var{widget}'s style. +@deffn Procedure gtk-widget-get-style-context widget +Returns the GtkStyleContext associated with @var{widget}. +@var{Widget} must be realized. The returned object is only valid +until @var{widget} changes style. @end deffn -Some colors depend on the state of a particular widget. The arguments -to the @code{gtk-widget-fg-color} procedure include a widget and an -optional ``state'', one of these symbols: @code{normal}, -@code{active}, @code{prelight}, @code{selected}, @code{insensitive}, -@code{inconsistent}, @code{focused} and @code{backdrop}. +@deffn Procedure gtk-style-context? object +Type predicate. +@end deffn -@anchor{gtk-widget-fg-color} -@deffn Procedure gtk-widget-fg-color widget #!optional state -The color used to draw @var{widget} when it is in @var{state}. -@var{State} defaults to @code{normal}. +@deffn Procedure gtk-style-context-add-provider context provider priority +Adds @var{provider}, a GtkStyleProvider, to the style @var{context}. +@var{Priority} can be a non-negative integer or one of the symbols +@code{fallback}, @code{theme}, @code{settings}, @code{application} or +@code{user} (equivalent to the integers 1, 200, 400, 600 and 800 +respectively). Styles specified with high priority override lower +priority specifications. @end deffn -@deffn Procedure gtk-widget-bg-color widget #!optional state -@var{Widget}'s background color. Similar to -@bref{gtk-widget-fg-color}. +@deffn Class +A direct subclass of gobject representing a reference to a +GtkCssProvider. @end deffn -@anchor{set-gtk-widget-fg-color!} -@deffn Procedure set-gtk-widget-fg-color! widget color #!optional state -Sets the foreground color used to draw @var{widget} when it is in -@var{state}. @var{State} defaults to @code{normal}. @var{Color} -should be a value acceptable to @bref{gtk-widget-parse-color}. -@emph{Note} that the effect of this procedure on widgets that have -@emph{not} been realized is undefined at best. +@deffn Procedure gtk-css-provider? +Type predicate. +@end deffn + +@deffn Procedure guarantee-gtk-css-provider +Type guarantor. @end deffn -@deffn Procedure set-gtk-widget-bg-color! widget color #!optional state -Sets the background color of @var{widget}. See -@bref{set-gtk-widget-fg-color!}. +@deffn Procedure gtk-css-provider-new +A new GtkCssProvider. @end deffn -@deffn Procedure gtk-widget-font widget -A PangoFontDescription alien --- a toolkit object owned by @var{widget}. +@deffn Procedure gtk-css-provider-get-default +Returns the provider containing the style settings used as a fallback +for all widgets. @end deffn -@deffn Procedure set-gtk-widget-font! widget font -Set @var{widget} to use @var{font}, a PangoFontDescription. -@var{Widget} will ref @var{font}; Scheme can free it. +@deffn Procedure gtk-css-provider-get-named name variant +Returns a GtkCssProvider in which a named theme has been loaded. +@var{Name} must be a string. @var{Variant} can be @code{#f} or a +string, for example: @code{"dark"}. @end deffn -@node Gtk Container, Gtk Window, Gtk Widget, API Reference +@deffn Procedure gtk-css-provider-load-from-data provider string +Loads the CSS-like @var{string} into @var{provider}, clearing any +previously loaded information. +@end deffn + +@deffn Procedure gtk-css-provider-load-from-file provider gfile +Loads the CSS-like content of @var{gfile} (a GFile) into +@var{provider}, clearing any previously loaded information. +@end deffn + +@deffn Procedure gtk-css-provider-load-from-path provider path +Loads the CSS-like content of the file named @var{path} (a string or +pathname) into @var{provider}, clearing any previously loaded +information. +@end deffn + +@node Gtk Container, Gtk Window, Gtk CSS Provider, API Reference @section Gtk Container A Gtk widget with a list of ``children''. The list records only the @@ -806,16 +833,6 @@ window from other windows they may have open. A good title might include the application name and current document. @end deffn -@deffn Procedure gtk-window-set-opacity window opacity -Request a partially transparent @var{window}. @var{Opacity} can vary -from 0.0 (fully transparent) to 1.0 (fully opaque). On X11 the -request has no effect without a compositing manager. -@xref{gtk-widget-is-composited?}. -Note that setting a window's -opacity after the window has been shown causes it to flicker once on -Windows. -@end deffn - @anchor{gtk-window-set-default-size} @deffn Procedure gtk-window-set-default-size window width height Sets @var{window}'s default size to @var{width} x @var{height}. If diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index 101e815da..f234ef360 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -624,13 +624,14 @@ USA. (if (swat-widget-realized? widget) (realize-option widget name spec))) (define (realize-option widget name spec) - (case name + #;(case name ((foreground) (set-gtk-widget-fg-color! widget spec 'normal)) ((background) (set-gtk-widget-bg-color! widget spec 'normal)) ((activeforeground) (set-gtk-widget-fg-color! widget spec 'active)) ((activebackground) (set-gtk-widget-bg-color! widget spec 'active)) ((font) (set-gtk-widget-font! widget spec)) - (else (warn "Cannot realize widget option:" name spec widget)))) + (else (warn "Cannot realize widget option:" name spec widget))) + (warn "Cannot realize widget option:" name spec widget)) (define (realize-options widget) (set-swat-widget-realized?! widget #t)