glib/gobject.generating.lisp

   1 (in-package :gobject)
   2
   3 (defvar *lisp-name-package* (find-package :gobject))
   4 (defvar *strip-prefix* "")
   5 (defvar *lisp-name-exceptions* nil)
   6 (defvar *generation-exclusions* nil)
   7 (defvar *known-interfaces* (make-hash-table :test 'equal))
   8
   9 (defun name->supplied-p (name)
  10   (intern (format nil "~A-SUPPLIED-P" (symbol-name name))
  11           *lisp-name-package*))
  12
  13 (defun property->method-arg (property)
  14   (destructuring-bind (name accessor-name g-name type readable writable) property
  15     (declare (ignore accessor-name g-name type readable writable))
  16     `(,name nil ,(name->supplied-p name))))
  17
  18 (defun property->arg-push (property)
  19   (destructuring-bind (name accessor-name g-name type readable writable) property
  20     (declare (ignore accessor-name readable writable))
  21     `(when ,(name->supplied-p name)
  22        (push ,g-name arg-names)
  23        (push ,type arg-types)
  24        (push ,name arg-values))))
  25
  26 (defun accessor-name (class-name property-name)
  27   (intern (format nil "~A-~A" (symbol-name class-name)
  28                   (lispify-name property-name))
  29           *lisp-name-package*))
  30
  31 (defun property->reader (property)
  32   (let ((name (nth 1 property))
  33         (prop-name (nth 2 property))
  34         (prop-type (nth 3 property)))
  35     `(defun ,name (object)
  36        (g-object-call-get-property object ,prop-name ,prop-type))))
  37
  38 (defun property->writer (property)
  39   (let ((name (nth 1 property))
  40         (prop-name (nth 2 property))
  41         (prop-type (nth 3 property)))
  42     `(defun (setf ,name) (new-value object)
  43        (g-object-call-set-property object ,prop-name new-value ,prop-type)
  44        new-value)))
  45
  46 (defun property->accessors (property export)
  47   (append (when (nth 4 property)
  48             (list (property->reader property)))
  49           (when (nth 5 property)
  50             (list (property->writer property)))
  51           (when export
  52             (list `(export ',(nth 1 property)
  53                            (find-package ,(package-name (symbol-package (nth 1 property)))))))))
  54
  55 (defun interface->lisp-class-name (interface)
  56   (etypecase interface
  57     (symbol interface)
  58     (string (or (gethash interface *known-interfaces*)
  59                 (error "Unknown interface ~A" interface)))))
  60
  61 (defun type-initializer-call (type-initializer)
  62   (etypecase type-initializer
  63     (string `(foreign-funcall ,type-initializer g-type))
  64     (symbol `(funcall ',type-initializer))))
  65
  66 (defmacro define-g-object-class (g-type-name name
  67                                  (&key (superclass 'g-object)
  68                                        (export t)
  69                                        interfaces
  70                                        type-initializer)
  71                                  (&rest properties))
  72   (let* ((superclass-properties (get superclass 'properties))
  73          (combined-properties (append superclass-properties properties)))
  74     `(progn
  75        (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces)) ())
  76        (register-object-type ,g-type-name ',name)
  77        ,@(when type-initializer
  78                (list (type-initializer-call type-initializer)))
  79        ,@(when export
  80                (list `(export ',name (find-package ,(package-name (symbol-package name))))))
  81        (defmethod initialize-instance :before
  82            ((object ,name) &key pointer
  83             ,@(mapcar #'property->method-arg
  84                       combined-properties))
  85          (unless (or pointer (and (slot-boundp object 'pointer)
  86                                   (not (null-pointer-p (pointer object)))))
  87            (let (arg-names arg-values arg-types)
  88              ,@(mapcar #'property->arg-push combined-properties)
  89              (setf (pointer object)
  90                    (g-object-call-constructor ,g-type-name
  91                                               arg-names
  92                                               arg-values
  93                                               arg-types)
  94                    (g-object-has-reference object) t))))
  95        ,@(loop
  96             for property in properties
  97             append (property->accessors property export))
  98
  99        (eval-when (:compile-toplevel :load-toplevel :execute)
 100          (setf (get ',name 'superclass) ',superclass
 101                (get ',name 'properties) ',combined-properties)))))
 102
 103 (defmacro define-g-interface (g-name name (&key (export t) type-initializer) &body properties)
 104   `(progn
 105      (defclass ,name () ())
 106      ,@(when export
 107              (list `(export ',name (find-package ,(package-name (symbol-package name))))))
 108      ,@(when type-initializer
 109              (list (type-initializer-call type-initializer)))
 110      ,@(loop
 111           for property in properties
 112           append (property->accessors property export))
 113      (eval-when (:compile-toplevel :load-toplevel :execute)
 114        (setf (get ',name 'properties) ',properties)
 115        (setf (gethash ,g-name *known-interfaces*) ',name))))
 116
 117 (defun starts-with (name prefix)
 118   (and prefix (> (length name) (length prefix)) (string= (subseq name 0 (length prefix)) prefix)))
 119
 120 (defun strip-start (name prefix)
 121   (if (starts-with name prefix)
 122       (subseq name (length prefix))
 123       name))
 124
 125 (defun lispify-name (name)
 126   (with-output-to-string (stream)
 127     (loop for c across (strip-start name *strip-prefix*)
 128        for firstp = t then nil
 129        do (when (and (not firstp) (upper-case-p c)) (write-char #\- stream))
 130        do (write-char (char-upcase c) stream))))
 131
 132 (defun g-name->name (name)
 133   (or (second (assoc name *lisp-name-exceptions* :test 'equal))
 134       (intern (string-upcase (lispify-name name)) *lisp-name-package*)))
 135
 136 (defun property->property-definition (class-name property)
 137   (let ((name (g-name->name (g-class-property-definition-name property)))
 138         (accessor-name (accessor-name class-name (g-class-property-definition-name property)))
 139         (g-name (g-class-property-definition-name property))
 140         (type (g-type-name (g-class-property-definition-type property)))
 141         (readable (g-class-property-definition-readable property))
 142         (writable (and (g-class-property-definition-writable property)
 143                        (not (g-class-property-definition-constructor-only property)))))
 144     `(,name ,accessor-name ,g-name ,type ,readable ,writable)))
 145
 146 (defun probable-type-init-name (type-name)
 147   (with-output-to-string (stream)
 148     (iter (for c in-string type-name)
 149           (for prev-c previous c)
 150           (when (and (not (first-iteration-p))
 151                      (upper-case-p c)
 152                      (not (upper-case-p prev-c))
 153                      (not (char= prev-c #\_)))
 154             (write-char #\_ stream))
 155           (write-char (char-downcase c) stream))
 156     (write-string "_get_type" stream)))
 157
 158 (defun get-g-class-definition (type)
 159   (let* ((g-type (ensure-g-type type))
 160          (g-name (g-type-name g-type))
 161          (name (g-name->name g-name))
 162          (superclass-g-type (g-type-parent g-type))
 163          (superclass-name (g-name->name (g-type-name superclass-g-type)))
 164          (interfaces (g-type-interfaces g-type))
 165          (properties (class-properties g-type))
 166          (type-init-name (probable-type-init-name g-name))
 167          (own-properties
 168           (remove-if-not (lambda (property)
 169                            (= g-type
 170                               (g-class-property-definition-owner-type property)))
 171                          properties)))
 172     `(define-g-object-class ,g-name ,name
 173          (:superclass ,superclass-name
 174                       :export t
 175                       :interfaces (,@(mapcar #'g-type-name interfaces))
 176                       ,@(when (and (foreign-symbol-pointer type-init-name)
 177                                    (not (null-pointer-p (foreign-symbol-pointer type-init-name))))
 178                               `(:type-initializer ,type-init-name)))
 179        (,@(mapcar (lambda (property)
 180                     (property->property-definition name property))
 181                   own-properties))
 182        )))
 183
 184 (defun get-g-interface-definition (interface)
 185   (let* ((type (ensure-g-type interface))
 186          (g-name (g-type-name type))
 187          (name (g-name->name g-name))
 188          (properties (interface-properties type))
 189          (probable-type-initializer (probable-type-init-name g-name)))
 190     `(define-g-interface ,g-name ,name
 191          (:export t
 192                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 193                           `(:type-initializer ,probable-type-initializer)))
 194        ,@(mapcar (lambda (property)
 195                    (property->property-definition name property))
 196                  properties))))
 197
 198 (defun get-g-class-definitions-for-root-1 (type)
 199   (unless (member (ensure-g-type type) *generation-exclusions* :test '=)
 200     (cons (get-g-class-definition type)
 201           (reduce #'append
 202                   (mapcar #'get-g-class-definitions-for-root-1
 203                           (g-type-children type))))))
 204
 205 (defun get-g-class-definitions-for-root (type)
 206   (setf type (ensure-g-type type))
 207   (get-g-class-definitions-for-root-1 type))
 208
 209 (defvar *referenced-types*)
 210
 211 (defun class-or-interface-properties (type)
 212   (setf type (ensure-g-type type))
 213   (cond
 214     ((= (g-type-fundamental type) +g-type-object+) (class-properties type))
 215     ((= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
 216
 217 (defun get-shallow-referenced-types (type)
 218   (setf type (ensure-g-type type))
 219   (remove-duplicates (sort (loop
 220                               for property in (class-or-interface-properties type)
 221                               when (= type (g-class-property-definition-owner-type property))
 222                               collect (g-class-property-definition-type property))
 223                            #'<)
 224                      :test 'equal))
 225
 226 (defun get-referenced-types-1 (type)
 227   (setf type (ensure-g-type type))
 228   (loop
 229      for property-type in (get-shallow-referenced-types type)
 230      do (pushnew property-type *referenced-types* :test '=))
 231   (loop
 232      for type in (g-type-children type)
 233      do (get-referenced-types-1 type)))
 234
 235 (defun get-referenced-types (root-type)
 236   (let (*referenced-types*)
 237     (get-referenced-types-1 (ensure-g-type root-type))
 238     *referenced-types*))
 239
 240 (defun filter-types-by-prefix (types prefix)
 241   (remove-if-not
 242    (lambda (type)
 243      (starts-with (g-type-name (ensure-g-type type)) prefix))
 244    types))
 245
 246 (defun filter-types-by-fund-type (types fund-type)
 247   (setf fund-type (ensure-g-type fund-type))
 248   (remove-if-not
 249    (lambda (type)
 250      (equal (g-type-fundamental (ensure-g-type type)) fund-type))
 251    types))
 252
 253 (defmacro define-g-enum (g-name name (&key (export t) type-initializer)  &body values)
 254   `(progn
 255      (defcenum ,name ,@values)
 256      (register-enum-type ,g-name ',name)
 257      ,@(when export
 258              (list `(export ',name (find-package ,(package-name (symbol-package name))))))
 259      ,@(when type-initializer
 260              (list (type-initializer-call type-initializer)))))
 261
 262 (defun enum-value->definition (enum-value)
 263   (let ((value-name (intern (lispify-name (enum-item-nick enum-value))
 264                             (find-package :keyword)))
 265         (numeric-value (enum-item-value enum-value)))
 266     `(,value-name ,numeric-value)))
 267
 268 (defun get-g-enum-definition (type)
 269   (let* ((g-type (ensure-g-type type))
 270          (g-name (g-type-name g-type))
 271          (name (g-name->name g-name))
 272          (items (get-enum-items g-type))
 273          (probable-type-initializer (probable-type-init-name g-name)))
 274     `(define-g-enum ,g-name ,name
 275          (:export t
 276                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 277                           (list :type-initializer
 278                                 probable-type-initializer)))
 279        ,@(mapcar #'enum-value->definition items))))
 280
 281 (defmacro define-g-flags (g-name name (&key (export t) type-initializer) &body values)
 282   `(progn
 283      (defbitfield ,name ,@values)
 284      (register-enum-type ,g-name ',name)
 285      ,@(when export
 286              (list `(export ',name (find-package ,(package-name (symbol-package name))))))
 287      ,@(when type-initializer
 288              (list (type-initializer-call type-initializer)))))
 289
 290 (defun flags-value->definition (flags-value)
 291   (let ((value-name (intern (lispify-name (flags-item-nick flags-value))
 292                             (find-package :keyword)))
 293         (numeric-value (flags-item-value flags-value)))
 294     `(,value-name ,numeric-value)))
 295
 296 (defun get-g-flags-definition (type)
 297   (let* ((g-type (ensure-g-type type))
 298          (g-name (g-type-name g-type))
 299          (name (g-name->name g-name))
 300          (items (get-flags-items g-type))
 301          (probable-type-initializer (probable-type-init-name g-name)))
 302     `(define-g-flags ,g-name ,name
 303          (:export t
 304                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 305                           (list :type-initializer
 306                                 probable-type-initializer)))
 307        ,@(mapcar #'flags-value->definition items))))
 308
 309 (defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions)
 310   (if (not (streamp file))
 311       (with-open-file (stream file :direction :output :if-exists :supersede)
 312         (generate-types-hierarchy-to-file stream root-type
 313                                           :prefix prefix
 314                                           :package package
 315                                           :exceptions exceptions
 316                                           :prologue prologue
 317                                           :include-referenced include-referenced
 318                                           :interfaces interfaces
 319                                           :enums enums
 320                                           :flags flags
 321                                           :objects objects
 322                                           :exclusions exclusions))
 323       (let* ((*generation-exclusions* (mapcar #'ensure-g-type exclusions))
 324              (*lisp-name-package* (or package *package*))
 325              (*package* *lisp-name-package*)
 326              (*strip-prefix* (or prefix ""))
 327              (*lisp-name-exceptions* exceptions)
 328              (*print-case* :downcase)
 329              (referenced-types (and include-referenced
 330                                     (filter-types-by-prefix
 331                                      (get-referenced-types root-type)
 332                                      prefix))))
 333         (setf exclusions (mapcar #'ensure-g-type exclusions))
 334         (when prologue
 335           (write-string prologue file)
 336           (terpri file))
 337         (when include-referenced
 338           (loop
 339              for interface in interfaces
 340              do (loop
 341                    for referenced-type in (get-shallow-referenced-types interface)
 342                    do (pushnew referenced-type referenced-types :test 'equal)))
 343           (loop
 344              for object in objects
 345              do (loop
 346                    for referenced-type in (get-shallow-referenced-types object)
 347                    do (pushnew referenced-type referenced-types :test 'equal)))
 348           (loop
 349              for enum-type in (filter-types-by-fund-type
 350                                referenced-types "GEnum")
 351              for def = (get-g-enum-definition enum-type)
 352              unless (member (ensure-g-type enum-type) exclusions :test '=)
 353              do (format file "~S~%~%" def))
 354
 355           (loop
 356              for flags-type in (filter-types-by-fund-type
 357                                 referenced-types "GFlags")
 358              for def = (get-g-flags-definition flags-type)
 359              unless (member (ensure-g-type flags-type) exclusions :test '=)
 360              do (format file "~S~%~%" def)))
 361         (loop
 362            with auto-enums = (and include-referenced
 363                                   (filter-types-by-fund-type
 364                                    referenced-types "GEnum"))
 365            for enum in enums
 366            for def = (get-g-enum-definition enum)
 367            unless (find (ensure-g-type enum) auto-enums :test 'equal)
 368            do (format file "~S~%~%" def))
 369         (loop
 370            with auto-flags = (and include-referenced
 371                                   (filter-types-by-fund-type
 372                                    referenced-types "GFlags"))
 373            for flags-type in flags
 374            for def = (get-g-flags-definition flags-type)
 375            unless (find (ensure-g-type flags-type) auto-flags :test 'equal)
 376            do (format file "~S~%~%" def))
 377         (loop
 378            for interface in interfaces
 379            for def = (get-g-interface-definition interface)
 380            do (format file "~S~%~%" def))
 381         (loop
 382            for def in (get-g-class-definitions-for-root root-type)
 383            do (format file "~S~%~%" def))
 384         (loop
 385            for object in objects
 386            for def = (get-g-class-definition object)
 387            do (format file "~S~%~%" def)))))