[snow-cvs] r46 - in trunk/src/lisp/snow: . swing
Alessio Stalla
astalla at common-lisp.net
Tue Jan 26 20:16:21 UTC 2010
Author: astalla
Date: Tue Jan 26 15:16:20 2010
New Revision: 46
Log:
Refactoring: eliminated definterface-defimplementation.
If and when SWT will be supported, I will fork the project specifically for
SWT, sharing the code that is in common.
SWT is different enough from Swing that changing the functional API would not
be enough; the macros must be changed as well.
Added:
trunk/src/lisp/snow/swing-data-binding.lisp
trunk/src/lisp/snow/swing.lisp (contents, props changed)
Removed:
trunk/src/lisp/snow/cells.lisp
trunk/src/lisp/snow/swing/
Modified:
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/repl.lisp
trunk/src/lisp/snow/snow.asd
trunk/src/lisp/snow/start.lisp
trunk/src/lisp/snow/widgets.lisp
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Tue Jan 26 15:16:20 2010
@@ -225,4 +225,4 @@
(if (eq (car list) 'cells:c?)
`(make-data-binding 'cell ,list)
`(make-data-binding ',(car list) ,@(cdr list)))))
- (t `(make-simple-data-binding ,(read stream)))))))
+ (t `(make-simple-data-binding ,(read stream)))))))
\ 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 Tue Jan 26 15:16:20 2010
@@ -1,6 +1,6 @@
;;; repl.lisp
;;;
-;;; Copyright (C) 2008-2009 Alessio Stalla
+;;; Copyright (C) 2008-2010 Alessio Stalla
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
@@ -31,10 +31,25 @@
(in-package :snow)
-(definterface make-gui-repl *gui-backend* (&key dispose-on-close environment)
- "Creates a component that allows to interact with the Lisp system by typing text in a text area and receiving output in the same text area.")
+;;REPL
+(defun make-gui-repl (&key dispose-on-close environment)
+ "Creates a component that allows to interact with the Lisp system by typing text in a text area and receiving output in the same text area."
+ (let ((text-area (new "javax.swing.JTextArea"))
+ (repl-doc (new "snow.swing.ConsoleDocument"
+ (compile nil
+ `(lambda ()
+ (snow::with-snow-dynamic-environment
+ (let (, at environment)
+ (top-level::top-level-loop))))))))
+ (setf (widget-property text-area :document) repl-doc)
+ (invoke "setupTextComponent" repl-doc text-area)
+ (when dispose-on-close
+ (invoke "disposeOnClose" repl-doc dispose-on-close))
+ text-area))
+
+(defun dispose-gui-repl (repl)
+ "Performs operations necessary to dispose of a repl's allocated resources."
+ (invoke "dispose" (widget-property repl :document)))
(define-widget gui-repl (dispose-on-close environment) make-gui-repl)
-(definterface dispose-gui-repl *gui-backend* (repl)
- "Performs operations necessary to dispose of a repl's allocated resources.")
Modified: trunk/src/lisp/snow/snow.asd
==============================================================================
--- trunk/src/lisp/snow/snow.asd (original)
+++ trunk/src/lisp/snow/snow.asd Tue Jan 26 15:16:20 2010
@@ -31,17 +31,17 @@
;;Core stuff + cells if needed
(asdf:defsystem :snow
:serial t
- :version "0.2"
+ :version "0.3"
:depends-on (:cl-utilities :named-readtables :cells)
:components ((:file "packages")
(:file "sexy-java")
(:file "utils")
(:file "cx-dynamic-environments")
(:file "snow")
+ (:file "swing")
(:file "widgets")
(:file "repl")
(:file "data-binding")
- (:file "cells")
- (:file "backend")
+ (:file "swing-data-binding")
(:file "debugger")
(:file "inspector")))
\ No newline at end of file
Modified: trunk/src/lisp/snow/start.lisp
==============================================================================
--- trunk/src/lisp/snow/start.lisp (original)
+++ trunk/src/lisp/snow/start.lisp Tue Jan 26 15:16:20 2010
@@ -31,11 +31,11 @@
(in-package :snow)
(defun snow-about ()
- (dialog (:id dlg :title "Snow v0.2" :visible-p t)
+ (dialog (:id dlg :title "Snow v0.3" :visible-p t)
(label :layout "wrap"
- :text "Snow version 0.2")
+ :text "Snow version 0.3")
(label :layout "wrap"
- :text "Copyright (C) 2008-2009 Alessio Stalla")
+ :text "Copyright (C) 2008-2010 Alessio Stalla")
(label :layout "wrap"
:text "This program is distributed under the GNU GPL; see the file copying for details.")
(label :layout "wrap"
Added: trunk/src/lisp/snow/swing-data-binding.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/swing-data-binding.lisp Tue Jan 26 15:16:20 2010
@@ -0,0 +1,56 @@
+;;; swing-data-binding.lisp
+;;;
+;;; Copyright (C) 2008-2010 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)
+
+(defmethod bind-widget ((widget (jclass "javax.swing.JTextField")) binding)
+ (jstatic (jmethod "com.jgoodies.binding.adapter.Bindings"
+ "bind"
+ "javax.swing.JTextField"
+ "com.jgoodies.binding.value.ValueModel"
+ "boolean")
+ nil widget (make-model binding)
+ (make-immediate-object t :boolean)))
+
+(defmethod bind-widget ((widget (jclass "javax.swing.JLabel")) binding)
+ (jstatic (jmethod "com.jgoodies.binding.adapter.Bindings"
+ "bind"
+ "javax.swing.JLabel"
+ "com.jgoodies.binding.value.ValueModel")
+ nil widget (make-model binding)))
+
+(defmethod (setf widget-property) ((value data-binding) (widget (jclass "java.awt.Component")) name)
+ (jstatic (jmethod "com.jgoodies.binding.adapter.Bindings"
+ "bind"
+ "javax.swing.JComponent"
+ "java.lang.String"
+ "com.jgoodies.binding.value.ValueModel")
+ nil widget (dashed->camelcased name) (make-model value))
+ value)
\ No newline at end of file
Added: trunk/src/lisp/snow/swing.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/swing.lisp Tue Jan 26 15:16:20 2010
@@ -0,0 +1,210 @@
+;;; swing.lisp
+;;;
+;;; Copyright (C) 2008-2010 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)
+
+(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))))
+
+(defun make-action-listener (obj)
+ (cond
+ ((or (functionp obj) (symbolp obj))
+ (jmake-proxy "java.awt.event.ActionListener"
+ (lambda/dynamic-environment (this method-name event)
+ (funcall obj event))))
+ ((stringp obj)
+ (unless *backing-bean*
+ (error "No backing bean specified while action listener is a method name: ~A~%" obj))
+ (make-action-listener (jmethod (jclass-of *backing-bean*) obj
+ (jclass "java.awt.event.ActionEvent"))))
+ ((jinstance-of-p obj (jclass "java.lang.reflect.Method"))
+ (unless *backing-bean*
+ (error "No backing bean specified while action listener is a jmethod: ~A~%" obj))
+ (make-action-listener
+ (let ((bb *backing-bean*))
+ #'(lambda (evt) (jcall obj bb evt)))))
+ (t obj))) ;This allows to use a native Java action listener
+
+(defun make-layout-manager (widget layout &rest args)
+ (if (typep layout 'java-object)
+ layout
+ (ecase layout
+ ((or :default :mig) (apply #'new "net.miginfocom.swing.MigLayout" args))
+ (:box (new "javax.swing.BoxLayout"
+ (if (jinstance-of-p widget "javax.swing.JFrame")
+ (invoke "getContentPane" widget)
+ widget)
+ (ecase (car args)
+ (:x (jfield "javax.swing.BoxLayout" "X_AXIS"))
+ (:y (jfield "javax.swing.BoxLayout" "Y_AXIS")))))
+ (:flow (new "java.awt.FlowLayout"))
+ (:border (new "java.awt.BorderLayout"))
+ ((nil) nil))))
+
+(defun (setf layout-manager) (lm 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)
+ (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"))
+
+(defun call-in-gui-thread (fn)
+ (jstatic "invokeLater" "javax.swing.SwingUtilities"
+ (new "snow.FunctionRunnable" fn)))
+
+;;Base API implementation
+(defun add-child (child &optional (parent *parent*) layout-constraints)
+ (if layout-constraints
+ (jcall +add-to-container-with-constraints+
+ parent
+ layout-constraints
+ child)
+ (jcall +add-to-container+ parent child)))
+
+(defun (setf widget-enabled-p) (value widget)
+ (setf (widget-property widget :enabled) value))
+
+(defun widget-enabled-p (widget)
+ (widget-property widget :enabled))
+
+(defun (setf widget-font) (value widget)
+ (setf (widget-property widget :font) value))
+
+(defun (setf widget-background) (value widget)
+ (setf (widget-property widget :background) value))
+
+(defun (setf widget-foreground) (value widget)
+ (setf (widget-property widget :foreground) value))
+
+(defun (setf widget-location) (value widget)
+ (invoke "setLocation" widget (aref value 0) (aref value 1)))
+
+(defun (setf widget-size) (value widget)
+ (invoke "setSize" widget (realpart value) (imagpart value)))
+
+(defun (setf widget-text) (value widget)
+ (setf (widget-property widget :text) value))
+
+(defun widget-text (widget)
+ (widget-property widget :text))
+
+(defun (setf widget-visible-p) (value widget)
+ (setf (widget-property widget :visible) value))
+
+(defun widget-visible-p (widget)
+ (widget-property widget :visible))
+
+(defun make-border (border-spec)
+ (if (jinstance-of-p border-spec "javax.swing.border.Border")
+ border-spec
+ (let ((border (ensure-list border-spec)))
+ (ecase (car border)
+ (:bevel
+ (let ((type (ecase (or (cadr border) :lowered)
+ (:lowered
+ (jfield "javax.swing.border.BevelBorder" "LOWERED"))
+ (:raised
+ (jfield "javax.swing.border.BevelBorder" "RAISED")))))
+ (jcall (jmethod "javax.swing.BorderFactory"
+ "createBevelBorder" "int")
+ nil type)))
+ (:compound
+ (let ((outer (cadr border)) (inner (caddr border)))
+ (jcall (jmethod "javax.swing.BorderFactory"
+ "createCompoundBorder"
+ "javax.swing.border.Border"
+ "javax.swing.border.Border")
+ nil outer inner)))
+ (:empty
+ (if (cdr border)
+ (if (= 4 (length (cdr border)))
+ (jcall (jmethod "javax.swing.BorderFactory"
+ "createEmptyBorder" "int" "int" "int" "int")
+ nil (second border) (third border) (fourth border)
+ (fifth border))
+ (error "Wrong number of arguments for empty border: ~A (~S)"
+ (length (cdr border)) (cdr border)))
+ (jcall (jmethod "javax.swing.BorderFactory"
+ "createEmptyBorder")
+ nil)))
+ ))))
+
+(defun (setf widget-border) (value widget)
+ (when (jinstance-of-p widget "javax.swing.JComponent")
+ (invoke "setBorder" widget (if value (make-border value) nil))))
+
+(defun dispose (obj)
+ (invoke "dispose" obj))
+
+(defun show (obj)
+ (invoke "show" obj))
+
+(defun hide (obj)
+ (invoke "hide" obj))
+
+(defun color (color-spec)
+ (cond
+ ((integerp color-spec) (new "java.awt.Color" color-spec))
+ ((keywordp color-spec) (case color-spec
+ (:black (jfield "java.awt.Color" "BLACK"))
+ (:blue (jfield "java.awt.Color" "BLUE"))
+ (:green (jfield "java.awt.Color" "GREEN"))
+ (:red (jfield "java.awt.Color" "RED"))
+ (:white (jfield "java.awt.Color" "WHITE"))))
+ (t (error "Invalid color: ~A" color-spec))))
+
+(defun font (name size &optional style)
+ (let ((style-int (case style
+ ((or :plain nil) (jfield "java.awt.Font" "PLAIN"))
+ (:bold (jfield "java.awt.Font" "BOLD"))
+ (:italic (jfield "java.awt.Font" "ITALIC"))
+ (:bold-italic (logior (jfield "java.awt.Font" "BOLD")
+ (jfield "java.awt.Font" "ITALIC")))
+ (t (error "Unknown font style: ~A" style)))))
+ (new "java.awt.Font" name style-int size)))
Modified: trunk/src/lisp/snow/widgets.lisp
==============================================================================
--- trunk/src/lisp/snow/widgets.lisp (original)
+++ trunk/src/lisp/snow/widgets.lisp Tue Jan 26 15:16:20 2010
@@ -1,6 +1,6 @@
;;; widgets.lisp
;;;
-;;; Copyright (C) 2008-2009 Alessio Stalla
+;;; Copyright (C) 2008-2010 Alessio Stalla
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
@@ -30,14 +30,42 @@
(in-package :snow)
-;;Windows
-(definterface make-frame *gui-backend* (&key menu-bar title on-close
- &allow-other-keys))
+(defmacro defwidget (name &rest args)
+ (let ((maker-sym (intern (str (symbol-name '#:make-) (symbol-name name)))))
+ `(define-widget ,name (, at args &allow-other-keys) ,maker-sym)))
+
+;;Windows and dialogs
+(defun 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
+ ((#'ext:exit 'ext:exit :exit)
+ (lambda (evt)
+ (declare (ignore evt))
+ (ext:exit)))
+ (t on-close))))
+ (invoke "addWindowListener" f (new "snow.swing.WindowListener"
+ nil nil on-close nil nil nil nil))))
+ f))
(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))
+(defun make-dialog (&key parent title modal-p visible-p &allow-other-keys)
+ (let ((d (jnew "javax.swing.JDialog"
+ parent
+ (if modal-p
+ (jfield "java.awt.Dialog$ModalityType" "APPLICATION_MODAL")
+ (jfield "java.awt.Dialog$ModalityType" "MODELESS")))))
+ (set-widget-properties d
+ :title title)
+ d))
(define-widget-macro dialog
((&rest args &key &common-widget-args
@@ -55,29 +83,51 @@
,@(generate-default-children-processing-code id body)
(setf (widget-visible-p self) ,visible-p)))
+(defun pack (window)
+ (jcall (jmethod "java.awt.Window" "pack") window)
+ window)
+
;;Menus
-(definterface make-menu-bar *gui-backend* (&key &allow-other-keys))
+(defun make-menu-bar (&key &allow-other-keys)
+ (jnew "javax.swing.JMenuBar"))
(define-container-widget menu-bar () make-menu-bar)
-(definterface make-menu *gui-backend* (&key text &allow-other-keys))
+(defun make-menu (&key text &allow-other-keys)
+ (if text
+ (jnew "javax.swing.JMenu" text)
+ (jnew "javax.swing.JMenu")))
(define-container-widget menu (text) make-menu)
-(definterface make-menu-item *gui-backend*
- (&key text on-action &allow-other-keys))
+(defun make-menu-item (&key text on-action &allow-other-keys)
+ (let ((m (new "javax.swing.JMenuItem")))
+ (setup-button m text on-action)
+ m))
(define-widget menu-item (text on-action) make-menu-item)
;;Panels
-(definterface make-panel *gui-backend* (&key &allow-other-keys))
+(defun make-panel (&key &allow-other-keys)
+ (jnew "javax.swing.JPanel"))
(define-container-widget panel () make-panel)
(defvar *tabs*)
-(definterface make-tabs *gui-backend* (&key (wrap t) (tab-placement :top)
- &allow-other-keys))
+(defun make-tabs (&key (wrap t) (tab-placement :top) &allow-other-keys)
+ (let ((tabs (jnew "javax.swing.JTabbedPane")))
+ (invoke "setTabLayoutPolicy" tabs
+ (if wrap
+ (jfield "javax.swing.JTabbedPane" "WRAP_TAB_LAYOUT")
+ (jfield "javax.swing.JTabbedPane" "SCROLL_TAB_LAYOUT")))
+ (invoke "setTabPlacement" tabs
+ (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))
(define-widget-macro tabs
((&rest args &key id &common-widget-args (wrap t) (tab-placement :top))
@@ -96,19 +146,33 @@
(add-child (progn , at body) *tabs* ,name)
(error "tab outside tabset: ~A" ,name)))
-(definterface make-scroll-panel *gui-backend* (view))
+(defun make-scroll-panel (view)
+ (let ((p (jnew "javax.swing.JScrollPane")))
+ (setf (scroll-panel-view p) view)
+ p))
-(definterface scroll-panel-view *gui-backend* (self))
+(defun scroll-panel-view (self)
+ (jproperty-value self "viewportView"))
-(definterface (setf scroll-panel-view) *gui-backend* (view self))
+(defun (setf scroll-panel-view) (view self)
+ (setf (jproperty-value self "viewportView") view))
(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))
+(defun 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))
(define-widget-macro split
((&rest args &key &common-widget-args orientation smoothp)
@@ -116,34 +180,97 @@
`(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 (str (symbol-name '#: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)
+(defun make-button (&key text on-action &allow-other-keys)
+ (let ((btn (new "javax.swing.JButton")))
+ (setup-button btn text on-action)
+ btn))
-(defwidget check-box text selected-p)
+(defwidget button text on-action)
-;;Misc
+(defun make-check-box (&key text selected-p &allow-other-keys)
+ (let ((btn (new "javax.swing.JCheckBox")))
+ (when text
+ (setf (widget-property btn :text) text))
+ (setf (widget-property btn :selected)
+ (if selected-p selected-p (jbool nil)))
+ btn))
-(defwidget progress-bar value orientation (paint-border t) progress-string)
+(defwidget check-box text selected-p)
;;Text
+(defun make-label (&key text &allow-other-keys)
+ (let ((lbl (new "javax.swing.JLabel")))
+ (when text
+ (setf (widget-property lbl :text) text))
+ lbl))
(defwidget label text)
+(defun make-text-field (&key text &allow-other-keys)
+ (let ((field (new "javax.swing.JTextField")))
+ (when text
+ (setf (widget-property field :text) text))
+ field))
+
(defwidget text-field text)
+(defun 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))
+
(defwidget text-area text)
+(defun make-dialog-prompt-stream ()
+ (jnew "snow.SwingDialogPromptStream"))
+
;;Lists
+(defun make-list-model (list)
+ (new "snow.list.ConsListModel" list))
+
+(defun 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) cell-renderer)
+ (setf (widget-property list :prototype-cell-value) prototype-cell-value)
+ (when selected-index
+ (setf (widget-property list :selected-index) selected-index))
+ list))
(defwidget list-widget model selected-index)
;;Trees
+(defun make-tree-model (list)
+ (new "snow.tree.ConsTreeModel" list))
+
+(defun 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))
+ (setf (widget-property tree :cell-renderer) cell-renderer)
+ tree))
+
+(defwidget tree model)
+
+;;Misc
+(defconstant +swingconstant-vertical+ (jfield "javax.swing.SwingConstants" "VERTICAL"))
+
+(defun make-progress-bar (&key value orientation (paint-border t) progress-string &allow-other-keys)
+ (let ((pbar (jnew "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))
-(defwidget tree model)
\ No newline at end of file
+(defwidget progress-bar value orientation (paint-border t) progress-string)
\ No newline at end of file
More information about the snow-cvs
mailing list