rlm@10: ;; Copyright (c) Stephen C. Gilardi. All rights reserved. The use and rlm@10: ;; distribution terms for this software are covered by the Eclipse Public rlm@10: ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can rlm@10: ;; be found in the file epl-v10.html at the root of this distribution. By rlm@10: ;; using this software in any fashion, you are agreeing to be bound by the rlm@10: ;; terms of this license. You must not remove this notice, or any other, rlm@10: ;; from this software. rlm@10: ;; rlm@10: ;; clojure.contrib.swing-utils rlm@10: ;; rlm@10: ;; Useful functions for interfacing Clojure to Swing rlm@10: ;; rlm@10: ;; scgilardi (gmail) rlm@10: ;; Created 31 May 2009 rlm@10: rlm@10: (ns clojure.contrib.swing-utils rlm@10: (:import (java.awt.event ActionListener KeyAdapter) rlm@10: (javax.swing AbstractAction Action rlm@10: JMenu JMenuBar JMenuItem rlm@10: SwingUtilities)) rlm@10: (:use [clojure.contrib.def :only (defvar)])) rlm@10: rlm@10: (defn add-action-listener rlm@10: "Adds an ActionLister to component. When the action fires, f will be rlm@10: invoked with the event as its first argument followed by args. rlm@10: Returns the listener." rlm@10: [component f & args] rlm@10: (let [listener (proxy [ActionListener] [] rlm@10: (actionPerformed [event] (apply f event args)))] rlm@10: (.addActionListener component listener) rlm@10: listener)) rlm@10: rlm@10: (defn add-key-typed-listener rlm@10: "Adds a KeyListener to component that only responds to KeyTyped events. rlm@10: When a key is typed, f is invoked with the KeyEvent as its first argument rlm@10: followed by args. Returns the listener." rlm@10: [component f & args] rlm@10: (let [listener (proxy [KeyAdapter] [] rlm@10: (keyTyped [event] (apply f event args)))] rlm@10: (.addKeyListener component listener) rlm@10: listener)) rlm@10: rlm@10: ;; ---------------------------------------------------------------------- rlm@10: ;; Meikel Brandmeyer rlm@10: rlm@10: (defn do-swing* rlm@10: "Runs thunk in the Swing event thread according to schedule: rlm@10: - :later => schedule the execution and return immediately rlm@10: - :now => wait until the execution completes." rlm@10: [schedule thunk] rlm@10: (cond rlm@10: (= schedule :later) (SwingUtilities/invokeLater thunk) rlm@10: (= schedule :now) (if (SwingUtilities/isEventDispatchThread) rlm@10: (thunk) rlm@10: (SwingUtilities/invokeAndWait thunk))) rlm@10: nil) rlm@10: rlm@10: (defmacro do-swing rlm@10: "Executes body in the Swing event thread asynchronously. Returns rlm@10: immediately after scheduling the execution." rlm@10: [& body] rlm@10: `(do-swing* :later (fn [] ~@body))) rlm@10: rlm@10: (defmacro do-swing-and-wait rlm@10: "Executes body in the Swing event thread synchronously. Returns rlm@10: after the execution is complete." rlm@10: [& body] rlm@10: `(do-swing* :now (fn [] ~@body))) rlm@10: rlm@10: (defvar action-translation-table rlm@10: (atom {:name Action/NAME rlm@10: :accelerator Action/ACCELERATOR_KEY rlm@10: :command-key Action/ACTION_COMMAND_KEY rlm@10: :long-desc Action/LONG_DESCRIPTION rlm@10: :short-desc Action/SHORT_DESCRIPTION rlm@10: :mnemonic Action/MNEMONIC_KEY rlm@10: :icon Action/SMALL_ICON}) rlm@10: "Translation table for the make-action constructor.") rlm@10: rlm@10: (defn make-action rlm@10: "Create an Action proxy from the given action spec. The standard keys rlm@10: recognised are: :name, :accelerator, :command-key, :long-desc, rlm@10: :short-desc, :mnemonic and :icon - corresponding to the similar named rlm@10: Action properties. The :handler value is used in the actionPerformed rlm@10: method of the proxy to pass on the event." rlm@10: [spec] rlm@10: (let [t-table @action-translation-table rlm@10: handler (:handler spec) rlm@10: spec (dissoc spec :handler) rlm@10: spec (map (fn [[k v]] [(t-table k) v]) spec) rlm@10: action (proxy [AbstractAction] [] rlm@10: (actionPerformed [evt] (handler evt)))] rlm@10: (doseq [[k v] spec] rlm@10: (.putValue action k v)) rlm@10: action)) rlm@10: rlm@10: (defvar menu-constructor-dispatch rlm@10: (atom #{:action :handler :items}) rlm@10: "An atom containing the dispatch set for the add-menu-item method.") rlm@10: rlm@10: (defmulti add-menu-item rlm@10: "Adds a menu item to the parent according to the item description. rlm@10: The item description is a map of the following structure. rlm@10: rlm@10: Either: rlm@10: - one single :action specifying a javax.swing.Action to be associated rlm@10: with the item. rlm@10: - a specification suitable for make-action rlm@10: - a set of :name, :mnemonic and :items keys, specifying a submenu with rlm@10: the given sequence of item entries. rlm@10: - an empty map specifying a separator." rlm@10: {:arglists '([parent item])} rlm@10: (fn add-menu-item-dispatch [_ item] rlm@10: (some @menu-constructor-dispatch (keys item)))) rlm@10: rlm@10: (defmethod add-menu-item :action rlm@10: add-menu-item-action rlm@10: [parent {:keys [action]}] rlm@10: (let [item (JMenuItem. action)] rlm@10: (.add parent item))) rlm@10: rlm@10: (defmethod add-menu-item :handler rlm@10: add-menu-item-handler rlm@10: [parent spec] rlm@10: (add-menu-item parent {:action (make-action spec)})) rlm@10: rlm@10: (defmethod add-menu-item :items rlm@10: add-menu-item-submenu rlm@10: [parent {:keys [items mnemonic name]}] rlm@10: (let [menu (JMenu. name)] rlm@10: (when mnemonic rlm@10: (.setMnemonic menu mnemonic)) rlm@10: (doseq [item items] rlm@10: (add-menu-item menu item)) rlm@10: (.add parent menu))) rlm@10: rlm@10: (defmethod add-menu-item nil ; nil meaning separator rlm@10: add-menu-item-separator rlm@10: [parent _] rlm@10: (.addSeparator parent)) rlm@10: rlm@10: (defn make-menubar rlm@10: "Create a menubar containing the given sequence of menu items. The menu rlm@10: items are described by a map as is detailed in the docstring of the rlm@10: add-menu-item function." rlm@10: [menubar-items] rlm@10: (let [menubar (JMenuBar.)] rlm@10: (doseq [item menubar-items] rlm@10: (add-menu-item menubar item)) rlm@10: menubar)) rlm@10: rlm@10: ;; ----------------------------------------------------------------------