From astalla at common-lisp.net Tue Nov 3 21:50:33 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Tue, 03 Nov 2009 16:50:33 -0500 Subject: [snow-cvs] r13 - in trunk: lib src/java/snow/binding src/java/snow/example src/java/snow/list src/lisp/snow Message-ID: 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 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 From astalla at common-lisp.net Wed Nov 4 22:33:00 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 04 Nov 2009 17:33:00 -0500 Subject: [snow-cvs] r14 - trunk/docs Message-ID: Author: astalla Date: Wed Nov 4 17:33:00 2009 New Revision: 14 Log: Updated tutorial with $ syntax. Modified: trunk/docs/tutorial.html Modified: trunk/docs/tutorial.html ============================================================================== --- trunk/docs/tutorial.html (original) +++ trunk/docs/tutorial.html Wed Nov 4 17:33:00 2009 @@ -161,7 +161,7 @@ ...

Data Binding

-Keeping the GUI state in sync with the application objects state is generally tedious and error-prone. Data Binding is the process of automating the synchronization of state between two objects, in this case a GUI component and an application-level object. Snow supports several kinds of data binding, and it uses two library to do so: JGoodies Binding on the Java side and Cells on the Lisp side. +Keeping the GUI state in sync with the application objects state is generally tedious and error-prone. Data Binding is the process of automating the synchronization of state between two objects, in this case a GUI component and an application-level object. Snow supports several kinds of data binding, and it uses two libraries to do so: JGoodies Binding on the Java side and Cells on the Lisp side.

General concepts

There are two general ways to bind or connect a widget to some object's property: one is by using the :binding property of the widget, letting the framework choose which property of the widget to bind, e.g. the text property for a text field; for example: 
@@ -173,7 +173,7 @@
this will connect the specific property of the widget with the user-provided object or property.

Types of data binding

-Snow supports several types of data binding; some are more indicated for Lisp applications, other for Java applications. +Snow supports several types of data binding; some are more indicated for Lisp applications, others for Java applications.
  • Binding to a variable. Syntax: (make-simple-data-binding <variable>)
    This is the simplest form of data binding: you connect a widget's property to a suitably instrumented Lisp variable. Such a variable must be initialized with (make-var <value>), read with (var <name>), and written with (setf (var <name>) <value>). Example: 
    @@ -181,7 +181,7 @@
 (setf (var *x*) "new value")
 (button :text (make-simple-data-binding *x*))
    • -
  • Binding to a Presentation Model. Syntax: (make-bean-data-binding <object> <property> ...other args...)
    This kind of binding uses Martin Fowler's Presentation Model pattern as implemented by JGoodies Binding. You implement, in Java, a suitable subclass of PresentationModel (in simple cases, you can just use the base class); you then bind a widget to a model returned by an instance of this class for a bean property. Example: +
  • Binding to a Presentation Model. Syntax: (make-bean-data-binding <object> <property> ...other args...)
    This kind of binding uses Martin Fowler's Presentation Model pattern as implemented by JGoodies Binding. You implement, in Java, a suitable subclass of PresentationModel (in simple cases, you can just use the base class provided by JGoodies); you then bind a widget to a model returned by an instance of this class for a bean property. Example: 
     (defvar *presentation-model* (new "my.presentation.Model"))
 (text-field :text (make-bean-data-binding *presentation-model* "myProperty"))
@@ -204,14 +204,23 @@
                     *x* (c? (* 2 (my-slot *x*)))
                     (lambda (new-value) (setf (my-slot *x*) new-value))))
    • - +
+

Syntactic sugar

+To avoid the verbosity of make-foo-data-binding, Snow provides convenient syntax to cover the most common cases of data binding. You can enable this special syntax by evaluating the form (in-readtable snow:syntax), for example placing it in every source file right after the (in-package :snow-user) form at the top of the file.
+This special syntax is accessed by using the prefix $. It covers the following cases: +
    +
  • $foo is equivalent to (make-simple-data-binding foo).
    • +
  • $(c? ...) is equivalent to (make-cell-data-binding (c? ...)).
    • +
  • $(slot ...) is equivalent to (make-slot-data-binding ...).
    • +
  • ${bean.path} is a bit more complex. This syntax resembles that of the "Expression Language" used in JSP and JSF. First, bean is used as the name of a bean: the function stored in the special variable *bean-factory* is called with it as an argument to produce a Java object. The default function simply reads and evaluates bean as the name of a Lisp variable, but you can customize this behavior: for example, you can provide a callback that gets the bean from a Spring application context2. Then, once the bean has been obtained, two things can happen: if path is a simple property (i.e. it has no dots) and the bean is an instance of JGoodies PresentationModel, a binding to the property is asked to the presentation model, as by (make-bean-data-binding bean path); else, a property path data binding is constructed, as by (make-property-data-binding bean path-as-list).

What's more?

-I haven't covered which widgets are supported and how much of their API is supported. At this stage, Snow is little more than a prototype, so very little of the Swing API is covered. The best way to learn about Snow usage is to look at the examples included with Snow: the debugger (debugger.lisp), inspector (inspector.lisp) and the REPL (repl.lisp and swing/swing.lisp). Also, I haven't talked about how to use your custom widgets with Snow, and probably other things. Drop me a line at alessiostalla @ Google's mail service, and I'll be happy to help you. +I haven't covered which widgets are supported and how much of their API is supported. At this stage, Snow is in a early stage of development, so very little of the Swing API is covered. The best way to learn about Snow usage is to look at the examples included with Snow: the debugger (debugger.lisp), inspector (inspector.lisp) and the REPL (repl.lisp and swing/swing.lisp). Also, I haven't talked about how to use your custom widgets with Snow, and probably other things. Drop me a line at alessiostalla @ Google's mail service, and I'll be happy to help you.

Footnotes

  1. If you really mess things up, you can change the package of the REPL to one where the symbol QUIT is not visible. If you find yourself in this situation, type (ext:quit) to exit.
    2. +
  2. Snow provides a convenient Java class - org.armedbear.lisp.Callback - that you can subclass to create your custom callback function. You have just to implement the appropriate overload of the call method, or alternatively use one of the static methods Callback.fromXXX to create a Callback from several kinds of Java callbacks.
