[snow-cvs] r13 - in trunk: lib src/java/snow/binding src/java/snow/example src/java/snow/list src/lisp/snow
Alessio Stalla
astalla at common-lisp.net
Tue Nov 3 21:50:33 UTC 2009
Author: astalla
Date: Tue Nov 3 16:50:33 2009
New Revision: 13
Log:
Updated to latest abcl for nicer printing of stack frames
Enhanced debugger to show the backtrace and current condition
Fixed "EL" syntax
Fixed example
Exported more symbols
Modified:
trunk/lib/abcl.jar
trunk/src/java/snow/binding/BeanPropertyPathBinding.java
trunk/src/java/snow/example/example.lisp
trunk/src/java/snow/list/ConsListCellRenderer.java
trunk/src/lisp/snow/cells.lisp
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/debugger.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/snow.lisp
Modified: trunk/lib/abcl.jar
==============================================================================
Binary files. No diff available.
Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java
==============================================================================
--- trunk/src/java/snow/binding/BeanPropertyPathBinding.java (original)
+++ trunk/src/java/snow/binding/BeanPropertyPathBinding.java Tue Nov 3 16:50:33 2009
@@ -78,6 +78,9 @@
throw new RuntimeException(e);
}
PropertyDescriptor pd = getPropertyDescriptor(oClass, propertyName);
+ if(pd == null) {
+ throw new RuntimeException("Property " + propertyName + " not found in " + oClass);
+ }
reader = pd.getReadMethod();
writer = pd.getWriteMethod();
if(nextPropertyPath.length > 0) {
Modified: trunk/src/java/snow/example/example.lisp
==============================================================================
--- trunk/src/java/snow/example/example.lisp (original)
+++ trunk/src/java/snow/example/example.lisp Tue Nov 3 16:50:33 2009
@@ -1,67 +1,63 @@
-(in-package :snow)
+(in-package :snow-user)
(in-readtable snow:syntax)
(defmodel my-model ()
((a :accessor aaa :initform (c-in "4"))
(b :accessor bbb :initform (c? (concatenate 'string (aaa self) "2")))))
-(defvar *object* (new "snow.example.SnowExample"))
+(defvar *bean* (new "snow.example.SnowExample"))
(defvar *variable* (make-var "42"))
(defvar *cells-object* (make-instance 'my-model))
-(setq *bean-factory* #'(lambda (x) ;dummy
- (declare (ignore x))
- *object*))
(with-gui (:swing)
- (let ((myframe
- (frame (:id frame-id :title "Sample JFrame" :visible-p t)
- (tree :model (make-tree-model '(1 2 (c (a b)) 3)))
- (button :text "push me"
- :on-action (lambda (event)
- (princ "Thanks for pushing me! ")
- (format t "My parent is ~A~%" frame-id)
- (finish-output)))
- (scroll (:layout "grow")
- (list-widget :model (make-list-model '(1 2 (c (a b)) 3))
- :prototype-cell-value "abcdefghijklmnopq"))
- (panel (:layout-manager :border :layout "wrap")
- (button :text "borderlayout - center")
- (button :text "borderlayout - east"
- :layout (jfield "java.awt.BorderLayout" "EAST")))
- (scroll ()
- (panel ()
- (label :text "bean binding")
- (label :binding (make-bean-data-binding *object* "property1")
- :layout "wrap")
- (label :text "EL binding")
- (label :binding ${bean.nested.property1}
- :layout "wrap")
- (label :text "cells bindings: aaa and bbb")
- (label :binding (make-cells-data-binding (c? (aaa *cells-object*))))
- (label :binding (make-cells-data-binding (c? (bbb *cells-object*)))
- :layout "wrap")
- (label :text "simple binding to a variable")
- (label :binding (make-simple-data-binding *variable*)
- :layout "wrap")
- (button :text "another one" :layout "wrap")
- (label :text "set property1")
- (text-field :binding (make-bean-data-binding *object* "property1")
- :layout "growx, wrap")
- (label :text "set nested.property1")
- (text-field :binding ${bean.nested.property1}
- :layout "growx, wrap")
- (button :text "Test!"
- :layout "wrap"
- :on-action (lambda (event)
- (setf (jproperty-value *object* "property1")
- "Test property")
- (setf (jproperty-value
- (jproperty-value *object* "nested")
- "property1")
- "Nested property")
- (setf (var *variable*) "Test var")
- (setf (aaa *cells-object*) "Test cell"))))))))
- (pack myframe)))
+ (frame (:id frame :title "Sample JFrame" :visible-p t)
+ (tree :model (make-tree-model '(1 2 (c (a b)) 3)))
+ (button :text "push me"
+ :on-action (lambda (event)
+ (princ "Thanks for pushing me! ")
+ (format t "My parent is ~A~%" frame)
+ (finish-output)))
+ (scroll (:layout "grow")
+ (list-widget :model (make-list-model '(1 2 (c (a b)) 3))
+ :prototype-cell-value "abcdefghijklmnopq"))
+ (panel (:layout-manager :border :layout "wrap")
+ (button :text "borderlayout - center")
+ (button :text "borderlayout - east"
+ :layout (jfield "java.awt.BorderLayout" "EAST")))
+ (scroll ()
+ (panel ()
+ (label :text "bean binding")
+ (label :binding ${*bean*.property1}
+ :layout "wrap")
+ (label :text "EL binding")
+ (label :binding ${*bean*.nested.property1}
+ :layout "wrap")
+ (label :text "cells bindings: aaa and bbb")
+ (label :binding $(c? (aaa *cells-object*)))
+ (label :binding $(cell (c? (bbb *cells-object*)))
+ :layout "wrap")
+ (label :text "simple binding to a variable")
+ (label :binding $*variable*
+ :layout "wrap")
+ (button :text "another one" :layout "wrap")
+ (label :text "set property1")
+ (text-field :binding ${*bean*.property1}
+ :layout "growx, wrap")
+ (label :text "set nested.property1")
+ (text-field :binding ${*bean*.nested.property1}
+ :layout "growx, wrap")
+ (button :text "Test!"
+ :layout "wrap"
+ :on-action (lambda (event)
+ (setf (jproperty-value *bean* "property1")
+ "Test property")
+ (setf (jproperty-value
+ (jproperty-value *bean* "nested")
+ "property1")
+ "Nested property")
+ (setf (var *variable*) "Test var")
+ (setf (aaa *cells-object*) "Test cell")))))
+ (pack frame)))
(let ((fr (frame (:title "pippo" :visible-p t)
(panel (:layout "wrap")
@@ -70,9 +66,9 @@
:on-action (lambda (event)
(print "Hello, world!")
(print event)))
- (text-field :binding (make-bean-data-binding *object* "property1"))
+ (text-field :binding (make-bean-data-binding *bean* "property1"))
(text-field :binding
- (make-cells-data-binding (c? (aaa *cells-object*))
+ (make-cell-data-binding (c? (aaa *cells-object*))
#'(lambda (x)
(setf (aaa *cells-object*) x))))
(text-field :binding (make-slot-data-binding *cells-object* 'aaa))
Modified: trunk/src/java/snow/list/ConsListCellRenderer.java
==============================================================================
--- trunk/src/java/snow/list/ConsListCellRenderer.java (original)
+++ trunk/src/java/snow/list/ConsListCellRenderer.java Tue Nov 3 16:50:33 2009
@@ -37,34 +37,32 @@
import javax.swing.DefaultListCellRenderer;
import javax.swing.JList;
-import org.armedbear.lisp.ConditionThrowable;
-import org.armedbear.lisp.Function;
-import org.armedbear.lisp.LispObject;
+import org.armedbear.lisp.*;
public class ConsListCellRenderer extends DefaultListCellRenderer {
- private Function function = null;
-
- public ConsListCellRenderer() {
- }
-
- public ConsListCellRenderer(Function fn) {
- this.function = fn;
- }
-
- @Override
- public Component getListCellRendererComponent(JList list, Object value,
- int index, boolean isSelected, boolean cellHasFocus) {
- Object retVal;
- try {
- retVal = function != null && value instanceof LispObject ? function.execute((LispObject) value) : value;
- if(retVal instanceof LispObject) {
- retVal = ((LispObject) retVal).writeToString();
- }
- } catch (ConditionThrowable e) {
- throw new RuntimeException(e);
- }
- return super.getListCellRendererComponent(list, retVal, index, isSelected, cellHasFocus);
+ private LispObject function = null;
+
+ public ConsListCellRenderer() {}
+
+ public ConsListCellRenderer(LispObject fn) {
+ this.function = fn;
+ }
+
+ @Override
+ public Component getListCellRendererComponent(JList list, Object value,
+ int index, boolean selected,
+ boolean cellHasFocus) {
+ Object retVal;
+ try {
+ retVal = function != null && value instanceof LispObject ? function.execute((LispObject) value) : value;
+ if(retVal instanceof LispObject) {
+ retVal = ((LispObject) retVal).writeToString();
+ }
+ } catch (ConditionThrowable e) {
+ throw new RuntimeException(e);
}
+ return super.getListCellRendererComponent(list, retVal, index, selected, cellHasFocus);
+ }
}
Modified: trunk/src/lisp/snow/cells.lisp
==============================================================================
--- trunk/src/lisp/snow/cells.lisp (original)
+++ trunk/src/lisp/snow/cells.lisp Tue Nov 3 16:50:33 2009
@@ -31,36 +31,36 @@
(in-package :snow)
;;Cellular slot Binding
-(defmodel cells-data-binding (data-binding cells::model-object)
+(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 cells-data-binding) &rest args)
+(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 cells-data-binding) new-value)
+(defobserver expression ((binding cell-data-binding) new-value)
(bwhen (it (binding-model binding))
(invoke "valueChanged" it new-value)))
-(defun make-cells-data-binding (expression &optional writer)
+(defun make-cell-data-binding (expression &optional writer)
(check-type writer (or null function))
(let ((instance
- (make-instance 'cells-data-binding :expression expression)))
+ (make-instance 'cell-data-binding :expression expression)))
(setf (binding-writer instance) writer)
instance))
(defun make-slot-data-binding (object slot-accessor-name)
- (make-cells-data-binding
+ (make-cell-data-binding
(eval `(c? (,slot-accessor-name ,object)))
(compile nil `(lambda (x)
(setf (,slot-accessor-name ,object) x)))))
-(defmethod make-model ((binding cells-data-binding))
+(defmethod make-model ((binding cell-data-binding))
(binding-model binding))
(defun make-cells-value-model (binding)
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Tue Nov 3 16:50:33 2009
@@ -99,31 +99,34 @@
(apply #'make-instance 'bean-data-binding :object object :property property
args))
+(defconstant +presentation-model-class+
+ (jclass "com.jgoodies.binding.PresentationModel"))
+
+(defun presentation-model-p (obj)
+ (jinstance-of-p obj +presentation-model-class+))
+
(defmethod make-model ((binding bean-data-binding))
- (let ((presentation-model-class
- (jclass "com.jgoodies.binding.PresentationModel")))
- (if (jinstance-of-p (binding-object binding) presentation-model-class)
- (if (binding-buffered-p binding)
- (jcall (jmethod presentation-model-class
- "getBufferedModel" "java.lang.String")
- (binding-object binding)
- (dashed->camelcased (binding-property binding)))
- (jcall (jmethod presentation-model-class
- "getModel" "java.lang.String")
- (binding-object binding)
- (dashed->camelcased (binding-property binding))))
+ (if (presentation-model-p (binding-object binding))
+ (if (binding-buffered-p binding)
+ (jcall (jmethod +presentation-model-class+
+ "getBufferedModel" "java.lang.String")
+ (binding-object binding)
+ (dashed->camelcased (binding-property binding)))
+ (jcall (jmethod +presentation-model-class+
+ "getModel" "java.lang.String")
+ (binding-object binding)
+ (dashed->camelcased (binding-property binding))))
(jnew (jconstructor "com.jgoodies.binding.beans.PropertyAdapter"
"java.lang.Object" "java.lang.String"
"boolean")
(binding-object binding)
(dashed->camelcased (binding-property binding))
- (jbool (binding-observed-p binding))))))
+ (jbool (binding-observed-p binding)))))
;;EL data binding
(defvar *bean-factory*
#'(lambda (bean-name)
- (declare (ignore bean-name))
- (error "No bean factory defined - please bind *bean-factory*"))
+ (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
@@ -133,42 +136,53 @@
:variable (new "snow.binding.BeanPropertyPathBinding"
obj (apply #'jvector "java.lang.String" path))))
+;;Default binding types
+(defun default-data-binding-constructors ()
+ (let ((ht (make-hash-table)))
+ (setf (gethash 'simple ht) 'make-simple-data-binding)
+ (setf (gethash 'var ht) 'make-simple-data-binding)
+ (setf (gethash 'bean ht) 'make-bean-data-binding)
+ #+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))
+
+(defparameter *binding-constructors* (default-data-binding-constructors))
+
+(defun make-data-binding (type &rest options)
+ (apply (gethash type *binding-constructors*) options))
+
(defun make-el-data-binding-from-expression (el-expr)
(let* ((splitted-expr (split-sequence #\. el-expr))
(obj (funcall *bean-factory* (car splitted-expr)))
(path (cdr splitted-expr)))
(if path
- (make-property-data-binding obj path)
+ (if (and (presentation-model-p obj) (null (cdr path)))
+ (make-bean-data-binding obj (car path))
+ (make-property-data-binding obj path))
(make-simple-data-binding (make-var obj)))))
+;(load "src/java/snow/example/example")
+
(defreadtable snow:syntax
(:merge :standard)
- (:macro-char #\$ :dispatch)
- (:dispatch-macro-char
- #\$ #\{
- #'(lambda (stream char number)
- (declare (ignore char number))
- `(make-el-data-binding-from-expression
- ,(with-output-to-string (str)
- (loop
- :for ch := (read-char stream) :then (read-char stream)
- :until (char= ch #\})
- :do (write-char ch str)))))))
-
-;;Default binding types
-#|(defun default-data-binding-types ()
- (let ((ht (make-hash-table)))
- (setf (gethash :simple ht) 'simple-data-binding)
- (setf (gethash :bean ht) 'bean-data-binding)
- ht))
-
-(defparameter *binding-types* (default-data-binding-types))
-
-(defun get-data-binding-class (binding-type)
- (if (keywordp binding-type)
- (gethash binding-type *binding-types*)
- binding-type))
-
-(defun make-data-binding (type &rest options)
- (apply #'make-instance (get-data-binding-class type) options))
-|#
\ No newline at end of file
+ (:macro-char #\$
+ #'(lambda (stream char)
+ (declare (ignore char))
+ (case (peek-char nil stream)
+ (#\{
+ (read-char stream) ;;consume the #\{ character
+ `(make-el-data-binding-from-expression
+ ,(with-output-to-string (str)
+ (loop
+ :for ch := (read-char stream) :then (read-char stream)
+ :until (char= ch #\})
+ :do (write-char ch str)))))
+ (#\(
+ (let ((list (read stream)))
+ `(make-data-binding ',(car list) ,@(cdr list))))
+ (t `(make-simple-data-binding ,(read stream)))))))
Modified: trunk/src/lisp/snow/debugger.lisp
==============================================================================
--- trunk/src/lisp/snow/debugger.lisp (original)
+++ trunk/src/lisp/snow/debugger.lisp Tue Nov 3 16:50:33 2009
@@ -41,27 +41,57 @@
:model (make-list-model
(mapcar (lambda (restart)
(format nil "~A" (restart-name restart)))
- restarts)))))
- (dialog (:id dlg :title "Condition signaled" :modal-p t)
- (label
- :layout "wrap"
- :text (format nil
- "Debugger invoked on condition of type ~A:"
- (type-of condition)))
- (label :layout "wrap" :text (format nil "~A" condition))
- (label :layout "wrap" :text "Available restarts:")
- (scroll (:layout "grow, wrap") list)
- (button :text "Ok"
- :on-action (lambda (evt)
- (declare (ignore evt))
- (when (>= (widget-property list :selected-index) 0)
- (dispose dlg))))
- (pack dlg)
- (show dlg))
- (let ((*query-io* (make-dialog-prompt-stream)))
- (when (>= (widget-property list :selected-index) 0)
- (invoke-restart-interactively
- (nth (widget-property list :selected-index) restarts))))))
+ restarts))))
+ (backtrace (system:backtrace)))
+ (dont-add ;;So that the debugger can be invoked when *parent* is not nil
+ (dialog (:id dlg :title "Condition signaled" :modal-p t)
+ (label
+ :layout "wrap"
+ :text (format nil
+ "Debugger invoked on condition of type ~A:"
+ (type-of condition)))
+ (label :layout "wrap" :text (format nil "~A" condition))
+ (label :layout "wrap" :text "Available restarts:")
+ (scroll (:layout "grow, wrap") list)
+ (panel ()
+ (button :text "Ok"
+ :on-action (lambda (evt)
+ (declare (ignore evt))
+ (when
+ (>= (widget-property list :selected-index) 0)
+ (dispose dlg))))
+ (button :text "Backtrace"
+ :on-action
+ (lambda (evt)
+ (declare (ignore evt))
+ (dialog (:id dlg :title "Backtrace" :modal-p t)
+ (scroll (:layout "wrap")
+ (list-widget :model (make-list-model backtrace)))
+ (button :text "Ok"
+ :on-action (lambda (evt)
+ (declare (ignore evt))
+ (dispose dlg)))
+ (pack dlg)
+ (show dlg))))
+ (button :text "Condition"
+ :on-action
+ (lambda (evt)
+ (declare (ignore evt))
+ (dialog (:id dlg :title "Condition" :modal-p t)
+ (scroll (:layout "wrap")
+ (text-area :text (sys::%format nil "~A" condition)))
+ (button :text "Ok"
+ :on-action (lambda (evt)
+ (declare (ignore evt))
+ (dispose dlg)))
+ (pack dlg)
+ (show dlg)))))
+ (pack dlg)
+ (show dlg))
+ (let ((*query-io* (make-dialog-prompt-stream)))
+ (when (>= (widget-property list :selected-index) 0)
+ (invoke-restart-interactively
+ (nth (widget-property list :selected-index) restarts)))))))
(defun install-graphical-debugger ()
(let ((old-debugger-hook *debugger-hook*))
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Tue Nov 3 16:50:33 2009
@@ -37,21 +37,37 @@
#:button
#:frame
#:label
+ #:list-widget
#:panel
+ #:scroll
#:text-area
#:text-field
+ #:tree
+ ;;Models
+ #:make-list-model
+ #:make-tree-model
;;Common operations on widgets
+ #:add-child
+ #:dont-add
#:hide
#:pack
#:show
;;Data binding
#:make-var
+ #:make-bean-data-binding
+ #:make-cell-data-binding
+ #:make-simple-data-binding
+ #:make-slot-data-binding
#:var
+ #:bean
+ #:cell
+ #:slot
;;Various
#:install-graphical-debugger
#:*parent*
#:self
#:syntax
+ #:with-gui
#:with-widget
;;Java
#:invoke
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Tue Nov 3 16:50:33 2009
@@ -199,12 +199,17 @@
"Arranges <fn> to be called from a thread in which it is safe to create GUI components (for example, the Event Dispatching Thread in Swing).")
(defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body)
- (with-unique-names (gui-backend-var)
+ (with-unique-names (gui-backend-var package-var debugger-hook-var)
+ ;;this really needs Pascal Costanza's dynamic environments
`(let* ((,gui-backend-var ,gui-backend)
- (*gui-backend* ,gui-backend-var))
+ (*gui-backend* ,gui-backend-var)
+ (,package-var *package*)
+ (,debugger-hook-var *debugger-hook*))
(call-in-gui-thread
(lambda ()
- (let ((*gui-backend* ,gui-backend-var))
+ (let ((*gui-backend* ,gui-backend-var)
+ (*package* ,package-var)
+ (*debugger-hook* ,debugger-hook-var))
, at body))))))
;;Common Interfaces
More information about the snow-cvs
mailing list