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