1;; guile-gnome
2;; Copyright (C) 2001 Martin Baulig <martin@gnome.org>
3;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com>
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;; Parameters are constraints for values, both in type and in range.
25;; This module wraps the parameters code of the GLib type system,
26;; allowing parameters to be manipulated and created from Scheme.
27;;
28;; There is a parameter class for each type of parameter:
29;; @code{<gparam-int>}, @code{<gparam-object>}, etc.
30
31;;
32;;; Code:
33
34(define-module (gnome gobject gparameter)
35  #:use-module (oop goops)
36  #:use-module (gnome gobject config)
37  #:use-module (gnome gobject utils)
38  #:use-module (gnome gobject gtype)
39  #:use-module (gnome gobject gvalue)
40
41  #:export     ( ;; GOOPS parameter base class
42                <gparam>
43                ;; Parameter classes
44                <gparam-char> <gparam-uchar> <gparam-boolean> <gparam-int>
45                <gparam-uint> <gparam-long> <gparam-ulong> <gparam-int64>
46                <gparam-uint64> <gparam-float> <gparam-double>
47                <gparam-unichar> <gparam-pointer> <gparam-string>
48                <gparam-boxed> <gparam-enum> <gparam-flags> <gparam-gtype>
49                ;; Helper class
50                <gparam-spec-flags>
51                ;; Limits
52                gparameter:uint-max gparameter:int-min gparameter:int-max
53                gparameter:ulong-max gparameter:long-min
54                gparameter:long-max gparameter:uint64-max
55                gparameter:int64-min gparameter:int64-max
56                gparameter:float-max gparameter:float-min
57                gparameter:double-max gparameter:double-min
58                gparameter:byte-order
59                ))
60
61(define-class-with-docs <gparam-spec-flags> (<gflags>)
62  "A @code{<gflags>} type for the flags allowable on a @code{<gparam>}:
63@code{read}, @code{write}, @code{construct}, @code{construct-only}, and
64@code{lax-validation}."
65  #:vtable
66  #((read "Readable" 1)
67    (write "Writable" 2)
68    (construct "Set on object construction" 4)
69    (construct-only "Only set on object construction" 8)
70    (lax-validation "Don't require strict validation on parameter conversion" 16)))
71
72;; The C code needs to reference <gparam> for use in its predicates.
73;; Define it now before loading the library.
74(define-class <gparam-class> (<gtype-class>)
75  (value-type #:init-keyword #:value-type))
76
77(define-method (compute-get-n-set (class <gparam-class>) s)
78  (case (slot-definition-allocation s)
79    ((#:checked)
80     (let ((already-allocated (slot-ref class 'nfields))
81           (pred (get-keyword #:pred (slot-definition-options s) #f))
82           (trans (get-keyword #:trans (slot-definition-options s) #f)))
83       (or pred (gruntime-error "Missing #:pred for #:checked slot"))
84       ;; allocate a field in the struct
85       (slot-set! class 'nfields (+ already-allocated 1))
86       ;; struct-ref and struct-set! don't work on the structs that back
87       ;; GOOPS objects, because they are "light structs", without the
88       ;; hidden word that says how many fields are in the struct.
89       ;; Patches submitted to guile-devel on 10 April 2008. Until then,
90       ;; use our own struct accessors.
91       (list (lambda (instance)
92               (%hacky-struct-ref instance already-allocated))
93             (lambda (instance value)
94               (let ((value (if trans (trans value) value)))
95                 (if (pred value)
96                     (%hacky-struct-set! instance already-allocated value)
97                     (gruntime-error
98                      "Bad value for slot ~A on instance ~A: ~A"
99                      (slot-definition-name s) instance value)))))))
100
101    (else (next-method))))
102
103(define-class-with-docs <gparam> (<gtype-instance>)
104  "The base class for GLib parameter objects. (Doc slots)"
105  (name #:init-keyword #:name #:allocation #:checked #:pred symbol?)
106  (nick #:init-keyword #:nick #:allocation #:checked #:pred string?)
107  (blurb #:init-keyword #:blurb #:allocation #:checked #:pred string?)
108  (flags #:init-keyword #:flags #:init-value '(read write)
109         #:allocation #:checked #:pred number?
110         #:trans (lambda (x)
111                   (apply + (gflags->value-list
112                             (make <gparam-spec-flags> #:value x)))))
113  #:gtype-name "GParam"
114  #:metaclass <gparam-class>)
115
116
117(eval-when (expand load eval)
118  (dynamic-call "scm_init_gnome_gobject_parameters"
119		(dynamic-link *guile-gnome-gobject-lib-path*)))
120
121(define-class-with-docs <gparam-char> (<gparam>)
122  "Parameter for @code{<gchar>} values."
123  (minimum
124   #:init-keyword #:minimum #:init-value (integer->char 0)
125   #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x))))
126  (maximum
127   #:init-keyword #:maximum #:init-value (integer->char 127)
128   #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x))))
129  (default-value
130   #:init-keyword #:default-value #:init-value (integer->char 127)
131   #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x))))
132  #:value-type <gchar>
133  #:gtype-name "GParamChar")
134
135(define-class-with-docs <gparam-uchar> (<gparam>)
136  "Parameter for @code{<guchar>} values."
137  (minimum
138   #:init-keyword #:minimum #:init-value (integer->char 0)
139   #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x))))
140  (maximum
141   #:init-keyword #:maximum #:init-value (integer->char 255)
142   #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x))))
143  (default-value
144   #:init-keyword #:default-value #:init-value (integer->char 255)
145   #:allocation #:checked #:pred (lambda (x) (or (char? x) (integer? x))))
146  #:value-type <guchar>
147  #:gtype-name "GParamUChar")
148
149(define-class-with-docs <gparam-boolean> (<gparam>)
150  "Parameter for @code{<gboolean>} values."
151  (default-value
152   #:init-keyword #:default-value #:init-value #f
153   #:allocation #:checked #:pred boolean?)
154  #:value-type <gboolean>
155  #:gtype-name "GParamBoolean")
156
157(define-class-with-docs <gparam-int> (<gparam>)
158  "Parameter for @code{<gint>} values."
159  (minimum
160   #:init-keyword #:minimum #:init-value gparameter:int-min
161   #:allocation #:checked #:pred integer?)
162  (maximum
163   #:init-keyword #:maximum #:init-value gparameter:int-max
164   #:allocation #:checked #:pred integer?)
165  (default-value
166   #:init-keyword #:default-value #:init-value 0
167   #:allocation #:checked #:pred integer?)
168  #:value-type <gint>
169  #:gtype-name "GParamInt")
170
171(define-class-with-docs <gparam-uint> (<gparam>)
172  "Parameter for @code{<guint>} values."
173  (minimum
174   #:init-keyword #:minimum #:init-value 0
175   #:allocation #:checked #:pred integer?)
176  (maximum
177   #:init-keyword #:maximum #:init-value gparameter:uint-max
178   #:allocation #:checked #:pred integer?)
179  (default-value
180   #:init-keyword #:default-value #:init-value 0
181   #:allocation #:checked #:pred integer?)
182  #:value-type <guint>
183  #:gtype-name "GParamUInt")
184
185(define-class-with-docs <gparam-unichar> (<gparam>)
186  "Parameter for Unicode codepoints, represented as @code{<guint>}
187values."
188  (default-value
189   #:init-keyword #:default-value #:init-value 0
190   #:allocation #:checked #:pred integer?)
191  #:value-type <guint>
192  #:gtype-name "GParamUnichar")
193
194(define-class-with-docs <gparam-long> (<gparam>)
195  "Parameter for @code{<glong>} values."
196  (minimum
197   #:init-keyword #:minimum #:init-value gparameter:long-min
198   #:allocation #:checked #:pred integer?)
199  (maximum
200   #:init-keyword #:maximum #:init-value gparameter:long-max
201   #:allocation #:checked #:pred integer?)
202  (default-value
203   #:init-keyword #:default-value #:init-value 0
204   #:allocation #:checked #:pred integer?)
205  #:value-type <glong>
206  #:gtype-name "GParamLong")
207
208(define-class-with-docs <gparam-ulong> (<gparam>)
209  "Parameter for @code{<gulong>} values."
210  (minimum
211   #:init-keyword #:minimum #:init-value 0
212   #:allocation #:checked #:pred integer?)
213  (maximum
214   #:init-keyword #:maximum #:init-value gparameter:ulong-max
215   #:allocation #:checked #:pred integer?)
216  (default-value
217   #:init-keyword #:default-value #:init-value 0
218   #:allocation #:checked #:pred integer?)
219  #:value-type <gulong>
220  #:gtype-name "GParamULong")
221
222(define-class-with-docs <gparam-int64> (<gparam>)
223  "Parameter for @code{<gint64>} values."
224  (minimum
225   #:init-keyword #:minimum #:init-value gparameter:int64-min
226   #:allocation #:checked #:pred integer?)
227  (maximum
228   #:init-keyword #:maximum #:init-value gparameter:int64-max
229   #:allocation #:checked #:pred integer?)
230  (default-value
231   #:init-keyword #:default-value #:init-value 0
232   #:allocation #:checked #:pred integer?)
233  #:value-type <gint64>
234  #:gtype-name "GParamInt64")
235
236(define-class-with-docs <gparam-uint64> (<gparam>)
237  "Parameter for @code{<guint64>} values."
238  (minimum
239   #:init-keyword #:minimum #:init-value 0
240   #:allocation #:checked #:pred integer?)
241  (maximum
242   #:init-keyword #:maximum #:init-value gparameter:uint64-max
243   #:allocation #:checked #:pred integer?)
244  (default-value
245   #:init-keyword #:default-value #:init-value 0
246   #:allocation #:checked #:pred integer?)
247  #:value-type <guint64>
248  #:gtype-name "GParamUInt64")
249
250(define-class-with-docs <gparam-float> (<gparam>)
251  "Parameter for @code{<gfloat>} values."
252  (minimum
253   #:init-keyword #:minimum #:init-value (- gparameter:float-max)
254   #:allocation #:checked #:pred real?)
255  (maximum
256   #:init-keyword #:maximum #:init-value gparameter:float-max
257   #:allocation #:checked #:pred real?)
258  (default-value
259   #:init-keyword #:default-value #:init-value 0.0
260   #:allocation #:checked #:pred real?)
261  #:value-type <gfloat>
262  #:gtype-name "GParamFloat")
263
264(define-class-with-docs <gparam-double> (<gparam>)
265  "Parameter for @code{<gdouble>} values."
266  (minimum
267   #:init-keyword #:minimum #:init-value (- gparameter:double-max)
268   #:allocation #:checked #:pred real?)
269  (maximum
270   #:init-keyword #:maximum #:init-value gparameter:double-max
271   #:allocation #:checked #:pred real?)
272  (default-value
273   #:init-keyword #:default-value #:init-value 0.0
274   #:allocation #:checked #:pred real?)
275  #:value-type <gdouble>
276  #:gtype-name "GParamDouble")
277
278(define-class-with-docs <gparam-pointer> (<gparam>)
279  "Parameter for @code{<gpointer>} values."
280  #:value-type <gpointer>
281  #:gtype-name "GParamPointer")
282
283(define-class-with-docs <gparam-string> (<gparam>)
284  "Parameter for @code{<gchararray>} values."
285  (default-value
286   #:init-keyword #:default-value #:init-value ""
287   #:allocation #:checked #:pred (lambda (x) (or (not x) (string? x))))
288  #:value-type <gchararray>
289  #:gtype-name "GParamString")
290
291(define (class-is-a? x is-a)
292  (memq is-a (class-precedence-list x)))
293
294(define-class-with-docs <gparam-boxed> (<gparam>)
295  "Parameter for @code{<gboxed>} values."
296  (boxed-type
297   #:init-keyword #:boxed-type #:allocation #:checked
298   #:pred (lambda (x) (class-is-a? x <gboxed>)))
299  #:value-type <gboxed>
300  #:gtype-name "GParamBoxed")
301
302(define-class-with-docs <gparam-enum> (<gparam>)
303  "Parameter for @code{<genum>} values."
304  (enum-type
305   #:init-keyword #:enum-type #:allocation #:checked
306   #:pred (lambda (x) (class-is-a? x <genum>)))
307  (default-value
308   #:init-keyword #:default-value #:init-value 0
309   #:allocation #:checked #:pred number?)
310  #:value-type <genum>
311  #:gtype-name "GParamEnum")
312
313(define-class-with-docs <gparam-flags> (<gparam>)
314  "Parameter for @code{<gflags>} values."
315  (flags-type
316   #:init-keyword #:flags-type #:allocation #:checked
317   #:pred (lambda (x) (class-is-a? x <gflags>)))
318  (default-value
319   #:init-keyword #:default-value #:init-value 0
320   #:allocation #:checked #:pred number?)
321  #:value-type <gflags>
322  #:gtype-name "GParamFlags")
323
324(define-class-with-docs <gparam-value-array> (<gparam>)
325  "Parameter for @code{<gvalue-array>} values."
326  (element-spec
327   #:init-keyword #:element-spec #:allocation #:checked
328   #:pred (lambda (x) (or (not x) (is-a? x <gparam>))))
329  #:value-type <gvalue-array>
330  #:gtype-name "GParamValueArray")
331
332(define-class-with-docs <gparam-gtype> (<gparam>)
333  "Parameter for @code{<gtype>} values."
334  (is-a-type
335   #:init-keyword #:is-a-type #:allocation #:checked
336   #:pred (lambda (x) (or (not x) (is-a? x <gtype-class>))))
337  #:value-type <gtype-class>
338  #:gtype-name "GParamGType")
339
340;;;
341;;; {Instance Initialization}
342;;;
343
344;; fixme, make me more useful
345(define-method (write (param <gparam>) file)
346  (let ((class (class-of param))
347        (loc (number->string (object-address param) 16)))
348    (if (slot-bound? class 'name)
349        (with-accessors (name)
350          (format file "<~a ~a ~a>" (class-name class) (name param) loc))
351        (format file "<~a (uninitialized) ~a>" (class-name class) loc))))
352