|
rlm@10
|
1 ;; Copyright (c) Stephen C. Gilardi. All rights reserved. The use and
|
|
rlm@10
|
2 ;; distribution terms for this software are covered by the Eclipse Public
|
|
rlm@10
|
3 ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
|
|
rlm@10
|
4 ;; be found in the file epl-v10.html at the root of this distribution. By
|
|
rlm@10
|
5 ;; using this software in any fashion, you are agreeing to be bound by the
|
|
rlm@10
|
6 ;; terms of this license. You must not remove this notice, or any other,
|
|
rlm@10
|
7 ;; from this software.
|
|
rlm@10
|
8 ;;
|
|
rlm@10
|
9 ;; clojure.contrib.swing-utils
|
|
rlm@10
|
10 ;;
|
|
rlm@10
|
11 ;; Useful functions for interfacing Clojure to Swing
|
|
rlm@10
|
12 ;;
|
|
rlm@10
|
13 ;; scgilardi (gmail)
|
|
rlm@10
|
14 ;; Created 31 May 2009
|
|
rlm@10
|
15
|
|
rlm@10
|
16 (ns clojure.contrib.swing-utils
|
|
rlm@10
|
17 (:import (java.awt.event ActionListener KeyAdapter)
|
|
rlm@10
|
18 (javax.swing AbstractAction Action
|
|
rlm@10
|
19 JMenu JMenuBar JMenuItem
|
|
rlm@10
|
20 SwingUtilities))
|
|
rlm@10
|
21 (:use [clojure.contrib.def :only (defvar)]))
|
|
rlm@10
|
22
|
|
rlm@10
|
23 (defn add-action-listener
|
|
rlm@10
|
24 "Adds an ActionLister to component. When the action fires, f will be
|
|
rlm@10
|
25 invoked with the event as its first argument followed by args.
|
|
rlm@10
|
26 Returns the listener."
|
|
rlm@10
|
27 [component f & args]
|
|
rlm@10
|
28 (let [listener (proxy [ActionListener] []
|
|
rlm@10
|
29 (actionPerformed [event] (apply f event args)))]
|
|
rlm@10
|
30 (.addActionListener component listener)
|
|
rlm@10
|
31 listener))
|
|
rlm@10
|
32
|
|
rlm@10
|
33 (defn add-key-typed-listener
|
|
rlm@10
|
34 "Adds a KeyListener to component that only responds to KeyTyped events.
|
|
rlm@10
|
35 When a key is typed, f is invoked with the KeyEvent as its first argument
|
|
rlm@10
|
36 followed by args. Returns the listener."
|
|
rlm@10
|
37 [component f & args]
|
|
rlm@10
|
38 (let [listener (proxy [KeyAdapter] []
|
|
rlm@10
|
39 (keyTyped [event] (apply f event args)))]
|
|
rlm@10
|
40 (.addKeyListener component listener)
|
|
rlm@10
|
41 listener))
|
|
rlm@10
|
42
|
|
rlm@10
|
43 ;; ----------------------------------------------------------------------
|
|
rlm@10
|
44 ;; Meikel Brandmeyer
|
|
rlm@10
|
45
|
|
rlm@10
|
46 (defn do-swing*
|
|
rlm@10
|
47 "Runs thunk in the Swing event thread according to schedule:
|
|
rlm@10
|
48 - :later => schedule the execution and return immediately
|
|
rlm@10
|
49 - :now => wait until the execution completes."
|
|
rlm@10
|
50 [schedule thunk]
|
|
rlm@10
|
51 (cond
|
|
rlm@10
|
52 (= schedule :later) (SwingUtilities/invokeLater thunk)
|
|
rlm@10
|
53 (= schedule :now) (if (SwingUtilities/isEventDispatchThread)
|
|
rlm@10
|
54 (thunk)
|
|
rlm@10
|
55 (SwingUtilities/invokeAndWait thunk)))
|
|
rlm@10
|
56 nil)
|
|
rlm@10
|
57
|
|
rlm@10
|
58 (defmacro do-swing
|
|
rlm@10
|
59 "Executes body in the Swing event thread asynchronously. Returns
|
|
rlm@10
|
60 immediately after scheduling the execution."
|
|
rlm@10
|
61 [& body]
|
|
rlm@10
|
62 `(do-swing* :later (fn [] ~@body)))
|
|
rlm@10
|
63
|
|
rlm@10
|
64 (defmacro do-swing-and-wait
|
|
rlm@10
|
65 "Executes body in the Swing event thread synchronously. Returns
|
|
rlm@10
|
66 after the execution is complete."
|
|
rlm@10
|
67 [& body]
|
|
rlm@10
|
68 `(do-swing* :now (fn [] ~@body)))
|
|
rlm@10
|
69
|
|
rlm@10
|
70 (defvar action-translation-table
|
|
rlm@10
|
71 (atom {:name Action/NAME
|
|
rlm@10
|
72 :accelerator Action/ACCELERATOR_KEY
|
|
rlm@10
|
73 :command-key Action/ACTION_COMMAND_KEY
|
|
rlm@10
|
74 :long-desc Action/LONG_DESCRIPTION
|
|
rlm@10
|
75 :short-desc Action/SHORT_DESCRIPTION
|
|
rlm@10
|
76 :mnemonic Action/MNEMONIC_KEY
|
|
rlm@10
|
77 :icon Action/SMALL_ICON})
|
|
rlm@10
|
78 "Translation table for the make-action constructor.")
|
|
rlm@10
|
79
|
|
rlm@10
|
80 (defn make-action
|
|
rlm@10
|
81 "Create an Action proxy from the given action spec. The standard keys
|
|
rlm@10
|
82 recognised are: :name, :accelerator, :command-key, :long-desc,
|
|
rlm@10
|
83 :short-desc, :mnemonic and :icon - corresponding to the similar named
|
|
rlm@10
|
84 Action properties. The :handler value is used in the actionPerformed
|
|
rlm@10
|
85 method of the proxy to pass on the event."
|
|
rlm@10
|
86 [spec]
|
|
rlm@10
|
87 (let [t-table @action-translation-table
|
|
rlm@10
|
88 handler (:handler spec)
|
|
rlm@10
|
89 spec (dissoc spec :handler)
|
|
rlm@10
|
90 spec (map (fn [[k v]] [(t-table k) v]) spec)
|
|
rlm@10
|
91 action (proxy [AbstractAction] []
|
|
rlm@10
|
92 (actionPerformed [evt] (handler evt)))]
|
|
rlm@10
|
93 (doseq [[k v] spec]
|
|
rlm@10
|
94 (.putValue action k v))
|
|
rlm@10
|
95 action))
|
|
rlm@10
|
96
|
|
rlm@10
|
97 (defvar menu-constructor-dispatch
|
|
rlm@10
|
98 (atom #{:action :handler :items})
|
|
rlm@10
|
99 "An atom containing the dispatch set for the add-menu-item method.")
|
|
rlm@10
|
100
|
|
rlm@10
|
101 (defmulti add-menu-item
|
|
rlm@10
|
102 "Adds a menu item to the parent according to the item description.
|
|
rlm@10
|
103 The item description is a map of the following structure.
|
|
rlm@10
|
104
|
|
rlm@10
|
105 Either:
|
|
rlm@10
|
106 - one single :action specifying a javax.swing.Action to be associated
|
|
rlm@10
|
107 with the item.
|
|
rlm@10
|
108 - a specification suitable for make-action
|
|
rlm@10
|
109 - a set of :name, :mnemonic and :items keys, specifying a submenu with
|
|
rlm@10
|
110 the given sequence of item entries.
|
|
rlm@10
|
111 - an empty map specifying a separator."
|
|
rlm@10
|
112 {:arglists '([parent item])}
|
|
rlm@10
|
113 (fn add-menu-item-dispatch [_ item]
|
|
rlm@10
|
114 (some @menu-constructor-dispatch (keys item))))
|
|
rlm@10
|
115
|
|
rlm@10
|
116 (defmethod add-menu-item :action
|
|
rlm@10
|
117 add-menu-item-action
|
|
rlm@10
|
118 [parent {:keys [action]}]
|
|
rlm@10
|
119 (let [item (JMenuItem. action)]
|
|
rlm@10
|
120 (.add parent item)))
|
|
rlm@10
|
121
|
|
rlm@10
|
122 (defmethod add-menu-item :handler
|
|
rlm@10
|
123 add-menu-item-handler
|
|
rlm@10
|
124 [parent spec]
|
|
rlm@10
|
125 (add-menu-item parent {:action (make-action spec)}))
|
|
rlm@10
|
126
|
|
rlm@10
|
127 (defmethod add-menu-item :items
|
|
rlm@10
|
128 add-menu-item-submenu
|
|
rlm@10
|
129 [parent {:keys [items mnemonic name]}]
|
|
rlm@10
|
130 (let [menu (JMenu. name)]
|
|
rlm@10
|
131 (when mnemonic
|
|
rlm@10
|
132 (.setMnemonic menu mnemonic))
|
|
rlm@10
|
133 (doseq [item items]
|
|
rlm@10
|
134 (add-menu-item menu item))
|
|
rlm@10
|
135 (.add parent menu)))
|
|
rlm@10
|
136
|
|
rlm@10
|
137 (defmethod add-menu-item nil ; nil meaning separator
|
|
rlm@10
|
138 add-menu-item-separator
|
|
rlm@10
|
139 [parent _]
|
|
rlm@10
|
140 (.addSeparator parent))
|
|
rlm@10
|
141
|
|
rlm@10
|
142 (defn make-menubar
|
|
rlm@10
|
143 "Create a menubar containing the given sequence of menu items. The menu
|
|
rlm@10
|
144 items are described by a map as is detailed in the docstring of the
|
|
rlm@10
|
145 add-menu-item function."
|
|
rlm@10
|
146 [menubar-items]
|
|
rlm@10
|
147 (let [menubar (JMenuBar.)]
|
|
rlm@10
|
148 (doseq [item menubar-items]
|
|
rlm@10
|
149 (add-menu-item menubar item))
|
|
rlm@10
|
150 menubar))
|
|
rlm@10
|
151
|
|
rlm@10
|
152 ;; ----------------------------------------------------------------------
|
