← Back to branch summary

~ubuntu-branches/ubuntu/trusty/guile-gnome-platform/trusty-proposed

« back to all changes in this revision

Viewing changes to gtk/gnome/gtk.scm

  • Committer: Bazaar Package Importer
  • Author(s): Andreas Rottmann
  • Date: 2009-03-01 22:51:48 UTC
  • mfrom: (1.1.2 upstream) (3.2.1 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090301225148-5cubt342wiv8jpmf
Tags: 2.16.1-1
* New upstream release.
* Upstream bumped API, hence all package names changed from
  guile-gnome0-* to guile-gnome2-*.
* Standards-Version 3.8.0 (no changes).
* Remove unused guile-gnome2-cairo.install file.
* Added ${misc:Depends} to all packages.
* Do not build-depend on a -1 revision of the g-wrap packages.
* Add a proper "Copyright YEARS AUTHORS" line to debian/copyright.

Show diffs side-by-side

added added

removed removed

Lines of Context:
gtk/gnome/gtk.scm
24
24
;;
25
25
;;; Code:
26
26
 
27
 
(define-module (gnome gtk))
 
27
(define-module (gnome gtk)
 
28
  #:use-module (oop goops)
 
29
  #:use-module (gnome gobject)
 
30
  #:use-module (gnome gobject generics)
 
31
  #:use-module (gnome gobject utils)
 
32
  #:use-module (gnome gw support modules)
 
33
  #:export (<guile-gtk-tree-model>
 
34
            on-get-flags on-get-n-columns on-get-column-type
 
35
            on-get-iter on-get-path on-get-value on-iter-next
 
36
            on-iter-children on-iter-has-child on-iter-n-children
 
37
            on-iter-nth-child on-iter-parent
 
38
 
 
39
            gtk-tree-or-list-store-set
 
40
            gtk-text-buffer-create-tag create-tag
 
41
            gtk-stock-id))
28
42
 
29
43
(if (getenv "GUILE_GTK_DEBUG")
30
 
    (define progress display)
31
 
    (define progress identity))
32
 
 
33
 
(progress "(gnome gtk): [")
34
 
 
35
 
(progress "goops ")
36
 
(use-modules (oop goops))
37
 
(progress "gobject ")
38
 
(use-modules (gnome gobject) (gnome gobject generics))
39
 
(progress "glib ")
40
 
(use-modules (gnome glib))
41
 
(progress "atk ")
42
 
(use-modules (gnome gw atk))
43
 
(progress "pango ")
44
 
(use-modules (gnome gw pango))
45
 
(progress "gdk ")
46
 
(use-modules (gnome gw gdk))
47
 
(progress "gtk ")
48
 
(use-modules (gnome gw gtk))
49
 
(progress "support")
 
44
    (define-macro (time-debug . forms)
 
45
      `(begin
 
46
         (define %before (tms:clock (times)))
 
47
         ,@forms
 
48
         (let ((diff (/ (- (tms:clock (times)) %before)
 
49
                        internal-time-units-per-second)))
 
50
           (format (current-error-port)
 
51
                   "(gnome gtk): ~a: ~as" ',forms diff))))
 
52
    (define-macro (time-debug . forms)
 
53
      `(begin ,@forms)))
 
54
 
 
55
(time-debug (use-modules (gnome gw gdk)))
 
56
(time-debug (use-modules (gnome gw gtk)))
 
57
(re-export-modules (gnome gw gdk)
 
58
                   (gnome gw gtk))
50
59
 
51
60
;; Support explicit object destruction.
52
 
