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 (defvar *ui-child-packers* (make-hash-table))
50 (defmacro def-ui-child-packer (class (var child-def child) &body body)
51 `(setf (gethash ',class *ui-child-packers*)
52 (lambda (,var ,child-def ,child) ,@body)))
54 (def-ui-child-packer container (w d child)
56 `(container-add ,w ,child))
58 (defun get-ui-child-prop-value (d name required-p context)
59 (let ((prop (find name (ui-child-props d) :key #'ui-prop-name)))
60 (if (and required-p (null prop))
61 (error "~A is a mandatory child property for ~A" name context)
62 (when prop (ui-prop-value prop)))))
64 (def-ui-child-packer box (b d child)
65 (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name))
66 (fill-prop (find :fill (ui-child-props d) :key #'ui-prop-name))
67 (padding-prop (find :padding (ui-child-props d) :key #'ui-prop-name))
68 (pack-type-prop (find :pack-type (ui-child-props d) :key #'ui-prop-name)))
70 (box-pack-start ,b ,child
71 ,@(when expand-prop (list :expand (ui-prop-value expand-prop)))
72 ,@(when fill-prop (list :fill (ui-prop-value fill-prop)))
73 ,@(when padding-prop (list :padding (ui-prop-value padding-prop))))
74 ,@(when pack-type-prop
75 (list `(setf (box-child-pack-type ,b ,child) ,(ui-prop-value pack-type-prop)))))))
77 (def-ui-child-packer paned (p d child)
78 (let ((resize-prop (find :resize (ui-child-props d) :key #'ui-prop-name))
79 (shrink-prop (find :shrink (ui-child-props d) :key #'ui-prop-name)))
80 `(if (null (paned-child-1 ,p))
81 (paned-pack-1 ,p ,child
82 ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
83 ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop))))
84 (paned-pack-2 ,p ,child
85 ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
86 ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop)))))))
88 (def-ui-child-packer table (table d child)
89 `(table-attach ,table ,child
90 ,(get-ui-child-prop-value d :left t "table packing")
91 ,(get-ui-child-prop-value d :right t "table packing")
92 ,(get-ui-child-prop-value d :top t "table packing")
93 ,(get-ui-child-prop-value d :bottom t "table packing")
94 ,@(let ((x-options (get-ui-child-prop-value d :x-options nil nil)))
96 (list :x-options x-options)))
97 ,@(let ((y-options (get-ui-child-prop-value d :y-options nil nil)))
99 (list :y-options y-options)))
100 ,@(let ((x-padding (get-ui-child-prop-value d :x-padding nil nil)))
102 (list :x-padding x-padding)))
103 ,@(let ((y-padding (get-ui-child-prop-value d :y-padding nil nil)))
105 (list :y-padding y-padding)))))
107 (def-ui-child-packer tree-view (w d child)
109 `(tree-view-append-column ,w ,child))
111 (def-ui-child-packer tree-view-column (w d child)
113 (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name)))
115 (tree-view-column-pack-start ,w ,child
116 ,@(when expand-prop (list :expand (ui-prop-value expand-prop))))
117 ,@(iter (for prop in (ui-child-props d))
118 (when (eql (ui-prop-name prop) :attribute)
119 (collect `(tree-view-column-add-attribute ,w ,child
120 ,(first (ui-prop-value prop))
121 ,(second (ui-prop-value prop)))))))))
123 (def-ui-child-packer toolbar (b d child)
124 (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name))
125 (homogeneous-prop (find :homogeneous (ui-child-props d) :key #'ui-prop-name)))
127 (toolbar-insert ,b ,child -1)
129 `(container-call-set-property ,b ,child "expand" ,(ui-prop-value expand-prop) +g-type-boolean+))
130 ,(when homogeneous-prop
131 `(container-call-set-property ,b ,child "homogeneous" ,(ui-prop-value homogeneous-prop) +g-type-boolean+)))))
133 (defun get-child-packer-fn (d)
134 (iter (for class first (find-class (ui-d-class d)) then (first (c2mop:class-direct-superclasses class)))
136 (for packer = (gethash (class-name class) *ui-child-packers*))
137 (when packer (return packer))))
139 (defun get-child-packer (d var)
140 (let ((fn (get-child-packer-fn d)))
142 (let ((forms (iter (for child in (ui-d-children d))
143 (for child-var = (ui-d-var (ui-child-v child)))
144 (collect (funcall fn var child child-var)))))
145 (when forms (cons 'progn forms))))))
147 (defun get-ui-d-initializer (d var)
148 (get-child-packer d var))
150 (defun set-ui-expansion-1 (d)
152 ;; only direct-vars do not have class
153 (setf (ui-d-var d) (get-ui-d-var d)
154 (ui-d-initform d) (get-ui-d-initform d))
155 (setf (ui-d-initializer d) (get-ui-d-initializer d (ui-d-var d)))))
157 (defun set-ui-expansion (description)
158 (iter (for child in (ui-d-children description))
159 (set-ui-expansion (ui-child-v child)))
160 (set-ui-expansion-1 description))
162 (defun flattened-ui-descriptions (d)
164 (iter (for child in (ui-d-children d))
165 (when (ui-d-class (ui-child-v child))
166 (appending (flattened-ui-descriptions (ui-child-v child)))))))
168 (defmacro let-ui (ui-description &body body)
169 (let* ((description (parse-ui-description ui-description))
170 (items (flattened-ui-descriptions description)))
171 (set-ui-expansion description)
172 `(let (,@(iter (for i in items)
173 (collect (list (ui-d-var i)
174 (ui-d-initform i)))))
175 ,@(iter (for i in items)
176 (when (ui-d-initializer i)
177 (collect (ui-d-initializer i))))