From: Dmitry Kalyanov <Kalyanov.Dmitry@gmail.com>
Date: Sun, 27 Sep 2009 05:56:32 +0000 (+0400)
Subject: Add embedded UI specification language
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=313c905391ae6cfdcb15a0a341db2bd0951e489e;p=cl-gtk2.git

Add embedded UI specification language
---

diff --git a/doc/Makefile b/doc/Makefile
index 7259322..099c2d6 100644
--- a/doc/Makefile
+++ b/doc/Makefile
@@ -1,4 +1,4 @@
-all: doc.html tutorial.html gobject/index.html gtk/index.html gobject/style.css gtk/style.css
+all: doc.html tutorial.html gobject/index.html gtk/index.html gobject/style.css gtk/style.css gtk/let-ui.png gtk/let-ui-glext.png
 
 .PHONY: all archive
 
@@ -27,6 +27,12 @@ gobject/index.html: gobject.texi gobject.ref.texi
 gtk/style.css: style.css
 	([ -x gtk ] || mkdir gtk) && cp $< $@
 
+gtk/let-ui.png: let-ui.png
+	cp $< $@
+
+gtk/let-ui-glext.png: let-ui-glext.png
+	cp $< $@
+
 gtk/index.html: gtk.texi gtk.ref.texi gdk.ref.texi gobject.ref.texi glib.ref.texi gdk.enums.texi \
 gtk.flags.texi gtk.objects.texi gdk.flags.texi gdk.structs.texi gtk.interfaces.texi gtk.widgets.texi gdk.objects.texi \
  gtk.enums.texi gtk.main_loop.texi gtk.structs.texi
diff --git a/doc/gtk.ref.texi b/doc/gtk.ref.texi
index 4b159af..e3ed077 100644
--- a/doc/gtk.ref.texi
+++ b/doc/gtk.ref.texi
@@ -6,6 +6,7 @@
 * Gtk+ Structs::
 * Gtk+ Enums::
 * Gtk+ Flags::
+* Gtk+ Embedded UI Mini-language::
 @end menu
 
 All symbols of Gtk+ binding in cl-gtk2 reside in @code{gtk} package.
@@ -44,3 +45,104 @@ All symbols of Gtk+ binding in cl-gtk2 reside in @code{gtk} package.
 @chapter Gtk+ Flags
 
 @include gtk.flags.texi