(define-method (make-gobject-instance class type (instance <gtk-object>) initargs)
 
61
(define-method (initialize (instance <gtk-object>) initargs)
53
62
  (next-method)
54
63
  (connect instance 'destroy
55
64
           (lambda args
56
 
             (let ((primitive-instance (slot-ref instance 'gtype-instance)))
57
 
               (%gtype-instance-primitive-destroy! primitive-instance))))
58
 
  instance)
59
 
 
60
 
(define-public <guile-gtk-tree-model> <guile-gtk-generic-tree-model>)
 
65
             (gtype-instance-destroy! instance))))
 
66
 
 
67
(define <guile-gtk-tree-model> <guile-gtk-generic-tree-model>)
 
68
 
 
69
;; FIXME: doc me!
 
70
(define-generic-with-docs on-get-flags
 
71
  "")
 
72
(define-generic-with-docs on-get-n-columns
 
73
  "")
 
74
(define-generic-with-docs on-get-column-type
 
75
  "")
 
76
(define-generic-with-docs on-get-iter
 
77
  "")
 
78
(define-generic-with-docs on-get-path
 
79
  "")
 
80
(define-generic-with-docs on-get-value
 
81
  "")
 
82
(define-generic-with-docs on-iter-next
 
83
  "")
 
84
(define-generic-with-docs on-iter-children
 
85
  "")
 
86
(define-generic-with-docs on-iter-has-child
 
87
  "")
 
88
(define-generic-with-docs on-iter-n-children
 
89
  "")
 
90
(define-generic-with-docs on-iter-nth-child
 
91
  "")
 
92
(define-generic-with-docs on-iter-parent
 
93
  "")
61
94
 
62
95
;; Support tree models written in guile.
63
96
(define-method (on-get-flags (obj <guile-gtk-tree-model>))
64
97
  (make <gtk-tree-model-flags> #:value 0))
65
 
(define-method (on-get-n-columns (obj <guile-gtk-tree-model>))
66
 
  (error "This method needs to be overridden by a subclass."))
67
 
(define-method (on-get-column-type (obj <guile-gtk-tree-model>) index)
68
 
  (error "This method needs to be overridden by a subclass."))
69
 
(define-method (on-get-iter (obj <guile-gtk-tree-model>) path)
70
 
  (error "This method needs to be overridden by a subclass."))
71
 
(define-method (on-get-path (obj <guile-gtk-tree-model>) iter)
72
 
  (error "This method needs to be overridden by a subclass."))
73
 
(define-method (on-get-value (obj <guile-gtk-tree-model>) iter index)
74
 
  (error "This method needs to be overridden by a subclass."))
75
 
(define-method (on-iter-next (obj <guile-gtk-tree-model>) iter)
76
 
  (error "This method needs to be overridden by a subclass."))
77
 
(define-method (on-iter-children (obj <guile-gtk-tree-model>) parent)
78
 
  (error "This method needs to be overridden by a subclass."))
79
 
(define-method (on-iter-has-child (obj <guile-gtk-tree-model>) iter)
80
 
  (error "This method needs to be overridden by a subclass."))
81
 
(define-method (on-iter-n-children (obj <guile-gtk-tree-model>) iter)
82
 
  (error "This method needs to be overridden by a subclass."))
83
 
(define-method (on-iter-nth-child (obj <guile-gtk-tree-model>) parent n)
84
 
  (error "This method needs to be overridden by a subclass."))
85
 
(define-method (on-iter-parent (obj <guile-gtk-tree-model>) iter)
86
 
  (error "This method needs to be overridden by a subclass."))
87
 
 
88
 
(export on-get-flags on-get-n-columns on-get-column-type
89
 
        on-get-iter on-get-path on-get-value on-iter-next
90
 
        on-iter-children on-iter-has-child on-iter-n-children
91
 
        on-iter-nth-child on-iter-parent)
92
98
 
93
99
;; Miscellany.
94
 
(define-public (gtk-tree-or-list-store-set store iter . args)
 
100
(define (gtk-tree-or-list-store-set store iter . args)
95
101
  (or (even? (length args)) (scm-error 'gruntime-error "Invalid arguments"))
96
102
  (let loop ((args args))
97
103
    (if (eq? args '())
106
112
(define-method (set (store <gtk-tree-store>) (iter <gtk-tree-iter>) . args)
107
113
  (apply gtk-tree-or-list-store-set store iter args))
108
114
 
109
 
(define-public (gtk-text-buffer-create-tag buffer tag-name . properties)
 
115
(define (gtk-text-buffer-create-tag buffer tag-name . properties)
110
116
  (let ((tag (make <gtk-text-tag> #:name tag-name)))
111
117
    (if (not (even? (length properties)))
112
118
        (scm-error 'gruntime-error "Invalid property list: ~A" properties))
121
127
  (apply gtk-text-buffer-create-tag buffer tag-name properties))
122
128
(export create-tag)
123
129
 
124
 
;; Make <gtk-message-dialog> have a specific metaclass so we can do
125
 
;; class methods.
126
 
(define-class <gtk-message-dialog-class> ((class-of <gtk-message-dialog>)))
127
 
(especify-metaclass! <gtk-message-dialog> <gtk-message-dialog-class>)
128
 
(define-method (make-instance (class <gtk-message-dialog-class>) . initargs)
129
 
  (let ((instance (allocate-instance class initargs))
130
 
        (parent (get-keyword #:parent initargs #f))
131
 
        (flags (get-keyword #:flags initargs #f))
132
 
        (message-type (get-keyword #:message-type initargs 'error))
133
 
        (buttons (get-keyword #:buttons initargs 'close))
134
 
        (text (get-keyword #:text initargs "Error")))
135
 
    (slot-set! instance 'gtype-instance
136
 
               (%gtk-message-dialog-new parent flags message-type buttons text))
137
 
    instance))
138
 
 
139
 
(define-public (gtk-stock-id nick)
 
130
(define (gtk-stock-id nick)
140
131
  (string-append "gtk-" (symbol->string nick)))
141
132
 
142
 
(use-modules (gnome gw support modules))
143
 
 
144
 
(re-export-modules (gnome gw gdk)
145
 
                   (gnome gw gtk))
146
 
 
147
 
(progress "]\n")