gtk/ui-markup.lisp

   1 (in-package :gtk)
   2
   3 (defstruct ui-d class props children expansion var initform initializer)
   4
   5 (defstruct ui-prop name value)
   6
   7 (defstruct ui-child v props)
   8
   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)))))
  16
  17 (defun parse-ui-children (list)
  18   ;; list is (child*)
  19   ;; child is {ui {:prop value}*}
  20   (iter (while list)
  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)))
  25         (setf list rest)
  26         (collect (make-ui-child :v child :props props))))
  27
  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)))))
  35
  36 (defun get-ui-d-var (d)
  37   (let ((prop (find :var (ui-d-props d) :key #'ui-prop-name)))
  38     (if prop
  39         (ui-prop-value prop)
  40         (gensym (format nil "~A-" (symbol-name (ui-d-class d)))))))
  41
  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)))))))
  47
  48 (defvar *ui-child-packers* (make-hash-table))
  49
  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)))
  53
  54 (def-ui-child-packer container (w d child)
  55   (declare (ignore d))
  56   `(container-add ,w ,child))
  57
  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)))))
  63
  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)))
  69     `(progn
  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)))))))
  76
  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)))))))
  87
  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)))
  95                         (when x-options
  96                           (list :x-options x-options)))
  97                  ,@(let ((y-options (get-ui-child-prop-value d :y-options nil nil)))
  98                         (when y-options
  99                           (list :y-options y-options)))
 100                  ,@(let ((x-padding (get-ui-child-prop-value d :x-padding nil nil)))
 101                         (when x-padding
 102                           (list :x-padding x-padding)))
 103                  ,@(let ((y-padding (get-ui-child-prop-value d :y-padding nil nil)))
 104                         (when y-padding
 105                           (list :y-padding y-padding)))))
 106
 107 (def-ui-child-packer tree-view (w d child)
 108   (declare (ignore d))
 109   `(tree-view-append-column ,w ,child))
 110
 111 (def-ui-child-packer tree-view-column (w d child)
 112   (declare (ignore d))
 113   (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name)))
 114     `(progn
 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)))))))))
 122
 123 (defun get-child-packer-fn (d)
 124   (iter (for class first (find-class (ui-d-class d)) then (first (c2mop:class-direct-superclasses class)))
 125         (while class)
 126         (for packer = (gethash (class-name class) *ui-child-packers*))
 127         (when packer (return packer))))
 128
 129 (defun get-child-packer (d var)
 130   (let ((fn (get-child-packer-fn d)))
 131     (when fn
 132       (let ((forms (iter (for child in (ui-d-children d))
 133                          (for child-var = (ui-d-var (ui-child-v child)))
 134                          (collect (funcall fn var child child-var)))))
 135         (when forms (cons 'progn forms))))))
 136
 137 (defun get-ui-d-initializer (d var)
 138   (get-child-packer d var))
 139
 140 (defun set-ui-expansion-1 (d)
 141   (when (ui-d-class d)
 142     ;; only direct-vars do not have class
 143     (setf (ui-d-var d) (get-ui-d-var d)
 144           (ui-d-initform d) (get-ui-d-initform d))
 145     (setf (ui-d-initializer d) (get-ui-d-initializer d (ui-d-var d)))))
 146
 147 (defun set-ui-expansion (description)
 148   (iter (for child in (ui-d-children description))
 149         (set-ui-expansion (ui-child-v child)))
 150   (set-ui-expansion-1 description))
 151
 152 (defun flattened-ui-descriptions (d)
 153   (cons d
 154         (iter (for child in (ui-d-children d))
 155               (when (ui-d-class (ui-child-v child))
 156                 (appending (flattened-ui-descriptions (ui-child-v child)))))))
 157
 158 (defmacro let-ui (ui-description &body body)
 159   (let* ((description (parse-ui-description ui-description))
 160          (items (flattened-ui-descriptions description)))
 161     (set-ui-expansion description)
 162     `(let (,@(iter (for i in items)
 163                    (collect (list (ui-d-var i)
 164                                   (ui-d-initform i)))))
 165        ,@(iter (for i in items)
 166                (when (ui-d-initializer i)
 167                  (collect (ui-d-initializer i))))
 168        ,@body)))