+
+@node Gtk+ Embedded UI Mini-language
+@chapter Gtk+ Embedded UI Mini-language
+
+For convenience of specifying widgets hierarchy in Lisp code, the @ref{let-ui} macro is introduced.
+
+@RMacro let-ui
+@lisp
+(let-ui ui-description &body body)
+
+ui-description ::= widget
+widget ::= (class properties child*)
+properties ::= @{:prop-name prop-value@}*
+child ::= widget properties
+child ::= (:expr expr) properties
+@end lisp
+
+@table @var
+@item @var{class}
+Name of class of a widget
+@item @var{:prop-name}
+Name of class's slot or a @code{:var} for specifying the variable name to which the object will be bound
+@item @var{prop-value}
+A Lisp expression that will be evaluated to obtain the initarg for slot of a class; or a symbol if @code{:prop-name} is @code{:var}
+@item @var{expr}
+An expression that will be evaluated to obtain the widget
+@end table
+
+This macro creates widgets and evaluates the @var{body}. Widgets that have @code{:var} specified are bound to lexical variables with specified names.
+
+@var{ui-description} specifies the hierarchy of widgets in a window. It can specify either the entire top-level window or other kind of widgets. @var{ui-description} is a mini-language for specifying widgets. @ref{let-ui} creates specified widgets, lexically binds specified variables to widgets and evaluates the @var{body}. The @var{body} my refer to these widgets.
+
+@var{widget} is the specification of a single widget. It may specify some properties (slots of objects) and their values (the expressions to be evaluated), a variable name that will be bound to the widget (the @code{:var} property whose @var{prop-value} must be a symbol) and widget's children.
+
+@var{class} specifies the class of the widget (e.g., @ref{label}, @ref{button}, @ref{gtk-window}). @var{:prop-name} may be any slot of the class. If @var{:var} property is specified, then corresponding variable is accessible in @var{body} and its value is the widget on which it is specified as @var{:var}.
+
+Container widgets may specify their @var{children} along with their @var{child properties}. Child properties specify how @var{children} are used in @var{widget}. They are specific to the type of the container:
+@itemize
+@item @ref{box} specifies @code{:expand}, @code{:fill}. See @ref{box-pack-start} for information.
+@item @ref{paned} specifies @code{:resize}, @code{:shrink}. See @ref{paned-pack-1} for information.
+@item @ref{table} specifies @code{:left}, @code{:right}, @code{:top}, @code{:bottom}, @code{:x-options}, @code{:y-options}, @code{x-padding}, @code{y-padding}. Of these, @code{:left}, @code{:right}, @code{:top} and @code{:bottom} are mandatory. See @ref{table-attach} for information.
+@end itemize
+
+An example:
+@lisp
+(let-ui (gtk-window :title "Hello" :position :center :var w
+                    (v-box
+                     (label :label "Hello, world!")
+                     (button :label "gtk-ok" :use-stock t) :expand nil))
+  (widget-show w))
+@end lisp
+produces this output:
+
+@image{let-ui,,,,png}
+
+More complex example from demo of cl-gtk2-gtk-glext:
+@lisp
+(let-ui (v-paned :var v
+                 (:expr (opengl-window-drawing-area window))
+                 :resize t :shrink nil
+                 (v-box
+                  (h-paned
+                   (scrolled-window
+                    :hscrollbar-policy :automatic
+                    :vscrollbar-policy :automatic
+                    (:expr (opengl-window-expose-fn-text-view window)))
+                   :resize t :shrink nil
+                   (scrolled-window
+                    :hscrollbar-policy :automatic
+                    :vscrollbar-policy :automatic
+                    (:expr (opengl-window-resize-fn-text-view window)))
+                   :resize t :shrink nil)
+                  (h-box
+                   (button :label "Update functions" :var update-fns-button) :expand nil
+                   (button :label "Redraw" :var redraw-button) :expand nil)
+                  :expand nil)
+                 :resize t :shrink nil)
+  (container-add window v)
+  (connect-signal update-fns-button "clicked"
+                  (lambda (b)
+                    (declare (ignore b))
+                    (update-fns window)))
+  (connect-signal redraw-button "clicked"
+                  (lambda (b)
+                    (declare (ignore b))
+                    (widget-queue-draw (opengl-window-drawing-area window))))
+  (let ((area (opengl-window-drawing-area window)))
+    (setf (gl-drawing-area-on-expose area)
+          (lambda (w e)
+            (declare (ignore w e))
+            (opengl-interactive-on-expose window))
+          (gl-drawing-area-on-resize area)
+          (lambda (widget w h)
+            (declare (ignore widget))
+            (opengl-interactive-on-resize window w h)))))
+@end lisp
+produces this output:
+
+@image{let-ui-glext,,,,png}
+
+In this example, not top-level window, but a widget is created and then added to already existing window. This UI also uses some already created widgets: @code{(:expr (opengl-window-resize-fn-text-view window))}.
diff --git a/doc/gtk.widgets.texi b/doc/gtk.widgets.texi
index 0966de9..7c4604f 100644
--- a/doc/gtk.widgets.texi
+++ b/doc/gtk.widgets.texi
@@ -427,6 +427,10 @@ Signals:
 @itemize
 @end itemize
 
+@RMethod box-pack-start
+@lisp
+box-pack-start
+@end lisp
 
 
 
@@ -3076,6 +3080,11 @@ Signals:
 @end itemize
 
 
+@RMethod paned-pack-1
+@lisp
+paned-pack-1
+@end lisp
+
 
 
 @node plug
@@ -3730,6 +3739,11 @@ Signals:
 @end itemize
 
 
+@RMethod table-attach
+@lisp
+table-attach
+@end lisp
+
 
 
 @node tearoff-menu-item
