[snow-cvs] r20 - in trunk/src: java/snow java/snow/example java/snow/showcase lisp/snow lisp/snow/showcase lisp/snow/swing
Alessio Stalla
astalla at common-lisp.net
Fri Nov 20 22:12:53 UTC 2009
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 <fn> 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))
More information about the snow-cvs
mailing list