doc/introspection.lisp

   1 (defpackage :gtk-doc-introspection
   2   #+(or clozure-common-lisp openmcl) (:shadowing-import-from :closer-mop #:defgeneric #:ensure-generic-function #:standard-generic-function)
   3   (:use :cl :gtk :gobject :gdk :iter :closer-mop)
   4   (:export #:get-gobject-classes
   5            #:generate-doc-for-class
   6            #:generate-texinfo-for-class
   7            #:generate-texinfo-for-package
   8            #:get-enums
   9            #:generate-texinfo-for-enum
  10            #:generate-texinfo-for-packages
  11            #:get-flags
  12            #:get-structs
  13            #:get-opaque-boxeds))
  14
  15 (in-package :gtk-doc-introspection)
  16
  17 (defun get-gobject-classes (package)
  18   (when (symbolp package) (setf package (find-package package)))
  19   (unless package (error "Package is NIL"))
  20   (iter (for symbol in-package package :external-only t)
  21         (for class = (find-class symbol nil))
  22         (when (and class (subtypep class 'gobject:g-object))
  23           (collect class))))
  24
  25 (defun get-enums (package)
  26   (when (symbolp package) (setf package (find-package package)))
  27   (iter (for (g-type-name type) in-hashtable gobject::*registered-enum-types*)
  28         (when (eq (symbol-package type) package)
  29           (collect type))))
  30
  31 (defun get-flags (package)
  32   (when (symbolp package) (setf package (find-package package)))
  33   (iter (for (g-type-name type) in-hashtable gobject::*registered-flags-types*)
  34         (when (eq (symbol-package type) package)
  35           (collect type))))
  36
  37 (defun get-structs (package)
  38   (when (symbolp package) (setf package (find-package package)))
  39   (iter (for symbol in-package package :external-only t)
  40         (for class = (find-class symbol nil))
  41         (when (and class (typep class 'structure-class))
  42           (collect class))))
  43
  44 (defun get-opaque-boxeds (package)
  45   (when (symbolp package) (setf package (find-package package)))
  46   (iter (for symbol in-package package :external-only t)
  47         (for class = (find-class symbol nil))
  48         (when (and class (subtypep class 'g-boxed-opaque))
  49           (collect class))))
  50
  51 (defvar *doc-packages* nil)
  52
  53 (defun generate-texinfo-for-packages (directory packages)
  54   (setf packages (mapcar (lambda (x)
  55                            (if (symbolp x)
  56                                (find-package x)
  57                                x))
  58                          packages))
  59   (ensure-directories-exist directory)
  60   (let ((*doc-packages* packages))
  61     (iter (for package in packages)
  62           (for file-name = (format nil "~A.ref.texi" (string-downcase (package-name package))))
  63           (for file-path = (merge-pathnames file-name directory))
  64           (generate-texinfo-for-package file-path package))))
  65
  66 (defun generate-texinfo-for-package (file package)
  67   (when (symbolp package) (setf package (find-package package)))
  68   (with-open-file (stream file :direction :output :if-exists :supersede)
  69     (let ((classes (sort (copy-list (get-gobject-classes package)) #'string< :key #'class-name))
  70           (enums (sort (copy-list (get-enums package)) #'string<))
  71           (flags (sort (copy-list (get-flags package)) #'string<))
  72           (structs (sort (copy-list (get-structs package)) #'string< :key #'class-name))
  73           (opaque-boxeds (sort (copy-list (get-opaque-boxeds package)) #'string< :key #'class-name)))
  74       (format stream "@menu~%")
  75       (format stream "* ~A Classes::~%" (string-downcase (package-name package)))
  76       (format stream "* ~A Structs::~%" (string-downcase (package-name package)))
  77       (format stream "* ~A Opaque Boxeds::~%" (string-downcase (package-name package)))
  78       (format stream "* ~A Enums::~%" (string-downcase (package-name package)))
  79       (format stream "* ~A Flags::~%" (string-downcase (package-name package)))
  80       (format stream "@end menu~%~%")
  81
  82       (format stream "@node ~A Classes~%" (string-downcase (package-name package)))
  83       (format stream "@section ~A Classes~%~%" (string-downcase (package-name package)))
  84       (format stream "@menu~%")
  85       (iter (for class in classes)
  86             (format stream "* ~A::~%" (string-downcase (symbol-name (class-name class)))))
  87       (format stream "@end menu~%~%")
  88       (format stream "Reference of classes in package ~A~%~%" (package-name package))
  89       (iter (for class in classes)
  90             (generate-texinfo-for-class class stream)
  91             (format stream "~%"))
  92
  93       (format stream "@node ~A Structs~%" (string-downcase (package-name package)))
  94       (format stream "@section ~A Structs~%~%" (string-downcase (package-name package)))
  95       (format stream "@menu~%")
  96       (iter (for struct in structs)
  97             (format stream "* ~A::~%" (string-downcase (symbol-name (class-name struct)))))
  98       (format stream "@end menu~%~%")
  99       (format stream "Reference of structs in package ~A~%~%" (package-name package))
 100       (iter (for struct in structs)
 101             (generate-texinfo-for-struct struct stream)
 102             (format stream "~%"))
 103
 104       (format stream "@node ~A Opaque Boxeds~%" (string-downcase (package-name package)))
 105       (format stream "@section ~A Opaque Boxeds~%~%" (string-downcase (package-name package)))
 106       (format stream "@menu~%")
 107       (iter (for boxed in opaque-boxeds)
 108             (format stream "* ~A::~%" (string-downcase (symbol-name (class-name boxed)))))
 109       (format stream "@end menu~%~%")
 110       (format stream "Reference of opaque boxeds in package ~A~%~%" (package-name package))
 111       (iter (for boxed in opaque-boxeds)
 112             (generate-texinfo-for-opaque-boxed boxed stream)
 113             (format stream "~%"))
 114
 115       (format stream "@node ~A Enums~%" (string-downcase (package-name package)))
 116       (format stream "@section ~A Enums~%~%" (string-downcase (package-name package)))
 117       (format stream "@menu~%")
 118       (iter (for enum in enums)
 119             (format stream "* ~A::~%" (string-downcase (symbol-name enum))))
 120       (format stream "@end menu~%~%")
 121       (format stream "Reference of enums in package ~A~%~%" (package-name package))
 122       (iter (for enum in enums)
 123             (generate-texinfo-for-enum enum stream)
 124             (format stream "~%"))
 125
 126       (format stream "@node ~A Flags~%" (string-downcase (package-name package)))
 127       (format stream "@section ~A Flags~%~%" (string-downcase (package-name package)))
 128       (format stream "@menu~%")
 129       (iter (for flags-type in flags)
 130             (format stream "* ~A::~%" (string-downcase (symbol-name flags-type))))
 131       (format stream "@end menu~%~%")
 132       (format stream "Reference of flags in package ~A~%~%" (package-name package))
 133       (iter (for flags-type in flags)
 134             (generate-texinfo-for-flags flags-type stream)
 135             (format stream "~%"))
 136
 137       )))
 138
 139 (defun get-class-signals (class)
 140   (when (typep class 'gobject-class)
 141     (let* ((g-type-name (gobject::gobject-class-g-type-name class))
 142            (signals (type-signals g-type-name :include-inherited nil)))
 143       signals)))
 144
 145 (defun generate-doc-for-signal (signal)
 146   signal)
 147
 148 (defgeneric texi-ref (object))
 149
 150 (defmethod texi-ref ((class class))
 151   (symbol-texi-ref (class-name class)))
 152
 153 (defun symbol-texi-ref (symbol)
 154   (if (member (symbol-package symbol) *doc-packages*)
 155       (format nil "@ref{~A}" (string-downcase (symbol-name symbol)))
 156       (symbol-texi symbol)))
 157
 158 (defun symbol-texi (symbol)
 159   (format nil "@code{~A}" (string-downcase (symbol-name symbol))))
 160
 161 (defun g-type-texi (type)
 162   (cond
 163     ((g-type= "gchararray" type) "@code{string}")
 164     ((g-type= "GStrv" type) "@code{(list string)}")
 165     ((or (g-type= +g-type-int+ type)
 166          (g-type= +g-type-int64+ type)
 167          (g-type= +g-type-long+ type)) "@code{integer}")
 168     ((or (g-type= +g-type-uint+ type)
 169          (g-type= +g-type-uint64+ type)
 170          (g-type= +g-type-ulong+ type)) "@code{(integer 0)}")
 171     ((g-type= +g-type-float+ type) "@code{single-float}")
 172     ((g-type= +g-type-double+ type) "@code{double-float}")
 173     ((g-type= +g-type-void+ type) "@code{null}")
 174     ((g-type= +g-type-param+ type) "@code{class-property-info}")
 175     ((g-type= +g-type-string+ type) "@code{string}")
 176     ((g-type= +g-type-boolean+ type) "@code{boolean}")
 177     ((g-type= +g-type-pointer+ type) "@code{foreign-pointer}")
 178     ((and (g-type= (g-type-fundamental type) "GBoxed")
 179           (gethash (g-type-string type) gobject::*g-type-name->g-boxed-foreign-info*))
 180      (symbol-texi-ref (gobject::g-boxed-info-name (gethash (g-type-string type)
 181                                                            gobject::*g-type-name->g-boxed-foreign-info*))))
 182     ((and (g-type= (g-type-fundamental type) "GEnum")
 183           (gethash (g-type-string type) gobject::*registered-enum-types*))
 184      (symbol-texi-ref (gethash (g-type-string type) gobject::*registered-enum-types*)))
 185     ((and (g-type= (g-type-fundamental type) "GFlags")
 186           (gethash (g-type-string type) gobject::*registered-flags-types*))
 187      (symbol-texi-ref (gethash (g-type-string type) gobject::*registered-flags-types*)))
 188     ((and (or (g-type= (g-type-fundamental type) "GObject")
 189               (g-type= (g-type-fundamental type) "GInterface"))
 190           (gethash (g-type-string type) gobject::*registered-object-types*))
 191      (symbol-texi-ref (gethash (g-type-string type) gobject::*registered-object-types*)))
 192     (t (g-type-string type))))
 193
 194 (defun generate-texinfo-for-class (class stream)
 195   (when (symbolp class) (setf class (find-class class)))
 196   (format stream "@node ~A~%" (string-downcase (symbol-name (class-name class))))
 197   (format stream "@subsection ~A~%"(string-downcase (symbol-name (class-name class))))
 198   (format stream "@Class ~A~%~%" (string-downcase (symbol-name (class-name class))))
 199   (format stream "Superclasses: ~{~A~^, ~}~%~%" (mapcar #'texi-ref (class-direct-superclasses class)))
 200   (format stream "Slots:~%")
 201   (let ((slots (sort (copy-list (class-direct-slots class)) #'string< :key #'slot-definition-name)))
 202     (if (null slots)
 203         (format stream "None~%~%")
 204         (progn
 205           (format stream "@itemize~%")
 206           (iter (for slot in slots)
 207                 (generate-texinfo-for-slot class slot stream))
 208           (format stream "@end itemize~%"))))
 209   (format stream "Signals:~%")
 210   (let ((signals (sort (copy-list (get-class-signals class)) #'string< :key #'signal-info-name)))
 211     (if (null signals)
 212         (format stream "None~%~%")
 213         (progn
 214           (format stream "@itemize~%")
 215           (iter (for signal in signals)
 216                 (generate-texinfo-for-signal class signal stream))
 217           (format stream "@end itemize~%")))))
 218
 219 (defun generate-texinfo-for-struct (class stream)
 220   (when (symbolp class) (setf class (find-class class)))
 221   (format stream "@node ~A~%" (string-downcase (symbol-name (class-name class))))
 222   (format stream "@subsection ~A~%"(string-downcase (symbol-name (class-name class))))
 223   (format stream "@Class ~A~%~%" (string-downcase (symbol-name (class-name class))))
 224   (format stream "Superclasses: ~{~A~^, ~}~%~%" (mapcar #'texi-ref (class-direct-superclasses class)))
 225   (format stream "Subclasses: ")
 226   (if (class-direct-subclasses class)
 227       (format stream "~{~A~^, ~}~%~%" (mapcar #'texi-ref (class-direct-subclasses class)))
 228       (format stream "None~%~%"))
 229   (format stream "Slots:~%")
 230   (let ((slots (sort (copy-list (class-direct-slots class)) #'string< :key #'slot-definition-name)))
 231     (if (null slots)
 232         (format stream "None~%~%")
 233         (progn
 234           (format stream "@itemize~%")
 235           (iter (for slot in slots)
 236                 (generate-texinfo-for-slot class slot stream))
 237           (format stream "@end itemize~%")))))
 238
 239 (defun generate-texinfo-for-opaque-boxed (class stream)
 240   (when (symbolp class) (setf class (find-class class)))
 241   (format stream "@node ~A~%" (string-downcase (symbol-name (class-name class))))
 242   (format stream "@subsection ~A~%"(string-downcase (symbol-name (class-name class))))
 243   (format stream "@Class ~A~%~%" (string-downcase (symbol-name (class-name class))))
 244   (format stream "Superclasses: ~{~A~^, ~}~%~%" (mapcar #'texi-ref (class-direct-superclasses class)))
 245   (format stream "Slots:~%")
 246   (let ((slots (sort (copy-list (class-direct-slots class)) #'string< :key #'slot-definition-name)))
 247     (if (null slots)
 248         (format stream "None~%~%")
 249         (progn
 250           (format stream "@itemize~%")
 251           (iter (for slot in slots)
 252                 (generate-texinfo-for-slot class slot stream))
 253           (format stream "@end itemize~%")))))
 254
 255 (defun generate-texinfo-for-slot (class slot stream)
 256   (format stream "@item ~A" (string-downcase (slot-definition-name slot)))
 257   (ignore-errors
 258     (when (typep slot 'gobject::gobject-property-direct-slot-definition)
 259       (let* ((class-g-type (gobject::gobject-class-g-type-name class))
 260              (property-name (gobject::gobject-property-direct-slot-definition-g-property-name slot))
 261              (property (if (g-type= (g-type-fundamental class-g-type) "GInterface")
 262                            (find property-name (interface-properties class-g-type)
 263                                  :key #'g-class-property-definition-name
 264                                  :test #'string=)
 265                            (class-property-info class-g-type property-name))))
 266         (format stream ". Type: ~A (flags:~@[~* readable~]~@[~* writable~]~@[~* constructor~]~@[~* constructor-only~])~%~%"
 267                 (g-type-texi (g-class-property-definition-type property))
 268                 (g-class-property-definition-readable property)
 269                 (g-class-property-definition-writable property)
 270                 (g-class-property-definition-constructor property)
 271                 (g-class-property-definition-constructor-only property)))))
 272   (format stream "~%~%"))
 273
 274 (defun generate-texinfo-for-signal (class signal stream)
 275   (declare (ignore class))
 276   (format stream "@item ~A. (~{~A~^, ~}) -> ~A ~@[ [~{~A~^, ~}]~]~%~%"
 277           (signal-info-name signal)
 278           (mapcar #'g-type-texi (signal-info-param-types signal))
 279           (g-type-texi (signal-info-return-type signal))
 280           (mapcar (lambda (x) (string-downcase (symbol-name x)))
 281                   (signal-info-flags signal))))
 282
 283 (defun generate-texinfo-for-enum (enum stream)
 284   (format stream "@node ~A~%" (string-downcase enum))
 285   (format stream "@subsection ~A~%" (string-downcase enum))
 286   (format stream "@Enum ~A~%" (string-downcase enum))
 287   (format stream "Values:~%")
 288   (format stream "@itemize~%")
 289   (iter (for v in (cffi::foreign-enum-keyword-list enum))
 290         (format stream "@item ~A~%" (string-downcase (format nil "~S" v))))
 291   (format stream "@end itemize~%~%"))
 292
 293 (defun generate-texinfo-for-flags (flags stream)
 294   (format stream "@node ~A~%" (string-downcase flags))
 295   (format stream "@subsection ~A~%" (string-downcase flags))
 296   (format stream "@Flags ~A~%" (string-downcase flags))
 297   (format stream "Values:~%")
 298   (format stream "@itemize~%")
 299   (iter (for v in (cffi::foreign-bitfield-symbol-list flags))
 300         (format stream "@item ~A~%" (string-downcase (format nil "~S" v))))
 301   (format stream "@end itemize~%~%"))