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