-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
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
* 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.
@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))}.
@itemize
@end itemize
+@RMethod box-pack-start
+@lisp
+box-pack-start
+@end lisp
@end itemize
+@RMethod paned-pack-1
+@lisp
+paned-pack-1
+@end lisp
+
@node plug
@end itemize
+@RMethod table-attach
+@lisp
+table-attach
+@end lisp
+
@node tearoff-menu-item
(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))
(:file "gtk.high-level")
+ (:file "ui-markup")
+
(:file "gtk.dialog.example")
(:file "gtk.demo")
#:demo-treeview-tree
#:test-custom-window
#:test-assistant
- #:test-entry-completion))
+ #:test-entry-completion
+ #:test-ui-markup))
(in-package :gtk-demo)
(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)))))
#: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)
--- /dev/null
+(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)))
projects / cl-gtk2.git / commitdiff
