[snow-cvs] r51 - in trunk: examples/swixml src/lisp/snow src/lisp/snow/showcase
Alessio Stalla
astalla at common-lisp.net
Thu Feb 4 19:03:49 UTC 2010
Author: astalla
Date: Thu Feb 4 14:03:48 2010
New Revision: 51
Log:
*event* passed as a special variable rather than as a function parameter.
Modified:
trunk/examples/swixml/helloworld.lisp
trunk/src/lisp/snow/debugger.lisp
trunk/src/lisp/snow/inspector.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/repl.lisp
trunk/src/lisp/snow/showcase/showcase.lisp
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/start.lisp
trunk/src/lisp/snow/swing.lisp
Modified: trunk/examples/swixml/helloworld.lisp
==============================================================================
--- trunk/examples/swixml/helloworld.lisp (original)
+++ trunk/examples/swixml/helloworld.lisp Thu Feb 4 14:03:48 2010
@@ -2,8 +2,7 @@
(in-readtable snow:syntax)
(let ((clicks (make-var 0)) tf)
- (flet ((submit (event)
- (declare (ignore event))
+ (flet ((submit ()
(setf (widget-text tf) (str (widget-text tf) "#"))
(incf (var clicks))))
(with-gui ()
Modified: trunk/src/lisp/snow/debugger.lisp
==============================================================================
--- trunk/src/lisp/snow/debugger.lisp (original)
+++ trunk/src/lisp/snow/debugger.lisp Thu Feb 4 14:03:48 2010
@@ -55,35 +55,28 @@
(scroll (:layout "grow, wrap") list)
(panel ()
(button :text "Ok"
- :on-action (lambda (evt)
- (declare (ignore evt))
+ :on-action (lambda ()
(when
(>= (widget-property list :selected-index) 0)
(dispose dlg))))
(button :text "Backtrace"
:on-action
- (lambda (evt)
- (declare (ignore evt))
+ (lambda ()
(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)))
+ :on-action (lambda () (dispose dlg)))
(pack dlg)
(show dlg))))
(button :text "Condition"
:on-action
- (lambda (evt)
- (declare (ignore evt))
+ (lambda ()
(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)))
+ :on-action (lambda () (dispose dlg)))
(pack dlg)
(show dlg)))))
(pack dlg)
Modified: trunk/src/lisp/snow/inspector.lisp
==============================================================================
--- trunk/src/lisp/snow/inspector.lisp (original)
+++ trunk/src/lisp/snow/inspector.lisp Thu Feb 4 14:03:48 2010
@@ -120,8 +120,7 @@
(button
:text "Inspect"
:layout "wrap"
- :on-action (lambda (evt)
- (declare (ignore evt))
+ :on-action (lambda ()
(update-inspector
panel
(inspector-panel (cons (part-descriptor part)
@@ -129,15 +128,13 @@
container window)
container)))
(button :text "Inspect (new window)"
- :on-action (lambda (evt)
- (declare (ignore evt))
+ :on-action (lambda ()
(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))
+ :on-action (lambda ()
(update-inspector
panel
(inspector-panel (cdr stack) container window)
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Thu Feb 4 14:03:48 2010
@@ -97,8 +97,8 @@
#:&common-widget-args
#:defimplementation
#:definterface
+ #:*event*
#:font
- #:*gui-backend*
#:jbool
#:layout-manager
#:make-dialog-prompt-stream
@@ -117,4 +117,4 @@
(defpackage :snow-user
(:use :common-lisp :snow :java :ext :named-readtables :cells)
(:shadowing-import-from :snow
- #:make-dialog-prompt-stream #:*gui-backend* #:self))
\ No newline at end of file
+ #:make-dialog-prompt-stream #:self))
\ No newline at end of file
Modified: trunk/src/lisp/snow/repl.lisp
==============================================================================
--- trunk/src/lisp/snow/repl.lisp (original)
+++ trunk/src/lisp/snow/repl.lisp Thu Feb 4 14:03:48 2010
@@ -38,7 +38,7 @@
(repl-doc (new "snow.swing.ConsoleDocument"
(compile nil
`(lambda ()
- (snow::with-snow-dynamic-environment
+ (with-snow-dynamic-environment
(let (, at environment)
(top-level::top-level-loop))))))))
(setf (widget-property text-area :document) repl-doc)
Modified: trunk/src/lisp/snow/showcase/showcase.lisp
==============================================================================
--- trunk/src/lisp/snow/showcase/showcase.lisp (original)
+++ trunk/src/lisp/snow/showcase/showcase.lisp Thu Feb 4 14:03:48 2010
@@ -1,7 +1,6 @@
(defpackage :snow-showcase
(:use :common-lisp :snow :java :ext :named-readtables :cells)
- (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*
- #:self))
+ (:shadowing-import-from :snow #:make-dialog-prompt-stream #:self))
(in-package :snow-showcase)
(in-readtable snow:syntax)
@@ -23,8 +22,7 @@
, at body)
(button :text "Show source"
:layout "dock south"
- :on-action (lambda (evt)
- (declare (ignore evt))
+ :on-action (lambda ()
(setf (var ,show-source-p) t))))
(panel (:layout "dock south, hidemode 3"
:visible-p $(c? (jbool (var ,show-source-p))))
@@ -37,8 +35,7 @@
(terpri str))))))
(button :text "Hide source"
:layout "dock south"
- :on-action (lambda (evt)
- (declare (ignore evt))
+ :on-action (lambda ()
(setf (var ,show-source-p) nil))))))))
*examples*
:test #'equal
@@ -76,8 +73,7 @@
:layout "growx, wrap")
(button :text "Test!"
:layout "wrap"
- :on-action (lambda (event)
- (declare (ignore event))
+ :on-action (lambda ()
(setf (jproperty-value *bean* "property1")
"Test property")
(setf (jproperty-value
@@ -89,7 +85,7 @@
(define-example "Mouse Events"
(panel (:layout "grow"
- :on-mouse-click (lambda (evt) (format t "Click! ~A~%" evt)))
+ :on-mouse-click (lambda () (format t "Click! ~A~%" *event*)))
(label :text "Click here!")))
(define-example "Lists and trees"
@@ -108,8 +104,7 @@
(define-example "Events"
(button :text "push me"
- :on-action (lambda (event)
- (declare (ignore event))
+ :on-action (lambda ()
(princ "Thanks for pushing me! ")
(finish-output))))
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Thu Feb 4 14:03:48 2010
@@ -30,74 +30,22 @@
(in-package :snow)
-;;Common Interfaces (much to do here!)
-(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 (setf widget-background) *gui-backend* (value widget))
-
-(definterface (setf widget-border) *gui-backend* (value widget))
-
-(definterface widget-enabled-p *gui-backend* (widget))
-
-(definterface (setf widget-enabled-p) *gui-backend* (value widget))
-
-(definterface (setf widget-font) *gui-backend* (value widget))
-
-(definterface (setf widget-foreground) *gui-backend* (value widget))
-
-(definterface (setf widget-location) *gui-backend* (value widget))
-
-(definterface (setf widget-size) *gui-backend* (value widget))
-
-(definterface widget-text *gui-backend* (widget))
-
-(definterface (setf widget-text) *gui-backend* (value widget))
-
-(definterface widget-visible-p *gui-backend* (widget))
-
-(definterface (setf widget-visible-p) *gui-backend* (value widget))
-
-(definterface dispose *gui-backend* (obj))
-
-(definterface color *gui-backend* (color-spec)
- "Constructs an object representing a color. The color can be specified the 24-bit RGB number, or by symbolic constants such as :black, :red or :green.")
-
-(definterface font *gui-backend* (name size &optional style)
- "Constructs an object representing a font. Parameters:
- name the name of the font family
- size the size in points
- style if provided, one of :plain, :bold, :italic or :bold-italic")
-
-(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 <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* nil)
+(defvar *event* nil "Dynamic variable holding an object that represents the event currently being handled.")
(defmacro with-snow-dynamic-environment (&body body)
- (with-unique-names (gui-backend-var package-var terminal-io-var
+ (with-unique-names (package-var terminal-io-var
standard-input-var standard-output-var error-output-var)
`(if *dynamic-environment*
(with-dynamic-environment (*dynamic-environment*)
, at body)
- (let ((,gui-backend-var *gui-backend*)
- (,package-var *package*)
+ (let ((,package-var *package*)
(,terminal-io-var *terminal-io*)
(,standard-input-var *standard-input*)
(,standard-output-var *standard-output*)
(,error-output-var *error-output*)) ;;Etc...
(dynamic-wind
- (let ((*gui-backend* ,gui-backend-var)
- (*package* ,package-var)
+ (let ((*package* ,package-var)
(*debugger-hook* *graphical-debugger-hook*)
(*terminal-io* ,terminal-io-var)
(*standard-input* ,standard-input-var)
@@ -116,8 +64,8 @@
(let ((*dynamic-environment* ,dynamic-environment))
, at body)))))))
-(defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body)
- (declare (ignore gui-backend))
+(defmacro with-gui ((&rest args) &body body)
+ (declare (ignore args))
`(call-in-gui-thread
(lambda/dynamic-environment () , at body)))
@@ -176,12 +124,6 @@
(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)
- "Creates a backed-specific object used to layout components.")
-
-(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)
@@ -225,11 +167,6 @@
(defun filter-unevaluated-widget-args (args)
(filter-arglist args '(:id))))
-(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 border font background foreground
;;mouse event handling
@@ -241,7 +178,8 @@
(macrolet ((wrap-event-callback (fn) ;;Pay attention to double evaluation
`(when ,fn
(lambda/dynamic-environment (evt)
- (funcall ,fn evt)))))
+ (let ((*event* evt))
+ (funcall ,fn))))))
(when *parent* (add-child self *parent* layout))
(setf (widget-enabled-p self) enabled-p)
(setf (widget-visible-p self) visible-p)
@@ -293,6 +231,7 @@
'&common-widget-args
arglist)
`(&environment ,env))
+ ,@(common-widget-args-declarations)
`(let ((self ,,constructor))
;;The lexical variable self is always bound to the current widget.
,(if id ;;id is one of the common args
@@ -331,6 +270,10 @@
self))
,@(filter-unevaluated-widget-args ,args))
`(progn
+;TODO - declare keys ignorable to reduce the number of warnings.
+; (declare (ignorable ,@(mapcar (lambda (k)
+; (if (atom k) k (car k)))
+; keys)))
,, at body))))
(defmacro define-container-widget (name keys constructor &body body)
Modified: trunk/src/lisp/snow/start.lisp
==============================================================================
--- trunk/src/lisp/snow/start.lisp (original)
+++ trunk/src/lisp/snow/start.lisp Thu Feb 4 14:03:48 2010
@@ -42,9 +42,7 @@
: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)))
+ (button :text "Ok" :on-action (lambda () (dispose dlg)))
(pack self)))
(defun snow-showcase ()
@@ -62,18 +60,12 @@
:menu-bar (menu-bar ()
(menu (:text "File")
(menu-item :text "Quit"
- :on-action (lambda (evt)
- (declare (ignore evt))
- (ext:quit))))
+ :on-action (lambda () (ext:quit))))
(menu (:text "Help")
(menu-item :text "Showcase"
- :on-action (lambda (evt)
- (declare (ignore evt))
- (snow-showcase)))
+ :on-action (lambda () (snow-showcase)))
(menu-item :text "About"
- :on-action (lambda (evt)
- (declare (ignore evt))
- (snow-about))))))
+ :on-action (lambda () (snow-about))))))
(scroll (:layout "grow")
(gui-repl :dispose-on-close frame
:environment `((*package* ,(find-package :snow-user))
Modified: trunk/src/lisp/snow/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing.lisp (original)
+++ trunk/src/lisp/snow/swing.lisp Thu Feb 4 14:03:48 2010
@@ -43,7 +43,9 @@
((or (functionp obj) (symbolp obj))
(jmake-proxy "java.awt.event.ActionListener"
(lambda/dynamic-environment (this method-name event)
- (funcall obj event))))
+ (declare (ignore this method-name))
+ (let ((*event* event))
+ (funcall obj)))))
((stringp obj)
(unless *backing-bean*
(error "No backing bean specified while action listener is a method name: ~A~%" obj))
@@ -58,6 +60,7 @@
(t obj))) ;This allows to use a native Java action listener
(defun make-layout-manager (widget layout &rest args)
+ "Creates an object used to layout components."
(if (typep layout 'java-object)
layout
(ecase layout
@@ -74,11 +77,13 @@
((nil) nil))))
(defun (setf layout-manager) (lm widget)
+ "Sets the layout manager for a given (container) widget."
(setf (widget-property widget :layout) lm))
(defun 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)
+ "Sets mouse listener(s) on a widget."
(let ((mouse-input-listener
(new "snow.swing.MouseInputListener"
on-mouse-click on-mouse-press on-mouse-release
@@ -95,6 +100,7 @@
(defconstant +add-to-container-with-constraints+ (jmethod "java.awt.Container" "add" "java.lang.String" "java.awt.Component"))
(defun call-in-gui-thread (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)."
(jstatic "invokeLater" "javax.swing.SwingUtilities"
(new "snow.FunctionRunnable" fn)))
@@ -189,6 +195,7 @@
(invoke "hide" obj))
(defun color (color-spec)
+ "Constructs an object representing a color. The color can be specified the 24-bit RGB number, or by symbolic constants such as :black, :red or :green."
(cond
((integerp color-spec) (new "java.awt.Color" color-spec))
((keywordp color-spec) (case color-spec
@@ -200,6 +207,10 @@
(t (error "Invalid color: ~A" color-spec))))
(defun font (name size &optional style)
+ "Constructs an object representing a font. Parameters:
+ name the name of the font family
+ size the size in points
+ style if provided, one of :plain, :bold, :italic or :bold-italic"
(let ((style-int (case style
((or :plain nil) (jfield "java.awt.Font" "PLAIN"))
(:bold (jfield "java.awt.Font" "BOLD"))
More information about the snow-cvs
mailing list