1 (defpackage :doc-skeleton
2 (:use :cl :gtk :gdk :gobject :iter :c2mop :glib)
3 (:export :widget-skeleton
8 (in-package :doc-skeleton)
10 (defun chapter-skeleton (output widgets &key use-refs (section "section"))
12 ((stringp output) (with-open-file (stream output :direction :output :if-exists :supersede)
13 (chapter-skeleton stream widgets :use-refs use-refs)))
14 ((null output) (with-output-to-string (stream)
15 (chapter-skeleton stream widgets :use-refs use-refs)))
16 ((or (eq t output) (streamp output))
17 (format output "@menu~%")
18 (iter (for w in widgets)
19 (format output "* ~A::~%" (string-downcase (symbol-name w))))
20 (format output "@end menu~%~%")
21 (iter (for w in widgets)
22 (write-string (widget-skeleton w :section section :use-refs use-refs) output)
23 (format output "~%~%")))))
25 (defparameter *gtk-widgets* '(about-dialog accel-label alignment arrow
26 aspect-frame assistant bin box button button-box calendar cell-view
27 check-button check-menu-item color-button color-selection
28 color-selection-dialog combo-box combo-box-entry container curve
29 dialog drawing-area entry event-box expander file-chooser-button
30 file-chooser-dialog file-chooser-widget fixed font-button
31 font-selection font-selection-dialog frame gamma-curve gtk-window
32 h-box h-button-box h-paned h-ruler h-s-v h-scale h-scrollbar
33 h-separator handle-box icon-view image image-menu-item input-dialog
34 invisible item label layout link-button menu menu-bar menu-item
35 menu-shell menu-tool-button message-dialog misc notebook
36 old-editable paned plug progress progress-bar radio-button
37 radio-menu-item radio-tool-button range recent-chooser-dialog
38 recent-chooser-menu recent-chooser-widget ruler scale scale-button
39 scrollbar scrolled-window separator separator-menu-item
40 separator-tool-item socket spin-button statusbar table
41 tearoff-menu-item text text-view toggle-button toggle-tool-button
42 tool-button tool-item toolbar tree tree-item tree-view v-box
43 v-button-box v-paned v-ruler v-scale v-scrollbar v-separator
44 viewport volume-button widget))
46 (defun all-gtk-widgets ()
47 (sort (iter (for symbol in-package (find-package :gtk) :external-only t)
48 (for class = (find-class symbol nil))
49 (when (and class (subclassp class (find-class 'gtk:widget)))
53 ;; (widget-skeleton widget &key (sectioning-command "section"))
54 ;; returns the texinfo string for widget (a symbol or class)
58 ;; @$SECTIONING-COMMAND $WIDGET
62 ;; Superclass: $(direct-superclass WIDGET)
64 ;; Interfaces: $(direct-interface widget)
69 ;; @item @anchor{slot.$widget.$slot}$slot. Type: $(slot-type slot). Accessor: $(slot-accessor slot). $(when (constructor-only slot) "Contructor-only slot.")
76 ;; @item @anchor{signal.$widget.$signal}"$signal". Signature: Type1 Arg1, .., Typen Argn => return-type. Options: $(signal-options)
82 (defun widget-skeleton (widget &key (section "section") (use-refs nil))
83 (unless (typep widget 'class) (setf widget (find-class widget)))
84 (with-output-to-string (stream)
85 (let ((*print-case* :downcase)
86 (*package* (symbol-package (class-name widget)))
88 (*use-refs* use-refs))
89 (format stream "@node ~A~%" (class-name widget))
90 (format stream "@~A ~A~%" section (class-name widget))
91 (format stream "@Class ~A~%" (class-name widget))
92 (format stream "Superclass:")
93 (iter (for super in (class-direct-superclasses widget))
94 (unless (and (typep super 'gobject-class) (gobject::gobject-class-interface-p super))
95 (format stream " @code{~A}" (class-name super))))
96 (format stream "~%~%")
97 (widget-slots stream widget)
98 (format stream "~%~%")
99 (widget-signals stream widget)
100 (format stream "~%~%")
101 (widget-child-properties stream widget))))
103 (defun widget-slots (stream widget)
104 (format stream "Slots:~%")
105 (format stream "@itemize~%")
106 (iter (for slot in (class-direct-slots widget))
107 (when (typep slot 'gobject::gobject-direct-slot-definition)
108 (format stream "@item @anchor{slot.~A.~A}~A. Type: ~A. Accessor: ~A."
109 (class-name widget) (slot-definition-name slot)
110 (slot-definition-name slot)
112 (slot-accessor slot))
113 (case (classify-slot-readability widget slot)
114 (:write-only (format stream " Write-only."))
115 (:read-only (format stream " Read-only.")))
116 (format stream "~%")))
117 (format stream "@end itemize~%"))
119 (defun widget-signals (stream widget)
120 (let ((g-type (gobject::gobject-class-g-type-name widget)))
121 (unless (string= g-type (gobject::gobject-class-g-type-name (first (class-direct-superclasses widget))))
122 (format stream "Signals:~%")
123 (format stream "@itemize~%")
124 ;; @item @anchor{signal.$widget.$signal}"$signal". Signature: Type1 Arg1, .., Typen Argn => return-type. Options: $(signal-options)
125 (iter (for signal in (type-signals g-type))
126 (format stream "@item @anchor{signal.~A.~A}\"~A\". Signature: ~A. Options: ~A."
128 (signal-info-name signal)
129 (signal-info-name signal)
130 (signal-signature signal)
131 (signal-options signal))
132 (format stream "~%"))
133 (format stream "@end itemize~%"))))
135 (defun widget-child-properties (stream widget)
136 (let ((g-type (gobject::gobject-class-g-type-name widget)))
137 (when (g-type-is-a g-type "GtkContainer")
138 (unless (string= g-type (gobject::gobject-class-g-type-name (first (class-direct-superclasses widget))))
139 (let ((props (gtk::container-class-child-properties g-type)))
141 (format stream "Child properties:~%")
142 (format stream "@itemize~%")
143 ;; @item @anchor{signal.$widget.$signal}"$signal". Signature: Type1 Arg1, .., Typen Argn => return-type. Options: $(signal-options)
144 (iter (for prop in props)
145 (for accessor = (format nil "~A-child-~A"
146 (string-downcase (symbol-name (class-name widget)))
147 (g-class-property-definition-name prop)))
148 (format stream "@item @anchor{childprop.~A.~A}~A. Type: ~A. Accessor: ~A."
149 (string-downcase (symbol-name (class-name widget)))
150 (g-class-property-definition-name prop)
151 (g-class-property-definition-name prop)
152 (type-string (g-class-property-definition-type prop))
154 (format stream "~%"))
155 (format stream "@end itemize~%")))))))
157 (defun signal-signature (s)
158 (with-output-to-string (stream)
159 (format stream "(instance ~A)" (type-string (signal-info-owner-type s)))
160 (iter (for type in (signal-info-param-types s))
162 (format stream ", (arg-~A ~A)" counter (type-string type)))
163 (format stream " @result{} ~A" (type-string (signal-info-return-type s)))))
165 (defun signal-options (s)
166 (format nil "~{~A~^, ~}"(signal-info-flags s)))
168 (defun slot-type (slot)
169 (let ((type (gobject::gobject-direct-slot-definition-g-property-type slot)))
172 (defun type-string (type)
174 (string (type-string-s type))
175 (t (type-string-f type))))
177 (defun ensure-list (x) (if (listp x) x (list x)))
179 (defun type-string-f (type)
180 (let ((l (ensure-list type)))
182 ((:string glib:g-string) "@code{string}")
183 ((:int :uint :long :ulong :char :uchar :int64 :uint64) "@code{integer}")
184 ((:boolean :bool) "@code{boolean}")
185 (g-object (if (second l)
186 (format-ref (string-downcase (symbol-name (second l))))
188 (g-boxed-foreign (format-ref (string-downcase (symbol-name (second l)))))
190 ((glist gslist) (format nil "list of ~A" (type-string-f (second l))))
191 (t (if (symbolp type)
195 (defun type-string-s (type)
197 ((g-type= type +g-type-string+) "@code{string}")
198 ((g-type= type +g-type-boolean+) "@code{boolean}")
199 ((g-type= type +g-type-float+) "@code{single-float}")
200 ((g-type= type +g-type-double+) "@code{double-float}")
201 ((or (g-type= type +g-type-int+)
202 (g-type= type +g-type-uint+)
203 (g-type= type +g-type-char+)
204 (g-type= type +g-type-uchar+)
205 (g-type= type +g-type-long+)
206 (g-type= type +g-type-ulong+)
207 (g-type= type +g-type-int64+)
208 (g-type= type +g-type-uint64+)
209 (g-type= type +g-type-uint64+)) "@code{integer}")
210 ((g-type= type +g-type-float+) "@code{single-float}")
211 ((g-type-is-a type +g-type-enum+) (enum-string type))
212 ((g-type-is-a type +g-type-flags+) (flags-string type))
213 ((g-type-is-a type +g-type-object+) (object-string type))
214 ((g-type-is-a type +g-type-boxed+) (boxed-string type))
217 (defun format-ref (s)
219 (format nil "@ref{~A}" s)
220 (format nil "@code{~A}" s)))
222 (defun flags-string (type)
223 (let ((flags (gobject::registered-flags-type (g-type-string type))))
226 (format nil "@code{~A}" (g-type-string type)))))
228 (defun enum-string (type)
229 (let ((enum (gobject::registered-enum-type (g-type-string type))))
232 (format nil "@code{~A}" (g-type-string type)))))
234 (defun object-string (type)
235 (let ((class (gobject::registered-object-type-by-name (g-type-string type))))
238 (format nil "@code{~A}" (g-type-string type)))))
240 (defun boxed-string (type)
241 (let ((boxed (ignore-errors (gobject::get-g-boxed-foreign-info-for-gtype (g-type-string type)))))
243 (format-ref (gobject::g-boxed-info-name boxed))
244 (format nil "@code{~A}" (g-type-string type)))))
246 (defmethod classify-slot-readability (class (slot gobject::gobject-property-direct-slot-definition))
247 (let* ((g-type (gobject::gobject-class-g-type-name class))
248 (property-name (gobject::gobject-property-direct-slot-definition-g-property-name slot))
249 (prop (class-property-info g-type property-name))
250 (readable (g-class-property-definition-readable prop))
251 (writable (g-class-property-definition-writable prop)))
253 ((and readable writable) :normal)
254 ((not readable) :write-only)
255 ((not writable) :read-only)
258 (defmethod classify-slot-readability (class (slot gobject::gobject-fn-direct-slot-definition))
259 (let ((readable (gobject::gobject-fn-direct-slot-definition-g-getter-name slot))
260 (writable (gobject::gobject-fn-direct-slot-definition-g-setter-name slot)))
262 ((and readable writable) :normal)
263 ((not readable) :write-only)
264 ((not writable) :read-only)
267 (defun slot-accessor (slot)
268 (let* ((readers (slot-definition-readers slot))
269 (writers (mapcar #'second (slot-definition-writers slot)))
270 (combined (union readers writers))
271 (accessor (first combined)))
273 (format nil "@anchor{~A}@code{~A}" accessor accessor)
274 (format nil "None"))))