3 (defstruct ui-d class props children expansion var initform initializer)
5 (defstruct ui-prop name value)
7 (defstruct ui-child v props)
9 (defun parse-ui-props (list)
10 ;; list is ({:prop value}* rest)
11 (iter (for x first list then (cddr x))
12 (while (keywordp (first x)))
13 (for (name value) = x)
14 (collect (make-ui-prop :name name :value value) into props)
15 (finally (return (values props x)))))
17 (defun parse-ui-children (list)
19 ;; child is {ui {:prop value}*}
21 (for child = (if (eq :expr (first (first list)))
22 (make-ui-d :var (second (first list)))
23 (parse-ui-description (first list))))
24 (for (values props rest) = (parse-ui-props (rest list)))
26 (collect (make-ui-child :v child :props props))))
28 (defun parse-ui-description (description)
29 ;; description is (class {:prop value}* child*)
30 ;; child is {ui {:prop value}*}
31 (let ((class (first description)))
32 (multiple-value-bind (props rest) (parse-ui-props (rest description))
33 (let ((children (parse-ui-children rest)))
34 (make-ui-d :class class :props props :children children)))))
36 (defun get-ui-d-var (d)
37 (let ((prop (find :var (ui-d-props d) :key #'ui-prop-name)))
40 (gensym (format nil "~A-" (symbol-name (ui-d-class d)))))))
42 (defun get-ui-d-initform (d)
43 `(make-instance ',(ui-d-class d)
44 ,@(iter (for prop in (ui-d-props d))
45 (unless (eq (ui-prop-name prop) :var)
46 (appending (list (ui-prop-name prop) (ui-prop-value prop)))))))
48 (defgeneric pack-child (container child &key))
50 (defmethod pack-child ((w container) child &key)
51 (container-add w child))
53 (defmethod pack-child ((b box) child &key (expand t) (fill t) (padding 0) pack-type position)
54 (box-pack-start b child
59 (setf (box-child-pack-type b child) pack-type))
61 (setf (box-child-position b child) position)))
63 (defmethod pack-child ((p paned) child &key (resize 'default) (shrink t))
64 (if (null (paned-child-1 p))
66 :resize (if (eq resize 'default) nil resize)
69 :resize (if (eq resize 'default) t resize)
72 (defmethod pack-child ((table table) child &key
74 (x-options '(:expand :fill)) (y-options '(:expand :fill)) (x-padding 0) (y-padding 0))
77 (error "left is a mandatory child property for table packing"))
79 (error "right is a mandatory child property for table packing"))
81 (error "top is a mandatory child property for table packing"))
83 (error "bottom is a mandatory child property for table packing"))
85 (table-attach table child left right top bottom
89 :y-padding y-padding))
91 (defmethod pack-child ((w tree-view) child &key)
92 (tree-view-append-column w child))
94 (defmethod pack-child ((w tree-view-column) child &key (expand t) attributes)
95 (tree-view-column-pack-start w child :expand expand)
96 (iter (for a on attributes by #'cddr)
97 (tree-view-column-add-attribute w child
101 (defmethod pack-child ((b toolbar) child &key (expand 'default) (homogeneous 'default))
102 (toolbar-insert b child -1)
103 (unless (eq expand 'default)
104 (container-call-set-property b child "expand" expand +g-type-boolean+))
105 (unless (eq homogeneous 'default)
106 (container-call-set-property b child "homogeneous" homogeneous +g-type-boolean+)))
108 (defun set-ui-expansion-1 (d)
110 ;; only direct-vars do not have class
111 (setf (ui-d-var d) (get-ui-d-var d)
112 (ui-d-initform d) (get-ui-d-initform d))))
114 (defun set-ui-expansion (description)
115 (iter (for child in (ui-d-children description))
116 (set-ui-expansion (ui-child-v child)))
117 (set-ui-expansion-1 description))
119 (defun flattened-ui-descriptions (d)
121 (iter (for child in (ui-d-children d))
122 (when (ui-d-class (ui-child-v child))
123 (appending (flattened-ui-descriptions (ui-child-v child)))))))
125 (defmacro let-ui (ui-description &body body)
126 (let* ((description (parse-ui-description ui-description))
127 (items (flattened-ui-descriptions description)))
128 (set-ui-expansion description)
129 `(let (,@(iter (for item in items)
130 (collect (list (ui-d-var item)
131 (ui-d-initform item)))))
132 ,@(iter (for item in items)
133 (appending (iter (for child in (ui-d-children item))
134 (for child-var = (ui-d-var (ui-child-v child)))
136 (iter (for p in (ui-child-props child))
137 (appending (list (ui-prop-name p) (ui-prop-value p))))))
138 (collect (list* 'pack-child (ui-d-var item) child-var props))))))