diff --git a/doc/let-ui-glext.png b/doc/let-ui-glext.png
new file mode 100644
index 0000000..5099277
Binary files /dev/null and b/doc/let-ui-glext.png differ
diff --git a/doc/let-ui.png b/doc/let-ui.png
new file mode 100644
index 0000000..4138dab
Binary files /dev/null and b/doc/let-ui.png differ
diff --git a/gtk-glext/demo.lisp b/gtk-glext/demo.lisp
index ed1cd6d..1efbde7 100644
--- a/gtk-glext/demo.lisp
+++ b/gtk-glext/demo.lisp
@@ -141,29 +141,27 @@
         (text-buffer-text (text-view-buffer (opengl-window-resize-fn-text-view window)))
         ";; Resize-fn. Parameters: w h
 ")
-  (let ((v (make-instance 'v-paned))
-        (lower-v-box (make-instance 'v-box))
-        (h (make-instance 'h-paned))
-        (buttons (make-instance 'h-box))
-        (update-fns-button (make-instance 'button :label "Update functions"))
-        (redraw-button (make-instance 'button :label "Redraw")))
+  (let-ui (v-paned :var v
+                   (:expr (opengl-window-drawing-area window))
+                   :resize t :shrink nil
+                   (v-box
+                    (h-paned
+                     (scrolled-window
+                      :hscrollbar-policy :automatic
+                      :vscrollbar-policy :automatic
+                      (:expr (opengl-window-expose-fn-text-view window)))
+                     :resize t :shrink nil
+                     (scrolled-window
+                      :hscrollbar-policy :automatic
+                      :vscrollbar-policy :automatic
+                      (:expr (opengl-window-resize-fn-text-view window)))
+                     :resize t :shrink nil)
+                    (h-box
+                     (button :label "Update functions" :var update-fns-button) :expand nil
+                     (button :label "Redraw" :var redraw-button) :expand nil)
+                    :expand nil)
+                   :resize t :shrink nil)
     (container-add window v)
-    (paned-pack-1 v (opengl-window-drawing-area window) :resize t :shrink nil)
-    (paned-pack-2 v lower-v-box :resize t :shrink nil)
-    (box-pack-start lower-v-box h)
-    (let ((scrolled (make-instance 'scrolled-window
-                                   :hscrollbar-policy :automatic
-                                   :vscrollbar-policy :automatic)))
-      (container-add scrolled (opengl-window-expose-fn-text-view window))
-      (paned-pack-1 h scrolled :resize t :shrink nil))
-    (let ((scrolled (make-instance 'scrolled-window
-                                   :hscrollbar-policy :automatic
-                                   :vscrollbar-policy :automatic)))
-      (container-add scrolled (opengl-window-resize-fn-text-view window))
-      (paned-pack-2 h scrolled :resize t :shrink nil))
-    (box-pack-start lower-v-box buttons :expand nil)
-    (box-pack-start buttons update-fns-button :expand nil)
-    (box-pack-start buttons redraw-button :expand nil)
     (connect-signal update-fns-button "clicked"
                     (lambda (b)
                       (declare (ignore b))
diff --git a/gtk/cl-gtk2-gtk.asd b/gtk/cl-gtk2-gtk.asd
index 98e72a1..6dd4847 100644
--- a/gtk/cl-gtk2-gtk.asd
+++ b/gtk/cl-gtk2-gtk.asd
@@ -56,6 +56,8 @@
                
                (:file "gtk.high-level")
 
+               (:file "ui-markup")
+
                (:file "gtk.dialog.example")
                
                (:file "gtk.demo")
diff --git a/gtk/gtk.demo.lisp b/gtk/gtk.demo.lisp
index e9bb59c..14ef3ec 100644
--- a/gtk/gtk.demo.lisp
+++ b/gtk/gtk.demo.lisp
@@ -27,7 +27,8 @@
            #:demo-treeview-tree
            #:test-custom-window
            #:test-assistant
-           #:test-entry-completion))
+           #:test-entry-completion
+           #:test-ui-markup))
 
 (in-package :gtk-demo)
 
@@ -922,3 +923,39 @@
                                 (funcall fn))))
             (box-pack-start v-box-buttons button :expand nil))
       (widget-show window))))
+
+(defun test-ui-markup ()
+  (within-main-loop
+    (let ((label (make-instance 'label :label "Hello!")))
+      (let-ui (gtk-window :type :toplevel
+                          :position :center
+                          :title "Hello, world!"
+                          :default-width 300
+                          :default-height 400
+                          :var w
+                          (v-box
+                           (:expr label) :expand nil
+                           (scrolled-window
+                            :hscrollbar-policy :automatic
+                            :vscrollbar-policy :automatic
+                            :shadow-type :etched-in
+                            (text-view :var tv))
+                           (h-box
+                            (label :label "Insert:") :expand nil
+                            (entry :var entry)
+                            (button :label "gtk-ok" :use-stock t :var btn) :expand nil)
+                           :expand nil
+                           (label :label "Table packing")
+                           :expand nil
+                           (table
+                            :n-columns 2
+                            :n-rows 2
+                            (label :label "2 x 1") :left 0 :right 2 :top 0 :bottom 1
+                            (label :label "1 x 1") :left 0 :right 1 :top 1 :bottom 2
+                            (label :label "1 x 1") :left 1 :right 2 :top 1 :bottom 2)))
+        (connect-signal btn "clicked"
+                        (lambda (b)
+                          (declare (ignore b))
+                          (text-buffer-insert (text-view-buffer tv)
+                                              (entry-text entry))))
+        (widget-show w)))))
diff --git a/gtk/gtk.package.lisp b/gtk/gtk.package.lisp
index 228a76f..7f07f35 100644
--- a/gtk/gtk.package.lisp
+++ b/gtk/gtk.package.lisp
@@ -23,7 +23,8 @@
            #:tree-lisp-store-add-column
            #:gtk-main-add-timeout
            #:gtk-call-aborted
-           #:gtk-call-aborted-condition))
+           #:gtk-call-aborted-condition
+           #:let-ui))
 
 (defpackage :gtk-examples
   (:use :cl :gtk :gdk :gobject)
diff --git a/gtk/ui-markup.lisp b/gtk/ui-markup.lisp
new file mode 100644
index 0000000..8bb13bc
--- /dev/null
+++ b/gtk/ui-markup.lisp
@@ -0,0 +1,148 @@
+(in-package :gtk)
+
+(defstruct ui-d class props children expansion var initform initializer)
+
+(defstruct ui-prop name value)
+
+(defstruct ui-child v props)
+
+(defun parse-ui-props (list)
+  ;; list is ({:prop value}* rest)
+  (iter (for x first list then (cddr x))
+        (while (keywordp (first x)))
+        (for (name value) = x)
+        (collect (make-ui-prop :name name :value value) into props)
+        (finally (return (values props x)))))
+
+(defun parse-ui-children (list)
+  ;; list is (child*)
+  ;; child is {ui {:prop value}*}
+  (iter (while list)
+        (for child = (if (eq :expr (first (first list)))
+                         (make-ui-d :var (second (first list)))
+                         (parse-ui-description (first list))))
+        (for (values props rest) = (parse-ui-props (rest list)))
+        (setf list rest)
+        (collect (make-ui-child :v child :props props))))
+
+(defun parse-ui-description (description)
+  ;; description is (class {:prop value}* child*)
+  ;; child is {ui {:prop value}*}
+  (let ((class (first description)))
+    (multiple-value-bind (props rest) (parse-ui-props (rest description))
+      (let ((children (parse-ui-children rest)))
+        (make-ui-d :class class :props props :children children)))))
+
+(defun get-ui-d-var (d)
+  (let ((prop (find :var (ui-d-props d) :key #'ui-prop-name)))
+    (if prop
+        (ui-prop-value prop)
+        (gensym (format nil "~A-" (symbol-name (ui-d-class d)))))))
+
+(defun get-ui-d-initform (d)
+  `(make-instance ',(ui-d-class d)
+                  ,@(iter (for prop in (ui-d-props d))
+                          (unless (eq (ui-prop-name prop) :var)
+                            (appending (list (ui-prop-name prop) (ui-prop-value prop)))))))
+
+(defvar *ui-child-packers* (make-hash-table))
+
+(defmacro def-ui-child-packer (class (var child-def child) &body body)
+  `(setf (gethash ',class *ui-child-packers*)
+         (lambda (,var ,child-def ,child) ,@body)))
+
+(def-ui-child-packer container (w d child)
+  (declare (ignore d))
+  `(container-add ,w ,child))
+
+(defun get-ui-child-prop-value (d name required-p context)
+  (let ((prop (find name (ui-child-props d) :key #'ui-prop-name)))
+    (if (and required-p (null prop))
+        (error "~A is a mandatory child property for ~A" name context)
+        (when prop (ui-prop-value prop)))))
+
+(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))))))
+
+(def-ui-child-packer paned (p d child)
+  (let ((resize-prop (find :resize (ui-child-props d) :key #'ui-prop-name))
+        (shrink-prop (find :shrink (ui-child-props d) :key #'ui-prop-name)))
+    `(if (null (paned-child-1 ,p))
+         (paned-pack-1 ,p ,child
+                       ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
+                       ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop))))
+         (paned-pack-2 ,p ,child
+                       ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
+                       ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop)))))))
+
+(def-ui-child-packer table (table d child)
+  `(table-attach ,table ,child
+                 ,(get-ui-child-prop-value d :left t "table packing")
+                 ,(get-ui-child-prop-value d :right t "table packing")
+                 ,(get-ui-child-prop-value d :top t "table packing")
+                 ,(get-ui-child-prop-value d :bottom t "table packing")
+                 ,@(let ((x-options (get-ui-child-prop-value d :x-options nil nil)))
+                        (when x-options
+                          (list :x-options x-options)))
+                 ,@(let ((y-options (get-ui-child-prop-value d :y-options nil nil)))
+                        (when y-options
+                          (list :y-options y-options)))
+                 ,@(let ((x-padding (get-ui-child-prop-value d :x-padding nil nil)))
+                        (when x-padding
+                          (list :x-padding x-padding)))
+                 ,@(let ((y-padding (get-ui-child-prop-value d :y-padding nil nil)))
+                        (when y-padding
+                          (list :y-padding y-padding)))))
+
+(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)
+        (for packer = (gethash (class-name class) *ui-child-packers*))
+        (when packer (return packer))))
+
+(defun get-child-packer (d var)
+  (let ((fn (get-child-packer-fn d)))
+    (when fn
+      (let ((forms (iter (for child in (ui-d-children d))
+                         (for child-var = (ui-d-var (ui-child-v child)))
+                         (collect (funcall fn var child child-var)))))
+        (when forms (cons 'progn forms))))))
+
+(defun get-ui-d-initializer (d var)
+  (get-child-packer d var))
+
+(defun set-ui-expansion-1 (d)
+  (when (ui-d-class d)
+    ;; only direct-vars do not have class
+    (setf (ui-d-var d) (get-ui-d-var d)
+          (ui-d-initform d) (get-ui-d-initform d))
+    (setf (ui-d-initializer d) (get-ui-d-initializer d (ui-d-var d)))))
+
+(defun set-ui-expansion (description)
+  (iter (for child in (ui-d-children description))
+        (set-ui-expansion (ui-child-v child)))
+  (set-ui-expansion-1 description))
+
+(defun flattened-ui-descriptions (d)
+  (cons d
+        (iter (for child in (ui-d-children d))
+              (when (ui-d-class (ui-child-v child))
+                (appending (flattened-ui-descriptions (ui-child-v child)))))))
+
+(defmacro let-ui (ui-description &body body)
+  (let* ((description (parse-ui-description ui-description))
+         (items (flattened-ui-descriptions description)))
+    (set-ui-expansion description)
+    `(let (,@(iter (for i in items)
+                   (collect (list (ui-d-var i)
+                                  (ui-d-initform i)))))
+       ,@(iter (for i in items)
+               (when (ui-d-initializer i)
+                 (collect (ui-d-initializer i))))
+       ,@body)))