From astalla at common-lisp.net Thu Nov 12 22:22:30 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 12 Nov 2009 17:22:30 -0500 Subject: [snow-cvs] r15 - in trunk/src: java/snow/example lisp/snow lisp/snow/swing Message-ID: Author: astalla Date: Thu Nov 12 17:22:30 2009 New Revision: 15 Log: Rationalized compilation and packages Added fix-implementation (untested) Modified: trunk/src/java/snow/example/example.lisp trunk/src/lisp/snow/compile-system.lisp trunk/src/lisp/snow/packages.lisp trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/swing/swing.lisp trunk/src/lisp/snow/utils.lisp Modified: trunk/src/java/snow/example/example.lisp ============================================================================== --- trunk/src/java/snow/example/example.lisp (original) +++ trunk/src/java/snow/example/example.lisp Thu Nov 12 17:22:30 2009 @@ -11,12 +11,6 @@ (with-gui (:swing) (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")) @@ -57,6 +51,13 @@ "Nested property") (setf (var *variable*) "Test var") (setf (aaa *cells-object*) "Test cell"))))) + (panel () + (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)))) (pack frame))) (let ((fr (frame (:title "pippo" :visible-p t) Modified: trunk/src/lisp/snow/compile-system.lisp ============================================================================== --- trunk/src/lisp/snow/compile-system.lisp (original) +++ trunk/src/lisp/snow/compile-system.lisp Thu Nov 12 17:22:30 2009 @@ -1,15 +1,12 @@ (require :asdf) -(unwind-protect - (unless - (progn - (jstatic "initAux" "snow.Snow") - (format t "asdf:*central-registry*: ~S" asdf:*central-registry*) - (pushnew :snow-cells *features*) - (format t "compiling snow...") - (asdf:oos 'asdf:compile-op :snow) - (format t "success~%") - t) - (format t "failed~%")) - (terpri) +(jstatic "initAux" "snow.Snow") +(pushnew :snow-cells *features*) +(format t "Compiling snow...~%") +(handler-bind ((error + #'(lambda (c) + (format t "Compilation failed: ~A~%" c) + (quit :status 1)))) + (asdf:oos 'asdf:compile-op :snow) + (format t "Success!~%") (quit)) \ No newline at end of file Modified: trunk/src/lisp/snow/packages.lisp ============================================================================== --- trunk/src/lisp/snow/packages.lisp (original) +++ trunk/src/lisp/snow/packages.lisp Thu Nov 12 17:22:30 2009 @@ -46,12 +46,21 @@ ;;Models #:make-list-model #:make-tree-model + ;;Event Listeners + #:make-action-listener ;;Common operations on widgets #:add-child + #:dispose #:dont-add #:hide #:pack + #:scroll-panel-view + #:set-widget-properties #:show + #:widget-enabled-p + #:widget-location + #:widget-property + #:widget-size ;;Data binding #:make-var #:make-bean-data-binding @@ -63,6 +72,14 @@ #:cell #:slot ;;Various + #:call-in-gui-thread + #:defimplementation + #:definterface + #:*gui-backend* + #:jbool + #:layout-manager + #:make-dialog-prompt-stream + #:make-layout-manager #:install-graphical-debugger #:*parent* #:self @@ -74,4 +91,5 @@ #:new)) (defpackage :snow-user - (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells)) \ No newline at end of file + (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells) + (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*)) \ No newline at end of file Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Thu Nov 12 17:22:30 2009 @@ -46,8 +46,10 @@ (princ (char-downcase ch) out)))) str)))) -(defgeneric widget-property (widget name)) -(defgeneric (setf widget-property) (value widget name)) +(defgeneric widget-property (widget name) + (:documentation "Retrieves the value of a widget's property. Widget properties names are dependent on the GUI backend and cannot be used portably across different GUI libraries.")) +(defgeneric (setf widget-property) (value widget name) + (:documentation "Sets the value of a widget's property. Widget properties names are dependent on the GUI backend and cannot be used portably across different GUI libraries.")) (defmethod (setf widget-property) (value widget name) (setf (jproperty-value widget (dashed->camelcased name)) @@ -76,12 +78,15 @@ `(setf (widget-property ,widget-var ,key) ,value)) props)))) -(defgeneric bind-widget (widget binding)) +(defgeneric bind-widget (widget binding) + (:documentation "Connects a widget to a data binding. The framework automatically chooses which property of the widget to connect.")) (definterface make-layout-manager *gui-backend* (widget type &rest args)) +(definterface (setf layout-manager) *gui-backend* (lm widget)) + (defun setup-container-widget (self &key (layout-manager :default) &allow-other-keys) - (setf (widget-property self :layout);;Swing specific!! + (setf (layout-manager self) (apply #'make-layout-manager self (ensure-list layout-manager)))) (defun generate-default-children-processing-code (id children) @@ -213,7 +218,7 @@ , at body)))))) ;;Common Interfaces -(defvar *gui-backend* :swing) +(defvar *gui-backend* :swing "Variable used to determine the GUI backend, and thus interface implementation, to use. Defaults to :swing.") (definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints)) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Thu Nov 12 17:22:30 2009 @@ -28,7 +28,11 @@ ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. -(in-package :snow) +(defpackage :snow-swing + (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells) + (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*)) + +(in-package :snow-swing) (defmacro defimpl (name args &body body) `(defimplementation ,name (*gui-backend* :swing) ,args @@ -59,11 +63,14 @@ (:border (new "java.awt.BorderLayout")) ((nil) nil)))) +(defimpl (setf layout-manager) (lm widget) + (setf (widget-property widget :layout) lm)) + (defconstant +add-to-container+ (jmethod "java.awt.Container" "add" "java.awt.Component")) (defconstant +add-to-container-with-constraints+ (jmethod "java.awt.Container" "add" "java.lang.String" "java.awt.Component")) -(defimplementation call-in-gui-thread (*gui-backend* :swing) (fn) +(defimpl call-in-gui-thread (fn) (jstatic "invokeLater" "javax.swing.SwingUtilities" (new "snow.FunctionRunnable" fn))) @@ -102,7 +109,7 @@ ;;; --- Widgets --- ;;; ;Frames and dialogs -(defimplementation make-frame (*gui-backend* :swing) +(defimplementation snow::make-frame (*gui-backend* :swing) (&key title visible-p on-close &allow-other-keys) (let ((f (new "javax.swing.JFrame"))) (set-widget-properties f @@ -120,7 +127,7 @@ nil nil on-close nil nil nil nil)))) f)) -(defimplementation make-dialog (*gui-backend* :swing) +(defimplementation snow::make-dialog (*gui-backend* :swing) (&key parent title modal-p visible-p &allow-other-keys) (let ((d (new "javax.swing.JDialog" parent @@ -137,10 +144,10 @@ window) ;Panels -(defimplementation make-panel (*gui-backend* :swing) (&key &allow-other-keys) +(defimpl snow::make-panel (&key &allow-other-keys) (new "javax.swing.JPanel")) -(defimplementation make-tabs (*gui-backend* :swing) +(defimplementation snow::make-tabs (*gui-backend* :swing) (&key (wrap t) (tab-placement :top) &allow-other-keys) (let ((tabs (new "javax.swing.JTabbedPane"))) (invoke "setTabLayoutPolicy" tabs @@ -155,19 +162,19 @@ (:right (jfield "javax.swing.JTabbedPane" "RIGHT")))) tabs)) -(defimplementation make-scroll-panel (*gui-backend* :swing) (view) +(defimplementation snow::make-scroll-panel (*gui-backend* :swing) (view) (let ((p (new "javax.swing.JScrollPane"))) (setf (scroll-panel-view p) view) p)) -(defimplementation scroll-panel-view (*gui-backend* :swing) (self) +(defimplementation snow::scroll-panel-view (*gui-backend* :swing) (self) (jproperty-value self "viewportView")) -(defimplementation (setf scroll-panel-view) (*gui-backend* :swing) (view self) +(defimpl (setf snow::scroll-panel-view) (view self) (setf (jproperty-value self "viewportView") view)) ;Buttons -(defimplementation make-button (*gui-backend* :swing) +(defimplementation snow::make-button (*gui-backend* :swing) (&key text on-action &allow-other-keys) (let ((btn (new "javax.swing.JButton"))) (when text @@ -178,7 +185,7 @@ (make-action-listener on-action))) btn)) -(defimpl make-check-box (&key text selected-p &allow-other-keys) +(defimpl snow::make-check-box (&key text selected-p &allow-other-keys) (let ((btn (new "javax.swing.JCheckBox"))) (when text (setf (widget-property btn :text) text)) @@ -187,38 +194,34 @@ btn)) ;Text -(defimplementation make-label (*gui-backend* :swing) - (&key text &allow-other-keys) +(defimpl snow::make-label (&key text &allow-other-keys) (let ((lbl (new "javax.swing.JLabel"))) (when text (setf (widget-property lbl :text) text)) lbl)) -(defimplementation make-text-field (*gui-backend* :swing) - (&key text &allow-other-keys) +(defimpl snow::make-text-field (&key text &allow-other-keys) (let ((field (new "javax.swing.JTextField"))) (when text (setf (widget-property field :text) text)) field)) -(defimplementation make-text-area (*gui-backend* :swing) - (&key text &allow-other-keys) +(defimpl snow::make-text-area (&key text &allow-other-keys) (let ((text-area (new "javax.swing.JTextArea"))) (when text (setf (widget-property text-area :text) text)) text-area)) -(defun make-dialog-prompt-stream () +(defun snow::make-dialog-prompt-stream () ;;todo!! (new "snow.SwingDialogPromptStream")) ;;Lists (defun make-list-model (list) (new "snow.list.ConsListModel" list)) -(defimplementation make-list-widget (*gui-backend* :swing) - (&key model prototype-cell-value selected-index - (cell-renderer (new "snow.list.ConsListCellRenderer")) - &allow-other-keys) +(defimpl snow::make-list-widget (&key model prototype-cell-value selected-index + (cell-renderer (new "snow.list.ConsListCellRenderer")) + &allow-other-keys) (let ((list (new "javax.swing.JList"))) (when model (setf (widget-property list :model) model)) (setf (widget-property list :cell-renderer) @@ -232,18 +235,15 @@ (defun make-tree-model (list) (new "snow.tree.ConsTreeModel" list)) -(defimplementation make-tree-widget (*gui-backend* :swing) - (&key model - (cell-renderer (new "snow.tree.ConsTreeCellRenderer")) - &allow-other-keys) +(defimpl snow::make-tree-widget (&key model (cell-renderer (new "snow.tree.ConsTreeCellRenderer")) + &allow-other-keys) (let ((tree (new "javax.swing.JTree"))) (when model (setf (widget-property tree :model) model)) (setf (widget-property tree :cell-renderer) cell-renderer) tree)) ;;REPL -(defimplementation make-gui-repl (*gui-backend* :swing) - (&key dispose-on-close environment) +(defimpl snow::make-gui-repl (&key dispose-on-close environment) (let ((text-area (new "javax.swing.JTextArea")) (repl-doc (new "snow.swing.ConsoleDocument" (compile nil @@ -258,5 +258,5 @@ (invoke "disposeOnClose" repl-doc dispose-on-close)) text-area)) -(defimplementation dispose-gui-repl (*gui-backend* :swing) (repl) +(defimpl snow::dispose-gui-repl (repl) (invoke "dispose" (widget-property repl :document))) Modified: trunk/src/lisp/snow/utils.lisp ============================================================================== --- trunk/src/lisp/snow/utils.lisp (original) +++ trunk/src/lisp/snow/utils.lisp Thu Nov 12 17:22:30 2009 @@ -116,7 +116,7 @@ `(progn (defun ,name (&rest ,args) ;todo... ,@(when documentation `(,documentation)) - (destructuring-bind ,arglist ,args + (destructuring-bind ,arglist ,args ;to check for arglist consistency (declare (ignore ,@(extract-argument-names arglist)))) (let ((impl (get-implementation ',dispatch-var ',name ,dispatch-var))) (if impl @@ -131,6 +131,14 @@ `(setf (get-implementation ',dispatch-var ',name ,dispatch-value) (lambda ,arglist , at body))) ;todo check arglist is congruent with interface +(defun fix-implementation (dispatch-var) + "Makes the current implementation of an interface permanent, avoiding a layer of indirection when calling the interface functions and thus improving performance, but losing the ability to change the implementation at runtime. Use only when your are absolutely sure you won't ever need to use a different implementation." + (let ((dispatch-value (eval dispatch-var))) + (loop + :for entry :in (get-interfaces dispatch-var) + :do (setf (symbol-function (car entry)) + (interface-implementation (cdr entry) dispatch-value))))) + ;;BROKEN (defmacro with-implementation ((dispatch-var &optional (dispatch-value (eval dispatch-var))) From astalla at common-lisp.net Wed Nov 18 06:28:25 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 18 Nov 2009 01:28:25 -0500 Subject: [snow-cvs] r16 - in trunk/src: java/snow lisp/snow Message-ID: Author: astalla Date: Wed Nov 18 01:28:24 2009 New Revision: 16 Log: Fixed pathname concatenation that made Snow not load on Windows. Modified: trunk/src/java/snow/Snow.java trunk/src/lisp/snow/snow.lisp Modified: trunk/src/java/snow/Snow.java ============================================================================== --- trunk/src/java/snow/Snow.java (original) +++ trunk/src/java/snow/Snow.java Wed Nov 18 01:28:24 2009 @@ -54,14 +54,7 @@ private static boolean init = false; private static ScriptEngine lispEngine; private static final String fileSeparator = System.getProperty("file.separator"); - - private static final String fixDirPath(String path) { - if(!path.endsWith(fileSeparator)) { - path += fileSeparator; - } - return path; - } - + /** * This method is public only because it needs to be called from Lisp. * Do not call it. @@ -154,13 +147,36 @@ baseDir = fixDirPath(f.getParentFile().getParent()); libDir = baseDir; } - lispEngine.eval("(pushnew #P\"" + baseDir + "snow/\" asdf:*central-registry* :test #'equal)"); - lispEngine.eval("(pushnew #P\"" + baseDir + "snow/swing/\" asdf:*central-registry* :test #'equal)"); - lispEngine.eval("(pushnew #P\"" + libDir + "cl-utilities-1.2.4/\" asdf:*central-registry* :test #'equal)"); - lispEngine.eval("(pushnew #P\"" + libDir + "named-readtables/\" asdf:*central-registry* :test #'equal)"); - lispEngine.eval("(pushnew #P\"" + libDir + "cells/\" asdf:*central-registry* :test #'equal)"); - lispEngine.eval("(pushnew #P\"" + libDir + "cells/utils-kt/\" asdf:*central-registry* :test #'equal)"); + addToAsdfCentralRegistry(lispEngine, baseDir, "snow"); + addToAsdfCentralRegistry(lispEngine, baseDir, "snow", "swing"); + addToAsdfCentralRegistry(lispEngine, libDir, "cl-utilities-1.2.4"); + addToAsdfCentralRegistry(lispEngine, libDir, "named-readtables"); + addToAsdfCentralRegistry(lispEngine, libDir, "cells"); + addToAsdfCentralRegistry(lispEngine, libDir, "cells", "utils-kt"); + } + } + + private static Object addToAsdfCentralRegistry(ScriptEngine lispEngine, String base, String... path) throws ScriptException { + return lispEngine.eval("(pushnew #P\"" + makePath(base, path) + "\" asdf:*central-registry* :test #'equal)"); + } + + private static String makePath(String base, String... path) { + for(String s : path) { + base = fixDirPath(base) + s; } + return escapePath(fixDirPath(base)); + } + + private static String escapePath(String str) { + //Replace single \ with double \ for Windows paths + return str.replace("\\", "\\\\"); + } + + private static final String fixDirPath(String path) { + if(!path.endsWith(fileSeparator)) { + path += fileSeparator; + } + return path; } public static synchronized ScriptEngine init() throws ScriptException { @@ -225,7 +241,7 @@ if(args.length == 0) { //Launch GUI REPL evalResource(Snow.class, "/snow/start.lisp", true); } else { //Launch regular ABCL - lispEngine.eval("(TOP-LEVEL::TOP-LEVEL)"); + lispEngine.eval("(LET ((*PACKAGE* (FIND-PACKAGE :SNOW-USER))) (TOP-LEVEL::TOP-LEVEL-LOOP))"); //org.armedbear.lisp.Main.main(args); } } catch (Exception e) { Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Wed Nov 18 01:28:24 2009 @@ -250,6 +250,9 @@ (define-container-widget dialog (parent title modal-p visible-p) make-dialog) +;;Menus +(definterface make-menu-bar *gui-backend* (&key &allow-other-keys)) + ;;Panels (definterface make-panel *gui-backend* (&key &allow-other-keys)) From astalla at common-lisp.net Wed Nov 18 20:36:13 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Wed, 18 Nov 2009 15:36:13 -0500 Subject: [snow-cvs] r17 - in trunk/src/java/snow: . swing Message-ID: Author: astalla Date: Wed Nov 18 15:36:12 2009 New Revision: 17 Log: Fixed non-GUI main() with original ABCL repl. Fixed ConsoleDocument: on Windows it was completely broken (it handled line separators incorrectly, preventing any input to go to the interpreter); on all platforms it didn't handle the caret correctly when editing in the middle of text. Modified: trunk/src/java/snow/Snow.java trunk/src/java/snow/swing/ConsoleDocument.java Modified: trunk/src/java/snow/Snow.java ============================================================================== --- trunk/src/java/snow/Snow.java (original) +++ trunk/src/java/snow/Snow.java Wed Nov 18 15:36:12 2009 @@ -49,6 +49,8 @@ import javax.script.ScriptEngineManager; import javax.script.ScriptException; +import org.armedbear.lisp.Interpreter; + public abstract class Snow { private static boolean init = false; @@ -235,14 +237,27 @@ return (Invocable) lispEngine; } - public static void main(String[] args) { + public static void main(final String[] args) { try { - Snow.init(); if(args.length == 0) { //Launch GUI REPL - evalResource(Snow.class, "/snow/start.lisp", true); + evalResource(Snow.class, "/snow/start.lisp", false); } else { //Launch regular ABCL - lispEngine.eval("(LET ((*PACKAGE* (FIND-PACKAGE :SNOW-USER))) (TOP-LEVEL::TOP-LEVEL-LOOP))"); - //org.armedbear.lisp.Main.main(args); + //Copied from org.armedbear.lisp.Main.main() + Runnable r = new Runnable() { + public void run() { + try { + Interpreter interpreter = Interpreter.createDefaultInstance(args); + Snow.init(); + interpreter.eval("(in-package :snow-user)"); + interpreter.run(); + } catch(Throwable t) { + System.err.println("Caught error, exiting: " + t); + t.printStackTrace(); + System.exit(1); + } + } + }; + new Thread(null, r, "interpreter", 4194304L).start(); } } catch (Exception e) { e.printStackTrace(); Modified: trunk/src/java/snow/swing/ConsoleDocument.java ============================================================================== --- trunk/src/java/snow/swing/ConsoleDocument.java (original) +++ trunk/src/java/snow/swing/ConsoleDocument.java Wed Nov 18 15:36:12 2009 @@ -167,7 +167,7 @@ * @return */ protected boolean processInputP(StringBuffer sb, String str) { - if(str.indexOf(System.getProperty("line.separator", "\n")) == -1) { + if(str.indexOf("\n") == -1) { return false; } int parenCount = 0; @@ -222,17 +222,18 @@ @Override public void changedUpdate(DocumentEvent e) { - txt.setCaretPosition(getLength()); } @Override public void insertUpdate(DocumentEvent e) { - txt.setCaretPosition(getLength()); + int len = getLength(); + if(len - e.getLength() == e.getOffset()) { //The insert was at the end of the document + txt.setCaretPosition(getLength()); + } } @Override public void removeUpdate(DocumentEvent e) { - txt.setCaretPosition(getLength()); } }); txt.setCaretPosition(getLength()); From astalla at common-lisp.net Thu Nov 19 22:49:52 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 19 Nov 2009 17:49:52 -0500 Subject: [snow-cvs] r18 - in trunk/src/lisp/snow: . swing Message-ID: Author: astalla Date: Thu Nov 19 17:49:51 2009 New Revision: 18 Log: Sketch of menu-bar support Exported check-box symbol Menu bar with file->quit and help->about in repl Modified: trunk/src/lisp/snow/packages.lisp trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/start.lisp trunk/src/lisp/snow/swing/swing.lisp Modified: trunk/src/lisp/snow/packages.lisp ============================================================================== --- trunk/src/lisp/snow/packages.lisp (original) +++ trunk/src/lisp/snow/packages.lisp Thu Nov 19 17:49:51 2009 @@ -35,9 +35,13 @@ (:export ;;Widgets #:button + #:check-box #:frame #:label #:list-widget + #:menu + #:menu-bar + #:menu-item #:panel #:scroll #:text-area Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Thu Nov 19 17:49:51 2009 @@ -52,11 +52,15 @@ (:documentation "Sets the value of a widget's property. Widget properties names are dependent on the GUI backend and cannot be used portably across different GUI libraries.")) (defmethod (setf widget-property) (value widget name) - (setf (jproperty-value widget (dashed->camelcased name)) + (setf (jproperty-value widget (if (stringp name) + name + (dashed->camelcased name))) value)) (defmethod widget-property (widget name) - (jproperty-value widget (dashed->camelcased name))) + (jproperty-value widget (if (stringp name) + name + (dashed->camelcased name)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun map-keys (fn arglist &key (filter-if (constantly nil))) @@ -239,10 +243,10 @@ (definterface pack *gui-backend* (window)) ;;Windows -(definterface make-frame *gui-backend* (&key title visible-p on-close +(definterface make-frame *gui-backend* (&key menu-bar title visible-p on-close &allow-other-keys)) -(define-container-widget frame (title visible-p on-close) make-frame) +(define-container-widget frame (menu-bar title visible-p on-close) make-frame) (definterface make-dialog *gui-backend* (&key parent title modal-p visible-p &allow-other-keys)) @@ -253,6 +257,17 @@ ;;Menus (definterface make-menu-bar *gui-backend* (&key &allow-other-keys)) +(define-container-widget menu-bar () make-menu-bar) + +(definterface make-menu *gui-backend* (&key text &allow-other-keys)) + +(define-container-widget menu (text) make-menu) + +(definterface make-menu-item *gui-backend* + (&key text on-action &allow-other-keys)) + +(define-widget menu-item (text on-action) make-menu-item) + ;;Panels (definterface make-panel *gui-backend* (&key &allow-other-keys)) Modified: trunk/src/lisp/snow/start.lisp ============================================================================== --- trunk/src/lisp/snow/start.lisp (original) +++ trunk/src/lisp/snow/start.lisp Thu Nov 19 17:49:51 2009 @@ -30,11 +30,36 @@ (in-package :snow) +(defun snow-about () + (dialog (:id dlg :title "Snow v0.2") + (label :layout "wrap" + :text "Snow version 0.2") + (label :layout "wrap" + :text "Copyright (C) 2008-2009 Alessio Stalla") + (label :layout "wrap" + :text "This program is distributed under the GNU GPL; see the file copying for details.") + (button :text "Ok" :on-action (lambda (evt) + (declare (ignore evt)) + (dispose dlg))) + (pack self) + (show self))) + (with-gui () (frame (:id frame :title "ABCL - Snow REPL" :size #C(800 300) :visible-p t :layout-manager '(:mig "fill" "[fill]" "") - :on-close :exit) + :on-close :exit + :menu-bar (menu-bar () + (menu (:text "File") + (menu-item :text "Quit" + :on-action (lambda (evt) + (declare (ignore evt)) + (ext:quit)))) + (menu (:text "Help") + (menu-item :text "About" + :on-action (lambda (evt) + (declare (ignore evt)) + (snow-about)))))) (scroll (:layout "grow") (gui-repl :dispose-on-close frame :environment `((*package* ,(find-package :snow-user))))))) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Thu Nov 19 17:49:51 2009 @@ -109,12 +109,14 @@ ;;; --- Widgets --- ;;; ;Frames and dialogs -(defimplementation snow::make-frame (*gui-backend* :swing) - (&key title visible-p on-close &allow-other-keys) +(defimpl snow::make-frame (&key menu-bar title visible-p on-close + &allow-other-keys) (let ((f (new "javax.swing.JFrame"))) (set-widget-properties f :title title :visible (jbool visible-p)) + (when menu-bar + (setf (widget-property f "JMenuBar") menu-bar)) (when on-close (let ((on-close (case on-close @@ -143,7 +145,29 @@ (jcall (jmethod "java.awt.Window" "pack") window) window) -;Panels +(defun setup-button (btn text on-action) + (when text + (setf (widget-property btn :text) text)) + (when on-action + (invoke "addActionListener" + btn + (make-action-listener on-action)))) + +;;Menus +(defimpl snow::make-menu-bar (&key &allow-other-keys) + (new "javax.swing.JMenuBar")) + +(defimpl snow::make-menu (&key text &allow-other-keys) + (if text + (new "javax.swing.JMenu" text) + (new "javax.swing.JMenu"))) + +(defimpl snow::make-menu-item (&key text on-action &allow-other-keys) + (let ((m (new "javax.swing.JMenuItem"))) + (setup-button m text on-action) + m)) + +;;Panels (defimpl snow::make-panel (&key &allow-other-keys) (new "javax.swing.JPanel")) @@ -177,12 +201,7 @@ (defimplementation snow::make-button (*gui-backend* :swing) (&key text on-action &allow-other-keys) (let ((btn (new "javax.swing.JButton"))) - (when text - (setf (widget-property btn :text) text)) - (when on-action - (invoke "addActionListener" - btn - (make-action-listener on-action))) + (setup-button btn text on-action) btn)) (defimpl snow::make-check-box (&key text selected-p &allow-other-keys) From astalla at common-lisp.net Thu Nov 19 23:05:36 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 19 Nov 2009 18:05:36 -0500 Subject: [snow-cvs] r19 - trunk/docs Message-ID: Author: astalla Date: Thu Nov 19 18:05:35 2009 New Revision: 19 Log: Minor updates in the docs. Modified: trunk/docs/faq.html trunk/docs/tutorial.html Modified: trunk/docs/faq.html ============================================================================== --- trunk/docs/faq.html (original) +++ trunk/docs/faq.html Thu Nov 19 18:05:35 2009 @@ -38,7 +38,7 @@

General questions about Snow

So, what is Snow?

-Snow is a declarative language (DSL) targeted to build graphical user interfaces based on the Java Swing GUI library. +Snow is a declarative language (DSL) targeted at building graphical user interfaces based on the Java Swing GUI library. It is somewhat similar in spirit to XUL or SwiXml, while adopting a unique approach which has many advantages over XML + scripting languages. Snow is a fully interactive language - you can prototype your GUI at the read-eval-print loop and see the results immediately, without a lengthy batch compilation phase.

Which technologies is Snow built upon?

Snow is written in a combination of Java and Common Lisp (particularly its implementation Modified: trunk/docs/tutorial.html ============================================================================== --- trunk/docs/tutorial.html (original) +++ trunk/docs/tutorial.html Thu Nov 19 18:05:35 2009 @@ -150,6 +150,8 @@ Snow can easily be embedded in a Java application by using JSR-223. The snow.Snow class has some static methods that can be used to load some Snow source code from a .lisp file (or classpath resource), or to obtain an instance of javax.script.ScriptEngine which you can use for more advanced stuff (e.g. compiling Lisp code, or calling specific Lisp functions). When embedding Snow to define (part of) the application's GUI, it is recommended that you modularize the Snow code in functions, which you'll call from Java to obtain the GUI components:

file.lisp

+(in-package :snow-user)
+
 (defun create-main-frame (&rest args)
   ...snow code...)
From astalla at common-lisp.net Fri Nov 20 22:12:53 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 20 Nov 2009 17:12:53 -0500 Subject: [snow-cvs] r20 - in trunk/src: java/snow java/snow/example java/snow/showcase lisp/snow lisp/snow/showcase lisp/snow/swing Message-ID: Author: astalla Date: Fri Nov 20 17:12:52 2009 New Revision: 20 Log: Imported dynamic-environments core from ContextL and rationalized a bit dynamic environment handling between threads Renamed example to showcase, packaged it as the rest of snow, included menu in repl to launch it Fixed a bug in data binding: *bean-factory* wasn't called with the right package (the one that was current when ${...} was read) resulting in unbound variable errors. Added: trunk/src/java/snow/showcase/ - copied from r9, /trunk/src/java/snow/example/ trunk/src/lisp/snow/cx-dynamic-environments.lisp trunk/src/lisp/snow/showcase/ trunk/src/lisp/snow/showcase/showcase.lisp (contents, props changed) Removed: trunk/src/java/snow/example/SnowExample.java trunk/src/java/snow/example/example.lisp trunk/src/java/snow/showcase/example.lisp Modified: trunk/src/java/snow/Snow.java trunk/src/java/snow/showcase/SnowExample.java trunk/src/lisp/snow/data-binding.lisp trunk/src/lisp/snow/inspector.lisp trunk/src/lisp/snow/snow.asd trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/start.lisp trunk/src/lisp/snow/swing/swing.lisp Modified: trunk/src/java/snow/Snow.java ============================================================================== --- trunk/src/java/snow/Snow.java (original) +++ trunk/src/java/snow/Snow.java Fri Nov 20 17:12:52 2009 @@ -203,14 +203,28 @@ return lispEngine; } + /** + * Compiles and loads a Lisp file from the classpath, relative to aClass. + */ public static Object evalResource(Class aClass, String resourcePath) throws ScriptException { return evalResource(aClass, resourcePath, true); } + /** + * Loads a Lisp file from the classpath, relative to aClass. If compileItFirst is true, the file is compiled before being loaded. + */ public static Object evalResource(Class aClass, String resourcePath, boolean compileItFirst) throws ScriptException { Reader r = new InputStreamReader(aClass.getResourceAsStream(resourcePath)); return evalResource(r, compileItFirst); } + + public static Object evalResource(String resourcePath) throws ScriptException { + return evalResource(Snow.class, resourcePath, true); + } + + public static Object evalResource(String resourcePath, boolean compileItFirst) throws ScriptException { + return evalResource(Snow.class, resourcePath, compileItFirst); + } public static Object evalResource(Reader reader) throws ScriptException { return evalResource(reader, true); Modified: trunk/src/java/snow/showcase/SnowExample.java ============================================================================== --- /trunk/src/java/snow/example/SnowExample.java (original) +++ trunk/src/java/snow/showcase/SnowExample.java Fri Nov 20 17:12:52 2009 @@ -1,4 +1,4 @@ -package snow.example; +package snow.showcase; import javax.script.ScriptException; import javax.swing.JFrame; Added: trunk/src/lisp/snow/cx-dynamic-environments.lisp ============================================================================== --- (empty file) +++ trunk/src/lisp/snow/cx-dynamic-environments.lisp Fri Nov 20 17:12:52 2009 @@ -0,0 +1,94 @@ +;;; Copyright (c) 2005 - 2009 Pascal Costanza +;;; +;;; Permission is hereby granted, free of charge, to any person +;;; obtaining a copy of this software and associated documentation +;;; files (the \"Software\"), to deal in the Software without +;;; restriction, including without limitation the rights to use, +;;; copy, modify, merge, publish, distribute, sublicense, and/or +;;; sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following +;;; conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;; OTHER DEALINGS IN THE SOFTWARE. + +;;;Alessio Stalla: This is taken from Pascal Costanza's ContextL library. +;;;It implements the low-level bits of dynamic environments support. + +(in-package :snow) + +#-cx-disable-dynamic-environments +(defvar *dynamic-wind-stack* '()) + +(defstruct (dynamic-mark (:constructor make-dynamic-mark (name))) + (name nil :read-only t)) + +(defmacro with-dynamic-mark ((mark-variable) &body body) + (let ((mark (gensym))) + `(let* ((,mark (make-dynamic-mark ',mark-variable)) + #-cx-disable-dynamic-environments + (*dynamic-wind-stack* (cons ,mark *dynamic-wind-stack*)) + (,mark-variable ,mark)) + , at body))) + +(defmacro dynamic-wind (&body body) + (let ((proceed-name (cond ((eq (first body) :proceed) + (pop body) (pop body)) + (t 'proceed)))) + (assert (symbolp proceed-name) (proceed-name)) + #-cx-disable-dynamic-environments + (with-unique-names (dynamic-wind-thunk proceed-thunk proceed-body) + `(flet ((,dynamic-wind-thunk (,proceed-thunk) + (macrolet ((,proceed-name (&body ,proceed-body) + `(if ,',proceed-thunk + (funcall (the function ,',proceed-thunk)) + (progn ,@,proceed-body)))) + , at body))) + (declare (inline ,dynamic-wind-thunk)) + (let ((*dynamic-wind-stack* (cons #',dynamic-wind-thunk *dynamic-wind-stack*))) + (,dynamic-wind-thunk nil)))) + #+cx-disable-dynamic-environments + (with-unique-names (proceed-body) + `(macrolet ((,proceed-name (&body ,proceed-body) + `(progn ,@,proceed-body))) + , at body)))) + +#-cx-disable-dynamic-environments +(progn + (defclass dynamic-environment () + ((dynamic-winds :initarg :dynamic-winds :reader dynamic-winds))) + + (defun capture-dynamic-environment (&optional mark) + (make-instance 'dynamic-environment + :dynamic-winds + (loop with dynamic-winds = '() + for entry in *dynamic-wind-stack* + if (functionp entry) do (push entry dynamic-winds) + else if (eq entry mark) return dynamic-winds + finally (return dynamic-winds)))) + + (defgeneric call-with-dynamic-environment (environment thunk) + (:method ((environment dynamic-environment) (thunk function)) + (declare (optimize (speed 3) (space 3) (debug 0) (safety 0) + (compilation-speed 0))) + (labels ((perform-calls (environment thunk) + (cond (environment + (assert (consp environment)) + (let ((function (first environment))) + (assert (functionp function)) + (let ((*dynamic-wind-stack* (cons function *dynamic-wind-stack*))) + (funcall function (lambda () (perform-calls (rest environment) thunk)))))) + (t (funcall thunk))))) + (perform-calls (dynamic-winds environment) thunk)))) + + (defmacro with-dynamic-environment ((environment) &body body) + `(call-with-dynamic-environment ,environment (lambda () , at body)))) Modified: trunk/src/lisp/snow/data-binding.lisp ============================================================================== --- trunk/src/lisp/snow/data-binding.lisp (original) +++ trunk/src/lisp/snow/data-binding.lisp Fri Nov 20 17:12:52 2009 @@ -156,9 +156,10 @@ (defun make-data-binding (type &rest options) (apply (gethash type *binding-constructors*) options)) -(defun make-el-data-binding-from-expression (el-expr) +(defun make-el-data-binding-from-expression (el-expr package) (let* ((splitted-expr (split-sequence #\. el-expr)) - (obj (funcall *bean-factory* (car splitted-expr))) + (obj (let ((*package* package)) + (funcall *bean-factory* (car splitted-expr)))) (path (cdr splitted-expr))) (if path (if (and (presentation-model-p obj) (null (cdr path))) @@ -166,8 +167,6 @@ (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 #\$ @@ -181,7 +180,8 @@ (loop :for ch := (read-char stream) :then (read-char stream) :until (char= ch #\}) - :do (write-char ch str))))) + :do (write-char ch str))) + ,*package*)) ;;Packages are externalizable: http://www.lispworks.com/documentation/HyperSpec/Body/03_bdbb.htm (#\( (let ((list (read stream))) `(make-data-binding ',(car list) ,@(cdr list)))) Modified: trunk/src/lisp/snow/inspector.lisp ============================================================================== --- trunk/src/lisp/snow/inspector.lisp (original) +++ trunk/src/lisp/snow/inspector.lisp Fri Nov 20 17:12:52 2009 @@ -109,7 +109,7 @@ (setf (widget-property txt :line-wrap) (jbool t))));Swing specific!!! (bwhen (parts (object-parts descr)) (with-parent-widget panel - (tabs (:id tabs :layout "grow, wrap" :wrap nil :tab-placement :left) + (tabs (:layout "grow, wrap" :wrap nil :tab-placement :left) (dolist (part parts) (let ((part part)) (tab (part-name part) @@ -121,6 +121,7 @@ :text "Inspect" :layout "wrap" :on-action (lambda (evt) + (declare (ignore evt)) (update-inspector panel (inspector-panel (cons (part-descriptor part) @@ -129,12 +130,14 @@ container))) (button :text "Inspect (new window)" :on-action (lambda (evt) + (declare (ignore evt)) (inspect-object (part-descriptor part))))))))))) (scroll (:layout "grow, wrap") (gui-repl :dispose-on-close window)) (panel () (button :text "Back" :enabled-p (cdr stack) :on-action (lambda (evt) + (declare (ignore evt)) (update-inspector panel (inspector-panel (cdr stack) container window) Added: trunk/src/lisp/snow/showcase/showcase.lisp ============================================================================== --- (empty file) +++ trunk/src/lisp/snow/showcase/showcase.lisp Fri Nov 20 17:12:52 2009 @@ -0,0 +1,93 @@ +#-snow-cells +(error "This showcase needs Snow built with Cells support") + +(defpackage :snow-showcase + (:use :common-lisp :snow :java :ext :named-readtables :cells) + (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*)) + +(in-package :snow-showcase) +(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 *bean* (new "snow.showcase.SnowExample")) +(defvar *variable* (make-var "42")) +(defvar *cells-object* (make-instance 'my-model)) + +(defun showcase () + (with-gui (:swing) + (frame (:id frame :title "Sample JFrame" :visible-p t) + (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"))))) + (panel () + (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)))) + (pack frame)))) +#|| (let ((fr (frame (:title "pippo" :visible-p t) + (panel (:layout "wrap") + (button :text "ciao" :enabled nil) + (button :text "mondo" :enabled 42 + :on-action (lambda (event) + (print "Hello, world!") + (print event))) + (text-field :binding (make-bean-data-binding *bean* "property1")) + (text-field :binding + (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)) + (text-field :binding (make-simple-data-binding *variable*) + :layout "wrap") + (label :text "haha") + (panel (:layout-manager :mig :layout "grow") + (button :text "Test Location" :location #(30 30))) + (label :text "hihi"))))) + (let ((lbl1 (label :text "a label")) + (lbl2 (label :text "another"))) + (add-child lbl1 fr "growx") + (add-child lbl2 fr "wrap")) + (pack fr))||# Modified: trunk/src/lisp/snow/snow.asd ============================================================================== --- trunk/src/lisp/snow/snow.asd (original) +++ trunk/src/lisp/snow/snow.asd Fri Nov 20 17:12:52 2009 @@ -36,6 +36,7 @@ :components ((:file "packages") (:file "sexy-java") (:file "utils") + (:file "cx-dynamic-environments") (:file "snow") (:file "repl") (:file "data-binding") Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Fri Nov 20 17:12:52 2009 @@ -207,19 +207,28 @@ (definterface call-in-gui-thread *gui-backend* (fn) "Arranges to be called from a thread in which it is safe to create GUI components (for example, the Event Dispatching Thread in Swing).") +(defvar *dynamic-environment*) + (defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body) - (with-unique-names (gui-backend-var package-var debugger-hook-var) - ;;this really needs Pascal Costanza's dynamic environments + (with-unique-names (gui-backend-var package-var debugger-hook-var + dynamic-environment) `(let* ((,gui-backend-var ,gui-backend) (*gui-backend* ,gui-backend-var) (,package-var *package*) - (,debugger-hook-var *debugger-hook*)) - (call-in-gui-thread - (lambda () - (let ((*gui-backend* ,gui-backend-var) - (*package* ,package-var) - (*debugger-hook* ,debugger-hook-var)) - , at body)))))) + (,debugger-hook-var *debugger-hook*)) ;;Etc... + (dynamic-wind + (let ((*gui-backend* ,gui-backend-var) + (*package* ,package-var) + (*debugger-hook* ,debugger-hook-var)) + (proceed + (format t "OUTSIDE ~A~%" *package*) + (let ((,dynamic-environment (capture-dynamic-environment))) + (call-in-gui-thread + (lambda () + (with-dynamic-environment (,dynamic-environment) + (let ((*dynamic-environment* ,dynamic-environment)) + (format t "INSIDE ~A~%" *package*) + , at body))))))))))) ;;Common Interfaces (defvar *gui-backend* :swing "Variable used to determine the GUI backend, and thus interface implementation, to use. Defaults to :swing.") Modified: trunk/src/lisp/snow/start.lisp ============================================================================== --- trunk/src/lisp/snow/start.lisp (original) +++ trunk/src/lisp/snow/start.lisp Fri Nov 20 17:12:52 2009 @@ -44,6 +44,13 @@ (pack self) (show self))) +(defun snow-showcase () + (unless (find-package '#:snow-showcase) + ;;loads the showcase file + (jstatic "evalResource" "snow.Snow" "/snow/showcase/showcase.lisp")) + (funcall (symbol-function (find-symbol (symbol-name '#:showcase) + (find-package '#:snow-showcase))))) + (with-gui () (frame (:id frame :title "ABCL - Snow REPL" :size #C(800 300) @@ -56,6 +63,10 @@ (declare (ignore evt)) (ext:quit)))) (menu (:text "Help") + (menu-item :text "Showcase" + :on-action (lambda (evt) + (declare (ignore evt)) + (snow-showcase))) (menu-item :text "About" :on-action (lambda (evt) (declare (ignore evt)) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Fri Nov 20 17:12:52 2009 @@ -40,14 +40,16 @@ (defun make-action-listener (obj) (if (or (functionp obj) (symbolp obj)) - (jmake-proxy "java.awt.event.ActionListener" - (lambda (this method-name event) - (declare (ignore this method-name)) - (funcall obj event))) + (let ((debugger-hook *debugger-hook*)) + (jmake-proxy "java.awt.event.ActionListener" + (let ((env snow::*dynamic-environment*)) + (lambda (this method-name event) + (declare (ignore this method-name)) + (snow::with-dynamic-environment (env) + (funcall obj event)))))) obj)) ;This allows to use a native Java action listener -(defimplementation make-layout-manager (*gui-backend* :swing) - (widget layout &rest args) +(defimpl make-layout-manager (widget layout &rest args) (if (typep layout 'java-object) layout (ecase layout @@ -243,8 +245,7 @@ &allow-other-keys) (let ((list (new "javax.swing.JList"))) (when model (setf (widget-property list :model) model)) - (setf (widget-property list :cell-renderer) - (new "snow.list.ConsListCellRenderer")) + (setf (widget-property list :cell-renderer) cell-renderer) (setf (widget-property list :prototype-cell-value) prototype-cell-value) (when selected-index (setf (widget-property list :selected-index) selected-index)) From astalla at common-lisp.net Fri Nov 20 22:18:32 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 20 Nov 2009 17:18:32 -0500 Subject: [snow-cvs] r21 - trunk/src/java/snow/example Message-ID: Author: astalla Date: Fri Nov 20 17:18:32 2009 New Revision: 21 Log: Removed unused directory Removed: trunk/src/java/snow/example/ From astalla at common-lisp.net Sat Nov 21 00:14:03 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 20 Nov 2009 19:14:03 -0500 Subject: [snow-cvs] r22 - trunk/src/lisp/snow/swing Message-ID: Author: astalla Date: Fri Nov 20 19:14:02 2009 New Revision: 22 Log: Fixed missing propagation of dynamic environment Modified: trunk/src/lisp/snow/swing/swing.lisp Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Fri Nov 20 19:14:02 2009 @@ -40,12 +40,12 @@ (defun make-action-listener (obj) (if (or (functionp obj) (symbolp obj)) - (let ((debugger-hook *debugger-hook*)) - (jmake-proxy "java.awt.event.ActionListener" - (let ((env snow::*dynamic-environment*)) - (lambda (this method-name event) - (declare (ignore this method-name)) - (snow::with-dynamic-environment (env) + (jmake-proxy "java.awt.event.ActionListener" + (let ((env snow::*dynamic-environment*)) + (lambda (this method-name event) + (declare (ignore this method-name)) + (snow::with-dynamic-environment (env) + (let ((snow::*dynamic-environment* env)) (funcall obj event)))))) obj)) ;This allows to use a native Java action listener From astalla at common-lisp.net Sun Nov 22 23:39:11 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 22 Nov 2009 18:39:11 -0500 Subject: [snow-cvs] r23 - in trunk: lib src/lisp/snow src/lisp/snow/showcase src/lisp/snow/swing Message-ID: Author: astalla Date: Sun Nov 22 18:39:10 2009 New Revision: 23 Log: Added split pane. Updated miglayout to latest version. Showcase shows code in the bottom panel. Added "child" macro to abstract add-child and fix inconsistency with layout constraints. Added: trunk/lib/miglayout-3.7.1.jar (contents, props changed) Removed: trunk/lib/miglayout-3.6.2.jar Modified: trunk/src/lisp/snow/inspector.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 Added: trunk/lib/miglayout-3.7.1.jar ============================================================================== Binary file. No diff available. Modified: trunk/src/lisp/snow/inspector.lisp ============================================================================== --- trunk/src/lisp/snow/inspector.lisp (original) +++ trunk/src/lisp/snow/inspector.lisp Sun Nov 22 18:39:10 2009 @@ -158,7 +158,7 @@ (let ((stack (list (ensure-object-descriptor obj)))) (with-gui () (frame (:id frame :layout-manager :border) - (add-child (inspector-panel stack frame frame) frame) + (child (inspector-panel stack frame frame)) (pack frame) (show frame))))) Modified: trunk/src/lisp/snow/packages.lisp ============================================================================== --- trunk/src/lisp/snow/packages.lisp (original) +++ trunk/src/lisp/snow/packages.lisp Sun Nov 22 18:39:10 2009 @@ -36,6 +36,7 @@ ;;Widgets #:button #:check-box + #:dialog #:frame #:label #:list-widget @@ -44,6 +45,9 @@ #:menu-item #:panel #:scroll + #:split + #:tab + #:tabs #:text-area #:text-field #:tree Modified: trunk/src/lisp/snow/showcase/showcase.lisp ============================================================================== --- trunk/src/lisp/snow/showcase/showcase.lisp (original) +++ trunk/src/lisp/snow/showcase/showcase.lisp Sun Nov 22 18:39:10 2009 @@ -8,6 +8,28 @@ (in-package :snow-showcase) (in-readtable snow:syntax) +(defvar *examples* (list)) + +(defmacro define-example (name &body body) + (cl-utilities:with-unique-names (original-code) + `(pushnew (list ,name + (lambda () + (let ((,original-code ',body)) + + (split (:orientation :vertical) + (panel (:layout-manager '(:mig "fill") :layout "wrap") + , at body) + (scroll () + (text-area :text + ,(with-output-to-string (str) + (let ((*print-case* :downcase)) + (dolist (form body) + (pprint form str) + (terpri str)))))))))) + *examples* + :test #'equal + :key #'car))) + (defmodel my-model () ((a :accessor aaa :initform (c-in "4")) (b :accessor bbb :initform (c? (concatenate 'string (aaa self) "2"))))) @@ -16,57 +38,71 @@ (defvar *variable* (make-var "42")) (defvar *cells-object* (make-instance 'my-model)) +(define-example "Lists and trees" + (scroll (:layout "grow") + (list-widget :model (make-list-model '(1 2 (c (a b)) 3)) + :prototype-cell-value "abcdefghijklmnopq")) + (scroll (:layout "grow") + (tree :model (make-tree-model '(1 2 (c (a b)) 3))))) + +(define-example "Layout" + (label :text "BorderLayout" :layout "wrap") + (panel (:layout-manager :border :layout "wrap") + (button :text "borderlayout - center") + (button :text "borderlayout - east" + :layout (jfield "java.awt.BorderLayout" "EAST")))) + +(define-example "Events" + (button :text "push me" + :on-action (lambda (event) + (declare (ignore event)) + (princ "Thanks for pushing me! ") + (finish-output)))) + +(define-example "Data Binding" + (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) + (declare (ignore 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")))))) + (defun showcase () (with-gui (:swing) - (frame (:id frame :title "Sample JFrame" :visible-p t) - (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"))))) - (panel () - (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)))) - (pack frame)))) + (frame (:id frame :title "Sample JFrame" :visible-p t :size #C(800 600) + :layout-manager '(:mig "fill")) + (tabs (:layout "grow") + (dolist (x *examples*) + (tab (car x) (funcall (cadr x)))))))) + #|| (let ((fr (frame (:title "pippo" :visible-p t) (panel (:layout "wrap") (button :text "ciao" :enabled nil) Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Sun Nov 22 18:39:10 2009 @@ -91,7 +91,8 @@ (defun setup-container-widget (self &key (layout-manager :default) &allow-other-keys) (setf (layout-manager self) - (apply #'make-layout-manager self (ensure-list layout-manager)))) + (apply #'make-layout-manager self + (ensure-list (or layout-manager :default))))) (defun generate-default-children-processing-code (id children) (let ((code @@ -168,6 +169,11 @@ ,@(generate-default-children-processing-code id body) (common-widget-setup self ,layout ,binding ,enabled-p ,location ,size))) +(define-widget-macro child + (widget &rest args &key layout binding (enabled-p t) location size) + widget + `(setup-widget , at args)) + (defmacro define-widget (name keys constructor &body body) (with-unique-names (args) `(define-widget-macro ,name @@ -207,7 +213,7 @@ (definterface call-in-gui-thread *gui-backend* (fn) "Arranges to be called from a thread in which it is safe to create GUI components (for example, the Event Dispatching Thread in Swing).") -(defvar *dynamic-environment*) +(defvar *dynamic-environment* nil) (defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body) (with-unique-names (gui-backend-var package-var debugger-hook-var @@ -221,13 +227,11 @@ (*package* ,package-var) (*debugger-hook* ,debugger-hook-var)) (proceed - (format t "OUTSIDE ~A~%" *package*) (let ((,dynamic-environment (capture-dynamic-environment))) (call-in-gui-thread (lambda () (with-dynamic-environment (,dynamic-environment) (let ((*dynamic-environment* ,dynamic-environment)) - (format t "INSIDE ~A~%" *package*) , at body))))))))))) ;;Common Interfaces @@ -317,6 +321,16 @@ `(make-scroll-panel (dont-add ,body)) `(common-widget-setup self ,layout ,binding ,enabled-p ,location ,size)) +(definterface make-split-panel *gui-backend* + (child1 child2 &key (orientation :horizontal) smoothp)) + +(define-widget-macro split + ((&rest args &key layout binding (enabled-p t) location size orientation smoothp) + child1 child2) + `(make-split-panel (dont-add ,child1) (dont-add ,child2) + :orientation ,orientation :smoothp ,smoothp) + `(common-widget-setup self ,layout ,binding ,enabled-p ,location ,size)) + ;;Buttons and similar (definterface make-button *gui-backend* (&key text on-action &allow-other-keys)) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Sun Nov 22 18:39:10 2009 @@ -41,7 +41,8 @@ (defun make-action-listener (obj) (if (or (functionp obj) (symbolp obj)) (jmake-proxy "java.awt.event.ActionListener" - (let ((env snow::*dynamic-environment*)) + (let ((env (or snow::*dynamic-environment* + (snow::capture-dynamic-environment)))) (lambda (this method-name event) (declare (ignore this method-name)) (snow::with-dynamic-environment (env) @@ -178,14 +179,14 @@ (let ((tabs (new "javax.swing.JTabbedPane"))) (invoke "setTabLayoutPolicy" tabs (if wrap - (jfield "javax.swing.JTabbedPane" "WRAP_TAB_LAYOUT") - (jfield "javax.swing.JTabbedPane" "SCROLL_TAB_LAYOUT"))) + #.(jfield "javax.swing.JTabbedPane" "WRAP_TAB_LAYOUT") + #.(jfield "javax.swing.JTabbedPane" "SCROLL_TAB_LAYOUT"))) (invoke "setTabPlacement" tabs - (case tab-placement - (:top (jfield "javax.swing.JTabbedPane" "TOP")) - (:bottom (jfield "javax.swing.JTabbedPane" "BOTTOM")) - (:left (jfield "javax.swing.JTabbedPane" "LEFT")) - (:right (jfield "javax.swing.JTabbedPane" "RIGHT")))) + (ecase tab-placement + (:top #.(jfield "javax.swing.JTabbedPane" "TOP")) + (:bottom #.(jfield "javax.swing.JTabbedPane" "BOTTOM")) + (:left #.(jfield "javax.swing.JTabbedPane" "LEFT")) + (:right #.(jfield "javax.swing.JTabbedPane" "RIGHT")))) tabs)) (defimplementation snow::make-scroll-panel (*gui-backend* :swing) (view) @@ -199,6 +200,18 @@ (defimpl (setf snow::scroll-panel-view) (view self) (setf (jproperty-value self "viewportView") view)) +(defimpl snow::make-split-panel (child1 child2 + &key (orientation :horizontal) smoothp) + (new "javax.swing.JSplitPane" + (ecase orientation + ((or :horizontal :h nil) + #.(jfield "javax.swing.JSplitPane" "HORIZONTAL_SPLIT")) + ((or :vertical :v) + #.(jfield "javax.swing.JSplitPane" "VERTICAL_SPLIT"))) + (jbool smoothp) + child1 + child2)) + ;Buttons (defimplementation snow::make-button (*gui-backend* :swing) (&key text on-action &allow-other-keys) From astalla at common-lisp.net Thu Nov 26 18:56:59 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 26 Nov 2009 13:56:59 -0500 Subject: [snow-cvs] r24 - in trunk/src/lisp/snow: . showcase swing Message-ID: Author: astalla Date: Thu Nov 26 13:56:58 2009 New Revision: 24 Log: Fixed $(c? ...) syntax Improved showcase to show source only when asked Convenience c-expr function to make a quick-and-dirty Cells expression 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/utils.lisp Modified: trunk/src/lisp/snow/cells.lisp ============================================================================== --- trunk/src/lisp/snow/cells.lisp (original) +++ trunk/src/lisp/snow/cells.lisp Thu Nov 26 13:56:58 2009 @@ -30,6 +30,18 @@ (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 Modified: trunk/src/lisp/snow/data-binding.lisp ============================================================================== --- trunk/src/lisp/snow/data-binding.lisp (original) +++ trunk/src/lisp/snow/data-binding.lisp Thu Nov 26 13:56:58 2009 @@ -145,9 +145,9 @@ #+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 '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)) @@ -184,5 +184,7 @@ ,*package*)) ;;Packages are externalizable: http://www.lispworks.com/documentation/HyperSpec/Body/03_bdbb.htm (#\( (let ((list (read stream))) - `(make-data-binding ',(car list) ,@(cdr list)))) + (if #+snow-cells (eq (car list) 'cells:c?) #-snow-cells nil + `(make-data-binding 'cell ,list) + `(make-data-binding ',(car list) ,@(cdr list))))) (t `(make-simple-data-binding ,(read stream))))))) Modified: trunk/src/lisp/snow/packages.lisp ============================================================================== --- trunk/src/lisp/snow/packages.lisp (original) +++ trunk/src/lisp/snow/packages.lisp Thu Nov 26 13:56:58 2009 @@ -69,16 +69,22 @@ #:widget-location #:widget-property #:widget-size + #:widget-visible-p ;;Data binding #:make-var #:make-bean-data-binding #:make-cell-data-binding #:make-simple-data-binding #:make-slot-data-binding - #:var #:bean #:cell #:slot + #:var + #:simple-data-binding + #+snow-cells + #:c-expr + #+snow-cells + #:c-value ;;Various #:call-in-gui-thread #:defimplementation Modified: trunk/src/lisp/snow/showcase/showcase.lisp ============================================================================== --- trunk/src/lisp/snow/showcase/showcase.lisp (original) +++ trunk/src/lisp/snow/showcase/showcase.lisp Thu Nov 26 13:56:58 2009 @@ -11,24 +11,42 @@ (defvar *examples* (list)) (defmacro define-example (name &body body) - (cl-utilities:with-unique-names (original-code) - `(pushnew (list ,name - (lambda () - (let ((,original-code ',body)) - - (split (:orientation :vertical) - (panel (:layout-manager '(:mig "fill") :layout "wrap") - , at body) - (scroll () - (text-area :text - ,(with-output-to-string (str) - (let ((*print-case* :downcase)) - (dolist (form body) - (pprint form str) - (terpri str)))))))))) - *examples* - :test #'equal - :key #'car))) + (cl-utilities:with-unique-names (original-code show-source-p) + `(pushnew + (list ,name + (lambda () + (let ((,original-code ',body) (,show-source-p (c-expr 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))))) + (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 ,gui-panel self)) + (panel (:layout "dock south, hidemode 3" + :visible-p $(c? (jbool (c-value ,show-source-p)))) + (scroll (:layout "grow, wrap") + (text-area :text + ,(with-output-to-string (str) + (let ((*print-case* :downcase)) + (dolist (form body) + (pprint form str) + (terpri str)))))) + (button :text "Hide source" + :layout "dock south" + :on-action (lambda (evt) + (declare (ignore evt)) + (setf (c-value ,show-source-p) nil))) + (setf ,source-panel self)))))) + *examples* + :test #'equal + :key #'car))) (defmodel my-model () ((a :accessor aaa :initform (c-in "4")) @@ -103,7 +121,8 @@ (dolist (x *examples*) (tab (car x) (funcall (cadr x)))))))) -#|| (let ((fr (frame (:title "pippo" :visible-p t) +#|| +(let ((fr (frame (:title "pippo" :visible-p t) (panel (:layout "wrap") (button :text "ciao" :enabled nil) (button :text "mondo" :enabled 42 Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Thu Nov 26 13:56:58 2009 @@ -111,7 +111,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun common-widget-args () - '(layout binding (enabled-p t) location size)) + '(layout binding (enabled-p t) (visible-p t) location size)) (defun common-widget-args-declarations () (let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x))) (common-widget-args)))) @@ -125,17 +125,19 @@ :collect value)) (defun filter-widget-args (args) "Eliminates widget arguments processed by common-widget-setup; else, they would be evaluated twice in the macro expansion." - (filter-arglist args '(:id :layout :binding :enabled-p :location + (filter-arglist args '(:id :layout :binding :enabled-p :visible-p :location :layout-manager :size)))) -(defun common-widget-setup (self layout binding enabled-p location size) +(defun common-widget-setup (self layout binding enabled-p visible-p + location size) (setup-widget self :layout layout :binding binding :enabled-p enabled-p - :location location :size size)) + :visible-p visible-p :location location :size size)) -(defun setup-widget (self &key layout binding (enabled-p t) location size - &allow-other-keys) +(defun setup-widget (self &key layout binding (enabled-p t) (visible-p t) + location size &allow-other-keys) (when *parent* (add-child self *parent* layout)) (setf (widget-enabled-p self) enabled-p) + (setf (widget-visible-p self) visible-p) (when location (setf (widget-location self) location)) (when binding (bind-widget self binding)) (when size (setf (widget-size self) size))) @@ -162,23 +164,26 @@ (setf (get ',name 'widget-p) t))) (define-widget-macro with-widget - ((widget &rest args &key id layout binding (enabled-p t) location size) + ((widget &rest args &key id layout binding (enabled-p t) (visible-p t) + location size) &body body) `(dont-add ,widget) `(progn ,@(generate-default-children-processing-code id body) - (common-widget-setup self ,layout ,binding ,enabled-p ,location ,size))) + (common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size))) (define-widget-macro child - (widget &rest args &key layout binding (enabled-p t) location size) + (widget &rest args &key layout binding (enabled-p t) (visible-p t) + location size) widget `(setup-widget , at args)) (defmacro define-widget (name keys constructor &body body) + "Convenience macro for defining a widget." (with-unique-names (args) `(define-widget-macro ,name (&rest ,args &key ,@(common-widget-args) , at keys) - `(funcall (lambda (&rest args) + `(funcall (lambda (&rest args) ;;to evaluate args only once (let ((self (apply (function ,',constructor) args))) (apply #'setup-widget self args) self)) @@ -187,11 +192,12 @@ ,, at body)))) (defmacro define-container-widget (name keys constructor &body body) + "Convenience macro for defining a container widget." (with-unique-names (args macro-body) `(define-widget-macro ,name ((&rest ,args &key id ,@(common-widget-args) layout-manager , at keys) &body ,macro-body) - `(funcall (lambda (&rest args) + `(funcall (lambda (&rest args) ;;to evaluate args only once (let ((self (apply (function ,',constructor) args))) (apply #'setup-widget self args) (apply #'setup-container-widget self args) @@ -243,6 +249,10 @@ (definterface (setf widget-enabled-p) *gui-backend* (value widget)) +(definterface widget-visible-p *gui-backend* (widget)) + +(definterface (setf widget-visible-p) *gui-backend* (value widget)) + (definterface (setf widget-location) *gui-backend* (value widget)) (definterface (setf widget-size) *gui-backend* (value widget)) @@ -256,15 +266,15 @@ (definterface pack *gui-backend* (window)) ;;Windows -(definterface make-frame *gui-backend* (&key menu-bar title visible-p on-close +(definterface make-frame *gui-backend* (&key menu-bar title on-close &allow-other-keys)) -(define-container-widget frame (menu-bar title visible-p on-close) make-frame) +(define-container-widget frame (menu-bar title on-close) make-frame) (definterface make-dialog *gui-backend* (&key parent title modal-p visible-p &allow-other-keys)) -(define-container-widget dialog (parent title modal-p visible-p) +(define-container-widget dialog (parent title modal-p) make-dialog) ;;Menus @@ -293,7 +303,7 @@ (define-widget-macro tabs ((&rest args - &key id layout binding (enabled-p t) location size (wrap t) + &key id layout binding (enabled-p t) (visible-p t) location size (wrap t) (tab-placement :top)) &body body) `(make-tabs :wrap ,wrap :tab-placement ,tab-placement) @@ -303,7 +313,8 @@ `((let ((,id self)) , at body)) body)) - (common-widget-setup self ,layout ,binding ,enabled-p ,location ,size))) + (common-widget-setup self ,layout ,binding ,enabled-p ,visible-p + ,location ,size))) (defmacro tab (name &body body) `(if *tabs* @@ -317,19 +328,19 @@ (definterface (setf scroll-panel-view) *gui-backend* (view self)) (define-widget-macro scroll - ((&rest args &key layout binding (enabled-p t) location size) body) + ((&rest args &key layout binding (enabled-p t) (visible-p t) location size) body) `(make-scroll-panel (dont-add ,body)) - `(common-widget-setup self ,layout ,binding ,enabled-p ,location ,size)) + `(setup-widget self , at args)) (definterface make-split-panel *gui-backend* (child1 child2 &key (orientation :horizontal) smoothp)) (define-widget-macro split - ((&rest args &key layout binding (enabled-p t) location size orientation smoothp) + ((&rest args &key layout binding (enabled-p t) (visible-p t) location size orientation smoothp) child1 child2) `(make-split-panel (dont-add ,child1) (dont-add ,child2) :orientation ,orientation :smoothp ,smoothp) - `(common-widget-setup self ,layout ,binding ,enabled-p ,location ,size)) + `(common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size)) ;;Buttons and similar (definterface make-button *gui-backend* (&key text on-action &allow-other-keys)) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Thu Nov 26 13:56:58 2009 @@ -87,13 +87,18 @@ child) (jcall +add-to-container+ parent child))) -(defimplementation (setf widget-enabled-p) (*gui-backend* :swing) - (value widget) +(defimpl (setf widget-enabled-p) (value widget) (setf (widget-property widget :enabled) value)) -(defimplementation widget-enabled-p (*gui-backend* :swing) (widget) +(defimpl widget-enabled-p (widget) (widget-property widget :enabled)) +(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))) Modified: trunk/src/lisp/snow/utils.lisp ============================================================================== --- trunk/src/lisp/snow/utils.lisp (original) +++ trunk/src/lisp/snow/utils.lisp Thu Nov 26 13:56:58 2009 @@ -74,12 +74,12 @@ (defun get-interface (dispatch-var interface-name) (cdr (assoc interface-name (getf (symbol-plist dispatch-var) 'interfaces) - :test #'equal))) ;to handle (setf x) function names + :test #'equal))) ;;to handle (setf x) function names (defun (setf get-interface) (value dispatch-var interface-name) (bif (it (assoc interface-name (getf (symbol-plist dispatch-var) 'interfaces) - :test #'equal)) ;to handle (setf x) function names + :test #'equal)) ;;to handle (setf x) function names (setf (cdr it) value) (progn (push (cons interface-name value) @@ -102,7 +102,7 @@ (let ((interface (get-interface dispatch-var interface-name))) (if interface (setf (interface-implementation interface dispatch-value) value) - (error "Interface ~A not found in ~A" interface-name dispatch-var)))) + (error "Interface ~S not found in ~S" interface-name dispatch-var)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun extract-argument-names (arglist) @@ -114,7 +114,7 @@ (defmacro definterface (name dispatch-var arglist &optional documentation) (with-unique-names (args) `(progn - (defun ,name (&rest ,args) ;todo... + (defun ,name (&rest ,args) ;;todo... ,@(when documentation `(,documentation)) (destructuring-bind ,arglist ,args ;to check for arglist consistency (declare (ignore ,@(extract-argument-names arglist)))) @@ -129,7 +129,7 @@ (defmacro defimplementation (name (dispatch-var dispatch-value) arglist &body body) `(setf (get-implementation ',dispatch-var ',name ,dispatch-value) - (lambda ,arglist , at body))) ;todo check arglist is congruent with interface + (lambda ,arglist , at body))) ;;todo check arglist is congruent with interface (defun fix-implementation (dispatch-var) "Makes the current implementation of an interface permanent, avoiding a layer of indirection when calling the interface functions and thus improving performance, but losing the ability to change the implementation at runtime. Use only when your are absolutely sure you won't ever need to use a different implementation." From nmamardashvili at common-lisp.net Thu Nov 26 19:33:10 2009 From: nmamardashvili at common-lisp.net (Nikita Mamardashvili) Date: Thu, 26 Nov 2009 14:33:10 -0500 Subject: [snow-cvs] r25 - in trunk/src/lisp/snow: . swing Message-ID: Author: nmamardashvili Date: Thu Nov 26 14:33:09 2009 New Revision: 25 Log: A helper macro (thanks to Michael Raskin) and minimal support for progress bars. Modified: trunk/src/lisp/snow/packages.lisp trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/swing/swing.lisp Modified: trunk/src/lisp/snow/packages.lisp ============================================================================== --- trunk/src/lisp/snow/packages.lisp (original) +++ trunk/src/lisp/snow/packages.lisp Thu Nov 26 14:33:09 2009 @@ -35,7 +35,8 @@ (:export ;;Widgets #:button - #:check-box + #:check-box + #:progress-bar #:dialog #:frame #:label Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Thu Nov 26 14:33:09 2009 @@ -342,6 +342,15 @@ :orientation ,orientation :smoothp ,smoothp) `(common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size)) +(defmacro defwidget (name &rest args) + (let* ( + (maker-sym (intern (concatenate 'string "MAKE-" (symbol-name name)))) + ) + `(progn + (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys)) + (define-widget ,name (, at args &allow-other-keys) ,maker-sym) + ))) + ;;Buttons and similar (definterface make-button *gui-backend* (&key text on-action &allow-other-keys)) @@ -350,11 +359,18 @@ (definterface make-check-box *gui-backend* (&key text selected-p &allow-other-keys)) (define-widget check-box (text selected-p &allow-other-keys) make-check-box) + +;;Misc + +(def-widget progress-bar value orientation (paint-border t) progress-string) + +;;Text + +(def-widget label text) -;;Text -(definterface make-label *gui-backend* (&key text &allow-other-keys)) +; (definterface make-label *gui-backend* (&key text &allow-other-keys)) -(define-widget label (text &allow-other-keys) make-label) +; (define-widget label (text &allow-other-keys) make-label) (definterface make-text-field *gui-backend* (&key text &allow-other-keys)) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Thu Nov 26 14:33:09 2009 @@ -232,6 +232,21 @@ (if selected-p selected-p (jbool nil))) btn)) +;Misc +(defconstant +swingconstant-vertical+ 1) ; it should be something like (jmethod "javax.swing.SwingConstants" "VERTICAL") +(defimpl snow::make-progress-bar (&key value orientation (paint-border t) progress-string &allow-other-keys) + (let ((pbar (new "javax.swing.JProgressBar"))) + (when value + (setf (widget-property pbar :value) value)) + (when orientation + (setf (widget-property pbar :orientation) +swingconstant-vertical+)) + (when (not paint-border) + (setf (widget-property pbar :border-painted) (jbool nil))) + (when progress-string + (setf (widget-property pbar :string-painted) (jbool t)) + (setf (widget-property pbar :string) progress-string) + ) + pbar)) ;Text (defimpl snow::make-label (&key text &allow-other-keys) (let ((lbl (new "javax.swing.JLabel"))) From astalla at common-lisp.net Thu Nov 26 20:26:00 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 26 Nov 2009 15:26:00 -0500 Subject: [snow-cvs] r26 - in trunk: docs src/lisp/snow src/lisp/snow/showcase src/lisp/snow/swing Message-ID: Author: astalla Date: Thu Nov 26 15:25:59 2009 New Revision: 26 Log: Updated tutorial Fixed progressbar Modified: trunk/docs/tutorial.html trunk/src/lisp/snow/showcase/showcase.lisp trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/start.lisp trunk/src/lisp/snow/swing/swing.lisp Modified: trunk/docs/tutorial.html ============================================================================== --- trunk/docs/tutorial.html (original) +++ trunk/docs/tutorial.html Thu Nov 26 15:25:59 2009 @@ -5,9 +5,10 @@

Snow Tutorial

+

Last modified 2009-11-26

  1. Getting and Installing Snow
    2. -
  2. Terminology
    3. +
  3. Building Snow from source (optional)
  4. The Snow REPL
  5. Basic Concepts
  6. Layout
    7. @@ -29,16 +30,8 @@ Currently Snow, when run from the jar, requires a temporary directory to load itself; make sure your application has write permissions on your OS's tmp directory. Snow should automatically clear its temporary files when the application exits. -

    Terminology

    -The boring part :) you can skip this if you know Lisp, since I'm going to loosely define some terms Snow borrows from Lisp that will be used in this tutorial. -
      -
    • car
      the first element of a list.
      • -
    • cdr
      the rest of a list (all elements except the first).
      • -
    • nil
      the empty list, and the only boolean false value.
      • -
    • t
      a self-evaluating symbol representing the canonical boolean true value (among other things).
      • -
    • form
      an expression to be evaluated or compiled.
      • -
    • keyword
      a self-evaluating symbol starting with a colon (like :title). More correctly, a symbol in the KEYWORD package.
      • -
    +

    Building Snow from source (optional)

    +Snow is built using the Ant program (a Java make-like tool). You can get it from <    http://ant.apache.org/>. To obtain the source code for Snow, either download a source release from the project page or, if you want the latest & greatest stuff, follow the instructions at <http://common-lisp.net/faq.shtml> to checkout it from the SVN repository. Once you have the source in a given directory, cd to that directory and issue the command ant snow.jar to build Snow. ant snow.clean removes all compiled files.

    The Snow REPL

    Being based on Lisp, Snow offers a REPL (read-eval-print-loop), an interactive prompt that allows you to evaluate arbitrary pieces of code. If you launch Snow through its main class (snow.Snow) with no command-line arguments, it will show a window containing the REPL (which is nothing more than a wrapped ABCL REPL). It should print

    Modified: trunk/src/lisp/snow/showcase/showcase.lisp ============================================================================== --- trunk/src/lisp/snow/showcase/showcase.lisp (original) +++ trunk/src/lisp/snow/showcase/showcase.lisp Thu Nov 26 15:25:59 2009 @@ -27,8 +27,7 @@ :layout "dock south" :on-action (lambda (evt) (declare (ignore evt)) - (setf (c-value ,show-source-p) t))) - (setf ,gui-panel self)) + (setf (c-value ,show-source-p) t)))) (panel (:layout "dock south, hidemode 3" :visible-p $(c? (jbool (c-value ,show-source-p)))) (scroll (:layout "grow, wrap") @@ -42,8 +41,7 @@ :layout "dock south" :on-action (lambda (evt) (declare (ignore evt)) - (setf (c-value ,show-source-p) nil))) - (setf ,source-panel self)))))) + (setf (c-value ,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 Thu Nov 26 15:25:59 2009 @@ -223,15 +223,17 @@ (defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body) (with-unique-names (gui-backend-var package-var debugger-hook-var - dynamic-environment) + dynamic-environment terminal-io-var) `(let* ((,gui-backend-var ,gui-backend) (*gui-backend* ,gui-backend-var) (,package-var *package*) - (,debugger-hook-var *debugger-hook*)) ;;Etc... + (,debugger-hook-var *debugger-hook*) + (,terminal-io-var *terminal-io*)) ;;Etc... (dynamic-wind (let ((*gui-backend* ,gui-backend-var) (*package* ,package-var) - (*debugger-hook* ,debugger-hook-var)) + (*debugger-hook* ,debugger-hook-var) + (*terminal-io* ,terminal-io-var)) (proceed (let ((,dynamic-environment (capture-dynamic-environment))) (call-in-gui-thread @@ -342,15 +344,12 @@ :orientation ,orientation :smoothp ,smoothp) `(common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size)) -(defmacro defwidget (name &rest args) - (let* ( - (maker-sym (intern (concatenate 'string "MAKE-" (symbol-name name)))) - ) - `(progn - (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys)) - (define-widget ,name (, at args &allow-other-keys) ,maker-sym) - ))) - +(defmacro defwidget (name &rest args) + (let* ((maker-sym (intern (concatenate 'string "MAKE-" (symbol-name name))))) + `(progn + (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys)) + (define-widget ,name (, at args &allow-other-keys) ,maker-sym)))) + ;;Buttons and similar (definterface make-button *gui-backend* (&key text on-action &allow-other-keys)) @@ -359,14 +358,14 @@ (definterface make-check-box *gui-backend* (&key text selected-p &allow-other-keys)) (define-widget check-box (text selected-p &allow-other-keys) make-check-box) - -;;Misc - -(def-widget progress-bar value orientation (paint-border t) progress-string) - -;;Text - -(def-widget label text) + +;;Misc + +(defwidget progress-bar value orientation (paint-border t) progress-string) + +;;Text + +(defwidget label text) ; (definterface make-label *gui-backend* (&key text &allow-other-keys)) Modified: trunk/src/lisp/snow/start.lisp ============================================================================== --- trunk/src/lisp/snow/start.lisp (original) +++ trunk/src/lisp/snow/start.lisp Thu Nov 26 15:25:59 2009 @@ -38,6 +38,10 @@ :text "Copyright (C) 2008-2009 Alessio Stalla") (label :layout "wrap" :text "This program is distributed under the GNU GPL; see the file copying for details.") + (label :layout "wrap" + :text "Many thanks to these people for contributing to Snow:") + (label :layout "wrap" + :text "Nikita \"Shviller\" Mamardashvili") (button :text "Ok" :on-action (lambda (evt) (declare (ignore evt)) (dispose dlg))) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Thu Nov 26 15:25:59 2009 @@ -232,21 +232,21 @@ (if selected-p selected-p (jbool nil))) btn)) -;Misc -(defconstant +swingconstant-vertical+ 1) ; it should be something like (jmethod "javax.swing.SwingConstants" "VERTICAL") -(defimpl snow::make-progress-bar (&key value orientation (paint-border t) progress-string &allow-other-keys) - (let ((pbar (new "javax.swing.JProgressBar"))) - (when value - (setf (widget-property pbar :value) value)) - (when orientation - (setf (widget-property pbar :orientation) +swingconstant-vertical+)) - (when (not paint-border) - (setf (widget-property pbar :border-painted) (jbool nil))) - (when progress-string - (setf (widget-property pbar :string-painted) (jbool t)) - (setf (widget-property pbar :string) progress-string) - ) - pbar)) +;Misc +(defconstant +swingconstant-vertical+ 1) ; it should be something like (jmethod "javax.swing.SwingConstants" "VERTICAL") +(defimpl snow::make-progress-bar (&key value orientation (paint-border t) progress-string &allow-other-keys) + (let ((pbar (new "javax.swing.JProgressBar"))) + (when value + (setf (widget-property pbar :value) value)) + (when orientation + (setf (widget-property pbar :orientation) +swingconstant-vertical+)) + (when (not paint-border) + (setf (widget-property pbar :border-painted) (jbool nil))) + (when progress-string + (setf (widget-property pbar :string-painted) (jbool t)) + (setf (widget-property pbar :string) progress-string)) + pbar)) + ;Text (defimpl snow::make-label (&key text &allow-other-keys) (let ((lbl (new "javax.swing.JLabel"))) From astalla at common-lisp.net Thu Nov 26 22:20:34 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Thu, 26 Nov 2009 17:20:34 -0500 Subject: [snow-cvs] r27 - in trunk/src/lisp/snow: . swing Message-ID: Author: astalla Date: Thu Nov 26 17:20:33 2009 New Revision: 27 Log: Fixed dialogs to be made visible only after the body has been evaluated, to get modality right. Modified: trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/swing/swing.lisp Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Thu Nov 26 17:20:33 2009 @@ -154,7 +154,7 @@ self)) (setf (get ',name 'widget-p) t))) -;Experimental - not working right now +;;Experimental - not working right now (defmacro define-widget-function (name arglist constructor &body body) `(progn (defun ,name (, at arglist) @@ -276,8 +276,25 @@ (definterface make-dialog *gui-backend* (&key parent title modal-p visible-p &allow-other-keys)) +(define-widget-macro dialog + ((&rest args &key id layout binding (enabled-p t) (visible-p t) location + size layout-manager parent title modal-p visible-p) + &body body) + `(funcall (lambda (&rest args) ;;to evaluate args only once + (let ((self (apply (function make-dialog) args))) + (apply #'setup-widget self `(:visible-p nil , at args)) + (apply #'setup-container-widget self args) + self)) + ;;remove id because it must not be evaluated + ;;and visible-p because it must be set last + ,@(filter-arglist args '(:id :visible-p))) + `(progn + ,@(generate-default-children-processing-code id body) + (setf (widget-visible-p self) ,visible-p))) + +#| (define-container-widget dialog (parent title modal-p) - make-dialog) + make-dialog)|# ;;Menus (definterface make-menu-bar *gui-backend* (&key &allow-other-keys)) Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Thu Nov 26 17:20:33 2009 @@ -145,8 +145,7 @@ (jfield "java.awt.Dialog$ModalityType" "APPLICATION_MODAL") (jfield "java.awt.Dialog$ModalityType" "MODELESS"))))) (set-widget-properties d - :title title - :visible (jbool visible-p)) + :title title) d)) (defimplementation pack (*gui-backend* :swing) (window) From nmamardashvili at common-lisp.net Fri Nov 27 13:58:50 2009 From: nmamardashvili at common-lisp.net (Nikita Mamardashvili) Date: Fri, 27 Nov 2009 08:58:50 -0500 Subject: [snow-cvs] r28 - in trunk/src/lisp/snow: . swing Message-ID: Author: nmamardashvili Date: Fri Nov 27 08:58:49 2009 New Revision: 28 Log: A little cleanup (making use of defwidget and defimpl macros). Modified: trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/swing/swing.lisp Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Fri Nov 27 08:58:49 2009 @@ -368,13 +368,10 @@ (define-widget ,name (, at args &allow-other-keys) ,maker-sym)))) ;;Buttons and similar -(definterface make-button *gui-backend* (&key text on-action &allow-other-keys)) + +(defwidget button text on-action) -(define-widget button (text on-action &allow-other-keys) make-button) - -(definterface make-check-box *gui-backend* (&key text selected-p &allow-other-keys)) - -(define-widget check-box (text selected-p &allow-other-keys) make-check-box) +(defwidget check-box text selected-p) ;;Misc @@ -384,25 +381,14 @@ (defwidget label text) -; (definterface make-label *gui-backend* (&key text &allow-other-keys)) - -; (define-widget label (text &allow-other-keys) make-label) - -(definterface make-text-field *gui-backend* (&key text &allow-other-keys)) +(defwidget text-field text) -(define-widget text-field (text &allow-other-keys) make-text-field) - -(definterface make-text-area *gui-backend* (&key text &allow-other-keys)) - -(define-widget text-area (text &allow-other-keys) make-text-area) +(defwidget text-area text) ;;Lists -(definterface make-list-widget *gui-backend* (&key model selected-index &allow-other-keys)) - -(define-widget list-widget (model selected-index &allow-other-keys) - make-list-widget) + +(defwidget list-widget model selected-index) ;;Trees -(definterface make-tree-widget *gui-backend* (&key model &allow-other-keys)) - -(define-widget tree (model &allow-other-keys) make-tree-widget) \ No newline at end of file + +(defwidget tree model) \ No newline at end of file Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Fri Nov 27 08:58:49 2009 @@ -78,8 +78,7 @@ (new "snow.FunctionRunnable" fn))) ;;Base API implementation -(defimplementation add-child (*gui-backend* :swing) - (child &optional (parent *parent*) layout-constraints) +(defimpl add-child (child &optional (parent *parent*) layout-constraints) (if layout-constraints (jcall +add-to-container-with-constraints+ parent @@ -105,13 +104,13 @@ (defimpl (setf widget-size) (value widget) (invoke "setSize" widget (realpart value) (imagpart value))) -(defimplementation dispose (*gui-backend* :swing) (obj) +(defimpl dispose (obj) (invoke "dispose" obj)) -(defimplementation show (*gui-backend* :swing) (obj) +(defimpl show (obj) (invoke "show" obj)) -(defimplementation hide (*gui-backend* :swing) (obj) +(defimpl hide (obj) (invoke "hide" obj)) ;;; --- Widgets --- ;;; @@ -137,8 +136,7 @@ nil nil on-close nil nil nil nil)))) f)) -(defimplementation snow::make-dialog (*gui-backend* :swing) - (&key parent title modal-p visible-p &allow-other-keys) +(defimpl snow::make-dialog (&key parent title modal-p visible-p &allow-other-keys) (let ((d (new "javax.swing.JDialog" parent (if modal-p @@ -148,7 +146,7 @@ :title title) d)) -(defimplementation pack (*gui-backend* :swing) (window) +(defimpl pack (window) (jcall (jmethod "java.awt.Window" "pack") window) window) @@ -178,8 +176,7 @@ (defimpl snow::make-panel (&key &allow-other-keys) (new "javax.swing.JPanel")) -(defimplementation snow::make-tabs (*gui-backend* :swing) - (&key (wrap t) (tab-placement :top) &allow-other-keys) +(defimpl snow::make-tabs (&key (wrap t) (tab-placement :top) &allow-other-keys) (let ((tabs (new "javax.swing.JTabbedPane"))) (invoke "setTabLayoutPolicy" tabs (if wrap @@ -193,12 +190,12 @@ (:right #.(jfield "javax.swing.JTabbedPane" "RIGHT")))) tabs)) -(defimplementation snow::make-scroll-panel (*gui-backend* :swing) (view) +(defimpl snow::make-scroll-panel (view) (let ((p (new "javax.swing.JScrollPane"))) (setf (scroll-panel-view p) view) p)) -(defimplementation snow::scroll-panel-view (*gui-backend* :swing) (self) +(defimpl snow::scroll-panel-view (self) (jproperty-value self "viewportView")) (defimpl (setf snow::scroll-panel-view) (view self) @@ -217,8 +214,7 @@ child2)) ;Buttons -(defimplementation snow::make-button (*gui-backend* :swing) - (&key text on-action &allow-other-keys) +(defimpl snow::make-button (&key text on-action &allow-other-keys) (let ((btn (new "javax.swing.JButton"))) (setup-button btn text on-action) btn)) @@ -287,7 +283,7 @@ (defun make-tree-model (list) (new "snow.tree.ConsTreeModel" list)) -(defimpl snow::make-tree-widget (&key model (cell-renderer (new "snow.tree.ConsTreeCellRenderer")) +(defimpl snow::make-tree (&key model (cell-renderer (new "snow.tree.ConsTreeCellRenderer")) &allow-other-keys) (let ((tree (new "javax.swing.JTree"))) (when model (setf (widget-property tree :model) model)) From astalla at common-lisp.net Fri Nov 27 15:27:39 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 27 Nov 2009 10:27:39 -0500 Subject: [snow-cvs] r29 - trunk/src/lisp/snow Message-ID: Author: astalla Date: Fri Nov 27 10:27:38 2009 New Revision: 29 Log: Fixed About popup Modified: trunk/src/lisp/snow/start.lisp Modified: trunk/src/lisp/snow/start.lisp ============================================================================== --- trunk/src/lisp/snow/start.lisp (original) +++ trunk/src/lisp/snow/start.lisp Fri Nov 27 10:27:38 2009 @@ -31,7 +31,7 @@ (in-package :snow) (defun snow-about () - (dialog (:id dlg :title "Snow v0.2") + (dialog (:id dlg :title "Snow v0.2" :visible-p t) (label :layout "wrap" :text "Snow version 0.2") (label :layout "wrap" @@ -45,8 +45,7 @@ (button :text "Ok" :on-action (lambda (evt) (declare (ignore evt)) (dispose dlg))) - (pack self) - (show self))) + (pack self))) (defun snow-showcase () (unless (find-package '#:snow-showcase) From astalla at common-lisp.net Fri Nov 27 19:21:35 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Fri, 27 Nov 2009 14:21:35 -0500 Subject: [snow-cvs] r30 - trunk/src/lisp/snow Message-ID: Author: astalla Date: Fri Nov 27 14:21:34 2009 New Revision: 30 Log: Fixed misuse of jstatic which broke the showcase on windows. Modified: trunk/src/lisp/snow/start.lisp Modified: trunk/src/lisp/snow/start.lisp ============================================================================== --- trunk/src/lisp/snow/start.lisp (original) +++ trunk/src/lisp/snow/start.lisp Fri Nov 27 14:21:34 2009 @@ -50,7 +50,7 @@ (defun snow-showcase () (unless (find-package '#:snow-showcase) ;;loads the showcase file - (jstatic "evalResource" "snow.Snow" "/snow/showcase/showcase.lisp")) + (jstatic (jmethod "snow.Snow" "evalResource" "java.lang.String") nil "/snow/showcase/showcase.lisp")) (funcall (symbol-function (find-symbol (symbol-name '#:showcase) (find-package '#:snow-showcase))))) From astalla at common-lisp.net Sat Nov 28 22:13:39 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Sat, 28 Nov 2009 17:13:39 -0500 Subject: [snow-cvs] r31 - tags Message-ID: Author: astalla Date: Sat Nov 28 17:13:38 2009 New Revision: 31 Log: Created tags directory Added: tags/ From astalla at common-lisp.net Sun Nov 29 12:22:30 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Sun, 29 Nov 2009 07:22:30 -0500 Subject: [snow-cvs] r32 - tags/0.2 Message-ID: Author: astalla Date: Sun Nov 29 07:22:29 2009 New Revision: 32 Log: Tagged 0.2 release. Added: tags/0.2/ - copied from r31, /trunk/ From astalla at common-lisp.net Mon Nov 30 22:44:36 2009 From: astalla at common-lisp.net (Alessio Stalla) Date: Mon, 30 Nov 2009 17:44:36 -0500 Subject: [snow-cvs] r33 - in trunk: . lib src/java/org/armedbear/lisp src/java/snow/binding src/java/snow/list src/java/snow/swing src/java/snow/tree src/lisp/snow src/lisp/snow/showcase src/lisp/snow/swing Message-ID: Author: astalla Date: Mon Nov 30 17:44:36 2009 New Revision: 33 Log: Updated to latest abcl Initial Mouse Listener support Refactoring in snow.lisp: introduced &common-widget-args meta-argument, moved actual widget definitions in another file (widgets.lisp), some more macrology with dynamic environments Added: trunk/src/java/snow/swing/MouseInputListener.java trunk/src/lisp/snow/widgets.lisp Modified: trunk/changelog trunk/lib/abcl.jar trunk/src/java/org/armedbear/lisp/Callback.java trunk/src/java/snow/binding/AccessorBinding.java trunk/src/java/snow/binding/BeanPropertyPathBinding.java trunk/src/java/snow/binding/Converter.java trunk/src/java/snow/list/ConsListCellRenderer.java trunk/src/java/snow/list/ConsListModel.java trunk/src/java/snow/swing/ConsoleDocument.java trunk/src/java/snow/swing/WindowListener.java trunk/src/java/snow/tree/ConsTreeCellRenderer.java trunk/src/java/snow/tree/ConsTreeModel.java trunk/src/lisp/snow/showcase/showcase.lisp trunk/src/lisp/snow/snow.asd trunk/src/lisp/snow/snow.lisp trunk/src/lisp/snow/swing/swing.lisp trunk/src/lisp/snow/utils.lisp Modified: trunk/changelog ============================================================================== --- trunk/changelog (original) +++ trunk/changelog Mon Nov 30 17:44:36 2009 @@ -1,7 +1,16 @@ -2009-10-06 - Rationalized widget construction in macros define-widget and - define-container-widget. Now code is more functional instead of - procedural. +Snow version 0.2 (2009-11-28) + +This is an alpha release, focused on stabilizing the core engine, providing +user-friendly data binding, GUI REPL, debugger and inspector, and a showcase +application. + +Features: +- Basic framework: widget macros, data binding, possibility of multiple backends coexisting at runtime (e.g. Swing and SWT). +- Supported widgets: most Swing widgets are very minimally supported. + +Bug fixes: +- Several Windows-specific bugs were fixed. + ----------------------- old svn repo log below: Modified: trunk/lib/abcl.jar ============================================================================== Binary files. No diff available. Modified: trunk/src/java/org/armedbear/lisp/Callback.java ============================================================================== --- trunk/src/java/org/armedbear/lisp/Callback.java (original) +++ trunk/src/java/org/armedbear/lisp/Callback.java Mon Nov 30 17:44:36 2009 @@ -33,6 +33,8 @@ package org.armedbear.lisp; +import static org.armedbear.lisp.Lisp.error; + import java.util.concurrent.Callable; public abstract class Callback extends Function { @@ -42,41 +44,29 @@ } @Override - public LispObject execute() throws ConditionThrowable { - try { - return JavaObject.getInstance(call()); - } catch(Throwable e) { - throw new ConditionThrowable(new JavaException(e)); - } + public LispObject execute() { + return JavaObject.getInstance(call()); } - protected Object call() throws Throwable { + protected Object call() { return error(new WrongNumberOfArgumentsException(this)); } @Override - public LispObject execute(LispObject arg0) throws ConditionThrowable { - try { - return JavaObject.getInstance(call(arg0.javaInstance())); - } catch(Exception e) { - throw new ConditionThrowable(new JavaException(e)); - } + public LispObject execute(LispObject arg0) { + return JavaObject.getInstance(call(arg0.javaInstance())); } - protected Object call(Object arg0) throws Exception, ConditionThrowable { + protected Object call(Object arg0) { return error(new WrongNumberOfArgumentsException(this)); } @Override - public LispObject execute(LispObject arg0, LispObject arg1) throws ConditionThrowable { - try { - return JavaObject.getInstance(call(arg0.javaInstance(), arg1.javaInstance())); - } catch(Exception e) { - throw new ConditionThrowable(new JavaException(e)); - } + public LispObject execute(LispObject arg0, LispObject arg1) { + return JavaObject.getInstance(call(arg0.javaInstance(), arg1.javaInstance())); } - protected Object call(Object arg0, Object arg1) throws Exception, ConditionThrowable { + protected Object call(Object arg0, Object arg1) { return error(new WrongNumberOfArgumentsException(this)); } @@ -93,8 +83,12 @@ public static Callback fromCallable(final Callable c) { return new Callback() { - protected Object call() throws Exception { - return c.call(); + protected Object call() { + try { + return c.call(); + } catch(Exception e) { + return error(new JavaException(e)); + } } }; } Modified: trunk/src/java/snow/binding/AccessorBinding.java ============================================================================== --- trunk/src/java/snow/binding/AccessorBinding.java (original) +++ trunk/src/java/snow/binding/AccessorBinding.java Mon Nov 30 17:44:36 2009 @@ -32,7 +32,6 @@ package snow.binding; -import org.armedbear.lisp.ConditionThrowable; import org.armedbear.lisp.JavaObject; import org.armedbear.lisp.LispObject; @@ -55,35 +54,27 @@ } - @Override - public Object getValue() { - try { - return reader.execute(place).javaInstance(); - } catch (ConditionThrowable e) { - throw new RuntimeException(e); - } - } - - @Override - public void setValue(Object value) { - try { - writer.execute(JavaObject.getInstance(value, true), place); - } catch (ConditionThrowable e) { - throw new RuntimeException(e); - } - } + @Override + public Object getValue() { + return reader.execute(place).javaInstance(); + } + + @Override + public void setValue(Object value) { + writer.execute(JavaObject.getInstance(value, true), place); + } /** * Called from Lisp to notify a value change without invoking the writer. */ - public void valueChanged(Object value) { - fireValueChange(oldValue, value, false); - oldValue = value; - } - - public LispObject getPlace() { - return place; - } + public void valueChanged(Object value) { + fireValueChange(oldValue, value, false); + oldValue = value; + } + + public LispObject getPlace() { + return place; + } public void setPlace(LispObject place) { Modified: trunk/src/java/snow/binding/BeanPropertyPathBinding.java ============================================================================== --- trunk/src/java/snow/binding/BeanPropertyPathBinding.java (original) +++ trunk/src/java/snow/binding/BeanPropertyPathBinding.java Mon Nov 30 17:44:36 2009 @@ -32,7 +32,6 @@ package snow.binding; -import org.armedbear.lisp.ConditionThrowable; import org.armedbear.lisp.JavaObject; import org.armedbear.lisp.LispObject; import java.beans.*; Modified: trunk/src/java/snow/binding/Converter.java ============================================================================== --- trunk/src/java/snow/binding/Converter.java (original) +++ trunk/src/java/snow/binding/Converter.java Mon Nov 30 17:44:36 2009 @@ -32,7 +32,6 @@ package snow.binding; -import org.armedbear.lisp.ConditionThrowable; import org.armedbear.lisp.JavaObject; import org.armedbear.lisp.LispObject; @@ -53,30 +52,22 @@ } - @Override - public Object getValue() { - Object value = valueModel.getValue(); - try { - return converterTo.execute(JavaObject.getInstance(value, true)).javaInstance(); - } catch (ConditionThrowable e) { - throw new RuntimeException(e); - } - } - - @Override - public void setValue(Object obj) { - try { - Object value = converterFrom.execute(JavaObject.getInstance(obj, true)).javaInstance(); - valueModel.setValue(value); - } catch (ConditionThrowable e) { - throw new RuntimeException(e); - } - } - - public ValueModel getValueModel() { - return valueModel; - } - + @Override + public Object getValue() { + Object value = valueModel.getValue(); + return converterTo.execute(JavaObject.getInstance(value, true)).javaInstance(); + } + + @Override + public void setValue(Object obj) { + Object value = converterFrom.execute(JavaObject.getInstance(obj, true)).javaInstance(); + valueModel.setValue(value); + } + + public ValueModel getValueModel() { + return valueModel; + } + public void setValueModel(ValueModel valueModel) { this.valueModel = valueModel; Modified: trunk/src/java/snow/list/ConsListCellRenderer.java ============================================================================== --- trunk/src/java/snow/list/ConsListCellRenderer.java (original) +++ trunk/src/java/snow/list/ConsListCellRenderer.java Mon Nov 30 17:44:36 2009 @@ -54,14 +54,10 @@ 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); - } + retVal = function != null && value instanceof LispObject ? function.execute((LispObject) value) : value; + if(retVal instanceof LispObject) { + retVal = ((LispObject) retVal).writeToString(); + } return super.getListCellRendererComponent(list, retVal, index, selected, cellHasFocus); } Modified: trunk/src/java/snow/list/ConsListModel.java ============================================================================== --- trunk/src/java/snow/list/ConsListModel.java (original) +++ trunk/src/java/snow/list/ConsListModel.java Mon Nov 30 17:44:36 2009 @@ -34,7 +34,6 @@ import javax.swing.AbstractListModel; -import org.armedbear.lisp.ConditionThrowable; import org.armedbear.lisp.Cons; import org.armedbear.lisp.Fixnum; import org.armedbear.lisp.Lisp; @@ -53,23 +52,15 @@ } } - @Override - public Object getElementAt(int index) { - try { - LispObject o = Symbol.NTH.execute(Fixnum.getInstance(index), cons); - return o.javaInstance(); - } catch (ConditionThrowable e) { - throw new RuntimeException(e); - } - } - - @Override - public int getSize() { - try { - return Symbol.LENGTH.execute(cons).intValue(); - } catch(ConditionThrowable e) { - throw new RuntimeException(e); - } - } + @Override + public Object getElementAt(int index) { + LispObject o = Symbol.NTH.execute(Fixnum.getInstance(index), cons); + return o.javaInstance(); + } + + @Override + public int getSize() { + return Symbol.LENGTH.execute(cons).intValue(); + } } Modified: trunk/src/java/snow/swing/ConsoleDocument.java ============================================================================== --- trunk/src/java/snow/swing/ConsoleDocument.java (original) +++ trunk/src/java/snow/swing/ConsoleDocument.java Mon Nov 30 17:44:36 2009 @@ -51,17 +51,17 @@ import javax.swing.text.DefaultStyledDocument; import javax.swing.text.JTextComponent; -import org.armedbear.lisp.ConditionThrowable; import org.armedbear.lisp.Function; import org.armedbear.lisp.Interpreter; import org.armedbear.lisp.LispObject; import org.armedbear.lisp.LispThread; -import org.armedbear.lisp.Package; -import org.armedbear.lisp.SpecialBinding; +import org.armedbear.lisp.SpecialBindingsMark; import org.armedbear.lisp.Stream; import org.armedbear.lisp.Symbol; import org.armedbear.lisp.TwoWayStream; +import static org.armedbear.lisp.Lisp.*; + public class ConsoleDocument extends DefaultStyledDocument { private int lastEditableOffset = 0; @@ -122,24 +122,20 @@ private boolean disposed = false; private final Thread replThread; - public ConsoleDocument(LispObject replFunction) { - final LispObject replWrapper = makeReplWrapper(new StreamEx(new BufferedReader(reader)), - new StreamEx(new BufferedWriter(writer)), - replFunction); - replThread = new Thread("REPL-thread-" + System.identityHashCode(this)) { - public void run() { - try { - while(true) { - replWrapper.execute(); - yield(); - } - } catch (ConditionThrowable e) { - throw new RuntimeException(e); - } - } - }; - replThread.start(); - } + public ConsoleDocument(LispObject replFunction) { + final LispObject replWrapper = makeReplWrapper(new StreamEx(new BufferedReader(reader)), + new StreamEx(new BufferedWriter(writer)), + replFunction); + replThread = new Thread("REPL-thread-" + System.identityHashCode(this)) { + public void run() { + while(true) { + replWrapper.execute(); + yield(); + } + } + }; + replThread.start(); + } @Override public void insertString(int offs, String str, AttributeSet a) @@ -253,69 +249,67 @@ replThread.interrupt(); //really? } - private final LispObject debuggerHook = new Function() { - - @Override - public LispObject execute(LispObject condition, LispObject debuggerHook) - throws ConditionThrowable { - if(disposed) { - return Package.PACKAGE_SYS.findSymbol("%DEBUGGER-HOOK-FUNCTION").execute(condition, debuggerHook); - } else { - return NIL; - } + private final LispObject debuggerHook = new Function() { + + @Override + public LispObject execute(LispObject condition, LispObject debuggerHook) { + if(disposed) { + return PACKAGE_SYS.findSymbol("%DEBUGGER-HOOK-FUNCTION").execute(condition, debuggerHook); + } else { + return NIL; } - + } + }; - public LispObject makeReplWrapper(final Stream in, final Stream out, final LispObject fn) { - return new Function() { - @Override - public LispObject execute() - throws ConditionThrowable { - SpecialBinding lastSpecialBinding = LispThread.currentThread().lastSpecialBinding; - try { - TwoWayStream ioStream = new TwoWayStream(in, out); - LispThread.currentThread().bindSpecial(Symbol.DEBUGGER_HOOK, debuggerHook); - LispThread.currentThread().bindSpecial(Symbol.STANDARD_INPUT, in); - LispThread.currentThread().bindSpecial(Symbol.STANDARD_OUTPUT, out); - LispThread.currentThread().bindSpecial(Symbol.TERMINAL_IO, ioStream); - LispThread.currentThread().bindSpecial(Symbol.DEBUG_IO, ioStream); - LispThread.currentThread().bindSpecial(Symbol.QUERY_IO, ioStream); - return fn.execute(); - } finally { - LispThread.currentThread().lastSpecialBinding = lastSpecialBinding; - } - } - - }; - } + public LispObject makeReplWrapper(final Stream in, final Stream out, final LispObject fn) { + return new Function() { + @Override + public LispObject execute() { + SpecialBindingsMark lastSpecialBinding = LispThread.currentThread().markSpecialBindings(); + try { + TwoWayStream ioStream = new TwoWayStream(in, out); + LispThread.currentThread().bindSpecial(Symbol.DEBUGGER_HOOK, debuggerHook); + LispThread.currentThread().bindSpecial(Symbol.STANDARD_INPUT, in); + LispThread.currentThread().bindSpecial(Symbol.STANDARD_OUTPUT, out); + LispThread.currentThread().bindSpecial(Symbol.TERMINAL_IO, ioStream); + LispThread.currentThread().bindSpecial(Symbol.DEBUG_IO, ioStream); + LispThread.currentThread().bindSpecial(Symbol.QUERY_IO, ioStream); + return fn.execute(); + } finally { + LispThread.currentThread().resetSpecialBindings(lastSpecialBinding); + } + } + + }; + } - public void disposeOnClose(Window parent) { - parent.addWindowListener(new WindowAdapter() { - @Override - public void windowClosing(WindowEvent e) { - dispose(); - } - }); - } + public void disposeOnClose(Window parent) { + parent.addWindowListener(new WindowAdapter() { + @Override + public void windowClosing(WindowEvent e) { + dispose(); + } + }); + } - public static void main(String[] args) { - LispObject repl = null; - try { - repl = Interpreter.createInstance().eval("#'top-level::top-level-loop"); - } catch (Throwable e) { - e.printStackTrace(); - System.exit(1); - } - final ConsoleDocument d = new ConsoleDocument(repl); - final JTextComponent txt = new JTextArea(d); - d.setupTextComponent(txt); - JFrame f = new JFrame(); - f.add(new JScrollPane(txt)); - d.disposeOnClose(f); - f.setDefaultCloseOperation(f.EXIT_ON_CLOSE); - f.pack(); - f.setVisible(true); - } + public static void main(String[] args) { + LispObject repl = null; + try { + repl = Interpreter.createInstance().eval("#'top-level::top-level-loop"); + } catch (Throwable e) { + e.printStackTrace(); + System.exit(1); + } + final ConsoleDocument d = new ConsoleDocument(repl); + final JTextComponent txt = new JTextArea(d); + d.setupTextComponent(txt); + JFrame f = new JFrame(); + f.add(new JScrollPane(txt)); + d.disposeOnClose(f); + f.setDefaultCloseOperation(f.EXIT_ON_CLOSE); + f.pack(); + f.setVisible(true); + } } Added: trunk/src/java/snow/swing/MouseInputListener.java ============================================================================== --- (empty file) +++ trunk/src/java/snow/swing/MouseInputListener.java Mon Nov 30 17:44:36 2009 @@ -0,0 +1,92 @@ +/* + * WindowListener.java + * + * Copyright (C) 2008-2009 Alessio Stalla + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + * + * As a special exception, the copyright holders of this library give you + * permission to link this library with independent modules to produce an + * executable, regardless of the license terms of these independent + * modules, and to copy and distribute the resulting executable under + * terms of your choice, provided that you also meet, for each linked + * independent module, the terms and conditions of the license of that + * module. An independent module is a module which is not derived from + * or based on this library. If you modify this library, you may extend + * this exception to your version of the library, but you are not + * obligated to do so. If you do not wish to do so, delete this + * exception statement from your version. + */ + +package snow.swing; + +import java.awt.event.MouseEvent; + +import org.armedbear.lisp.JavaObject; +import org.armedbear.lisp.LispObject; + +public class MouseInputListener implements javax.swing.event.MouseInputListener { + + private LispObject mouseClicked, mouseEntered, mouseExited, mousePressed, mouseReleased; + private LispObject mouseDragged, mouseMoved; + + public MouseInputListener(LispObject mouseClicked, LispObject mousePressed, LispObject mouseReleased, LispObject mouseEntered, LispObject mouseExited, LispObject mouseDragged, LispObject mouseMoved) { + super(); + this.mouseClicked = mouseClicked; + this.mousePressed = mousePressed; + this.mouseReleased = mouseReleased; + + this.mouseEntered = mouseEntered; + this.mouseExited = mouseExited; + + this.mouseDragged = mouseDragged; + this.mouseMoved = mouseMoved; + } + + private static final void invokeDelegate(LispObject delegate, MouseEvent e) { + if(delegate != null) { + delegate.execute(new JavaObject(e)); + } + } + + public void mouseClicked(MouseEvent e) { + invokeDelegate(mouseClicked, e); + } + + public void mouseEntered(MouseEvent e) { + invokeDelegate(mouseEntered, e); + } + + public void mouseExited(MouseEvent e) { + invokeDelegate(mouseExited, e); + } + + public void mousePressed(MouseEvent e) { + invokeDelegate(mousePressed, e); + } + + public void mouseReleased(MouseEvent e) { + invokeDelegate(mouseReleased, e); + } + + public void mouseDragged(MouseEvent e) { + invokeDelegate(mouseDragged, e); + } + + public void mouseMoved(MouseEvent e) { + invokeDelegate(mouseMoved, e); + } + +} Modified: trunk/src/java/snow/swing/WindowListener.java ============================================================================== --- trunk/src/java/snow/swing/WindowListener.java (original) +++ trunk/src/java/snow/swing/WindowListener.java Mon Nov 30 17:44:36 2009 @@ -34,77 +34,72 @@ import java.awt.event.WindowEvent; -import org.armedbear.lisp.ConditionThrowable; import org.armedbear.lisp.JavaObject; import org.armedbear.lisp.LispObject; public class WindowListener implements java.awt.event.WindowListener { - private LispObject windowActivated; - private LispObject windowClosed; - private LispObject windowClosing; - private LispObject windowDeactivated; - private LispObject windowDeiconified; - private LispObject windowIconified; - private LispObject windowOpened; + private LispObject windowActivated; + private LispObject windowClosed; + private LispObject windowClosing; + private LispObject windowDeactivated; + private LispObject windowDeiconified; + private LispObject windowIconified; + private LispObject windowOpened; - public WindowListener(LispObject windowActivated, LispObject windowClosed, - LispObject windowClosing, LispObject windowDeactivated, - LispObject windowDeiconified, LispObject windowIconified, - LispObject windowOpened) { - super(); - this.windowActivated = windowActivated; - this.windowClosed = windowClosed; - this.windowClosing = windowClosing; - this.windowDeactivated = windowDeactivated; - this.windowDeiconified = windowDeiconified; - this.windowIconified = windowIconified; - this.windowOpened = windowOpened; - } + public WindowListener(LispObject windowActivated, LispObject windowClosed, + LispObject windowClosing, LispObject windowDeactivated, + LispObject windowDeiconified, LispObject windowIconified, + LispObject windowOpened) { + super(); + this.windowActivated = windowActivated; + this.windowClosed = windowClosed; + this.windowClosing = windowClosing; + this.windowDeactivated = windowDeactivated; + this.windowDeiconified = windowDeiconified; + this.windowIconified = windowIconified; + this.windowOpened = windowOpened; + } - private static final void invokeDelegate(LispObject delegate, WindowEvent e) { - if(delegate != null) { - try { - delegate.execute(new JavaObject(e)); - } catch (ConditionThrowable e1) { - throw new RuntimeException(e1); - } - } + private static final void invokeDelegate(LispObject delegate, WindowEvent e) { + if(delegate != null) { + delegate.execute(new JavaObject(e)); } + } - @Override - public void windowActivated(WindowEvent e) { - invokeDelegate(windowActivated, e); - } - - @Override - public void windowClosed(WindowEvent e) { - invokeDelegate(windowClosed, e); - } - - @Override - public void windowClosing(WindowEvent e) { - invokeDelegate(windowClosing, e); - } - - @Override - public void windowDeactivated(WindowEvent e) { - invokeDelegate(windowDeactivated, e); - } - - @Override - public void windowDeiconified(WindowEvent e) { - invokeDelegate(windowDeiconified, e); - } - - @Override - public void windowIconified(WindowEvent e) { - invokeDelegate(windowIconified, e); - } - - @Override - public void windowOpened(WindowEvent e) { - invokeDelegate(windowOpened, e); - } + @Override + public void windowActivated(WindowEvent e) { + invokeDelegate(windowActivated, e); + } + + @Override + public void windowClosed(WindowEvent e) { + invokeDelegate(windowClosed, e); + } + + @Override + public void windowClosing(WindowEvent e) { + invokeDelegate(windowClosing, e); + } + + @Override + public void windowDeactivated(WindowEvent e) { + invokeDelegate(windowDeactivated, e); + } + + @Override + public void windowDeiconified(WindowEvent e) { + invokeDelegate(windowDeiconified, e); + } + + @Override + public void windowIconified(WindowEvent e) { + invokeDelegate(windowIconified, e); + } + + @Override + public void windowOpened(WindowEvent e) { + invokeDelegate(windowOpened, e); + } } Modified: trunk/src/java/snow/tree/ConsTreeCellRenderer.java ============================================================================== --- trunk/src/java/snow/tree/ConsTreeCellRenderer.java (original) +++ trunk/src/java/snow/tree/ConsTreeCellRenderer.java Mon Nov 30 17:44:36 2009 @@ -37,34 +37,29 @@ import javax.swing.JTree; import javax.swing.tree.DefaultTreeCellRenderer; -import org.armedbear.lisp.ConditionThrowable; import org.armedbear.lisp.Cons; import org.armedbear.lisp.LispObject; public class ConsTreeCellRenderer extends DefaultTreeCellRenderer { - @Override - public Component getTreeCellRendererComponent(JTree tree, Object value, - boolean sel, boolean expanded, boolean leaf, int row, - boolean hasFocus) { - if(value instanceof LispObject) { - LispObject obj = (LispObject) value; - try { - if(obj instanceof Cons) { - return super.getTreeCellRendererComponent(tree, ((Cons) obj).car.writeToString(), sel, expanded, leaf, - row, hasFocus); - } else { - return super.getTreeCellRendererComponent(tree, obj.writeToString(), sel, expanded, leaf, - row, hasFocus); - } - } catch(ConditionThrowable t) { - //Should never happen - throw new RuntimeException(t); - } - } else { - return super.getTreeCellRendererComponent(tree, value, sel, expanded, leaf, - row, hasFocus); - } + @Override + public Component getTreeCellRendererComponent(JTree tree, Object value, + boolean sel, boolean expanded, + boolean leaf, int row, + boolean hasFocus) { + if(value instanceof LispObject) { + LispObject obj = (LispObject) value; + if(obj instanceof Cons) { + return super.getTreeCellRendererComponent(tree, ((Cons) obj).car.writeToString(), sel, expanded, leaf, + row, hasFocus); + } else { + return super.getTreeCellRendererComponent(tree, obj.writeToString(), sel, expanded, leaf, + row, hasFocus); + } + + } else { + return super.getTreeCellRendererComponent(tree, value, sel, expanded, leaf, + row, hasFocus); } - + } } Modified: trunk/src/java/snow/tree/ConsTreeModel.java ============================================================================== --- trunk/src/java/snow/tree/ConsTreeModel.java (original) +++ trunk/src/java/snow/tree/ConsTreeModel.java Mon Nov 30 17:44:36 2009 @@ -39,7 +39,6 @@ import javax.swing.tree.TreeModel; import javax.swing.tree.TreePath; -import org.armedbear.lisp.ConditionThrowable; import org.armedbear.lisp.Cons; import org.armedbear.lisp.Fixnum; import org.armedbear.lisp.Lisp; @@ -56,81 +55,66 @@ this.cons = cons; } - @Override - public Object getChild(Object parent, int index) { - if(parent instanceof Cons) { - try { - return Symbol.NTH.execute(Fixnum.getInstance(index + 1), (Cons) parent); - } catch (ConditionThrowable e) { - return null; - } - } else { - return null; - } - } - - @Override - public int getChildCount(Object parent) { - if(parent instanceof Cons) { - try { - return ((Fixnum) Symbol.LENGTH.execute((Cons) parent)).value - 1; - } catch (ConditionThrowable e) { - return 0; - } - } else { - return 0; - } - } - - @Override - public int getIndexOfChild(Object parent, Object child) { - if(parent == null || child == null) { - return -1; - } - try { - if(Symbol.MEMBER.execute((LispObject) parent, cons) != Lisp.NIL) { - Object pos = Symbol.POSITION.execute((LispObject) child, (LispObject) parent); - if(pos instanceof Fixnum) { - return ((Fixnum) pos).value - 1; - } else { - return -1; - } - } else { - return -1; - } - } catch (ConditionThrowable e) { - return -1; - } - } - - @Override - public Object getRoot() { - return cons; - } - - @Override - public boolean isLeaf(Object node) { - try { - return Symbol.ATOM.execute((LispObject) node) != Lisp.NIL; - } catch (ConditionThrowable e) { - return true; - } - } - - @Override - public void addTreeModelListener(TreeModelListener l) { - listeners.add(l); - } + @Override + public Object getChild(Object parent, int index) { + if(parent instanceof Cons) { + return Symbol.NTH.execute(Fixnum.getInstance(index + 1), (Cons) parent); + + } else { + return null; + } + } + + @Override + public int getChildCount(Object parent) { + if(parent instanceof Cons) { + return ((Fixnum) Symbol.LENGTH.execute((Cons) parent)).value - 1; + } else { + return 0; + } + } + + @Override + public int getIndexOfChild(Object parent, Object child) { + if(parent == null || child == null) { + return -1; + } + if(Symbol.MEMBER.execute((LispObject) parent, cons) != Lisp.NIL) { + Object pos = Symbol.POSITION.execute((LispObject) child, (LispObject) parent); + if(pos instanceof Fixnum) { + return ((Fixnum) pos).value - 1; + } else { + return -1; + } + } else { + return -1; + } + } + + @Override + public Object getRoot() { + return cons; + } + + @Override + public boolean isLeaf(Object node) { + return Symbol.ATOM.execute((LispObject) node) != Lisp.NIL; + } + + @Override + public void addTreeModelListener(TreeModelListener l) { + listeners.add(l); + } + + @Override + public void removeTreeModelListener(TreeModelListener l) { + listeners.remove(l); + } + + @Override + public void valueForPathChanged(TreePath path, Object newValue) { + // TODO Auto-generated method stub - @Override - public void removeTreeModelListener(TreeModelListener l) { - listeners.remove(l); - } - - @Override - public void valueForPathChanged(TreePath path, Object newValue) { - // TODO Auto-generated method stub - - } + } } Modified: trunk/src/lisp/snow/showcase/showcase.lisp ============================================================================== --- trunk/src/lisp/snow/showcase/showcase.lisp (original) +++ trunk/src/lisp/snow/showcase/showcase.lisp Mon Nov 30 17:44:36 2009 @@ -1,6 +1,3 @@ -#-snow-cells -(error "This showcase needs Snow built with Cells support") - (defpackage :snow-showcase (:use :common-lisp :snow :java :ext :named-readtables :cells) (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*)) @@ -54,6 +51,46 @@ (defvar *variable* (make-var "42")) (defvar *cells-object* (make-instance 'my-model)) +(define-example "Data Binding" + (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) + (declare (ignore 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"))))) + +(define-example "Mouse Events" + (panel (:layout "grow" + :on-mouse-click (lambda (evt) (format t "Click! ~A~%" evt))) + (label :text "Click here!"))) + (define-example "Lists and trees" (scroll (:layout "grow") (list-widget :model (make-list-model '(1 2 (c (a b)) 3)) @@ -75,48 +112,12 @@ (princ "Thanks for pushing me! ") (finish-output)))) -(define-example "Data Binding" - (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) - (declare (ignore 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")))))) - (defun showcase () (with-gui (:swing) (frame (:id frame :title "Sample JFrame" :visible-p t :size #C(800 600) :layout-manager '(:mig "fill")) (tabs (:layout "grow") - (dolist (x *examples*) + (dolist (x (reverse *examples*)) (tab (car x) (funcall (cadr x)))))))) #|| Modified: trunk/src/lisp/snow/snow.asd ============================================================================== --- trunk/src/lisp/snow/snow.asd (original) +++ trunk/src/lisp/snow/snow.asd Mon Nov 30 17:44:36 2009 @@ -38,6 +38,7 @@ (:file "utils") (:file "cx-dynamic-environments") (:file "snow") + (:file "widgets") (:file "repl") (:file "data-binding") #+snow-cells Modified: trunk/src/lisp/snow/snow.lisp ============================================================================== --- trunk/src/lisp/snow/snow.lisp (original) +++ trunk/src/lisp/snow/snow.lisp Mon Nov 30 17:44:36 2009 @@ -30,9 +30,71 @@ (in-package :snow) +;;Common Interfaces +(defvar *gui-backend* :swing "Variable used to determine the GUI backend, and thus interface implementation, to use. Defaults to :swing.") + +(definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints)) + +(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-visible-p) *gui-backend* (value widget)) + +(definterface (setf widget-location) *gui-backend* (value widget)) + +(definterface (setf widget-size) *gui-backend* (value widget)) + +(definterface dispose *gui-backend* (obj)) + +(definterface show *gui-backend* (obj)) + +(definterface hide *gui-backend* (obj)) + +(definterface pack *gui-backend* (window)) + (defvar *parent* nil) +(definterface call-in-gui-thread *gui-backend* (fn) + "Arranges to be called from a thread in which it is safe to create GUI components (for example, the Event Dispatching Thread in Swing).") + +(defvar *dynamic-environment* nil) + +(defmacro with-snow-dynamic-environment (&body body) + (with-unique-names (gui-backend-var package-var terminal-io-var) + `(if *dynamic-environment* + (with-dynamic-environment (*dynamic-environment*) + , at body) + (let* ((,gui-backend-var *gui-backend*) + (,package-var *package*) + (,terminal-io-var *terminal-io*)) ;;Etc... + (dynamic-wind + (let ((*gui-backend* ,gui-backend-var) + (*package* ,package-var) + (*debugger-hook* *graphical-debugger-hook*) + (*terminal-io* ,terminal-io-var)) + (proceed + (let ((*dynamic-environment* (capture-dynamic-environment))) + (with-dynamic-environment (*dynamic-environment*) + , at body))))))))) + +(defmacro lambda/dynamic-environment (args &body body) + (with-unique-names (dynamic-environment) + `(with-snow-dynamic-environment + (let ((,dynamic-environment *dynamic-environment*)) + (lambda ,args (with-dynamic-environment (,dynamic-environment) + (let ((*dynamic-environment* ,dynamic-environment)) + , at body))))))) + +(defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body) + (declare (ignore gui-backend)) + `(call-in-gui-thread + (lambda/dynamic-environment () , at body))) + (defun dashed->camelcased (string-designator) + "Transforms a name (string designator) from the Lisp naming convention of separating multiple words with dashes to the Java camelCase convention." (let ((str (string string-designator)) (last-was-dash-p nil)) (with-output-to-string (out) @@ -76,6 +138,7 @@ (nreverse result))))) (defmacro set-widget-properties (widget &rest props) + "Convenience macro to set a number of widget properties in bulk." (with-unique-names (widget-var) `(let ((,widget-var ,widget)) ,@(map-keys (lambda (key value) @@ -85,16 +148,20 @@ (defgeneric bind-widget (widget binding) (:documentation "Connects a widget to a data binding. The framework automatically chooses which property of the widget to connect.")) -(definterface make-layout-manager *gui-backend* (widget type &rest args)) +(definterface make-layout-manager *gui-backend* (widget type &rest args) + "Creates a backed-specific object used to layout components.") -(definterface (setf layout-manager) *gui-backend* (lm widget)) +(definterface (setf layout-manager) *gui-backend* (lm widget) + "Sets the layout manager for a given (container) widget.") (defun setup-container-widget (self &key (layout-manager :default) &allow-other-keys) + "Common setup for all container widgets." (setf (layout-manager self) (apply #'make-layout-manager self (ensure-list (or layout-manager :default))))) (defun generate-default-children-processing-code (id children) + "Can be used inside a macro defining a container widget to generate the code to process its body, adding children to it." (let ((code (loop :for form :in children @@ -111,36 +178,60 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun common-widget-args () - '(layout binding (enabled-p t) (visible-p t) location size)) + '(layout binding (enabled-p t) (visible-p t) location size + on-mouse-click on-mouse-press on-mouse-release + on-mouse-enter on-mouse-exit + on-mouse-drag on-mouse-move)) + (defun common-container-widget-args () + '(id (layout-manager :default))) (defun common-widget-args-declarations () (let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x))) (common-widget-args)))) `((declare (ignorable , at arg-names))))) (defun filter-arglist (args filtered-keys) + "Eliminates :key value pairs in args where key is a member of filtered-keys. Returns a new list without the removed pairs." (loop :for key :in args :by #'cddr :for value :in (cdr args) by #'cddr :when (not (member key filtered-keys)) :collect key :and - :collect value)) - (defun filter-widget-args (args) - "Eliminates widget arguments processed by common-widget-setup; else, they would be evaluated twice in the macro expansion." - (filter-arglist args '(:id :layout :binding :enabled-p :visible-p :location - :layout-manager :size)))) - -(defun common-widget-setup (self layout binding enabled-p visible-p - location size) - (setup-widget self :layout layout :binding binding :enabled-p enabled-p - :visible-p visible-p :location location :size size)) + :collect value))) + +(definterface setup-mouse-listeners *gui-backend* + (widget on-mouse-click on-mouse-press on-mouse-release + on-mouse-enter on-mouse-exit on-mouse-drag on-mouse-move) + "Sets mouse listener(s) on a widget.") (defun setup-widget (self &key layout binding (enabled-p t) (visible-p t) - location size &allow-other-keys) - (when *parent* (add-child self *parent* layout)) - (setf (widget-enabled-p self) enabled-p) - (setf (widget-visible-p self) visible-p) - (when location (setf (widget-location self) location)) - (when binding (bind-widget self binding)) - (when size (setf (widget-size self) size))) + location size + ;;mouse event handling + on-mouse-click on-mouse-press on-mouse-release + on-mouse-enter on-mouse-exit + on-mouse-drag on-mouse-move + &allow-other-keys) + "Performs the common setup of any widget." + (macrolet ((wrap-event-callback (fn) ;;Pay attention to double evaluation + `(when ,fn + (lambda/dynamic-environment (evt) + (funcall ,fn evt))))) + (when *parent* (add-child self *parent* layout)) + (setf (widget-enabled-p self) enabled-p) + (setf (widget-visible-p self) visible-p) + (when (or on-mouse-click on-mouse-press on-mouse-release + on-mouse-enter on-mouse-exit + on-mouse-drag on-mouse-move) + (setup-mouse-listeners + self + (wrap-event-callback on-mouse-click) + (wrap-event-callback on-mouse-press) + (wrap-event-callback on-mouse-release) + (wrap-event-callback on-mouse-enter) + (wrap-event-callback on-mouse-exit) + (wrap-event-callback on-mouse-drag) + (wrap-event-callback on-mouse-move))) + (when location (setf (widget-location self) location)) + (when binding (bind-widget self binding)) + (when size (setf (widget-size self) size)))) #+emacs (put 'define-widget-macro 'lisp-indent-function 3) #+emacs (put 'define-widget 'lisp-indent-function 3) @@ -148,33 +239,22 @@ (defmacro define-widget-macro (name arglist constructor &body body) `(progn - (defmacro ,name (, at arglist) - `(let ((self ,,constructor)) ;The lexical variable self is always bound to the current widget. - ,, at body - self)) - (setf (get ',name 'widget-p) t))) - -;;Experimental - not working right now -(defmacro define-widget-function (name arglist constructor &body body) - `(progn - (defun ,name (, at arglist) + (defmacro ,name ,(splice-into (common-widget-args) '&common-widget-args + arglist) `(let ((self ,,constructor)) ;The lexical variable self is always bound to the current widget. ,, at body self)) (setf (get ',name 'widget-p) t))) (define-widget-macro with-widget - ((widget &rest args &key id layout binding (enabled-p t) (visible-p t) - location size) - &body body) + ((widget &rest args &key id &common-widget-args) &body body) `(dont-add ,widget) `(progn ,@(generate-default-children-processing-code id body) - (common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size))) + (setup-widget self ,@(filter-arglist args '(:id))))) (define-widget-macro child - (widget &rest args &key layout binding (enabled-p t) (visible-p t) - location size) + (widget &rest args &key &common-widget-args) widget `(setup-widget , at args)) @@ -182,7 +262,7 @@ "Convenience macro for defining a widget." (with-unique-names (args) `(define-widget-macro ,name - (&rest ,args &key ,@(common-widget-args) , at keys) + (&rest ,args &key &common-widget-args , at keys) `(funcall (lambda (&rest args) ;;to evaluate args only once (let ((self (apply (function ,',constructor) args))) (apply #'setup-widget self args) @@ -195,7 +275,7 @@ "Convenience macro for defining a container widget." (with-unique-names (args macro-body) `(define-widget-macro ,name - ((&rest ,args &key id ,@(common-widget-args) layout-manager , at keys) + ((&rest ,args &key &common-widget-args id layout-manager , at keys) &body ,macro-body) `(funcall (lambda (&rest args) ;;to evaluate args only once (let ((self (apply (function ,',constructor) args))) @@ -215,24 +295,17 @@ (defmacro dont-add (&body body) `(let ((*parent* nil)) , at body)) - -(definterface call-in-gui-thread *gui-backend* (fn) - "Arranges to be called from a thread in which it is safe to create GUI components (for example, the Event Dispatching Thread in Swing).") - -(defvar *dynamic-environment* nil) - -(defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body) - (with-unique-names (gui-backend-var package-var debugger-hook-var + +#|| (with-unique-names (gui-backend-var package-var dynamic-environment terminal-io-var) `(let* ((,gui-backend-var ,gui-backend) (*gui-backend* ,gui-backend-var) (,package-var *package*) - (,debugger-hook-var *debugger-hook*) (,terminal-io-var *terminal-io*)) ;;Etc... (dynamic-wind (let ((*gui-backend* ,gui-backend-var) (*package* ,package-var) - (*debugger-hook* ,debugger-hook-var) + (*debugger-hook* *graphical-debugger-hook*) (*terminal-io* ,terminal-io-var)) (proceed (let ((,dynamic-environment (capture-dynamic-environment))) @@ -240,155 +313,4 @@ (lambda () (with-dynamic-environment (,dynamic-environment) (let ((*dynamic-environment* ,dynamic-environment)) - , at body))))))))))) - -;;Common Interfaces -(defvar *gui-backend* :swing "Variable used to determine the GUI backend, and thus interface implementation, to use. Defaults to :swing.") - -(definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints)) - -(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-visible-p) *gui-backend* (value widget)) - -(definterface (setf widget-location) *gui-backend* (value widget)) - -(definterface (setf widget-size) *gui-backend* (value widget)) - -(definterface dispose *gui-backend* (obj)) - -(definterface show *gui-backend* (obj)) - -(definterface hide *gui-backend* (obj)) - -(definterface pack *gui-backend* (window)) - -;;Windows -(definterface make-frame *gui-backend* (&key menu-bar title on-close - &allow-other-keys)) - -(define-container-widget frame (menu-bar title on-close) make-frame) - -(definterface make-dialog *gui-backend* - (&key parent title modal-p visible-p &allow-other-keys)) - -(define-widget-macro dialog - ((&rest args &key id layout binding (enabled-p t) (visible-p t) location - size layout-manager parent title modal-p visible-p) - &body body) - `(funcall (lambda (&rest args) ;;to evaluate args only once - (let ((self (apply (function make-dialog) args))) - (apply #'setup-widget self `(:visible-p nil , at args)) - (apply #'setup-container-widget self args) - self)) - ;;remove id because it must not be evaluated - ;;and visible-p because it must be set last - ,@(filter-arglist args '(:id :visible-p))) - `(progn - ,@(generate-default-children-processing-code id body) - (setf (widget-visible-p self) ,visible-p))) - -#| -(define-container-widget dialog (parent title modal-p) - make-dialog)|# - -;;Menus -(definterface make-menu-bar *gui-backend* (&key &allow-other-keys)) - -(define-container-widget menu-bar () make-menu-bar) - -(definterface make-menu *gui-backend* (&key text &allow-other-keys)) - -(define-container-widget menu (text) make-menu) - -(definterface make-menu-item *gui-backend* - (&key text on-action &allow-other-keys)) - -(define-widget menu-item (text on-action) make-menu-item) - -;;Panels -(definterface make-panel *gui-backend* (&key &allow-other-keys)) - -(define-container-widget panel () make-panel) - -(defvar *tabs*) - -(definterface make-tabs *gui-backend* (&key (wrap t) (tab-placement :top) - &allow-other-keys)) - -(define-widget-macro tabs - ((&rest args - &key id layout binding (enabled-p t) (visible-p t) location size (wrap t) - (tab-placement :top)) - &body body) - `(make-tabs :wrap ,wrap :tab-placement ,tab-placement) - `(let ((*tabs* self)) - (dont-add - ,@(if id - `((let ((,id self)) - , at body)) - body)) - (common-widget-setup self ,layout ,binding ,enabled-p ,visible-p - ,location ,size))) - -(defmacro tab (name &body body) - `(if *tabs* - (add-child (progn , at body) *tabs* ,name) - (error "tab outside tabset: ~A" ,name))) - -(definterface make-scroll-panel *gui-backend* (view)) - -(definterface scroll-panel-view *gui-backend* (self)) - -(definterface (setf scroll-panel-view) *gui-backend* (view self)) - -(define-widget-macro scroll - ((&rest args &key layout binding (enabled-p t) (visible-p t) location size) body) - `(make-scroll-panel (dont-add ,body)) - `(setup-widget self , at args)) - -(definterface make-split-panel *gui-backend* - (child1 child2 &key (orientation :horizontal) smoothp)) - -(define-widget-macro split - ((&rest args &key layout binding (enabled-p t) (visible-p t) location size orientation smoothp) - child1 child2) - `(make-split-panel (dont-add ,child1) (dont-add ,child2) - :orientation ,orientation :smoothp ,smoothp) - `(common-widget-setup self ,layout ,binding ,enabled-p ,visible-p ,location ,size)) - -(defmacro defwidget (name &rest args) - (let* ((maker-sym (intern (concatenate 'string "MAKE-" (symbol-name name))))) - `(progn - (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys)) - (define-widget ,name (, at args &allow-other-keys) ,maker-sym)))) - -;;Buttons and similar - -(defwidget button text on-action) - -(defwidget check-box text selected-p) - -;;Misc - -(defwidget progress-bar value orientation (paint-border t) progress-string) - -;;Text - -(defwidget label text) - -(defwidget text-field text) - -(defwidget text-area text) - -;;Lists - -(defwidget list-widget model selected-index) - -;;Trees - -(defwidget tree model) \ No newline at end of file + , at body)))))))))))||# \ No newline at end of file Modified: trunk/src/lisp/snow/swing/swing.lisp ============================================================================== --- trunk/src/lisp/snow/swing/swing.lisp (original) +++ trunk/src/lisp/snow/swing/swing.lisp Mon Nov 30 17:44:36 2009 @@ -69,6 +69,20 @@ (defimpl (setf layout-manager) (lm widget) (setf (widget-property widget :layout) lm)) +(defimpl snow::setup-mouse-listeners + (widget on-mouse-click on-mouse-press on-mouse-release + on-mouse-enter on-mouse-exit on-mouse-drag on-mouse-move) + (let ((mouse-input-listener + (new "snow.swing.MouseInputListener" + on-mouse-click on-mouse-press on-mouse-release + on-mouse-enter on-mouse-exit + on-mouse-drag on-mouse-move))) + (when (or on-mouse-click on-mouse-press on-mouse-release + on-mouse-enter on-mouse-exit) + (invoke "addMouseListener" widget mouse-input-listener)) + (when (or on-mouse-drag on-mouse-move) + (invoke "addMouseMotionListener" widget mouse-input-listener)))) + (defconstant +add-to-container+ (jmethod "java.awt.Container" "add" "java.awt.Component")) (defconstant +add-to-container-with-constraints+ (jmethod "java.awt.Container" "add" "java.lang.String" "java.awt.Component")) Modified: trunk/src/lisp/snow/utils.lisp ============================================================================== --- trunk/src/lisp/snow/utils.lisp (original) +++ trunk/src/lisp/snow/utils.lisp Mon Nov 30 17:44:36 2009 @@ -60,6 +60,23 @@ obj (list obj))) +(defun splice-if (item predicate tree) + (let ((list-item (reverse (ensure-list item)))) + (labels + ((aux (tree acc) + (if tree + (if (listp (car tree)) + (aux (cdr tree) + (cons (splice-if item predicate (car tree)) acc)) + (if (funcall predicate (car tree)) + (aux (cdr tree) (append list-item acc)) + (aux (cdr tree) (cons (car tree) acc)))) + (nreverse acc)))) + (aux tree nil)))) + +(defun splice-into (item olditem tree) + (splice-if item #'(lambda (x) (eq x olditem)) tree)) + ;;Interface/implementation (defstruct interface name lambda-list (implementations (list))) Added: trunk/src/lisp/snow/widgets.lisp ============================================================================== --- (empty file) +++ trunk/src/lisp/snow/widgets.lisp Mon Nov 30 17:44:36 2009 @@ -0,0 +1,149 @@ +;;; widgets.lisp +;;; +;;; Copyright (C) 2008-2009 Alessio Stalla +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License +;;; as published by the Free Software Foundation; either version 2 +;;; of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from +;;; or based on this library. If you modify this library, you may extend +;;; this exception to your version of the library, but you are not +;;; obligated to do so. If you do not wish to do so, delete this +;;; exception statement from your version. + +(in-package :snow) + +;;Windows +(definterface make-frame *gui-backend* (&key menu-bar title on-close + &allow-other-keys)) + +(define-container-widget frame (menu-bar title on-close) make-frame) + +(definterface make-dialog *gui-backend* + (&key parent title modal-p visible-p &allow-other-keys)) + +(define-widget-macro dialog + ((&rest args &key &common-widget-args + id layout-manager parent title modal-p visible-p) + &body body) + `(funcall (lambda (&rest args) ;;to evaluate args only once + (let ((self (apply (function make-dialog) args))) + (apply #'setup-widget self `(:visible-p nil , at args)) + (apply #'setup-container-widget self args) + self)) + ;;remove id because it must not be evaluated + ;;and visible-p because it must be set last + ,@(filter-arglist args '(:id :visible-p))) + `(progn + ,@(generate-default-children-processing-code id body) + (setf (widget-visible-p self) ,visible-p))) + +;;Menus +(definterface make-menu-bar *gui-backend* (&key &allow-other-keys)) + +(define-container-widget menu-bar () make-menu-bar) + +(definterface make-menu *gui-backend* (&key text &allow-other-keys)) + +(define-container-widget menu (text) make-menu) + +(definterface make-menu-item *gui-backend* + (&key text on-action &allow-other-keys)) + +(define-widget menu-item (text on-action) make-menu-item) + +;;Panels +(definterface make-panel *gui-backend* (&key &allow-other-keys)) + +(define-container-widget panel () make-panel) + +(defvar *tabs*) + +(definterface make-tabs *gui-backend* (&key (wrap t) (tab-placement :top) + &allow-other-keys)) + +(define-widget-macro tabs + ((&rest args &key id &common-widget-args (wrap t) (tab-placement :top)) + &body body) + `(make-tabs :wrap ,wrap :tab-placement ,tab-placement) + `(let ((*tabs* self)) + (dont-add + ,@(if id + `((let ((,id self)) + , at body)) + body)) + (setup-widget self ,@(filter-arglist args '(:id))))) + +(defmacro tab (name &body body) + `(if *tabs* + (add-child (progn , at body) *tabs* ,name) + (error "tab outside tabset: ~A" ,name))) + +(definterface make-scroll-panel *gui-backend* (view)) + +(definterface scroll-panel-view *gui-backend* (self)) + +(definterface (setf scroll-panel-view) *gui-backend* (view self)) + +(define-widget-macro scroll + ((&rest args &key &common-widget-args) body) + `(make-scroll-panel (dont-add ,body)) + `(setup-widget self , at args)) + +(definterface make-split-panel *gui-backend* + (child1 child2 &key (orientation :horizontal) smoothp)) + +(define-widget-macro split + ((&rest args &key &common-widget-args orientation smoothp) + child1 child2) + `(make-split-panel (dont-add ,child1) (dont-add ,child2) + :orientation ,orientation :smoothp ,smoothp) + `(setup-widget self ,@(filter-arglist args '(:orientation :smoothp)))) + +(defmacro defwidget (name &rest args) + (let* ((maker-sym (intern (concatenate 'string "MAKE-" (symbol-name name))))) + `(progn + (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys)) + (define-widget ,name (, at args &allow-other-keys) ,maker-sym)))) + +;;Buttons and similar +(defwidget button text on-action) + +(defwidget check-box text selected-p) + +;;Misc + +(defwidget progress-bar value orientation (paint-border t) progress-string) + +;;Text + +(defwidget label text) + +(defwidget text-field text) + +(defwidget text-area text) + +;;Lists + +(defwidget list-widget model selected-index) + +;;Trees + +(defwidget tree model) \ No newline at end of file