;;  Copyright (c) Stephen C. Gilardi. All rights reserved.  The use and

 ;;  distribution terms for this software are covered by the Eclipse Public

 ;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can

 ;;  be found in the file epl-v10.html at the root of this distribution.  By

 ;;  using this software in any fashion, you are agreeing to be bound by the

 ;;  terms of this license.  You must not remove this notice, or any other,

 ;;  from this software.

 ;;

 ;;  clojure.contrib.swing-utils

 ;;

 ;;  Useful functions for interfacing Clojure to Swing

 ;;

 ;;  scgilardi (gmail)

 ;;  Created 31 May 2009

 

 (ns clojure.contrib.swing-utils

   (:import (java.awt.event ActionListener KeyAdapter)

            (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

   invoked with the event as its first argument followed by args.

   Returns the listener."

   [component f & args]

   (let [listener (proxy [ActionListener] []

                    (actionPerformed [event] (apply f event args)))]

     (.addActionListener component listener)

     listener))

 

 (defn add-key-typed-listener

   "Adds a KeyListener to component that only responds to KeyTyped events.

   When a key is typed, f is invoked with the KeyEvent as its first argument

   followed by args. Returns the listener."

   [component f & args]

   (let [listener (proxy [KeyAdapter] []

                    (keyTyped [event] (apply f event args)))]

     (.addKeyListener component listener)

     listener))

 

 ;; ----------------------------------------------------------------------

 ;; Meikel Brandmeyer

 

 (defn do-swing*

   "Runs thunk in the Swing event thread according to schedule:

     - :later => schedule the execution and return immediately

     - :now   => wait until the execution completes."

   [schedule thunk]

   (cond

    (= schedule :later) (SwingUtilities/invokeLater thunk)

    (= schedule :now) (if (SwingUtilities/isEventDispatchThread)

                        (thunk)

                        (SwingUtilities/invokeAndWait thunk)))

   nil)

 

 (defmacro do-swing

   "Executes body in the Swing event thread asynchronously. Returns

   immediately after scheduling the execution."

   [& body]

   `(do-swing* :later (fn [] ~@body)))

 

 (defmacro do-swing-and-wait

   "Executes body in the Swing event thread synchronously. Returns

   after the execution is complete."

   [& 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))

 

 ;; ----------------------------------------------------------------------