glib/gobject.generating.lisp

   1 (in-package :gobject)
   2
   3 (defvar *lisp-name-package* nil
   4   "For internal use (used by class definitions generator). Specifies the package in which symbols are interned.")
   5 (defvar *strip-prefix* "")
   6 (defvar *lisp-name-exceptions* nil)
   7 (defvar *generation-exclusions* nil)
   8 (defvar *known-interfaces* (make-hash-table :test 'equal))
   9 (defvar *additional-properties* nil)
  10
  11 (defun name->supplied-p (name)
  12   (make-symbol (format nil "~A-SUPPLIED-P" (symbol-name name))))
  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 `(if (foreign-symbol-pointer ,type-initializer)
 140                  (foreign-funcall ,type-initializer g-type)
 141                  (warn "Type initializer '~A' is not available" ,type-initializer)))
 142     (symbol `(funcall ',type-initializer))))
 143
 144 (defun meta-property->slot (class-name property)
 145   `(,(property-name property)
 146      :allocation ,(if (gobject-property-p property) :gobject-property :gobject-fn)
 147      :g-property-type ,(if (gobject-property-p property) (gobject-property-type property) (cffi-property-type property))
 148      :accessor ,(intern (format nil "~A-~A" (symbol-name class-name) (property-name property)) (symbol-package class-name))
 149      :initarg ,(intern (string-upcase (property-name property)) (find-package :keyword))
 150      ,@(if (gobject-property-p property)
 151            `(:g-property-name ,(gobject-property-gname property))
 152            `(:g-getter ,(cffi-property-reader property)
 153                                 :g-setter ,(cffi-property-writer property)))))
 154
 155 (defmacro define-g-object-class (g-type-name name
 156                                  (&key (superclass 'g-object)
 157                                        (export t)
 158                                        interfaces
 159                                        type-initializer)
 160                                  (&rest properties))
 161   (setf properties (mapcar #'parse-property properties))
 162   `(progn
 163      (defclass ,name (,superclass ,@(mapcar #'interface->lisp-class-name interfaces))
 164        (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
 165        (:metaclass gobject-class)
 166        (:g-type-name . ,g-type-name)
 167        ,@(when type-initializer
 168                (list `(:g-type-initializer . ,type-initializer))))
 169      ,@(when export
 170              (cons `(export ',name (find-package ,(package-name (symbol-package name))))
 171                    (mapcar (lambda (property)
 172                              `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
 173                                       (find-package ,(package-name (symbol-package name)))))
 174                            properties)))))
 175
 176 (defmacro define-g-interface (g-type-name name (&key (export t) type-initializer) &body properties)
 177   (setf properties (mapcar #'parse-property properties))
 178   `(progn
 179      (defclass ,name ()
 180        (,@(mapcar (lambda (property) (meta-property->slot name property)) properties))
 181        (:metaclass gobject-class)
 182        (:g-type-name . ,g-type-name)
 183        (:g-interface-p . t)
 184        ,@(when type-initializer
 185                (list `(:g-type-initializer . ,type-initializer))))
 186      ,@(when export
 187              (cons `(export ',name (find-package ,(package-name (symbol-package name))))
 188                    (mapcar (lambda (property)
 189                              `(export ',(intern (format nil "~A-~A" (symbol-name name) (property-name property)) (symbol-package name))
 190                                       (find-package ,(package-name (symbol-package name)))))
 191                            properties)))
 192      (eval-when (:compile-toplevel :load-toplevel :execute)
 193        (setf (gethash ,g-type-name *known-interfaces*) ',name))))
 194
 195 (defun starts-with (name prefix)
 196   (and prefix (> (length name) (length prefix)) (string= (subseq name 0 (length prefix)) prefix)))
 197
 198 (defun strip-start (name prefix)
 199   (if (starts-with name prefix)
 200       (subseq name (length prefix))
 201       name))
 202
 203 (defun lispify-name (name)
 204   (with-output-to-string (stream)
 205     (loop for c across (strip-start name *strip-prefix*)
 206        for firstp = t then nil
 207        do (when (and (not firstp) (upper-case-p c)) (write-char #\- stream))
 208        do (write-char (char-upcase c) stream))))
 209
 210 (defun g-name->name (name)
 211   (or (second (assoc name *lisp-name-exceptions* :test 'equal))
 212       (intern (string-upcase (lispify-name name)) *lisp-name-package*)))
 213
 214 (defun property->property-definition (class-name property)
 215   (let ((name (g-name->name (g-class-property-definition-name property)))
 216         (accessor-name (accessor-name class-name (g-class-property-definition-name property)))
 217         (g-name (g-class-property-definition-name property))
 218         (type (g-type-name (g-class-property-definition-type property)))
 219         (readable (g-class-property-definition-readable property))
 220         (writable (and (g-class-property-definition-writable property)
 221                        (not (g-class-property-definition-constructor-only property)))))
 222     `(,name ,accessor-name ,g-name ,type ,readable ,writable)))
 223
 224 (defun probable-type-init-name (type-name)
 225   (with-output-to-string (stream)
 226     (iter (for c in-string type-name)
 227           (for prev-c previous c)
 228           (when (and (not (first-iteration-p))
 229                      (upper-case-p c)
 230                      (not (upper-case-p prev-c))
 231                      (not (char= prev-c #\_)))
 232             (write-char #\_ stream))
 233           (write-char (char-downcase c) stream))
 234     (write-string "_get_type" stream)))
 235
 236 (defun get-g-class-definition (type &optional lisp-name-package)
 237   (when (and (stringp type) (zerop (g-type-numeric type)))
 238     (let ((type-init-name (probable-type-init-name type)))
 239       (when (foreign-symbol-pointer type-init-name)
 240         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
 241   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
 242          (g-type (ensure-g-type type))
 243          (g-name (g-type-name g-type))
 244          (name (g-name->name g-name))
 245          (superclass-g-type (g-type-parent g-type))
 246          (superclass-name (g-name->name (g-type-name superclass-g-type)))
 247          (interfaces (g-type-interfaces g-type))
 248          (properties (class-properties g-type))
 249          (type-init-name (probable-type-init-name g-name))
 250          (own-properties
 251           (sort (copy-list (remove g-type properties :key #'g-class-property-definition-owner-type :test-not #'g-type=))
 252                 #'string< :key #'g-class-property-definition-name)))
 253     `(define-g-object-class ,g-name ,name
 254          (:superclass ,superclass-name
 255                       :export t
 256                       :interfaces (,@(sort (mapcar #'g-type-name interfaces) 'string<))
 257                       ,@(when (and (foreign-symbol-pointer type-init-name)
 258                                    (not (null-pointer-p (foreign-symbol-pointer type-init-name))))
 259                               `(:type-initializer ,type-init-name)))
 260        (,@(mapcar (lambda (property)
 261                     (property->property-definition name property))
 262                   own-properties)
 263           ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
 264
 265 (defun get-g-interface-definition (interface &optional lisp-name-package)
 266   (when (and (stringp interface) (zerop (g-type-numeric interface)))
 267     (let ((type-init-name (probable-type-init-name interface)))
 268       (when (foreign-symbol-pointer type-init-name)
 269         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
 270   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
 271          (type (ensure-g-type interface))
 272          (g-name (g-type-name type))
 273          (name (g-name->name g-name))
 274          (properties (sort (copy-list (interface-properties type))
 275                            #'string< :key #'g-class-property-definition-name))
 276          (probable-type-initializer (probable-type-init-name g-name)))
 277     `(define-g-interface ,g-name ,name
 278          (:export t
 279                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 280                           `(:type-initializer ,probable-type-initializer)))
 281        ,@(append (mapcar (lambda (property)
 282                            (property->property-definition name property))
 283                          properties)
 284                  (cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
 285
 286 (defun get-g-class-definitions-for-root-1 (type)
 287   (unless (member type *generation-exclusions* :test 'g-type=)
 288     (cons (get-g-class-definition type)
 289           (reduce #'append
 290                   (mapcar #'get-g-class-definitions-for-root-1
 291                           (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string))))))
 292
 293 (defun get-g-class-definitions-for-root (type)
 294   (setf type (ensure-g-type type))
 295   (get-g-class-definitions-for-root-1 type))
 296
 297 (defvar *referenced-types*)
 298
 299 (defun class-or-interface-properties (type)
 300   (setf type (ensure-g-type type))
 301   (cond
 302     ((g-type= (g-type-fundamental type) +g-type-object+) (class-properties type))
 303     ((g-type= (g-type-fundamental type) +g-type-interface+) (interface-properties type))))
 304
 305 (defun get-shallow-referenced-types (type)
 306   (setf type (ensure-g-type type))
 307   (remove-duplicates (sort (loop
 308                               for property in (class-or-interface-properties type)
 309                               when (g-type= type (g-class-property-definition-owner-type property))
 310                               collect (g-class-property-definition-type property))
 311                            #'string<
 312                            :key #'g-type-string)
 313                      :test 'equal))
 314
 315 (defun get-referenced-types-1 (type)
 316   (setf type (ensure-g-type type))
 317   (loop
 318      for property-type in (sort (copy-list (get-shallow-referenced-types type)) #'string> :key #'g-type-string)
 319      do (pushnew property-type *referenced-types* :test 'g-type=))
 320   (loop
 321      for type in (sort (copy-list (g-type-children type)) #'string< :key #'g-type-string)
 322      do (get-referenced-types-1 type)))
 323
 324 (defun get-referenced-types (root-type)
 325   (let (*referenced-types*)
 326     (get-referenced-types-1 (ensure-g-type root-type))
 327     *referenced-types*))
 328
 329 (defun filter-types-by-prefix (types prefix)
 330   (remove-if-not
 331    (lambda (type)
 332      (starts-with (g-type-name (ensure-g-type type)) prefix))
 333    types))
 334
 335 (defun filter-types-by-fund-type (types fund-type)
 336   (setf fund-type (ensure-g-type fund-type))
 337   (remove-if-not
 338    (lambda (type)
 339      (equal (g-type-fundamental (ensure-g-type type)) fund-type))
 340    types))
 341
 342 (defmacro define-g-enum (g-name name (&key (export t) type-initializer) &body values)
 343   "Defines a GEnum type for enumeration. Generates corresponding CFFI definition.
 344
 345 Example:
 346 @begin{pre}
 347 \(define-g-enum \"GdkGrabStatus\" grab-status () :success :already-grabbed :invalid-time :not-viewable :frozen)
 348 \(define-g-enum \"GdkExtensionMode\" gdk-extension-mode (:export t :type-initializer \"gdk_extension_mode_get_type\")
 349   (:none 0) (:all 1) (:cursor 2))
 350 @end{pre}
 351 @arg[g-name]{a string. Specifies the GEnum name}
 352 @arg[name]{a symbol. Names the enumeration type.}
 353 @arg[export]{a boolean. If true, @code{name} will be exported.}
 354 @arg[type-initializer]{a @code{NIL} or a string or a function designator.
 355
 356 If non-@code{NIL}, specifies the function that initializes the type: string specifies a C function that returns the GType value and function designator specifies the Lisp function.}
 357 @arg[values]{values for enum. Each value is a keyword or a list @code{(keyword integer-value)}. @code{keyword} corresponds to Lisp value of enumeration, and @code{integer-value} is an C integer for enumeration item. If @code{integer-value} is not specified, it is generated automatically (see CFFI manual)}"
 358   `(progn
 359      (defcenum ,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 `(at-init () ,(type-initializer-call type-initializer))))))
 365
 366 (defun enum-value->definition (enum-value)
 367   (let ((value-name (intern (lispify-name (enum-item-nick enum-value))
 368                             (find-package :keyword)))
 369         (numeric-value (enum-item-value enum-value)))
 370     `(,value-name ,numeric-value)))
 371
 372 (defun get-g-enum-definition (type &optional lisp-name-package)
 373   (when (and (stringp type) (zerop (g-type-numeric type)))
 374     (let ((type-init-name (probable-type-init-name type)))
 375       (when (foreign-symbol-pointer type-init-name)
 376         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
 377   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
 378          (g-type (ensure-g-type type))
 379          (g-name (g-type-name g-type))
 380          (name (g-name->name g-name))
 381          (items (get-enum-items g-type))
 382          (probable-type-initializer (probable-type-init-name g-name)))
 383     `(define-g-enum ,g-name ,name
 384          (:export t
 385                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 386                           (list :type-initializer
 387                                 probable-type-initializer)))
 388        ,@(mapcar #'enum-value->definition items))))
 389
 390 (defmacro define-g-flags (g-name name (&key (export t) type-initializer) &body values)
 391   "Defines a GFlags type for enumeration that can combine its values. Generates corresponding CFFI definition. Values of this type are lists of keywords that are combined.
 392
 393 Example:
 394 @begin{pre}
 395 \(define-g-flags \"GdkWindowState\" window-state ()
 396   (:withdrawn 1)
 397   (:iconified 2) (:maximized 4) (:sticky 8) (:fullscreen 16)
 398   (:above 32) (:below 64))
 399 @end{pre}
 400 @arg[g-name]{a string. Specifies the GEnum name}
 401 @arg[name]{a symbol. Names the enumeration type.}
 402 @arg[export]{a boolean. If true, @code{name} will be exported.}
 403 @arg[type-initializer]{a @code{NIL} or a string or a function designator.
 404
 405 If non-@code{NIL}, specifies the function that initializes the type: string specifies a C function that returns the GType value and function designator specifies the Lisp function.}
 406 @arg[values]{values for flags. Each value is a keyword or a list @code{(keyword integer-value)}. @code{keyword} corresponds to Lisp value of a flag, and @code{integer-value} is an C integer for flag. If @code{integer-value} is not specified, it is generated automatically (see CFFI manual)}"
 407   `(progn
 408      (defbitfield ,name ,@values)
 409      (register-flags-type ,g-name ',name)
 410      ,@(when export
 411              (list `(export ',name (find-package ,(package-name (symbol-package name))))))
 412      ,@(when type-initializer
 413              (list `(at-init () ,(type-initializer-call type-initializer))))))
 414
 415 (defun flags-value->definition (flags-value)
 416   (let ((value-name (intern (lispify-name (flags-item-nick flags-value))
 417                             (find-package :keyword)))
 418         (numeric-value (flags-item-value flags-value)))
 419     `(,value-name ,numeric-value)))
 420
 421 (defun get-g-flags-definition (type &optional lisp-name-package)
 422   (when (and (stringp type) (zerop (g-type-numeric type)))
 423     (let ((type-init-name (probable-type-init-name type)))
 424       (when (foreign-symbol-pointer type-init-name)
 425         (foreign-funcall-pointer (foreign-symbol-pointer type-init-name) () :int))))
 426   (let* ((*lisp-name-package* (or lisp-name-package *lisp-name-package* *package*))
 427          (g-type (ensure-g-type type))
 428          (g-name (g-type-name g-type))
 429          (name (g-name->name g-name))
 430          (items (get-flags-items g-type))
 431          (probable-type-initializer (probable-type-init-name g-name)))
 432     `(define-g-flags ,g-name ,name
 433          (:export t
 434                   ,@(when (foreign-symbol-pointer probable-type-initializer)
 435                           (list :type-initializer
 436                                 probable-type-initializer)))
 437        ,@(mapcar #'flags-value->definition items))))
 438
 439 (defun generate-types-hierarchy-to-file (file root-type &key include-referenced prefix package exceptions prologue interfaces enums flags objects exclusions additional-properties)
 440   (if (not (streamp file))
 441       (with-open-file (stream file :direction :output :if-exists :supersede)
 442         (generate-types-hierarchy-to-file stream root-type
 443                                           :prefix prefix
 444                                           :package package
 445                                           :exceptions exceptions
 446                                           :prologue prologue
 447                                           :include-referenced include-referenced
 448                                           :interfaces interfaces
 449                                           :enums enums
 450                                           :flags flags
 451                                           :objects objects
 452                                           :exclusions exclusions
 453                                           :additional-properties additional-properties))
 454       (let* ((*generation-exclusions* (mapcar #'ensure-g-type exclusions))
 455              (*lisp-name-package* (or package *package*))
 456              (*package* *lisp-name-package*)
 457              (*strip-prefix* (or prefix ""))
 458              (*lisp-name-exceptions* exceptions)
 459              (*print-case* :downcase)
 460              (*additional-properties* additional-properties)
 461              (referenced-types (and include-referenced
 462                                     (filter-types-by-prefix
 463                                      (get-referenced-types root-type)
 464                                      prefix))))
 465         (setf exclusions (mapcar #'ensure-g-type exclusions))
 466         (when prologue
 467           (write-string prologue file)
 468           (terpri file))
 469         (when include-referenced
 470           (loop
 471              for interface in interfaces
 472              do (loop
 473                    for referenced-type in (get-shallow-referenced-types interface)
 474                    do (pushnew referenced-type referenced-types :test 'g-type=)))
 475           (loop
 476              for object in objects
 477              do (loop
 478                    for referenced-type in (get-shallow-referenced-types object)
 479                    do (pushnew referenced-type referenced-types :test 'g-type=)))
 480           (loop
 481              for enum-type in (filter-types-by-fund-type
 482                                referenced-types "GEnum")
 483              for def = (get-g-enum-definition enum-type)
 484              unless (member enum-type exclusions :test 'g-type=)
 485              do (format file "~S~%~%" def))
 486
 487           (loop
 488              for flags-type in (filter-types-by-fund-type
 489                                 referenced-types "GFlags")
 490              for def = (get-g-flags-definition flags-type)
 491              unless (member flags-type exclusions :test 'g-type=)
 492              do (format file "~S~%~%" def)))
 493         (loop
 494            with auto-enums = (and include-referenced
 495                                   (filter-types-by-fund-type
 496                                    referenced-types "GEnum"))
 497            for enum in enums
 498            for def = (get-g-enum-definition enum)
 499            unless (find enum auto-enums :test 'g-type=)
 500            do (format file "~S~%~%" def))
 501         (loop
 502            with auto-flags = (and include-referenced
 503                                   (filter-types-by-fund-type
 504                                    referenced-types "GFlags"))
 505            for flags-type in flags
 506            for def = (get-g-flags-definition flags-type)
 507            unless (find flags-type auto-flags :test 'g-type=)
 508            do (format file "~S~%~%" def))
 509         (loop
 510            for interface in interfaces
 511            for def = (get-g-interface-definition interface)
 512            do (format file "~S~%~%" def))
 513         (loop
 514            for def in (get-g-class-definitions-for-root root-type)
 515            do (format file "~S~%~%" def))
 516         (loop
 517            for object in objects
 518            for def = (get-g-class-definition object)
 519            do (format file "~S~%~%" def)))))