glib/gobject.generating.lisp

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