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