doc/skeleton.lisp

   1 (defpackage :doc-skeleton
   2   (:use :cl :gtk :gdk :gobject :iter :c2mop :glib)
   3   (:export :widget-skeleton
   4            :chapter-skeleton
   5            :*gtk-widgets*
   6            :all-gtk-widgets))
   7
   8 (in-package :doc-skeleton)
   9
  10 (defun chapter-skeleton (output widgets &key use-refs (section "section"))
  11   (cond
  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 "~%~%")))))
  24
  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))
  45
  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)))
  50                 (collect symbol)))
  51         #'string<))
  52
  53 ;; (widget-skeleton widget &key (sectioning-command "section"))
  54 ;; returns the texinfo string for widget (a symbol or class)
  55 ;; Template:
  56 ;;
  57 ;; @node $WIDGET
  58 ;; @$SECTIONING-COMMAND $WIDGET
  59 ;;
  60 ;; @Class $WIDGET
  61 ;;
  62 ;; Superclass: $(direct-superclass WIDGET)
  63 ;;
  64 ;; Interfaces: $(direct-interface widget)
  65 ;;
  66 ;; Slots:
  67 ;; @itemize
  68 ;; $(for each slot)
  69 ;; @item @anchor{slot.$widget.$slot}$slot. Type: $(slot-type slot). Accessor: $(slot-accessor slot). $(when (constructor-only slot) "Contructor-only slot.")
  70 ;; $(end for)
  71 ;; @end itemize
  72 ;;
  73 ;; Signals:
  74 ;; @itemize
  75 ;; $(for each signal)
  76 ;; @item @anchor{signal.$widget.$signal}"$signal". Signature: Type1 Arg1, .., Typen Argn => return-type. Options: $(signal-options)
  77 ;; $(end for)
  78 ;; @end itemize
  79
  80 (defvar *use-refs* t)
  81
  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)))
  87           (*print-circle* nil)
  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))))
 102
 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)
 111                   (slot-type 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~%"))
 118
 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."
 127                     (class-name widget)
 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~%"))))
 134
 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)))
 140           (when props
 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))
 153                           accessor)
 154                   (format stream "~%"))
 155             (format stream "@end itemize~%")))))))
 156
 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))
 161           (for counter from 1)
 162           (format stream ", (arg-~A ~A)" counter (type-string type)))
 163     (format stream " @result{} ~A" (type-string (signal-info-return-type s)))))
 164
 165 (defun signal-options (s)
 166   (format nil "~{~A~^, ~}"(signal-info-flags s)))
 167
 168 (defun slot-type (slot)
 169   (let ((type (gobject::gobject-direct-slot-definition-g-property-type slot)))
 170     (type-string type)))
 171
 172 (defun type-string (type)
 173   (typecase type
 174     (string (type-string-s type))
 175     (t (type-string-f type))))
 176
 177 (defun ensure-list (x) (if (listp x) x (list x)))
 178
 179 (defun type-string-f (type)
 180   (let ((l (ensure-list type)))
 181     (case (first l)
 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))))
 187                     "@ref{g-object}"))
 188       (g-boxed-foreign (format-ref (string-downcase (symbol-name (second l)))))
 189       ((nil) "????")
 190       ((glist gslist) (format nil "list of ~A" (type-string-f (second l))))
 191       (t (if (symbolp type)
 192              (format-ref type)
 193              (format-ref l))))))
 194
 195 (defun type-string-s (type)
 196   (cond
 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))
 215     (t type)))
 216
 217 (defun format-ref (s)
 218   (if *use-refs*
 219       (format nil "@ref{~A}" s)
 220       (format nil "@code{~A}" s)))
 221
 222 (defun flags-string (type)
 223   (let ((flags (gobject::registered-flags-type (g-type-string type))))
 224     (if flags
 225         (format-ref flags)
 226         (format nil "@code{~A}" (g-type-string type)))))
 227
 228 (defun enum-string (type)
 229   (let ((enum (gobject::registered-enum-type (g-type-string type))))
 230     (if enum
 231         (format-ref enum)
 232         (format nil "@code{~A}" (g-type-string type)))))
 233
 234 (defun object-string (type)
 235   (let ((class (gobject::registered-object-type-by-name (g-type-string type))))
 236     (if class
 237         (format-ref class)
 238         (format nil "@code{~A}" (g-type-string type)))))
 239
 240 (defun boxed-string (type)
 241   (let ((boxed (ignore-errors (gobject::get-g-boxed-foreign-info-for-gtype (g-type-string type)))))
 242     (if boxed
 243         (format-ref (gobject::g-boxed-info-name boxed))
 244         (format nil "@code{~A}" (g-type-string type)))))
 245
 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)))
 252     (cond
 253       ((and readable writable) :normal)
 254       ((not readable) :write-only)
 255       ((not writable) :read-only)
 256       (t :bad))))
 257
 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)))
 261     (cond
 262       ((and readable writable) :normal)
 263       ((not readable) :write-only)
 264       ((not writable) :read-only)
 265       (t :bad))))
 266
 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)))
 272     (if accessor
 273         (format nil "@anchor{~A}@code{~A}" accessor accessor)
 274         (format nil "None"))))