added construction of tree-view columns to ui-markup eDSL.

[cl-gtk2.git] / gtk / ui-markup.lisp

diff --git a/gtk/ui-markup.lisp b/gtk/ui-markup.lisp
index 8bb13bc..799b309 100644 (file)
--- a/gtk/ui-markup.lisp
+++ b/gtk/ui-markup.lisp
@@ -64,11 +64,15 @@
 (def-ui-child-packer box (b d child)
   (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name))
         (fill-prop (find :fill (ui-child-props d) :key #'ui-prop-name))
-        (padding-prop (find :padding (ui-child-props d) :key #'ui-prop-name)))
-    `(box-pack-start ,b ,child
-                     ,@(when expand-prop (list :expand (ui-prop-value expand-prop)))
-                     ,@(when fill-prop (list :fill (ui-prop-value fill-prop)))
-                     ,@(when padding-prop (list :padding (ui-prop-value padding-prop))))))
+        (padding-prop (find :padding (ui-child-props d) :key #'ui-prop-name))
+        (pack-type-prop (find :pack-type (ui-child-props d) :key #'ui-prop-name)))
+    `(progn
+       (box-pack-start ,b ,child
+                       ,@(when expand-prop (list :expand (ui-prop-value expand-prop)))
+                       ,@(when fill-prop (list :fill (ui-prop-value fill-prop)))
+                       ,@(when padding-prop (list :padding (ui-prop-value padding-prop))))
+       ,@(when pack-type-prop
+               (list `(setf (box-child-pack-type ,b ,child) ,(ui-prop-value pack-type-prop)))))))
 
 (def-ui-child-packer paned (p d child)
   (let ((resize-prop (find :resize (ui-child-props d) :key #'ui-prop-name))
@@ -100,6 +104,22 @@
                         (when y-padding
                           (list :y-padding y-padding)))))
 
+(def-ui-child-packer tree-view (w d child)
+  (declare (ignore d))
+  `(tree-view-append-column ,w ,child))
+
+(def-ui-child-packer tree-view-column (w d child)
+  (declare (ignore d))
+  (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name)))
+    `(progn
+       (tree-view-column-pack-start ,w ,child
+                                   ,@(when expand-prop (list :expand (ui-prop-value expand-prop))))
+       ,@(iter (for prop in (ui-child-props d))
+              (when (eql (ui-prop-name prop) :attribute)
+                (collect `(tree-view-column-add-attribute ,w ,child
+                                                          ,(first (ui-prop-value prop))
+                                                          ,(second (ui-prop-value prop)))))))))
+
 (defun get-child-packer-fn (d)
   (iter (for class first (find-class (ui-d-class d)) then (first (c2mop:class-direct-superclasses class)))
         (while class)