swing-utils: add action and menu(bar) builders from Meikel Brandmeyer…

…, inspired by Waterfront

src/clojure/contrib/swing_utils.clj

@@ -15,7 +15,10 @@
 
 (ns clojure.contrib.swing-utils
   (:import (java.awt.event ActionListener KeyAdapter)
-           (javax.swing SwingUtilities)))
+           (javax.swing AbstractAction Action 
+                        JMenu JMenuBar JMenuItem
+                        SwingUtilities))
+  (:use [clojure.contrib.def :only (defvar)]))
 
 (defn add-action-listener
   "Adds an ActionLister to component. When the action fires, f will be
@@ -64,4 +67,86 @@
   [& body]
   `(do-swing* :now (fn [] ~@body)))
 
+(defvar action-translation-table
+  (atom {:name        Action/NAME
+         :accelerator Action/ACCELERATOR_KEY
+         :command-key Action/ACTION_COMMAND_KEY
+         :long-desc   Action/LONG_DESCRIPTION
+         :short-desc  Action/SHORT_DESCRIPTION
+         :mnemonic    Action/MNEMONIC_KEY
+         :icon        Action/SMALL_ICON})
+  "Translation table for the make-action constructor.")
+
+(defn make-action
+  "Create an Action proxy from the given action spec. The standard keys
+  recognised are: :name, :accelerator, :command-key, :long-desc,
+  :short-desc, :mnemonic and :icon - corresponding to the similar named
+  Action properties.  The :handler value is used in the actionPerformed
+  method of the proxy to pass on the event."
+  [spec]
+  (let [t-table @action-translation-table
+        handler (:handler spec)
+        spec    (dissoc spec :handler)
+        spec    (map (fn [[k v]] [(t-table k) v]) spec)
+        action  (proxy [AbstractAction] []
+                  (actionPerformed [evt] (handler evt)))]
+    (doseq [[k v] spec]
+      (.putValue action k v))
+    action))
+
+(defvar menu-constructor-dispatch
+  (atom #{:action :handler :items})
+  "An atom containing the dispatch set for the add-menu-item method.")
+
+(defmulti add-menu-item
+  "Adds a menu item to the parent according to the item description.
+   The item description is a map of the following structure.
+
+ Either:
+   - one single :action specifying a javax.swing.Action to be associated
+     with the item.
+   - a specification suitable for make-action
+   - a set of :name, :mnemonic and :items keys, specifying a submenu with
+     the given sequence of item entries.
+   - an empty map specifying a separator."
+  {:arglists '([parent item])}
+  (fn add-menu-item-dispatch [_ item]
+    (some @menu-constructor-dispatch (keys item))))
+
+(defmethod add-menu-item :action
+  add-menu-item-action
+  [parent {:keys [action]}]
+  (let [item (JMenuItem. action)]
+    (.add parent item)))
+
+(defmethod add-menu-item :handler
+  add-menu-item-handler
+  [parent spec]
+  (add-menu-item parent {:action (make-action spec)}))
+
+(defmethod add-menu-item :items
+  add-menu-item-submenu
+  [parent {:keys [items mnemonic name]}]
+  (let [menu (JMenu. name)]
+    (when mnemonic
+      (.setMnemonic menu mnemonic))
+    (doseq [item items]
+      (add-menu-item menu item))
+    (.add parent menu)))
+
+(defmethod add-menu-item nil ; nil meaning separator
+  add-menu-item-separator
+  [parent _]
+  (.addSeparator parent))
+
+(defn make-menubar
+  "Create a menubar containing the given sequence of menu items. The menu
+  items are described by a map as is detailed in the docstring of the
+  add-menu-item function."
+  [menubar-items]
+  (let [menubar (JMenuBar.)]
+    (doseq [item menubar-items]
+      (add-menu-item menubar item))
+    menubar))
+
 ;; ----------------------------------------------------------------------