[snow-cvs] r68 - trunk/src/lisp/snow

[Alessio Stalla]

Author: astalla
Date: Mon Mar  8 15:42:36 2010
New Revision: 68

Log:
Added file chooser and separator. Simple menu actions to load, compile and
compile+load in GUI REPL.


Modified:
   trunk/src/lisp/snow/packages.lisp
   trunk/src/lisp/snow/start.lisp
   trunk/src/lisp/snow/widgets.lisp

Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp	(original)
+++ trunk/src/lisp/snow/packages.lisp	Mon Mar  8 15:42:36 2010
@@ -38,6 +38,7 @@
     #:check-box
     #:progress-bar
     #:dialog
+    #:file-chooser
     #:frame
     #:label
     #:list-widget
@@ -46,6 +47,7 @@
     #:menu-item
     #:panel
     #:scroll
+    #:separator
     #:split
     #:tab
     #:tabs

Modified: trunk/src/lisp/snow/start.lisp
==============================================================================
--- trunk/src/lisp/snow/start.lisp	(original)
+++ trunk/src/lisp/snow/start.lisp	Mon Mar  8 15:42:36 2010
@@ -52,6 +52,18 @@
   (funcall (symbol-function (find-symbol (symbol-name '#:showcase)
 					 (find-package '#:snow-showcase)))))
 
+(defun snow-load ()
+  (let ((file (show-file-chooser)))
+    (when file (load file))))
+
+(defun snow-compile ()
+  (let ((file (show-file-chooser)))
+    (when file (compile file))))
+
+(defun snow-compile-and-load ()
+  (let ((file (show-file-chooser)))
+    (when file (load (compile-file file)))))
+
 (with-gui ()
   (frame (:id frame :title "ABCL - Snow REPL"
 	  :size #C(800 300)
@@ -59,6 +71,13 @@
 	  :on-close :exit
 	  :menu-bar (menu-bar ()
 		      (menu (:text "File")
+			(menu-item :text "Load..."
+				   :on-action #'snow-load)
+			(menu-item :text "Compile..."
+				   :on-action #'snow-compile)
+			(menu-item :text "Compile and load..."
+				   :on-action #'snow-compile-and-load)
+			(separator)
 			(menu-item :text "Quit"
 				   :on-action (lambda () (ext:quit))))
 		      (menu (:text "Help")

Modified: trunk/src/lisp/snow/widgets.lisp
==============================================================================
--- trunk/src/lisp/snow/widgets.lisp	(original)
+++ trunk/src/lisp/snow/widgets.lisp	Mon Mar  8 15:42:36 2010
@@ -83,6 +83,40 @@
      ,@(generate-default-children-processing-code id body)
      (setf (widget-visible-p self) ,visible-p)))
 
+(defun make-file-chooser (&key multi-selection-p &allow-other-keys)
+  (let ((c (jnew "javax.swing.JFileChooser")))
+    (jcall "setMultiSelectionEnabled" c (jbool multi-selection-p))
+    c))
+
+(defwidget file-chooser multi-selection-p)
+
+(defun jarray->list (arr)
+  (let ((ls (list)) (len (jarray-length arr)))
+    (dotimes (i len)
+      (push (jarray-ref arr i) ls))
+    (nreverse ls)))
+
+(defun show-file-chooser (&key (chooser (dont-add (file-chooser)))
+			  (parent *parent*) (operation :open))
+  (let ((result
+	 (ecase operation
+	   (:open (jcall "showOpenDialog" chooser parent))
+	   (:save (jcall "showSaveDialog" chooser parent)))))
+    (cond
+      ((= result (jfield "javax.swing.JFileChooser" "APPROVE_OPTION"))
+       (let ((files (if (jcall "isMultiSelectionEnabled" chooser)
+			(jarray->list (jcall "getSelectedFiles" chooser))
+			(jcall "getSelectedFile" chooser))))
+	 (values (if (listp files)
+		     (mapcar (lambda (f) (jcall "getAbsolutePath" f)) files)
+		     (jcall "getAbsolutePath" files))
+		 :approve
+		 files)))
+      ((= result (jfield "javax.swing.JFileChooser" "CANCEL_OPTION"))
+       (values nil :cancel nil))
+      ((= result (jfield "javax.swing.JFileChooser" "ERROR_OPTION"))
+       (values nil :error nil)))))
+
 (defun pack (window)
   (jcall (jmethod "java.awt.Window" "pack") window)
   window)
@@ -107,6 +141,11 @@
 
 (define-widget menu-item (text on-action) make-menu-item)
 
+(defun make-separator ()
+  (jnew "javax.swing.JSeparator"))
+
+(defwidget separator)
+
 ;;Panels
 (defun make-panel (&key &allow-other-keys)
   (jnew "javax.swing.JPanel"))