[snow-cvs] r40 - in trunk/src/lisp/snow: . showcase swing
Alessio Stalla
astalla at common-lisp.net
Mon Dec 28 20:11:26 UTC 2009
Author: astalla
Date: Mon Dec 28 15:11:25 2009
New Revision: 40
Log:
Merged cells data binding in data-binding.lisp
Changed implementation of simple-data-binding (and thus make-var and var) to use cells. c-expr and c-value are no longer necessary and have been removed.
Added the possibility to query and change the text of text components.
Modified:
trunk/src/lisp/snow/cells.lisp
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/showcase/showcase.lisp
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/swing/swing.lisp
trunk/src/lisp/snow/widgets.lisp
Modified: trunk/src/lisp/snow/cells.lisp
==============================================================================
--- trunk/src/lisp/snow/cells.lisp (original)
+++ trunk/src/lisp/snow/cells.lisp Mon Dec 28 15:11:25 2009
@@ -28,58 +28,3 @@
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
-(in-package :snow)
-
-(defmodel cell-expression ()
- ((expression :initarg :expression :accessor c-value
- :initform (error "expression is mandatory")
- :cell t)))
-
-(defun c-expr (&optional initial-value)
- (make-instance 'cell-expression :expression (c-in initial-value)))
-
-
-(defobserver c-value ((x cell-expression) new-value)
- (format t "nv ~A ~A~%" x new-value))
-
-;;Cellular slot Binding
-(defmodel cell-data-binding (data-binding cells::model-object)
- ((expression :initarg :expression :reader binding-expression
- :initform (error "expression is mandatory")
- :cell t)
- (writer :initarg writer :accessor binding-writer :initform nil :cell nil)
- (model :accessor binding-model :initform nil :cell nil)))
-
-(defmethod initialize-instance :after ((obj cell-data-binding) &rest args)
- (declare (ignore args))
- (setf (binding-model obj)
- (make-cells-value-model obj)))
-
-(defobserver expression ((binding cell-data-binding) new-value)
- (bwhen (it (binding-model binding))
- (invoke "valueChanged" it new-value)))
-
-(defun make-cell-data-binding (expression &optional writer)
- (check-type writer (or null function))
- (let ((instance
- (make-instance 'cell-data-binding :expression expression)))
- (setf (binding-writer instance) writer)
- instance))
-
-(defun make-slot-data-binding (object slot-accessor-name)
- (make-cell-data-binding
- (eval `(c? (,slot-accessor-name ,object)))
- (compile nil `(lambda (x)
- (setf (,slot-accessor-name ,object) x)))))
-
-(defmethod make-model ((binding cell-data-binding))
- (binding-model binding))
-
-(defun make-cells-value-model (binding)
- (new "snow.binding.AccessorBinding"
- binding
- #'binding-expression
- (lambda (value place)
- (declare (ignore place))
- (bwhen (it (binding-writer binding))
- (funcall it value)))))
\ No newline at end of file
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Mon Dec 28 15:11:25 2009
@@ -52,25 +52,60 @@
;;Concrete Binding implementations
-;;Simple Binding
-(defclass simple-data-binding (data-binding)
- ((variable :initarg :variable :reader binding-variable :initform (error "variable is required"))))
-
-(defun make-var (&optional obj)
- (new "com.jgoodies.binding.value.ValueHolder" obj (jbool nil)))
-
-(defun var (var)
- (invoke "getValue" var))
-
-(defun (setf var) (value var)
- (invoke "setValue" var value)
- value)
-
-(defun make-simple-data-binding (variable)
- (make-instance 'simple-data-binding :variable variable))
-
-(defmethod make-model ((binding simple-data-binding))
- (binding-variable binding))
+;;Cellular slot Binding
+(defmodel cell-data-binding (data-binding cells::model-object)
+ ((expression :initarg :expression :reader binding-expression
+ :initform (error "expression is mandatory")
+ :cell t)
+ (writer :initarg writer :accessor binding-writer :initform nil :cell nil)
+ (model :accessor binding-model :initform nil :cell nil)))
+
+(defmethod initialize-instance :after ((obj cell-data-binding) &rest args)
+ (declare (ignore args))
+ (setf (binding-model obj)
+ (make-cells-value-model obj)))
+
+(defobserver expression ((binding cell-data-binding) new-value)
+ (bwhen (it (binding-model binding))
+ (invoke "valueChanged" it new-value)))
+
+(defun make-cell-data-binding (expression &optional writer)
+ (check-type writer (or null function))
+ (let ((instance
+ (make-instance 'cell-data-binding :expression expression)))
+ (setf (binding-writer instance) writer)
+ instance))
+
+(defun make-slot-data-binding (object slot-accessor-name)
+ (make-cell-data-binding
+ (eval `(c? (,slot-accessor-name ,object)))
+ (compile nil `(lambda (x)
+ (setf (,slot-accessor-name ,object) x)))))
+
+(defmethod make-model ((binding cell-data-binding))
+ (binding-model binding))
+
+(defun make-cells-value-model (binding)
+ (new "snow.binding.AccessorBinding"
+ binding
+ #'binding-expression
+ (lambda (value place)
+ (declare (ignore place))
+ (bwhen (it (binding-writer binding))
+ (funcall it value)))))
+
+;;Cells-powered Variable Binding
+(defmodel cell-expression ()
+ ((expression :initarg :expression :accessor var
+ :initform (error "expression is mandatory")
+ :cell t)))
+
+(defun make-var (&optional initial-value)
+ (make-instance 'cell-expression :expression (c-in initial-value)))
+
+(defun make-simple-data-binding (var)
+ (make-cell-data-binding (c? (var var))
+ (lambda (x) (setf (var var) x))))
;;Bean Binding
@@ -129,12 +164,17 @@
(eval (read-from-string bean-name)))
"A callback called by the EL engine with a single argument, the name of a bean to fetch from the application.")
-;;For EL data bindings we reuse simple-data-binding, since its 'variable' can
-;;really be any JGoodies ValueModel
+(defclass value-model ()
+ ((value-model :initarg :value-model :reader value-model)))
+
(defun make-property-data-binding (obj path)
- (make-instance 'simple-data-binding
- :variable (new "snow.binding.BeanPropertyPathBinding"
- obj (apply #'jvector "java.lang.String" path))))
+ (make-instance
+ 'value-model
+ :value-model (new "snow.binding.BeanPropertyPathBinding"
+ obj (apply #'jvector "java.lang.String" path))))
+
+(defmethod make-model ((binding value-model))
+ (value-model binding))
;;Default binding types
(defun default-data-binding-constructors ()
@@ -145,9 +185,6 @@
#+snow-cells
(progn
(setf (gethash 'cell ht) 'make-cell-data-binding)
-;; (setf (gethash 'cells:c? ht)
-;; #'(lambda (&rest args) ;;c? is a macro
-;; (make-cell-data-binding (eval `(cells:c? , at args)))))
(setf (gethash 'slot ht) 'make-slot-data-binding))
ht))
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Mon Dec 28 15:11:25 2009
@@ -59,6 +59,7 @@
#:make-action-listener
;;Common operations on widgets
#:add-child
+ #:child
#:dispose
#:dont-add
#:hide
@@ -74,6 +75,7 @@
#:widget-location
#:widget-property
#:widget-size
+ #:widget-text
#:widget-visible-p
;;Data binding
#:make-var
@@ -104,6 +106,7 @@
#:install-graphical-debugger
#:*parent*
#:self
+ #:str
#:syntax
#:with-gui
#:with-widget
Modified: trunk/src/lisp/snow/showcase/showcase.lisp
==============================================================================
--- trunk/src/lisp/snow/showcase/showcase.lisp (original)
+++ trunk/src/lisp/snow/showcase/showcase.lisp Mon Dec 28 15:11:25 2009
@@ -12,21 +12,21 @@
`(pushnew
(list ,name
(lambda ()
- (let ((,original-code ',body) (,show-source-p (c-expr nil)))
+ (let ((,original-code ',body) (,show-source-p (make-var nil)))
(panel (:layout-manager '(:mig "fill"))
(panel (:layout "hidemode 3"
:visible-p
;;TODO handle booleans more transparently
- $(c? (jbool (not (c-value ,show-source-p)))))
+ $(c? (jbool (not (var ,show-source-p)))))
(panel (:layout-manager '(:mig "fill") :layout "grow, wrap")
, at body)
(button :text "Show source"
:layout "dock south"
:on-action (lambda (evt)
(declare (ignore evt))
- (setf (c-value ,show-source-p) t))))
+ (setf (var ,show-source-p) t))))
(panel (:layout "dock south, hidemode 3"
- :visible-p $(c? (jbool (c-value ,show-source-p))))
+ :visible-p $(c? (jbool (var ,show-source-p))))
(scroll (:layout "grow, wrap")
(text-area :text
,(with-output-to-string (str)
@@ -38,7 +38,7 @@
:layout "dock south"
:on-action (lambda (evt)
(declare (ignore evt))
- (setf (c-value ,show-source-p) nil))))))))
+ (setf (var ,show-source-p) nil))))))))
*examples*
:test #'equal
:key #'car)))
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Mon Dec 28 15:11:25 2009
@@ -35,25 +35,29 @@
(definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints))
+(definterface (setf widget-background) *gui-backend* (value widget))
+
+(definterface (setf widget-border) *gui-backend* (value widget))
+
(definterface widget-enabled-p *gui-backend* (widget))
(definterface (setf widget-enabled-p) *gui-backend* (value widget))
-(definterface widget-visible-p *gui-backend* (widget))
+(definterface (setf widget-font) *gui-backend* (value widget))
-(definterface (setf widget-visible-p) *gui-backend* (value widget))
+(definterface (setf widget-foreground) *gui-backend* (value widget))
(definterface (setf widget-location) *gui-backend* (value widget))
(definterface (setf widget-size) *gui-backend* (value widget))
-(definterface (setf widget-background) *gui-backend* (value widget))
+(definterface widget-text *gui-backend* (widget))
-(definterface (setf widget-border) *gui-backend* (value widget))
+(definterface (setf widget-text) *gui-backend* (value widget))
-(definterface (setf widget-font) *gui-backend* (value widget))
+(definterface widget-visible-p *gui-backend* (widget))
-(definterface (setf widget-foreground) *gui-backend* (value widget))
+(definterface (setf widget-visible-p) *gui-backend* (value widget))
(definterface dispose *gui-backend* (obj))
@@ -191,14 +195,11 @@
:for form :in children
:collect (if (listp form)
(cond
- ((get (car form) 'widget-p)
- `(let ((*parent* self)) ,form))
+ ((get (car form) 'widget-p) form)
(t `(let ((*parent* nil)) ,form)))
form))))
- (if id
- `((let ((,id self))
- , at code))
- code)))
+ `((let (,@(when id `((,id self))) (*parent* self))
+ , at code))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun common-widget-args ()
@@ -291,8 +292,8 @@
(define-widget-macro child
(widget &rest args &key &common-widget-args)
- widget
- `(setup-widget , at args))
+ `(dont-add ,widget)
+ `(setup-widget self , at args))
(defmacro define-widget (name keys constructor &body body)
"Convenience macro for defining a widget."
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Mon Dec 28 15:11:25 2009
@@ -117,17 +117,24 @@
(defimpl (setf widget-foreground) (value widget)
(setf (widget-property widget :foreground) value))
+(defimplementation (setf widget-location) (*gui-backend* :swing) (value widget)
+ (invoke "setLocation" widget (aref value 0) (aref value 1)))
+
+(defimpl (setf widget-size) (value widget)
+ (invoke "setSize" widget (realpart value) (imagpart value)))
+
+(defimpl (setf widget-text) (value widget)
+ (setf (widget-property widget :text) value))
+
+(defimpl widget-text (widget)
+ (widget-property widget :text))
+
(defimpl (setf widget-visible-p) (value widget)
(setf (widget-property widget :visible) value))
(defimpl widget-visible-p (widget)
(widget-property widget :visible))
-(defimplementation (setf widget-location) (*gui-backend* :swing) (value widget)
- (invoke "setLocation" widget (aref value 0) (aref value 1)))
-
-(defimpl (setf widget-size) (value widget)
- (invoke "setSize" widget (realpart value) (imagpart value)))
(defun make-border (border-spec)
(if (jinstance-of-p border-spec "javax.swing.border.Border")
Modified: trunk/src/lisp/snow/widgets.lisp
==============================================================================
--- trunk/src/lisp/snow/widgets.lisp (original)
+++ trunk/src/lisp/snow/widgets.lisp Mon Dec 28 15:11:25 2009
@@ -1,4 +1,3 @@
-
;;; widgets.lisp
;;;
;;; Copyright (C) 2008-2009 Alessio Stalla
More information about the snow-cvs
mailing list