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 (defgeneric pack-child (container child &key))
  49
  50 (defmethod pack-child ((w container) child &key)
  51   (container-add w child))
  52
  53 (defmethod pack-child ((b box) child &key (expand t) (fill t) (padding 0) pack-type position)
  54   (box-pack-start b child
  55                   :expand expand
  56                   :fill fill
  57                   :padding padding)
  58   (when pack-type
  59     (setf (box-child-pack-type b child) pack-type))
  60   (when position
  61     (setf (box-child-position b child) position)))
  62
  63 (defmethod pack-child ((p paned) child &key (resize 'default) (shrink t))
  64   (if (null (paned-child-1 p))
  65       (paned-pack-1 p child
  66                     :resize (if (eq resize 'default) nil resize)
  67                     :shrink shrink)
  68       (paned-pack-2 p child
  69                     :resize (if (eq resize 'default) t resize)
  70                     :shrink shrink)))
  71
  72 (defmethod pack-child ((table table) child &key
  73                        left right top bottom
  74                        (x-options '(:expand :fill)) (y-options '(:expand :fill)) (x-padding 0) (y-padding 0))
  75
  76   (unless left
  77     (error "left is a mandatory child property for table packing"))
  78   (unless right
  79     (error "right is a mandatory child property for table packing"))
  80   (unless top
  81     (error "top is a mandatory child property for table packing"))
  82   (unless bottom
  83     (error "bottom is a mandatory child property for table packing"))
  84
  85   (table-attach table child
  86                 :left left
  87                 :right right
  88                 :top top
  89                 :bottom bottom
  90                 :x-options x-options
  91                 :y-options y-options
  92                 :x-padding x-padding
  93                 :y-padding y-padding))
  94
  95 (defmethod pack-child ((w tree-view) child &key)
  96   (tree-view-append-column w child))
  97
  98 (defmethod pack-child ((w tree-view-column) child &key (expand t) attributes)
  99   (tree-view-column-pack-start w child :expand expand)
 100   (iter (for a on attributes by #'cddr)
 101         (tree-view-column-add-attribute w child
 102                                         (first a)
 103                                         (second a))))
 104
 105 (defmethod pack-child ((b toolbar) child &key (expand 'default) (homogeneous 'default))
 106   (toolbar-insert b child -1)
 107   (unless (eq expand 'default)
 108     (container-call-set-property b child "expand" expand +g-type-boolean+))
 109   (unless (eq homogeneous 'default)
 110     (container-call-set-property b child "homogeneous" homogeneous +g-type-boolean+)))
 111
 112 (defun set-ui-expansion-1 (d)
 113   (when (ui-d-class d)
 114     ;; only direct-vars do not have class
 115     (setf (ui-d-var d) (get-ui-d-var d)
 116           (ui-d-initform d) (get-ui-d-initform d))))
 117
 118 (defun set-ui-expansion (description)
 119   (iter (for child in (ui-d-children description))
 120         (set-ui-expansion (ui-child-v child)))
 121   (set-ui-expansion-1 description))
 122
 123 (defun flattened-ui-descriptions (d)
 124   (cons d
 125         (iter (for child in (ui-d-children d))
 126               (when (ui-d-class (ui-child-v child))
 127                 (appending (flattened-ui-descriptions (ui-child-v child)))))))
 128
 129 (defmacro let-ui (ui-description &body body)
 130   (let* ((description (parse-ui-description ui-description))
 131          (items (flattened-ui-descriptions description)))
 132     (set-ui-expansion description)
 133     `(let (,@(iter (for item in items)
 134                    (collect (list (ui-d-var item)
 135                                   (ui-d-initform item)))))
 136        ,@(iter (for item in items)
 137                (appending (iter (for child in (ui-d-children item))
 138                                 (for child-var = (ui-d-var (ui-child-v child)))
 139                                 (let ((props
 140                                        (iter (for p in (ui-child-props child))
 141                                              (appending (list (ui-prop-name p) (ui-prop-value p))))))
 142                                   (collect (list* 'pack-child (ui-d-var item) child-var props))))))
 143
 144        ,@body)))
 145