[snow-cvs] r18 - in trunk/src/lisp/snow: . swing

[Alessio Stalla]

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)