subclass.lisp

   1 (eval-when (:load-toplevel :compile-toplevel :execute)
   2   (asdf:oos 'asdf:load-op :gtk)
   3   (asdf:oos 'asdf:load-op :iterate)
   4   (asdf:oos 'asdf:load-op :metabang-bind)
   5   (use-package :cffi)
   6   (use-package :gobject)
   7   (use-package :iter)
   8   (use-package :bind))
   9
  10 (define-g-boxed-class nil g-type-info ()
  11   (class-size :uint16 :initform 0)
  12   (base-init :pointer :initform (null-pointer))
  13   (base-finalize :pointer :initform (null-pointer))
  14   (class-init :pointer :initform (null-pointer))
  15   (class-finalize :pointer :initform (null-pointer))
  16   (class-data :pointer :initform (null-pointer))
  17   (instance-size :uint16 :initform 0)
  18   (n-preallocs :uint16 :initform 0)
  19   (instance-init :pointer :initform (null-pointer))
  20   (value-type :pointer :initform (null-pointer)))
  21
  22 (defcfun (%g-type-register-static "g_type_register_static") gobject::g-type
  23   (parent-type gobject::g-type)
  24   (type-name :string)
  25   (info (g-boxed-ptr g-type-info))
  26   (flags gobject::g-type-flags))
  27
  28 (defcfun (%g-type-regiser-static-simple "g_type_register_static_simple") gobject::g-type
  29   (parent-type gobject::g-type)
  30   (type-name :string)
  31   (class-size :uint)
  32   (class-init :pointer)
  33   (instance-size :uint)
  34   (instance-init :pointer)
  35   (flags gobject::g-type-flags))
  36
  37 (define-g-boxed-class nil g-type-query ()
  38   (type gobject::g-type :initform 0)
  39   (name (:string :free-from-foreign nil :free-to-foreign nil) :initform (null-pointer))
  40   (class-size :uint :initform 0)
  41   (instance-size :uint :initform 0))
  42
  43 (defcfun (%g-type-query "g_type_query") :void
  44   (type gobject::g-type)
  45   (query (g-boxed-ptr g-type-query :in-out)))
  46
  47 (define-foreign-type g-quark ()
  48   ()
  49   (:actual-type :uint32)
  50   (:simple-parser g-quark))
  51
  52 (defcfun g-quark-from-string :uint32
  53   (string :string))
  54
  55 (defcfun g-quark-to-string (:string :free-from-foreign nil)
  56   (quark :uint32))
  57
  58 (defmethod translate-to-foreign (string (type g-quark))
  59   (g-quark-from-string string))
  60
  61 (defmethod translate-from-foreign (value (type g-quark))
  62   (g-quark-to-string value))
  63
  64 (defvar *stable-pointers-to-symbols* (make-array 0 :adjustable t :fill-pointer t))
  65
  66 (defun stable-pointer (symbol)
  67   (vector-push-extend symbol *stable-pointers-to-symbols*)
  68   (length *stable-pointers-to-symbols*))
  69
  70 (defun deref-stable-pointer (p)
  71   (aref *stable-pointers-to-symbols* (1- p)))
  72
  73 (defcfun g-type-set-qdata :void
  74   (type gobject::g-type)
  75   (quark g-quark)
  76   (data :pointer))
  77
  78 (defcfun g-type-get-qdata :pointer
  79   (type gobject::g-type)
  80   (quark g-quark))
  81
  82 (defun g-object-register-sub-type (name parent-type lisp-class)
  83   (let ((q (make-g-type-query)))
  84     (%g-type-query (gobject::ensure-g-type parent-type) q)
  85     (let ((new-type-id (%g-type-regiser-static-simple (gobject::ensure-g-type parent-type)
  86                                                       name
  87                                                       (g-type-query-class-size q)
  88                                                       (null-pointer)
  89                                                       (g-type-query-instance-size q)
  90                                                       (null-pointer)
  91                                                       nil)))
  92       (when (zerop new-type-id)
  93         (error "Type registration failed for ~A" name))
  94       (g-type-set-qdata new-type-id "lisp-class-name" (make-pointer (stable-pointer lisp-class)))
  95       (setf (get lisp-class 'g-type-name) name))))
  96
  97 (defun g-type-lisp-class (type)
  98   (let ((sp (pointer-address (g-type-get-qdata (gobject::ensure-g-type type) "lisp-class-name"))))
  99     (when (zerop sp)
 100       (error "Type ~A is not a lisp-based type" type))
 101     (deref-stable-pointer sp)))
 102
 103
 104 (eval-when (:compile-toplevel :load-toplevel :execute)
 105   (defun vtable-item->cstruct-item (member)
 106     (if (eq (first member) :skip)
 107         (second member)
 108         `(,(first member) :pointer)))
 109
 110   (defun vtable->cstruct (table-name options members)
 111     (bind (((&key cstruct-name &allow-other-keys) options))
 112       `(defcstruct ,cstruct-name
 113          ,@(mapcar #'vtable-item->cstruct-item members))))
 114
 115   (defun arg-name->name (name)
 116     (if (listp name)
 117         (second name)
 118         name))
 119
 120   (defun arg->arg-name (arg)
 121     (arg-name->name (first arg)))
 122
 123   (defun vtable-member->callback (table-name options member)
 124     (bind (((name return-type &rest args) member))
 125       `(defcallback ,name ,return-type ,args
 126          (funcall ',name ,@(mapcar #'arg->arg-name args)))))
 127
 128   (defun vtable->callbacks (table-name options members)
 129     (mapcar (lambda (member) (vtable-member->callback table-name options member))
 130             (remove-if (lambda (member) (eq (first member) :skip)) members)))
 131
 132   (defun vtable-member->init-member (iface-ptr-var table-name options member)
 133     (bind (((&key cstruct-name &allow-other-keys) options))
 134       `(setf (foreign-slot-value ,iface-ptr-var ',cstruct-name ',(first member))
 135              (callback ,(first member)))))
 136
 137   (defun vtable->interface-init (table-name options members)
 138     (bind (((&key interface-initializer &allow-other-keys) options))
 139       `(defcallback ,interface-initializer :void ((iface :pointer) (data :pointer))
 140          (declare (ignore data))
 141          ,@(mapcar (lambda (member) (vtable-member->init-member 'iface table-name options member))
 142                    (remove-if (lambda (member) (eq (first member) :skip)) members)))))
 143
 144   (defun vtable-member->generic-function (table-name options member)
 145     (bind (((name return-type &rest arguments) member))
 146       `(defgeneric ,name (,@(mapcar #'first arguments)))))
 147
 148   (defun vtable->generics-def (table-name options members)
 149     (mapcar (lambda (member) (vtable-member->generic-function table-name options member))
 150             (remove-if (lambda (member) (eq (first member) :skip)) members))))
 151
 152 (defmacro define-vtable (name options &body members)
 153   `(progn
 154      ,(vtable->cstruct name options members)
 155      ,@(vtable->callbacks name options members)
 156      ,(vtable->interface-init name options members)
 157      ,@(vtable->generics-def name options members)
 158      (eval-when (:compile-toplevel :load-toplevel :execute)
 159        (setf (get ',name 'options) ',options
 160              (get ',name 'members) ',members))))
 161
 162 (define-g-flags "GtkTreeModelFlags" tree-model-flags (t)
 163   (:iters-persist 1) (:list-only 2))
 164
 165 (define-g-boxed-class "GtkTreeIter" tree-iter ()
 166   (stamp :int)
 167   (user-data :pointer)
 168   (user-data-2 :pointer)
 169   (user-data-3 :pointer))
 170
 171 (defctype tree-path :pointer)
 172
 173 (define-vtable tree-model (:interface "GtkTreeModel" :class-name gtk-tree-model :cstruct-name gtk-tree-model-iface :interface-initializer gtk-tree-model-iface-init)
 174   (:skip (parent-instance gobject::g-type-interface))
 175   ;;some signals
 176   (tree-model-row-changed :void (tree-model :pointer) (path :pointer) (iter :pointer))
 177   (tree-model-row-inserted :void (tree-model :pointer) (path :pointer) (iter :pointer))
 178   (tree-model-row-has-child-toggled :void (tree-model :pointer) (path :pointer) (iter :pointer))
 179   (tree-model-row-deleted :void (tree-model :pointer) (path :pointer))
 180   (tree-model-rows-reordered :void (tree-model :pointer) (path :pointer) (iter :pointer) (new-order :pointer))
 181   ;;methods
 182   (tree-model-get-flags tree-model-flags (tree-model g-object))
 183   (tree-model-get-n-columns :int (tree-model g-object))
 184   (tree-model-get-column-type gobject::g-type (tree-model g-object) (index :int))
 185   (tree-model-get-iter :boolean (tree-model g-object) (iter (:pointer tree-iter)) (path tree-path))
 186   (tree-model-get-path tree-path (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
 187   (tree-model-get-value :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)) (n :int) (value (:pointer gobject::g-value)))
 188   (tree-model-iter-next :boolean (tree-model g-object) (iter (:pointer tree-iter)))
 189   (tree-model-iter-children :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)))
 190   (tree-model-iter-has-child :boolean (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
 191   (tree-model-iter-n-children :int (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
 192   (tree-model-iter-nth-child :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)) (n :int))
 193   (tree-model-iter-parent :boolean (tree-model g-object) (iter (:pointer tree-iter)) (child (g-boxed-ptr tree-iter)))
 194   (tree-model-ref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
 195   (tree-model-unref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter))))
 196
 197 (defcfun g-type-add-interface-static :void
 198   (instance-type gobject::g-type)
 199   (interface-type gobject::g-type)
 200   (info (:pointer gobject::g-interface-info)))
 201
 202 (defun add-interface (lisp-class vtable-name)
 203   (with-foreign-object (iface-info 'gobject::g-interface-info)
 204     (setf (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-init) (get-callback (getf (get vtable-name 'options) :interface-initializer))
 205           (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-finalize) (null-pointer)
 206           (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-data) (null-pointer))
 207     (unless (getf (get vtable-name 'options) :interface)
 208       (error "Vtable ~A is not a vtable of an interface"))
 209     (g-type-add-interface-static (gobject::g-type-from-name (get lisp-class 'g-type-name))
 210                                  (gobject::g-type-from-name (getf (get vtable-name 'options) :interface))
 211                                  iface-info)))
 212
 213 (defvar *o1* nil)
 214 (defvar *o2* nil)
 215
 216 (unless *o1*
 217   (g-object-register-sub-type "LispTreeStore" "GObject" 'lisp-tree-store)
 218   (setf *o1* t))
 219 (unless *o2*
 220   (add-interface 'lisp-tree-store 'tree-model)
 221   (setf *o2* t))
 222
 223 (defclass tree-model (g-object) ())
 224 (defmethod initialize-instance :before ((object tree-model) &key pointer)
 225   (unless pointer
 226     (setf (gobject::pointer object) (gobject::g-object-call-constructor (gobject::g-type-from-name "LispTreeStore") nil nil nil))))
 227
 228 (defmethod tree-model-get-flags ((model tree-model))
 229   (list :list-only))
 230
 231 (defmethod tree-model-get-n-columns ((model tree-model))
 232   1)
 233
 234 (defmethod tree-model-get-column-type ((model tree-model) index)
 235   (gobject::g-type-from-name "gchararray"))
 236
 237 (defcfun (%gtk-tree-path-get-depth "gtk_tree_path_get_depth") :int
 238   (path tree-path))
 239
 240 (defcfun (%gtk-tree-path-get-indices "gtk_tree_path_get_indices") (:pointer :int)
 241   (path tree-path))
 242
 243 (defcfun (%gtk-tree-path-new "gtk_tree_path_new") :pointer)
 244
 245 (defcfun (%gtk-tree-path-append-index "gtk_tree_path_append_index") :void
 246   (path :pointer)
 247   (index :int))
 248
 249 (defun tree-path-indices (path)
 250   (let ((n (%gtk-tree-path-get-depth path))
 251         (indices (%gtk-tree-path-get-indices path)))
 252     (loop
 253        for i from 0 below n
 254        collect (mem-aref indices :int i))))
 255
 256 (defmethod tree-model-get-iter ((model tree-model) iter path)
 257   (let ((indices (tree-path-indices path)))
 258     (when (= 1 (length indices))
 259       (with-foreign-slots ((stamp user-data user-data-2 user-data-3) iter tree-iter)
 260         (setf stamp 0 user-data (make-pointer (first indices)) user-data-2 (null-pointer) user-data-3 (null-pointer)))
 261       t)))
 262
 263 (defmethod tree-model-ref-node ((model tree-model) iter))
 264 (defmethod tree-model-unref-node ((model tree-model) iter))
 265
 266 (defmethod tree-model-iter-next ((model tree-model) iter)
 267   (with-foreign-slots ((stamp user-data) iter tree-iter)
 268     (let ((n (pointer-address user-data)))
 269       (when (< n 5)
 270         (setf user-data (make-pointer (1+ n)))
 271         t))))
 272
 273 (defmethod tree-model-iter-nth-child ((model tree-model) iter parent n)
 274   (with-foreign-slots ((stamp user-data user-data-2 user-data-3) iter tree-iter)
 275     (setf stamp 0 user-data (make-pointer n) user-data-2 (null-pointer) user-data-3 (null-pointer)))
 276   t)
 277
 278 (defmethod tree-model-iter-n-children ((model tree-model) iter)
 279   (if (null iter)
 280       5
 281       0))
 282
 283 (defmethod tree-model-get-path ((model tree-model) iter)
 284   (let ((path (%gtk-tree-path-new)))
 285     (%gtk-tree-path-append-index path (pointer-address (tree-iter-user-data iter)))
 286     path))
 287
 288 (defmethod tree-model-iter-has-child ((model tree-model) iter)
 289   nil)
 290
 291 (defmethod tree-model-get-value ((model tree-model) iter n value)
 292   (let ((n-row (pointer-address (tree-iter-user-data iter))))
 293     (gobject::set-g-value value (format nil "~A" (expt n-row 2)) (gobject::g-type-from-name "gchararray"))))
 294
 295 (defcfun (%gtk-tree-view-append-column "gtk_tree_view_append_column") :int
 296   (tree-view (g-object gtk:tree-view))
 297   (column (g-object gtk:tree-view-column)))
 298
 299 (defcfun (%gtk-tree-view-column-pack-start "gtk_tree_view_column_pack_start") :void
 300   (tree-column (g-object gtk:tree-view-column))
 301   (cell (g-object gtk:cell-renderer))
 302   (expand :boolean))
 303
 304 (defcfun (%gtk-tree-view-column-add-attribute "gtk_tree_view_column_add_attribute") :void
 305   (tree-column (g-object gtk:tree-view-column))
 306   (cell-renderer (g-object gtk:cell-renderer))
 307   (attribute :string)
 308   (column-number :int))
 309
 310 (defun test-treeview ()
 311   (let* ((window (make-instance 'gtk:gtk-window :type :toplevel :title "Treeview" :border-width 30))
 312          (model (make-instance 'tree-model))
 313          (tv (make-instance 'gtk:tree-view :model model :headers-visible t)))
 314     (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (gtk:gtk-main-quit)))
 315     (let ((column (make-instance 'gtk:tree-view-column :title "Number"))
 316           (renderer (make-instance 'gtk:cell-renderer-text :text "A text")))
 317       (%gtk-tree-view-column-pack-start column renderer t)
 318       (%gtk-tree-view-column-add-attribute column renderer "text" 0)
 319       (%gtk-tree-view-append-column tv column))
 320     (gtk:container-add window tv)
 321     (gtk:gtk-widget-show-all window)
 322     (gtk:gtk-main)))
 323
 324 (defcfun (%gtk-cell-layout-pack-start "gtk_cell_layout_pack_start") :void
 325   (cell-layout g-object)
 326   (cell (g-object gtk:cell-renderer))
 327   (expand :boolean))
 328
 329 (defcfun (%gtk-cell-layout-add-attribute "gtk_cell_layout_add_attribute") :void
 330   (cell-layout g-object)
 331   (cell (g-object gtk:cell-renderer))
 332   (attribute :string)
 333   (column :int))
 334
 335 (defun test-combobox ()
 336   (let* ((window (make-instance 'gtk:gtk-window :type :toplevel :title "cb" :border-width 30))
 337          (model (make-instance 'tree-model))
 338          (combobox (make-instance 'gtk:combo-box :model model)))
 339     (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (gtk:gtk-main-quit)))
 340     (g-signal-connect combobox "changed" (lambda (w) (declare (ignore w)) (format t "Changed cb; active now = ~A~%" (gtk:combo-box-active combobox))))
 341     (let ((renderer (make-instance 'gtk:cell-renderer-text)))
 342       (%gtk-cell-layout-pack-start combobox renderer t)
 343       (%gtk-cell-layout-add-attribute combobox renderer "text" 0))
 344     (gtk:container-add window combobox)
 345     (gtk:gtk-widget-show-all window)
 346     (gtk:gtk-main)))
 347
 348 (define-vtable widget (:class "GtkWidget" :cstruct-name widget-vtable :interface-initializer gtk-tree-model-iface-init)
 349   (:skip (parent-instance gobject::g-type-interface))
 350   ;;some signals
 351   (tree-model-row-changed :void (tree-model :pointer) (path :pointer) (iter :pointer))
 352   (tree-model-row-inserted :void (tree-model :pointer) (path :pointer) (iter :pointer))
 353   (tree-model-row-has-child-toggled :void (tree-model :pointer) (path :pointer) (iter :pointer))
 354   (tree-model-row-deleted :void (tree-model :pointer) (path :pointer))
 355   (tree-model-rows-reordered :void (tree-model :pointer) (path :pointer) (iter :pointer) (new-order :pointer))
 356   ;;methods
 357   (tree-model-get-flags tree-model-flags (tree-model g-object))
 358   (tree-model-get-n-columns :int (tree-model g-object))
 359   (tree-model-get-column-type gobject::g-type (tree-model g-object) (index :int))
 360   (tree-model-get-iter :boolean (tree-model g-object) (iter (:pointer tree-iter)) (path tree-path))
 361   (tree-model-get-path tree-path (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
 362   (tree-model-get-value :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)) (n :int) (value (:pointer gobject::g-value)))
 363   (tree-model-iter-next :boolean (tree-model g-object) (iter (:pointer tree-iter)))
 364   (tree-model-iter-children :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)))
 365   (tree-model-iter-has-child :boolean (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
 366   (tree-model-iter-n-children :int (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
 367   (tree-model-iter-nth-child :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)) (n :int))
 368   (tree-model-iter-parent :boolean (tree-model g-object) (iter (:pointer tree-iter)) (child (g-boxed-ptr tree-iter)))
 369   (tree-model-ref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
 370   (tree-model-unref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter))))