Improved doc-skeleton generator
[cl-gtk2.git] / doc / skeleton.lisp
1 (defpackage :doc-skeleton
2   (:use :cl :gtk :gdk :gobject :iter :c2mop :glib)
3   (:export :widget-skeleton
4            :widgets-chapter-skeleton
5            :enum-skeleton
6            :flags-skeleton
7            :all-enums
8            :all-flags
9            :enum-chapter-skeleton
10            :flags-chapter-skeleton
11            :struct-skeleton
12            #:all-structs
13            #:struct-chapter-skeleton
14            #:interface-chapter-skeleton
15            #:all-interfaces
16            #:interface-skeleton
17            #:all-widgets
18            #:all-classes
19            #:all-gtk-skeletons))
20
21 (in-package :doc-skeleton)
22
23 (defun widgets-chapter-skeleton (output widgets &key (use-refs t) (section "section"))
24   (cond
25     ((or (pathnamep output)
26          (stringp output))
27      (with-open-file (stream output :direction :output :if-exists :supersede)
28        (widgets-chapter-skeleton stream widgets :use-refs use-refs :section section)))
29     ((null output) (with-output-to-string (stream)
30                      (widgets-chapter-skeleton stream widgets :use-refs use-refs :section section)))
31     ((or (eq t output) (streamp output))
32      (format output "@menu~%")
33      (iter (for w in widgets)
34            (format output "* ~A::~%" (string-downcase (symbol-name w))))
35      (format output "@end menu~%~%")
36      (iter (for w in widgets)
37            (write-string (widget-skeleton w :section section :use-refs use-refs) output)
38            (format output "~%~%")))))
39
40 (defparameter *exclusions* '(gdk:display gdk:screen))
41
42 (defparameter *ref-exclusions* '(gtk-demo::custom-window gtkglext:gl-drawing-area gtkglext:gdk-gl-window gtkglext:gdk-gl-pixmap))
43
44 (defun all-widgets (package)
45   (sort (iter (for symbol in-package (find-package package) :external-only t)
46               (unless (member symbol *exclusions*)
47                 (for class = (find-class symbol nil))
48                 (when (and class (subclassp class (find-class 'gtk:widget)))
49                   (collect symbol))))
50         #'string<))
51
52 (defun all-classes (package)
53   (sort (iter (for symbol in-package (find-package package) :external-only t)
54               (unless (member symbol *exclusions*)
55                 (for class = (find-class symbol nil))
56                 (when (and class
57                            (not (subclassp class (find-class 'condition)))
58                            (not (subclassp class (find-class 'gtk:widget)))
59                            (or (not (typep class 'gobject::gobject-class))
60                                (not (gobject::gobject-class-interface-p class)))
61                            (not (typep class 'structure-class)))
62                   (collect symbol))))
63         #'string<))
64
65 ;; (widget-skeleton widget &key (sectioning-command "section"))
66 ;; returns the texinfo string for widget (a symbol or class)
67 ;; Template:
68 ;; 
69 ;; @node $WIDGET
70 ;; @$SECTIONING-COMMAND $WIDGET
71 ;;
72 ;; @Class $WIDGET
73 ;; 
74 ;; Superclass: $(direct-superclass WIDGET)
75 ;;
76 ;; Interfaces: $(direct-interface widget)
77 ;;
78 ;; Slots:
79 ;; @itemize
80 ;; $(for each slot)
81 ;; @item @anchor{slot.$widget.$slot}$slot. Type: $(slot-type slot). Accessor: $(slot-accessor slot). $(when (constructor-only slot) "Contructor-only slot.")
82 ;; $(end for)
83 ;; @end itemize
84 ;;
85 ;; Signals:
86 ;; @itemize
87 ;; $(for each signal)
88 ;; @item @anchor{signal.$widget.$signal}"$signal". Signature: Type1 Arg1, .., Typen Argn => return-type. Options: $(signal-options)
89 ;; $(end for)
90 ;; @end itemize
91
92 (defvar *use-refs* t)
93
94 (defun widget-skeleton (widget &key (section "section") (use-refs t))
95   (unless (typep widget 'class) (setf widget (find-class widget)))
96   (with-output-to-string (stream)
97     (let ((*print-case* :downcase)
98           (*package* (symbol-package (class-name widget)))
99           (*print-circle* nil)
100           (*use-refs* use-refs))
101       (format stream "@node ~A~%" (class-name widget))
102       (format stream "@~A ~A~%" section (class-name widget))
103       (format stream "@Class ~A~%" (class-name widget))
104       (format stream "Superclass:")
105       (iter (for super in (class-direct-superclasses widget))
106             (format stream " ~A" (format-ref (class-name super))))
107       (when (class-direct-subclasses widget)
108         (format stream "~%~%")
109         (format stream "Subclasses:")
110         (iter (for sub in (class-direct-subclasses widget))
111               (unless (member (class-name sub) *ref-exclusions*)
112                 (format stream " ~A" (format-ref (class-name sub))))))
113       (format stream "~%~%")
114       (widget-slots stream widget)
115       (format stream "~%~%")
116       (widget-signals stream widget)
117       (format stream "~%~%")
118       (widget-child-properties stream widget))))
119
120 (defun widget-slots (stream widget)
121   (format stream "Slots:~%")
122   (format stream "@itemize~%")
123   (iter (for slot in (sort (copy-list (class-direct-slots widget)) #'string< :key #'slot-definition-name))
124         (when (typep slot 'gobject::gobject-direct-slot-definition)
125           (format stream "@item @anchor{slot.~A.~A}~A. Type: ~A. Accessor: ~A."
126                   (class-name widget) (slot-definition-name slot)
127                   (slot-definition-name slot)
128                   (slot-type slot)
129                   (slot-accessor slot))
130           (case (classify-slot-readability widget slot)
131             (:write-only (format stream " Write-only."))
132             (:read-only (format stream " Read-only.")))
133           (format stream "~%")))
134   (format stream "@end itemize~%"))
135
136 (defun widget-signals (stream widget)
137   (when (typep widget 'gobject::gobject-class)
138     (let ((g-type (gobject::gobject-class-direct-g-type-name widget)))
139       (when g-type
140         (format stream "Signals:~%")
141         (format stream "@itemize~%")
142         ;; @item @anchor{signal.$widget.$signal}"$signal". Signature: Type1 Arg1, .., Typen Argn => return-type. Options: $(signal-options)
143         (iter (for signal in (sort (copy-list (type-signals g-type)) #'string< :key #'signal-info-name))
144               (format stream "@item @anchor{signal.~A.~A}\"~A\". Signature: ~A. Options: ~A."
145                       (class-name widget)
146                       (signal-info-name signal)
147                       (signal-info-name signal)
148                       (signal-signature signal)
149                       (signal-options signal))
150               (format stream "~%"))
151         (format stream "@end itemize~%")))))
152
153 (defun widget-child-properties (stream widget)
154   (when (typep stream 'gobject::gobject-class)
155     (let ((g-type (gobject::gobject-class-g-type-name widget)))
156       (when (g-type-is-a g-type "GtkContainer")
157         (unless (string= g-type (gobject::gobject-class-g-type-name (first (class-direct-superclasses widget))))
158           (let ((props (gtk::container-class-child-properties g-type)))
159             (when props
160               (format stream "Child properties:~%")
161               (format stream "@itemize~%")
162               ;; @item @anchor{signal.$widget.$signal}"$signal". Signature: Type1 Arg1, .., Typen Argn => return-type. Options: $(signal-options)
163               (iter (for prop in (sort (copy-list props) #'string< :key #'g-class-property-definition-name))
164                     (for accessor = (format nil "~A-child-~A"
165                                             (string-downcase (symbol-name (class-name widget)))
166                                             (g-class-property-definition-name prop)))
167                     (format stream "@item @anchor{childprop.~A.~A}~A. Type: ~A. Accessor: ~A."
168                             (string-downcase (symbol-name (class-name widget)))
169                             (g-class-property-definition-name prop)
170                             (g-class-property-definition-name prop)
171                             (type-string (g-class-property-definition-type prop))
172                             accessor)
173                     (format stream "~%"))
174               (format stream "@end itemize~%"))))))))
175
176 (defun signal-signature (s)
177   (with-output-to-string (stream)
178     (format stream "(instance ~A)" (type-string (signal-info-owner-type s)))
179     (iter (for type in (signal-info-param-types s))
180           (for counter from 1)
181           (format stream ", (arg-~A ~A)" counter (type-string type)))
182     (format stream " @result{} ~A" (type-string (signal-info-return-type s)))))
183
184 (defun signal-options (s)
185   (format nil "~{~A~^, ~}"(signal-info-flags s)))
186
187 (defun slot-type (slot)
188   (let ((type (gobject::gobject-direct-slot-definition-g-property-type slot)))
189     (type-string type)))
190
191 (defun type-string (type)
192   (typecase type
193     (string (type-string-s type))
194     (t (type-string-f type))))
195
196 (defun ensure-list (x) (if (listp x) x (list x)))
197
198 (defun type-string-f (type)
199   (let ((l (ensure-list type)))
200     (case (first l)
201       ((:string glib:g-string) "@code{string}")
202       ((:int :uint :long :ulong :char :uchar :int64 :uint64) "@code{integer}")
203       ((:boolean :bool) "@code{boolean}")
204       (g-object (if (second l)
205                     (format-ref (second l))
206                     "@ref{g-object}"))
207       (g-boxed-foreign (format-ref (second l)))
208       ((nil) "????")
209       ((glist gslist) (format nil "list of ~A" (type-string-f (second l))))
210       (t (if (symbolp type)
211              (format-ref type)
212              (format-ref l))))))
213
214 (defun type-string-s (type)
215   (cond
216     ((g-type= type +g-type-string+) "@code{string}")
217     ((g-type= type +g-type-boolean+) "@code{boolean}")
218     ((g-type= type +g-type-float+) "@code{single-float}")
219     ((g-type= type +g-type-double+) "@code{double-float}")
220     ((or (g-type= type +g-type-int+)
221          (g-type= type +g-type-uint+)
222          (g-type= type +g-type-char+)
223          (g-type= type +g-type-uchar+)
224          (g-type= type +g-type-long+)
225          (g-type= type +g-type-ulong+)
226          (g-type= type +g-type-int64+)
227          (g-type= type +g-type-uint64+)
228          (g-type= type +g-type-uint64+)) "@code{integer}")
229     ((g-type= type +g-type-float+) "@code{single-float}")
230     ((g-type-is-a type +g-type-enum+) (enum-string type))
231     ((g-type-is-a type +g-type-flags+) (flags-string type))
232     ((g-type-is-a type +g-type-object+) (object-string type))
233     ((g-type-is-a type +g-type-boxed+) (boxed-string type))
234     (t type)))
235
236 (defun format-ref (s)
237   (if (and *use-refs* (if (symbolp s)
238                           (not (eq (symbol-package s) (find-package :cl)))
239                           t))
240       (format nil "@ref{~A}" s)
241       (format nil "@code{~A}" s)))
242
243 (defun flags-string (type)
244   (let ((flags (gobject::registered-flags-type (g-type-string type))))
245     (if flags
246         (format-ref flags)
247         (format nil "@code{~A}" (g-type-string type)))))
248
249 (defun enum-string (type)
250   (let ((enum (gobject::registered-enum-type (g-type-string type))))
251     (if enum
252         (format-ref enum)
253         (format nil "@code{~A}" (g-type-string type)))))
254
255 (defun object-string (type)
256   (let ((class (gobject::registered-object-type-by-name (g-type-string type))))
257     (if class
258         (format-ref class)
259         (format nil "@code{~A}" (g-type-string type)))))
260
261 (defun boxed-string (type)
262   (let ((boxed (ignore-errors (gobject::get-g-boxed-foreign-info-for-gtype (g-type-string type)))))
263     (if boxed
264         (format-ref (gobject::g-boxed-info-name boxed))
265         (format nil "@code{~A}" (g-type-string type)))))
266
267 (defmethod classify-slot-readability (class (slot gobject::gobject-property-direct-slot-definition))
268   (let* ((g-type (gobject::gobject-class-g-type-name class))
269          (property-name (gobject::gobject-property-direct-slot-definition-g-property-name slot))
270          (prop (if (g-type-is-a g-type +g-type-interface+)
271                    (find property-name (interface-properties g-type)
272                          :test #'string=
273                          :key #'g-class-property-definition-name)
274                    (class-property-info g-type property-name)))
275          (readable (g-class-property-definition-readable prop))
276          (writable (g-class-property-definition-writable prop)))
277     (cond
278       ((and readable writable) :normal)
279       ((not readable) :write-only)
280       ((not writable) :read-only)
281       (t :bad))))
282
283 (defmethod classify-slot-readability (class (slot gobject::gobject-fn-direct-slot-definition))
284   (let ((readable (gobject::gobject-fn-direct-slot-definition-g-getter-name slot))
285         (writable (gobject::gobject-fn-direct-slot-definition-g-setter-name slot)))
286     (cond
287       ((and readable writable) :normal)
288       ((not readable) :write-only)
289       ((not writable) :read-only)
290       (t :bad))))
291
292 (defun slot-accessor (slot)
293   (let* ((readers (slot-definition-readers slot))
294          (writers (mapcar #'second (slot-definition-writers slot)))
295          (combined (union readers writers))
296          (accessor (first combined)))
297     (if accessor
298         (format nil "@anchor{fn.~A}@code{~A}" accessor accessor)
299         (format nil "None"))))
300
301 ;; Enum skeleton
302 ;; (enum-skeleton enum &key (section "section"))
303 ;; @node $enum
304 ;; @section $enum
305 ;; Values:
306 ;; @itemize
307 ;; $(enum-values enum)
308 ;; @end itemize
309
310 (defun enum-skeleton (enum &key (section "section"))
311   (with-output-to-string (stream)
312     (format stream "@node ~A~%" (string-downcase enum))
313     (format stream "@~A ~A~%" section (string-downcase enum))
314     (format stream "@Enum ~A~%" (string-downcase enum))
315     (format stream "Values: ~%")
316     (format stream "@itemize~%")
317     (iter (for item in (sort (copy-list (cffi:foreign-enum-keyword-list enum)) #'string<))
318           (format stream "@item @anchor{enum.~A.~A}:~A~%"
319                   (string-downcase enum)
320                   (string-downcase (symbol-name item))
321                   (string-downcase (symbol-name item))))
322     (format stream "@end itemize~%")))
323
324 (defun flags-skeleton (flags &key (section "section"))
325   (with-output-to-string (stream)
326     (format stream "@node ~A~%" (string-downcase flags))
327     (format stream "@~A ~A~%" section (string-downcase flags))
328     (format stream "@Flags ~A~%" (string-downcase flags))
329     (format stream "Values: ~%")
330     (format stream "@itemize~%")
331     (iter (for item in (sort (copy-list (cffi:foreign-bitfield-symbol-list flags)) #'string<))
332           (format stream "@item @anchor{flags.~A.~A}:~A~%"
333                   (string-downcase flags)
334                   (string-downcase (symbol-name item))
335                   (string-downcase (symbol-name item))))
336     (format stream "@end itemize~%")))
337
338 (defun all-enums (package)
339   (sort (iter (for symbol in-package package :external-only t)
340               (unless (member symbol *exclusions*)
341                 (when (ignore-errors (cffi:foreign-enum-keyword-list symbol))
342                   (collect symbol))))
343         #'string<))
344
345 (defun all-flags (package)
346   (sort (iter (for symbol in-package package :external-only t)
347               (unless (member symbol *exclusions*)
348                 (when (ignore-errors (cffi:foreign-bitfield-symbol-list symbol))
349                   (collect symbol))))
350         #'string<))
351
352 (defun enum-chapter-skeleton (output enums &key (section "section"))
353   (cond
354     ((or (pathnamep output) (stringp output))
355      (with-open-file (stream output :direction :output :if-exists :supersede)
356        (enum-chapter-skeleton stream enums :section section)))
357     ((null output) (with-output-to-string (stream)
358                      (enum-chapter-skeleton stream enums :section section)))
359     ((or (eq t output) (streamp output))
360      (format output "@menu~%")
361      (iter (for e in enums)
362            (format output "* ~A::~%" (string-downcase (symbol-name e))))
363      (format output "@end menu~%~%")
364      (iter (for e in enums)
365            (write-string (enum-skeleton e :section section) output)
366            (format output "~%~%")))))
367
368 (defun flags-chapter-skeleton (output flagss &key (section "section"))
369   (cond
370     ((or (pathnamep output) (stringp output))
371      (with-open-file (stream output :direction :output :if-exists :supersede)
372        (flags-chapter-skeleton stream flagss :section section)))
373     ((null output) (with-output-to-string (stream)
374                      (flags-chapter-skeleton stream flagss :section section)))
375     ((or (eq t output) (streamp output))
376      (format output "@menu~%")
377      (iter (for e in flagss)
378            (format output "* ~A::~%" (string-downcase (symbol-name e))))
379      (format output "@end menu~%~%")
380      (iter (for e in flagss)
381            (write-string (flags-skeleton e :section section) output)
382            (format output "~%~%")))))
383
384 ;; Struct skeleton
385 ;; (struct-skeleton struct &key (section "section") (use-refs t))
386 ;; @node $struct
387 ;; @$section $struct
388 ;; @Struct @struct
389 ;; Slots:
390 ;; @itemize
391 ;; $(for each slot
392 ;; @item $slot
393 ;; )
394 ;; @end itemize
395
396 (defun struct-skeleton (struct &key (section "section") (use-refs t))
397   (unless (typep struct 'class) (setf struct (find-class struct)))
398   (with-output-to-string (stream)
399     (let ((*print-case* :downcase)
400           (*package* (symbol-package (class-name struct)))
401           (*print-circle* nil)
402           (*use-refs* use-refs))
403       (format stream "@node ~A~%" (class-name struct))
404       (format stream "@~A ~A~%" section (class-name struct))
405       (format stream "@Struct ~A~%" (class-name struct))
406       (format stream "Superclass:")
407       (iter (for super in (class-direct-superclasses struct))
408             (format stream " ~A" (format-ref (class-name super))))
409       (when (class-direct-subclasses struct)
410         (format stream "~%~%")
411         (format stream "Subclasses:")
412         (iter (for sub in (class-direct-subclasses struct))
413               (unless (member (class-name sub) *ref-exclusions*)
414                 (format stream " ~A" (format-ref (class-name sub))))))
415       (format stream "~%~%")
416       (struct-slots stream struct))))
417
418 (defun struct-slots (stream struct)
419   (format stream "Slots:~%")
420   (format stream "@itemize~%")
421   (iter (for slot in (sort (copy-list (class-direct-slots struct)) #'string< :key #'slot-definition-name))
422         (format stream "@item @anchor{slot.~A.~A}~A. Accessor: ~A."
423                 (class-name struct) (string-downcase (slot-definition-name slot))
424                 (string-downcase (slot-definition-name slot))
425                 (format nil "~A-~A" (class-name struct) (slot-definition-name slot)))
426         (format stream "~%"))
427   (format stream "@end itemize~%"))
428
429 (defun all-structs (package)
430   (sort (iter (for symbol in-package package :external-only t)
431               (unless (member symbol *exclusions*)
432                 (for class = (find-class symbol nil))
433                 (when (and class (typep class (find-class 'structure-class)))
434                   (collect symbol))))
435         #'string<))
436
437 (defun struct-chapter-skeleton (output structs &key (section "section") (use-refs t))
438   (cond
439     ((or (stringp output) (pathnamep output))
440      (with-open-file (stream output :direction :output :if-exists :supersede)
441        (struct-chapter-skeleton stream structs :section section :use-refs use-refs)))
442     ((null output) (with-output-to-string (stream)
443                      (struct-chapter-skeleton stream structs :section section :use-refs use-refs)))
444     ((or (eq t output) (streamp output))
445      (format output "@menu~%")
446      (iter (for e in structs)
447            (format output "* ~A::~%" (string-downcase (symbol-name e))))
448      (format output "@end menu~%~%")
449      (iter (for e in structs)
450            (write-string (struct-skeleton e :section section :use-refs use-refs) output)
451            (format output "~%~%")))))
452
453 (defun interface-chapter-skeleton (output interfaces &key (use-refs t) (section "section"))
454   (cond
455     ((or (stringp output) (pathnamep output))
456      (with-open-file (stream output :direction :output :if-exists :supersede)
457        (interface-chapter-skeleton stream interfaces :use-refs use-refs :section section)))
458     ((null output) (with-output-to-string (stream)
459                      (interface-chapter-skeleton stream interfaces :use-refs use-refs :section section)))
460     ((or (eq t output) (streamp output))
461      (format output "@menu~%")
462      (iter (for w in interfaces)
463            (format output "* ~A::~%" (string-downcase (symbol-name w))))
464      (format output "@end menu~%~%")
465      (iter (for w in interfaces)
466            (write-string (interface-skeleton w :section section :use-refs use-refs) output)
467            (format output "~%~%")))))
468
469 (defun all-interfaces (package)
470   (sort (iter (for symbol in-package package :external-only t)
471               (unless (member symbol *exclusions*)
472                 (for class = (find-class symbol nil))
473                 (when (and class
474                            (typep class 'gobject:gobject-class)
475                            (gobject::gobject-class-interface-p class))
476                   (collect symbol))))
477         #'string<))
478
479 ;; (interface-skeleton interface &key (sectioning-command "section"))
480 ;; returns the texinfo string for interface (a symbol or class)
481 ;; Template:
482 ;; 
483 ;; @node $INTERFACE
484 ;; @$SECTIONING-COMMAND $INTERFACE
485 ;;
486 ;; @Class $INTERFACE
487 ;; 
488 ;; Interfaces: $(direct-interface interface)
489 ;;
490 ;; Slots:
491 ;; @itemize
492 ;; $(for each slot)
493 ;; @item @anchor{slot.$interface.$slot}$slot. Type: $(slot-type slot). Accessor: $(slot-accessor slot). $(when (constructor-only slot) "Contructor-only slot.")
494 ;; $(end for)
495 ;; @end itemize
496 ;;
497 ;; Signals:
498 ;; @itemize
499 ;; $(for each signal)
500 ;; @item @anchor{signal.$interface.$signal}"$signal". Signature: Type1 Arg1, .., Typen Argn => return-type. Options: $(signal-options)
501 ;; $(end for)
502 ;; @end itemize
503
504 (defun interface-skeleton (interface &key (section "section") (use-refs t))
505   (unless (typep interface 'class) (setf interface (find-class interface)))
506   (with-output-to-string (stream)
507     (let ((*print-case* :downcase)
508           (*package* (symbol-package (class-name interface)))
509           (*print-circle* nil)
510           (*use-refs* use-refs))
511       (format stream "@node ~A~%" (class-name interface))
512       (format stream "@~A ~A~%" section (class-name interface))
513       (format stream "@Class ~A~%" (class-name interface))
514       (when (class-direct-subclasses interface)
515         (format stream "~%~%")
516         (format stream "Subclasses:")
517         (iter (for sub in (class-direct-subclasses interface))
518               (unless (member (class-name sub) *ref-exclusions*)
519                 (format stream " ~A" (format-ref (class-name sub))))))
520       (format stream "~%~%")
521       (widget-slots stream interface)
522       (format stream "~%~%")
523       (widget-signals stream interface))))
524
525 (defun all-gtk-skeletons (dir)
526   (widgets-chapter-skeleton (merge-pathnames "gdk.objects.texi" dir) (all-classes :gdk))
527   (widgets-chapter-skeleton (merge-pathnames "gtk.objects.texi" dir) (all-classes :gtk))
528   (struct-chapter-skeleton (merge-pathnames "gtk.structs.texi" dir) (all-structs :gtk))
529   (struct-chapter-skeleton (merge-pathnames "gdk.structs.texi" dir) (all-structs :gdk))
530   (widgets-chapter-skeleton (merge-pathnames "gtk.widgets.texi" dir) (all-widgets :gtk))
531   (interface-chapter-skeleton (merge-pathnames "gtk.interfaces.texi" dir) (all-interfaces :gtk))
532   (enum-chapter-skeleton (merge-pathnames "gtk.enums.texi" dir) (all-enums :gtk))
533   (enum-chapter-skeleton (merge-pathnames "gdk.enums.texi" dir) (all-enums :gdk))
534   (flags-chapter-skeleton (merge-pathnames "gtk.flags.texi" dir) (all-flags :gtk))
535   (flags-chapter-skeleton (merge-pathnames "gdk.flags.texi" dir) (all-flags :gdk)))