1;; guile-gnome
2;; Copyright (C) 2003,2004,2015 Andy Wingo <wingo at pobox dot com>
3;; Copyright (C) 2001 Martin Baulig <martin@gnome.org>
4
5;; This program is free software; you can redistribute it and/or
6;; modify it under the terms of the GNU General Public License as
7;; published by the Free Software Foundation; either version 2 of
8;; the License, or (at your option) any later version.
9;;
10;; This program is distributed in the hope that it will be useful,
11;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13;; GNU General Public License for more details.
14;;
15;; You should have received a copy of the GNU General Public License
16;; along with this program; if not, contact:
17;;
18;; Free Software Foundation           Voice:  +1-617-542-5942
19;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
20;; Boston, MA  02111-1307,  USA       gnu@gnu.org
21
22;;; Commentary:
23;;
24;; GObject is what is commonly understood as @emph{the} object system
25;; for GLib. This is not strictly true. GObject is @emph{one}
26;; implementation of an object system, built on the other modules:
27;; GType, GValue, GParameter, GClosure, and GSignal.
28;;
29;; Similarly, this Guile module provides integration with the GObject
30;; object system, built on the Guile modules that support GType, GValue,
31;; GParameter, GClosure, and GSignal.
32;;
33;; The main class exported by this module is @code{<gobject>}.
34;; @code{<gobject>} classes can be subclassed by the user, which will
35;; register new subtypes with the GType runtime type system.
36;; @code{<gobject>} classes are are also created as needed when wrapping
37;; GObjects that come from C, for example from a function's return
38;; value.
39;;
40;; Besides supporting derivation, and signals like other
41;; @code{<gtype-instance>} implementations, @code{<gobject>} has the
42;; concept of @dfn{properties}, which are @code{<gvalue>}'s associated
43;; with the object. The values are constrained by @code{<gparam>}'s,
44;; which are associated with the object's class. This module exports the
45;; necessary routines to query, get, and set @code{<gobject>}
46;; properties.
47;;
48;; In addition, this module defines the @code{<ginterface>} base class,
49;; whose subclasses may be present as mixins of @code{<gobject>}
50;; classes. For example:
51;;
52;; @lisp
53;; (use-modules (gnome gtk) (oop goops))
54;; (class-direct-supers <gtk-widget>) @result{}
55;;    (#<<gobject-class> <atk-implementor-iface> 3033bad0>
56;;     #<<gobject-class> <gtk-object> 3034bc90>)
57;; @end lisp
58;;
59;; In this example, we see that @code{<gtk-widget>} has two
60;; superclasses, @code{<gtk-object>} and @code{<atk-implementor-iface>}.
61;; The second is an interface implemented by the @code{<gtk-widget>}
62;; class. See @code{gtype-interfaces} for more details.
63;;
64;;; Code:
65
66(define-module (gnome gobject gobject)
67  #:use-module ((srfi srfi-1) #:select (filter-map))
68  #:use-module (oop goops)
69  #:use-module (gnome gobject utils)
70  #:use-module (gnome gobject config)
71  #:use-module (gnome gobject gtype)
72  #:use-module (gnome gobject gvalue)
73  #:use-module (gnome gobject gparameter)
74  #:use-module (gnome gobject gsignal)
75
76  #:export     (;; Classes
77                <gobject> <ginterface> <gparam-object>
78                ;; Low-level subclassing
79                gtype-register-static
80                ;; Methods to override
81                gobject:get-property gobject:set-property
82                ;; Properties
83                gobject-class-get-properties gobject-class-find-property
84                gobject-class-get-property-names
85                gobject-get-property gobject-set-property))
86
87(eval-when (expand load eval)
88  (dynamic-call "scm_init_gnome_gobject"
89		(dynamic-link *guile-gnome-gobject-lib-path*)))
90
91
92;;;
93;;; {Class Initialization}
94;;;
95
96(define-class <gobject-class> (<gtype-class>))
97
98(define-method (compute-slots (class <gobject-class>))
99  (define (has-slot? name slots)
100    (and (pair? slots)
101         (or (eq? name (slot-definition-name (car slots)))
102             (has-slot? name (cdr slots)))))
103  (define (compute-extra-slots props slots)
104    (filter-map (lambda (prop)
105                  (and (not (has-slot? prop slots))
106                       (if (defined? '<slot>)
107                           (make <slot> #:name prop #:allocation #:gproperty)
108                           `(,prop #:allocation #:gproperty))))
109                props))
110  (let* ((slots (next-method))
111         (extra (compute-extra-slots
112                 (gobject-class-get-property-names class) slots)))
113    (with-accessors (direct-slots)
114      (set! (direct-slots class) (append (direct-slots class) extra)))
115    (append slots extra)))
116
117(define-method (compute-get-n-set (class <gobject-class>) slotdef)
118  (let ((name (slot-definition-name slotdef)))
119    (case (slot-definition-allocation slotdef)
120      ((#:gproperty) (list (lambda (o) (gobject-get-property o name))
121                           (lambda (o v) (gobject-set-property o name v))))
122      (else (next-method)))))
123
124(define-method (initialize (class <gobject-class>) initargs)
125  (define (install-properties!)
126    ;; To expose slots as gobject properties, <gobject> will process a
127    ;; #:gparam slot option to create a new gobject property.
128    (for-each
129     (lambda (slot)
130       (let ((pspec (get-keyword #:gparam (slot-definition-options slot) #f)))
131         (if pspec
132             (gobject-class-install-property
133              class
134              (apply make
135                     (car pspec) #:name (slot-definition-name slot)
136                     (cdr pspec))))))
137     (class-direct-slots class)))
138
139  (define (install-signals!)
140    ;; We parse a #:gsignal initialization argument to install signals.
141    (let loop ((args initargs))
142      (if (not (null? args))
143          (begin
144            (if (eq? (car args) #:gsignal)
145                (let ((signal (cadr args)))
146                  (if (not (and (list? signal) (>= (length signal) 2)))
147                      (gruntime-error "Invalid signal specification: ~A" signal))
148                  (let* ((name (car signal))
149                         (return-type (cadr signal))
150                         (param-types (cddr signal))
151                         (generic (gtype-class-create-signal class name return-type param-types)))
152                    ;; Some magic to define the generic
153                    (module-define! (current-module)
154                                    (generic-function-name generic) generic))))
155            (loop (cddr args))))))
156
157  (define (first pred list)
158    (cond ((null? list) #f)
159          ((pred (car list)) (car list))
160          (else (first pred (cdr list)))))
161  (define (gobject-class? c)
162    (memq <gobject> (class-precedence-list c)))
163
164  ;; real work starts here
165
166  (next-method
167   class
168   (cons*
169    #:gtype-name
170    (or (get-keyword #:gtype-name initargs #f)
171        (gtype-register-static
172         (class-name->gtype-name (get-keyword #:name initargs #f))
173         (first gobject-class?
174                (apply append
175                       (map class-precedence-list
176                            (get-keyword #:dsupers initargs '()))))))
177    initargs))
178  (install-properties!)
179  (install-signals!))
180
181(define-class-with-docs <gobject> (<gtype-instance>)
182  "The base class for GLib's default object system.
183
184@code{<gobject>}'s metaclass understands a new slot option,
185@code{#:gparam}, which will export a slot as a @code{<gobject>}
186property. The default implementation will set and access the value from
187the slot, but you can customize this by writing your own methods for
188@code{gobject:set-property} and @code{gobject:get-property}.
189
190In addition, the metaclass also understands @code{#:gsignal} arguments,
191which define signals on the class, and define the generics for the
192default signal handler. See @code{gtype-class-define-signal} for more
193information.
194
195For example:
196@lisp
197 ;; deriving from <gobject>
198 (define-class <test> (<gobject>)
199  ;; a normal object slot
200  my-data
201
202  ;; an object slot exported as a gobject property
203  (pub-data #:gparam (list <gparam-long> #:name 'test))
204
205  ;; likewise, using non-default parameter settings
206  (foo-data #:gparam (list <gparam-long> #:name 'foo
207                           #:minimum -3 #:maximum 1000
208                           #:default-value 42))
209
210  ;; a signal with no arguments and no return value
211  #:gsignal '(frobate #f)
212
213  ;; a signal with arguments and a return value
214  #:gsignal (list 'frobate <gboolean> <gint> <glong>))
215
216 ;; deriving from <test> -- also inherits properties and signals
217 (define-class <hungry> (<test>))
218@end lisp
219
220@code{<gobject>} classes also expose a slot for each GObject property
221defined on the class, if such a slot is not already defined.
222"
223  ;; add a slot for signal generics instead of module-define! ?
224  #:metaclass <gobject-class>
225  #:gtype-name "GObject")
226
227(define-class-with-docs <ginterface> (<gtype-instance>)
228  "The base class for GLib's interface types. Not derivable in Scheme."
229  #:metaclass <gobject-class>
230  #:gtype-name "GInterface")
231
232(define (class-is-a? x is-a)
233  (memq is-a (class-precedence-list x)))
234
235(define-class-with-docs <gparam-object> (<gparam>)
236  "Parameter for @code{<gobject>} values."
237  (object-type
238   #:init-keyword #:object-type #:allocation #:checked
239   #:pred (lambda (x) (is-a? x <gobject-class>)))
240  #:value-type <gobject>
241  #:gtype-name "GParamObject")
242
243
244;;;
245;;; {GObject Properties}
246;;;
247
248(define (gobject-class-find-property class name)
249  "Returns a property named @var{name} (a symbol), belonging to
250@var{class} or one of its parent classes, or @code{#f} if not found."
251  (let ((propname name))
252    (with-accessors (name)
253      (let lp ((props (gobject-class-get-properties class)))
254        (cond ((null? props) #f)
255              ((eq? (name (car props)) propname) (car props))
256              (else (lp (cdr props))))))))
257
258(define-generic-with-docs gobject:set-property
259  "Called to set a gobject property. Only properties directly belonging
260to the object's class will come through this function; superclasses
261handle their own properties.
262
263Takes three arguments: the object, the property name, and the value.
264
265Call @code{(next-method)} in your methods to invoke the default handler.")
266
267(define-method (gobject:set-property (object <gobject>) (name <symbol>) value)
268  "The default implementation of @code{gobject:set-property}, which sets
269slots on the object."
270  (if (class-slot-definition (class-of object) name)
271      (slot-set! object name value)
272      (gruntime-error "Properties added after object definition must be accessed via custom property methods: ~A" name)))
273
274(define-generic-with-docs gobject:get-property
275  "Called to get a gobject property. Only properties directly belonging
276to the object's class will come through this function; superclasses
277handle their own properties.
278
279Takes two arguments: the object and the property name.
280
281Call @code{(next-method)} in your methods to invoke the default handler")
282
283(define-method (gobject:get-property (object <gobject>) (name <symbol>))
284  "The default implementation of @code{gobject:get-property}, which
285calls @code{(slot-ref obj name)}."
286  (if (class-slot-definition (class-of object) name)
287      (slot-ref object name)
288      (gruntime-error "Properties added after object definition must be accessed via custom property methods: ~A" name)))
289
290(eval-when (load eval)
291  (%gnome-gobject-object-post-init))
292